Initial checkin of GCC 4.9.0 from trunk (r208799).

Change-Id: I48a3c08bb98542aa215912a75f03c0890e497dba

90 files changed, 226791 insertions, 0 deletions

diff --git a/gcc-4.9/gcc/fortran/ChangeLog b/gcc-4.9/gcc/fortran/ChangeLog
new file mode 100644
index 000000000..3e4d08d68
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/ChangeLog
@@ -0,0 +1,334 @@
+2014-03-22  Jakub Jelinek  <jakub@redhat.com>
+
+	PR debug/60603
+	* cpp.c (gfc_cpp_init): Restore cb_change_file call to
+	<built-in>.
+
+2014-03-21  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/60148
+	* gfortran.texi: Add description of namelist DELIM= behavior.
+
+2014-03-19  Tobias Burnus  <burnus@net-b.>
+
+	PR fortran/60543
+	* io.c (check_io_constraints): Use gfc_unset_implicit_pure.
+	* resolve.c (resolve_ordinary_assign): Ditto.
+
+2014-03-19  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/60543
+	PR fortran/60283
+	* gfortran.h (gfc_unset_implicit_pure): New prototype.
+	* resolve.c (gfc_unset_implicit_pure): New.
+	(resolve_structure_cons, resolve_function,
+	pure_subroutine): Use it.
+	* decl.c (match_old_style_init, gfc_match_data,
+	match_pointer_init, variable_decl): Ditto.
+	* expr.c (gfc_check_pointer_assign): Ditto.
+	* intrinsic.c (gfc_intrinsic_sub_interface): Ditto.
+	* io.c (match_vtag, gfc_match_open, gfc_match_close,
+	match_filepos, gfc_match_inquire, gfc_match_print,
+	gfc_match_wait): Ditto.
+	* match.c (gfc_match_critical, gfc_match_stopcode,
+	lock_unlock_statement, sync_statement, gfc_match_allocate,
+	gfc_match_deallocate): Ditto.
+	* parse.c (decode_omp_directive): Ditto.
+	* symbol.c (gfc_add_save): Ditto.
+
+2014-03-18  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/55207
+	PR fortran/60549
+	* decl.c (match_attr_spec): Revert r208590.
+
+2014-03-18  Jakub Jelinek  <jakub@redhat.com>
+
+	PR ipa/58721
+	* trans.c (gfc_unlikely, gfc_likely): Don't add __builtin_expect
+	if !optimize.
+
+2014-03-18  Tobias Burnus  <burnus@net-b.de>
+
+	PR ipa/58721
+	* trans.h (gfc_unlikely, gfc_likely): Add predictor as argument.
+	(gfc_trans_io_runtime_check): Remove.
+	* trans-io.c (gfc_trans_io_runtime_check): Make static; add has_iostat
+	as argument, add predictor to block.
+	(set_parameter_value, gfc_trans_open, gfc_trans_close, build_filepos,
+	gfc_trans_inquire, gfc_trans_wait, build_dt): Update calls.
+	* trans.c (gfc_unlikely, gfc_likely): Add predictor as argument.
+	(gfc_trans_runtime_check, gfc_allocate_using_malloc,
+	gfc_allocate_allocatable, gfc_deallocate_with_status): Set explicitly
+	branch predictor.
+	* trans-expr.c (gfc_conv_procedure_call): Ditto.
+	* trans-stmt.c (gfc_trans_allocate): Ditto.
+	* trans-array.c (gfc_array_init_size, gfc_array_allocate): Ditto.
+
+2014-03-15  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/55207
+	* decl.c (match_attr_spec): Variables in the main program implicitly
+	get the SAVE attribute in Fortran 2008.
+
+2014-03-14  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/60392
+	* trans-array.c (gfc_conv_array_parameter): Don't reuse the descriptor
+	if it has transposed dimensions.
+
+2014-03-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/60447
+	* f95-lang.c (gfc_init): Return false when only
+	preprocessing.
+	* options.c (gfc_post_options): Ditto.
+
+2014-03-08  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.texi (Fortran 2003 Status): Mention finalization,
+	deferred-length character support and input rounding.
+	(Fortran 2008 Status): Mention that at termination
+	signalling exceptions are shown.
+
+2014-03-06  Paul Thomas  <pault@gcc.gnu.org>
+	    Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/51976
+	* gfortran.h (symbol_attribute): Add deferred_parameter attribute.
+	* primary.c (build_actual_constructor): It is not an error if
+	a missing component has the deferred_parameter attribute;
+	equally, if one is given a value, it is an error.
+	* resolve.c (resolve_fl_derived0): Remove error for deferred
+	character length components.  Add the hidden string length
+	field to the structure. Give it the deferred_parameter
+	attribute.
+	* trans-array.c (duplicate_allocatable): Add a strlen field
+	which is used as the element size if it is non-null.
+	(gfc_duplicate_allocatable, gfc_copy_allocatable_data): Pass a
+	NULL to the new argument in duplicate_allocatable.
+	(structure_alloc_comps): Set the hidden string length as
+	appropriate. Use it in calls to duplicate_allocatable.
+	(gfc_alloc_allocatable_for_assignment): When a deferred length
+	backend declaration is variable, use that; otherwise use the
+	string length from the expression evaluation.
+	* trans-expr.c (gfc_conv_component_ref): If this is a deferred
+	character length component, the string length should have the
+	value of the hidden string length field.
+	(gfc_trans_subcomponent_assign): Set the hidden string length
+	field for deferred character length components.  Allocate the
+	necessary memory for the string.
+	(alloc_scalar_allocatable_for_assignment): Same change as in
+	gfc_alloc_allocatable_for_assignment above.
+	* trans-stmt.c (gfc_trans_allocate): Likewise.
+	* trans-intrinsic (size_of_string_in_bytes): Make non-static.
+	* trans-types.c (gfc_get_derived_type): Set the tree type for
+	a deferred character length component.
+	* trans.c (gfc_deferred_strlen): New function.
+	* trans.h (size_of_string_in_bytes,gfc_deferred_strlen): New prototypes.
+
+2014-03-01  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/60341
+	* frontend-passes.c (optimize_comparison): Guard two union accesses
+	with the corresponding tag checks.
+
+2014-02-28  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/60359
+	* class.c (find_intrinsic_vtab): Prevent duplicate creation of copy
+	procedure for characters.
+
+2014-02-21  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/60302
+	* check.c (gfc_check_c_f_pointer): Only clear 'size' if 'gfc_array_size'
+	is successful.
+
+2014-02-21  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/60234
+	* gfortran.h (gfc_build_class_symbol): Removed argument.
+	* class.c (gfc_add_component_ref): Fix up missing vtype if necessary.
+	(gfc_build_class_symbol): Remove argument 'delayed_vtab'. vtab is always
+	delayed now, except for unlimited polymorphics.
+	(comp_is_finalizable): Procedure pointer components are not finalizable.
+	* decl. (build_sym, build_struct, attr_decl1): Removed argument of
+	'gfc_build_class_symbol'.
+	* match.c (copy_ts_from_selector_to_associate, select_type_set_tmp):
+	Ditto.
+	* symbol.c (gfc_set_default_type): Ditto.
+
+2014-02-19  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/60232
+	* expr.c (gfc_get_variable_expr): Don't add REF_ARRAY for dimensionful
+	functions, which are used as procedure pointer target.
+
+2014-02-18  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/49397
+	* expr.c (gfc_check_pointer_assign): Add check for
+	F2008Cor2, C729.
+	* trans-decl.c (gfc_get_symbol_decl): Correctly generate external
+	decl in a corner case.
+
+2014-02-18  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/60231
+	* resolve.c (check_generic_tbp_ambiguity): Check for presence of dummy
+	arguments to prevent ICE.
+
+2014-02-17  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/55907
+	* resolve.c (build_default_init_expr): Don't initialize character
+	variable if -fno-automatic is given.
+
+2014-02-15  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/59599
+	* trans-intrinsic.c (gfc_conv_intrinsic_ichar): Calculate the
+	number of arguments.
+
+2014-02-11  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/52370
+	* trans-decl.c (gfc_build_dummy_array_decl): Set TREE_NO_WARNING
+	on decl if sym->attr.optional.
+
+2014-02-09  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/57522
+	* resolve.c (resolve_assoc_var): Set the subref_array_pointer
+	attribute for the 'associate-name' if necessary.
+	* trans-stmt.c (trans_associate_var): If the 'associate-name'
+	is a subref_array_pointer, assign the element size of the
+	associate variable to 'span'.
+
+2014-02-09  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/59026
+	* trans-expr.c (gfc_conv_procedure_call): Pass the value of the
+	actual argument to a formal argument with the value attribute
+	in an elemental procedure.
+
+2014-02-08  Janus Weil  <janus@gcc.gnu.org>
+	    Mikael Morin <mikael.morin@gcc.gnu.org>
+
+	PR fortran/58470
+	* class.c (generate_finalization_wrapper): Assert that proc_tree has
+	been set in gfc_resolve_finalizers.
+	* resolve.c (resolve_fl_derived0): Remove unnecessary call to
+	gfc_is_finalizable.
+
+2014-02-07  Benno Schulenberg  <bensberg@justemail.net>
+
+	PR translation/52289
+	* fortran/resolve.c (resolve_ordinary_assign): Fix typoed word
+	in an error message.
+
+2014-02-02  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/57033
+	* primary.c (gfc_convert_to_structure_constructor): Avoid null pointer
+	dereference.
+
+2014-02-01  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/59906
+	* trans-stmt.c (gfc_add_loop_ss_code): In the case of character
+	SS_REFERENCE, use gfc_conv_string_parameter to ensure that a
+	pointer to the string is stored.
+	* trans-expr.c (gfc_conv_expr_reference): Likewise, use
+	gfc_conv_string_parameter to ensure that a pointer to is passed
+	to the elemental function.
+
+2014-01-28  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/59414
+	* trans-stmt.c (gfc_trans_allocate): Before the pointer
+	assignment to transfer the source _vptr to a class allocate
+	expression, the final class reference should be exposed. The
+	tail that includes the _data and array references is stored.
+	This reduced expression is transferred to 'lhs' and the _vptr
+	added. Then the tail is restored to the allocate expression.
+
+2014-01-26  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/58007
+	* module.c (read_module): Assert for component name correctness.
+
+2014-01-18  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/58007
+	* module.c (MOD_VERSION): Bump.
+	(fp2, find_pointer2): Remove.
+	(mio_component_ref): Don't forcedfully set the containing derived type
+	symbol for loading.  Remove unused argument.
+	(mio_ref): Update caller
+	(mio_symbol): Dump component list earlier.
+	(skip_list): New argument nest_level.  Initialize level with the new
+	argument.
+	(read_module): Add forced pointer components association for derived
+	type symbols.
+
+2014-01-12  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/58026
+	* decl.c (gfc_match_data_decl): Improve error recovery.
+
+2014-01-09  Tobias Burnus  <burnus@net-b.de>
+
+	* cpp.c (gfc_cpp_handle_option): Add missing break.
+	* trans-io.c (transfer_expr): Silence unused value warning.
+
+2014-01-08  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/58182
+	* resolve.c (gfc_verify_binding_labels): Modify order of checks.
+
+2014-01-06  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/59589
+	* class.c (comp_is_finalizable): New function to dermine if a given
+	component is finalizable.
+	(finalize_component, generate_finalization_wrapper): Use it.
+
+2014-01-06  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/59023
+	PR fortran/59662
+	* resolve.c (resolve_global_procedure): Don't apply to c-binding
+	procedures.
+	(gfc_verify_binding_labels): Remove duplicate line.
+
+2014-01-04  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/59547
+	* class.c (add_proc_comp): Copy pure attribute.
+
+2014-01-02  Richard Sandiford  <rdsandiford@googlemail.com>
+
+	Update copyright years
+
+2014-01-02  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortranspec.c (lang_specific_driver): Update copyright notice
+	dates.
+	* gfc-internals.texi: Bump @copying's copyright year.
+	* gfortran.texi: Ditto.
+	* intrinsic.texi: Ditto.
+	* invoke.texi: Ditto.
+
+2014-01-02  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/59654
+	* resolve.c (resolve_typebound_procedures): No need to create the vtab
+	here.
+
+Copyright (C) 2014 Free Software Foundation, Inc.
+
+Copying and distribution of this file, with or without modification,
+are permitted in any medium without royalty provided the copyright
+notice and this notice are preserved.
diff --git a/gcc-4.9/gcc/fortran/ChangeLog-2002 b/gcc-4.9/gcc/fortran/ChangeLog-2002
new file mode 100644
index 000000000..fdee6e644
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/ChangeLog-2002
@@ -0,0 +1,340 @@
+2002-12-29  Paul Brook  <paul@nowt.org>
+
+	* trans-array.c: Document calling convention for arrays.
+
+2002-12-19  Paul Brook  <paul@nowt.org>
+
+	* trans-intrinsic.c (g95_conv_intrsinsic_function): Remove incorrect
+	assertion. Remove intrinsic subroutine G95_ISYM_* cases. Always pass
+	optional parameters for some intrinsics.
+	(g95_is_intrinsic_libcall): Add G95_ISYM_RESHAPE.
+	* trans-expr.c (g95_conv_function_call): Pass NULL for absent
+	optional parameters.
+	* trans.h (g95_se): Add ignore_optional flag.
+
+2002-12-15  Paul Brook  <paul@nowt.org>
+
+	* trans-array.c (g95_conv_array_parameter): Fix partial rank sections.
+	* trans-decl.c (g95_generate_function_code): Use TDI_original.
+
+2002-12-14  Paul Brook  <paul@nowt.org>
+
+	* trans-stmt.c (g95_trans_call): Use resolved symbol name.
+
+2002-12-12  Paul Brook  <paul@nowt.org>
+
+	* trans-array.c (g95_trans_array_constructor_subarray): Fully
+	initialize the scalarizer.
+	(various): Update to new format of g95_expr->value.constructor.
+
+2002-12-08  Paul Brook  <paul@nowt.org>
+
+	* trans-array.c (g95_put_offset_into_var): New function.
+	(g95_trans_array_constructor_subarray): New function.
+	(g95_trans_array_constructor_value): Use it.
+	(g95_array_cons_size): Don't abort() on array components.
+
+2002-12-08  Paul Brook  <paul@nowt.org>
+
+	* Make-lang.in (F95_ADDITIONAL_OBJS): Remove tree-dchain.o.
+	* support.c: Update #includes.
+	(statement_code_p, c_size_in_bytes, s_size_type_node): Remove.
+	* trans-array.c: Update #includes.
+	* trans.c: Ditto.
+	* trans-const.c: Ditto.
+	* trans-io.c: Ditto.
+	* trans-types.c: Ditto.
+	(g95_init_types): Set size_type_node.
+	* trans-decl.c: Update #includes.
+	(gfor_fndecl_adjust{l,r}): Declare and initialize.
+	* trans-stmt.c: Update #includes.
+	(g95_trans_do_while): Generate LABEL_EXPR, not GOTO_EXPR.
+	(g95_trans_select): Fix check for unbounded ranges.
+	* trans-expr.c: Update #includes.
+	(g95_conv_string_tmp): New function.
+	(g95_conv_concat_op): Use it.
+	* trans.h (g95_conv_string_tmp, gfor_fndecl_adjust{l,r}): Declare.
+	* Trans-intrisic.c: Update #includes.
+	(g95_conv_intrinsic_strcmp): New function.
+	(g95_conv_intrinsic_adjust): Ditto.
+	(g95_conv_intrinsic_function: Use them.
+
+2002-11-30  Paul Brook  <paul@nowt.org>
+
+	* trans-array.c (g95_walk_function_expr): Handle non-array return by
+	reference.
+	* trans-dec.c (g95_build_function_decl): Handle character return
+	parammeters.
+	(g95_get_fake_result_decl): Ditto.
+	(g95_trans_deferred_vars): Ditto.
+	* trans-expr.c (g95_conv_function_call): Ditto.
+	(g95_trans_arrayfunc_assign) Limit to array valued functions.
+	* trans-intrinsic.c (g95_conv_intrinsic_char): New function.
+	(g95_conv_intrinsic_function): Use it.
+	* trans-types.c (g95_sym_type): Handle functions returning strings.
+	(g95_return_by_reference): Ditto.
+	(g95_get_function_type): Ditto.
+
+2002-11-18  Paul Brook  <paul@nowt.org>
+
+	* trans-stmt.c (g95_trans_if): Fix IF statements when the condition
+	requires a temporary.
+	(g95_trans_select): Handle computed gotos.
+	* trans-types.c (g95_build_array_type): Warn about non-functional
+	assumed shape arrays.
+	* trans-expr.c (g95_trans_scalar_assign): Correctly handle post
+	blocks.
+	* trans-intrinsic.c (g95_conv_intrinsic_round): New function.
+	(g95_conv_intrinsic_int): New function.
+	(g95_conv_intrinsic_mod): New function.
+	(g95_conv_intrinsic_ichar): New function.
+	(g95_conv_intrinsic_function): Use them.
+	(g95_conv_intrinsic_dim): Use g95_evaluate_now.
+
+2002-11-17  Toon Moene  <toon@moene.indiv.nluug.nl>
+
+	* trans-types.c (g95_build_array_type): Assumed
+	sized arrays can have rank > 1.
+	* trans.c (g95_trans_code): Remove erroneous
+	warning about CONTINUE.
+	* trans-expr.c (g95_conv_variable): Remove
+	erroneous assert.
+
+2002-11-15  Paul Brook  <paul@nowt.org>
+
+	* trans-array.c (g95_conv_array_parameter): Check for NULL stride.
+
+2002-10-31  Paul Brook  <paul@nowt.org>
+
+	* f95-tree.c: Remove tree copying stuff that's now in gimple.c
+	* trans-expr.c (g95_conv_component_ref): Handle character string
+	components.
+	(g95_conv_string_parameter): Ditto.
+	* trans-types.c (g95_get_derived_type): Add length decl to caracter
+	string components.
+
+2002-10-10  Paul Brook  <paul@nowt.org>
+
+	* trans-decl.c (gfor_fndecl_size?): Declare and initialize.
+	* trans-expr.c (g95_conv_function_call): Remove unreliable return value
+	check.
+	* trans-intrinsic.c (g95_conv_intrinsic_size): New function.
+	(g95_conv_intrinsic_function): Handle size and shape intrinsics.
+	(g95_is_intrinsic_libcall): Add G95_ISYM_SHAPE.
+	* trans-types.c (pvoid_type_node): Declare and initialize.
+	* trans-array.c: Fix typo COMPONENT_REF->REF_COMPONENT
+	(g95_array_allocate): Fix when base==data.
+	(g95_conv_array_parameter): Correctly handle reduced rank sections.
+	* trans-io.c (g95_trans_write): Correctly handle string modifiers.
+
+2002-10-09  Paul Brook  <paul@nowt.org>
+
+	* (g95_conv_expr_reference): Handle character strings correctly.
+
+2002-10-07  Paul Brook  <paul@nowt.org>
+
+	(g95_expand_decl): Rename from f95_expand_decl_stmt and use as
+	langhook.
+	* trans-array.c (g95_build_array_initializer): Remove.
+	(g95_conv_array_initializer): New Function.
+	(g95_trans_auto_arry_allocation): Cleanup.
+	(g95_trans_init_character_array): Remove.
+	* g95spec.c: Link in libgforbegin.
+	* trans.c (g95_generate_code): Rename main function to MAIN__.
+	(g95_create_var): New function.
+	(g95_create_var_np): New function.
+	(g95_evaluate_now): New function.
+	(g95_start_block): New function.
+	(g95_finish_block): New function.
+	(g95_add_expr_to_block): New function.
+	(g95_add_block_to_block): New function.
+	* trans-expr.c (g95_conv_componen_ref): New function.
+	* Make-lang.in (F95_ADDITIONAL_OBJS): Add gimplify.o.
+	(F95_OBJS): Add dependency.o.
+	* f95-lang.c (g95_is_simple_stmt): Remove.
+	* f95-tree.c (mark_not_simple): New function.
+	(unshare_all_trees): New function.
+	(create_tmp_var, create_tmp_alias_var): Remove.
+	* support.c (declare_tmp_vars, tree_last_decl): Remove.
+	* trans*: Convert to new IR using GENERIC trees.  Don't bother about
+	SIMPLE/GIMPLE rules, this is now done by Lang-independant code.
+
+2002-10-01  Paul Brook  <paul@nowt.org>
+
+	* trans-array.c: Add support for descriptorless arrays.
+	(g95_conv_array_data): New function.
+	(g95_conv_array_base): New function.
+	* trans-array.h: Declare these here.
+	* trans-decl.c(g95_create_mopdule_variable): Perform variable
+	initialization and creation here.
+	(g95_create_module_vars): Instead of here.
+	* trans.h (G95_TYPE_ARRAY_*: Rename from G95_TYPE_DESCRIPTOR_*.
+	* trans-intrinsic.c: Ditto.
+	* trans-types.c (g95_is_nodesc_array): New function.
+	(g95_get_nodesc_array_type): New function.
+	(g95_sym_type, g95_get_derived_type): Use them.
+	* trans-const.c (g95_conv_mpf_to_tree): Remove workaround.
+
+2002-09-28  Paul Brook  <paul@nowt.org>
+
+	* trans-const.c (g95_conv_mpf_to_tree): Work around backend bug.
+	* trans-intrinsic.c (g95_conv_intrinsic_abs): Correctly detect complex
+	parameters.
+
+2002-09-24  Paul Brook  <paul@nowt.org>
+
+	* f95-lang.c (listify): Remove declaration.
+	(expand_function_body): Use optimize >=1 instead of flag_tree_saa.
+	(listify)
+	* f95-tree.c (get_name): New function.
+	* trans.c (module_namespace): Remove.
+	* trans-decl.c: Use g95_chainon_list rather than chainon(listify()).
+	* trans-types.c: Ditto.
+
+2002-09-19  Paul Brook  <paul@nowt.org>
+
+	* trans-array.c (g95_get_array_cons_size): New Function.
+	(g95_con_ss_startstride): Handle Array constructors.
+	(g95_conv_loop_setup): Ditto.
+	(g95_conv_array_parameter): Ditto.
+	* tras-decl.c (g95_finish_var_decl): Make initializes variables
+	static.
+
+2002-09-19  Paul Brook  <paul@nowt.org>
+
+	* trans.c (g95_simple_fold_tmp): Detect variables inside
+	NON_LVALUE_EXPR.
+	* trans-stmt.c (g95_trans_arithmetic_if): Implement this.
+
+2002-09-18  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* Make-lang.in (F95_ADDITIONAL_OBJS): Add tree-ssa-dce.o
+
+2002-09-14  Paul Brook  <paul@nowt.org>
+
+	* trans.c (g95_create_module_variable): Move to trans-decl.c.
+	* trans-const.c (g95_conv_string_init): New Function.
+	* trans-const.h: Declare it.
+	* trans-decl.c (g95_get_symbol_decl): Handle initializers for static
+	variables. Don't bail on intrinsic symbols.
+	(get_extern_function_decl): Handle specific intrinsic functions.
+	* trans-types.c (g95_sym_type): Dummy functions don't return
+	reference types.
+	* trans-array.c (g95_build_array_initializer): New Function.
+	(g95_trans_auto_array_allocation): Build initializer for static decls.
+	Don't use mpz_addmul, it's GMP4 only.
+
+2002-09-12  Paul Brook  <paul@nowt.org>
+
+	* trans-decl.c (g95_generate_code): Fix thinko with return variable.
+	(g95_get_extern_function_decl, g95_build_function_decl): Mangle
+	assembler names for module procedures.
+
+2002-09-11  Tobias Schlueter  <Tobias.Schlueter@physik.uni-muenchen.de>
+
+	* trans-array.c,h trans-expr.c, trans-stmt.c: Correct spelling of
+	dependency/
+
+2002-09-10  Paul Brook  <paul@nowt.org>
+
+	* trans-array.c: Change format of G95_SS_TEMP strictures.
+	(g95_check_fncall_dependancy): New function.
+	(trans_dummy_array_bias): stride[n], not stride[n-1]. for calculating
+	offsets.
+	* trans-decl.c (g95_get_symbol_decl): move assertion after handling of
+	result variables.
+	(g95_build_function_decl): Don't assume result arrays are packed.
+	(g95_trans-deferred-vars): Handle array result variables.
+	(g95_generate_fuction_code): Clear saved_function_decls.
+	* trans-expr.c (g95_conv_fnction_call): Handle direct array return by
+	reference.
+	(g95_trans_arrayfunc_assign): New function.
+	(g95_trans_assignment): Use it.
+	* trans.h (g95_ss): Add temp struct for G95_SS_TEMP.
+	(g95_se): Add direct_byref.
+	* trans-types.c: Use sym->result rather than sym where appropriate.
+	* trans-intrinsic.c (g95_conv_intrinsic_funcall): New function.
+	Update other functions to use this.
+	(g95_is_intrinsic_libcall): New function.
+	(g95_conv_intrinsic_function): Add MATMUL and PRODUCT intrinsics.
+	(g95_walk_intrinsic_function): Ditto.
+
+2002-09-08  Paul Brook  <paul@nowt.org>
+
+	* trans-types.c: Change rank field to dtype field in array descriptor.
+	* trans-array.c: Implement filling of dtype array descriptor field.
+	* trans-intrinsic.c: Fix broken LEN intrinsic.
+
+2002-09-07  Paul Brook  <paul@nowt.org>
+
+	* trans-intrinsic.c: Remove outdated todo intrinsic list.
+	(g95_get_symbol_for_expr): Remove hack for fortran based intrinsics.
+	(g95_walk_intrinsic_function): Add MINLOC and MAXLOC.
+
+2002-09-06  Paul Brook  <paul@nowt.org>
+
+	* Make-lang.in (F95_ADDITIONAL_OBJS): Add tree_alias_comon.o.
+	(gt-f95-trans-types.h): Add dependancy information.
+	* config-lang.in (gtfiles): Add trans-types.c
+	* f95-lang.c (g95_be_parse_file): Pass error and warning counts
+	back to top-level code.
+	* trans-array.c, trans-types.c: Change format of array descriptor.
+	(g95_conv_descriptor_dimension): New function.
+	* trans-types.h (g95_conv_descriptor_rank): define.
+	* trans-intrinsic.c: Implement PRODUCT, COUNT. MINLOC and MAXLOC
+	intrinsics.
+
+2002-09-02  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* trans-array.c, trans-types.c:	Add rank information to descriptor.
+
+2002-09-06  Tobias Schlueter  <Tobias.Schlueter@physik.uni-muenchen.de>
+
+	* trans-stmt.c (g95_trans_allocate): Fix when ref==NULL.
+
+2002-09-04  Paul Brook  <paul@nowt.org>
+
+	* f95-lang.c (g95_create_decls): New function.
+	(g95_init):  Move initialization of external decls to above, and call
+	from g95_be_parse_file.
+	* trans.c (g95_finish_stmt): Don't amputate the decl chain.
+	* trans-types.c (g95_init_types): Always name integer and char types.
+	(g95_get_array_type_bounds): TYPE_NAME may be a TYPE_DECL.
+
+2002-09-02  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* Make-lang.in: Add options.c to F95_PARSER_OBJS
+
+2002-09-02  Paul Brook  <paul@nowt.org>
+
+	* g95_generate_code: Clear the attr for __fortran_main.
+	* trans-types.c (g95_finish_type): New function.
+	* g95_init_io_state_type: Use g95_finish_type.
+	* g95_conv_intrinsic_anyall: Fix thinko in result initialization.
+
+2002-09-01  Paul Brook  <paul@nowt.org>
+
+	* README.backend: Warn about the dangers of extra config.h files.
+	Remove obsolete libgfor stuff.
+	* config-lang.in: Add target-libgfor dependancy.
+	* g95_conv_mpf_to_tree: Use & free allocated buffer p rather than buff.
+
+2002-09-01  Toon Moene  <toon@moene.indiv.nluug.nl>
+
+	* g95_conv_mpz_to_tree: Free storage pointed to by q,
+	not by buff.
+
+2002-08-30  Paul Brook  <paul@nowt.org>
+
+	* trans-intrinsic.c (g95_conv_intrinsic_function,
+	g95_walk_intrinsic_function): Added ANY and ALL.
+	(g95_conv_intrinsic_anyall): New function.
+	* iresolve.c (g95_resolve_any, g95_resolve_all): Include rank in
+	mangled name
+
+
+Copyright (C) 2002 Free Software Foundation, Inc.
+
+Copying and distribution of this file, with or without modification,
+are permitted in any medium without royalty provided the copyright
+notice and this notice are preserved.
diff --git a/gcc-4.9/gcc/fortran/ChangeLog-2003 b/gcc-4.9/gcc/fortran/ChangeLog-2003
new file mode 100644
index 000000000..051ebb88f
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/ChangeLog-2003
@@ -0,0 +1,2346 @@
+2003-12-26  Feng Wang  <fengwang@nudt.edu.cn>
+
+	* dump-parse-tree.c (gfc_show_code_node): Add ASSIGN and ASSIGNED GOTO
+	dumping.
+	* gfortran.h (gfc_statement): New ST_LABEL_ASSIGNMENT.
+	(gfc_exec_op): New EXEC_LABEL_ASSIGN.
+	(symbol_attribute):New variable attribute: assign.
+	* io.c (resolve_tag):Integer variable is allowed.
+	(match_dt_format): Add ASSIGN statement. Set assign flag.
+	* match.c (gfc_match_if): Change ST_NONE to ST_LABEL_ASSIGNMENT.
+	(gfc_match_assign): Add ASSIGN statement. Set assign flag.
+	(gfc_match_goto): Add ASSIGNED GOTO statement. Set assign flag.
+	* parse.c (decode_statement): Add ST_LABEL_ASSIGNMENT.
+	(next_statement): Add ST_LABEL_ASSIGNMENT.
+	(gfc_ascii_statement): Add ST_LABEL_ASSIGNMENT.
+	* resolve.c (resolve_code): Resolve ASSIGN and ASSIGNED GOTO statement.
+	(resolve_blocks): Resolve ASSIGNED GOTO statement label list.
+	* st.c (gfc_free_statement): Add EXEC_LABEL_ASSIGN.
+	* trans-decl.c (gfc_get_symbol_decl): Create the shadow variable for
+	assign.  Put them into the stuct lang_decl.
+	* trans-io.c (set_string): Add the assign statement.
+	* trans-stmt.c (gfc_trans_label_assign): New function.
+	(gfc_trans_goto): Translate ASSIGNED GOTO statement.
+	* trans-stmt.h (gfc_trans_label_assign): Added function prototype.
+	* trans.c (gfc_trans_code): Add EXEC_LABEL_ASSIGN.
+	* trans.h (lang_decl):Add shadow variable decl tree needed by assign.
+	(GFC_DECL_ASSIGN_ADDR(node)): New macro to access this.
+	(GFC_DECL_ASSIGN(node)): New macro to access flag.
+
+2003-12-31  Huang Chun  <chunhuang73@hotmail.com>
+
+	PR fortran/13434
+	* trans-intrinsic.c (gfc_conv_intrinsic_minmaxval): Fixed bug in
+	minval/maxval.
+
+2003-12-22  Toon Moene  <toon@moene.indiv.nluug.nl>
+
+	* options.c (gfc_init_options): Set flag_argument_noalias to 2, to indicate
+	that arguments to subroutines/functions can't alias themselves, nor global
+	memory.
+
+2003-12-20  Steven Bosscher  <stevenb@suse.de>
+
+	* trans-expr.c (gfc_conv_expr_op): Fold the result expression.
+	* trans.c (gfc_add_modify_expr, gfc_add_expr_to_block): Likewise.
+
+2003-12-12  Huang Chun  <chunhuang73@hotmail.com>
+
+	* primary.c (match_substring): Fix substring bug for start point
+	or end point is NULL.
+	* trans-expr.c (gfc_conv_substring): Ditto
+	* trans-types.c (gfc_sym_type): Get correct type of scalar
+	character variables.
+	* trans-intrinsic.c (gfc_conv_intrinsic_len): Handle character in
+	derived type.
+
+2003-12-10  Richard Henderson  <rth@redhat.com>
+
+	* options.c (gfc_post_options): Don't ever use rtl inlining.
+
+2003-12-05  Canqun Yang  <canqun@nudt.edu.cn>
+
+	* trans-common.c: Re-implement COMMON blocks and EQUIVALENCE lists.
+	* trans-equivalence.c: Remove.
+	* trans-decl.c (gfc_get_symbol_decl): Update to match.
+	(gfc_generate_function_code): Ditto.
+	* trans-array.c (gfc_conv_array_parameter): Ditto.
+	* Make-lang.in (F95_OBJS): Remove fortran/trans-equivalence.o
+	(F95_ADDITIONAL_OBJS): Add stor-layout.o
+	* trans.h (gfc_trans_equivalence): Remove.
+	* gfortran.h (struct gfc_equiv): Add used field.
+	(struct gfc_symbol): Remove addr_base, addr_offset, equiv_ring,
+	equiv_offset fields.
+
+2003-12-05  Richard Henderson  <rth@redhat.com>
+
+	* trans.c (gfc_build_addr_expr): New.
+	(gfc_build_indirect_ref, gfc_build_array_ref): New.
+	* trans.h: Declare them.
+	* trans-array.c, trans-expr.c, trans-intrinsic.c, trans-io.c,
+	trans-stmt.c, trans.c (*): Use them.
+
+	* f95-lang.c (gfc_post_options): Remove dead prototype.
+	* trans-array.c (gfc_trans_deferred_vars): Remove unused variable.
+	* trans-stmt.c (gfc_evaluate_where_mask): Fix temporary_list
+	allocation size.
+
+2003-12-01  Feng Wang  <fengwang@nudt.edu.cn>
+
+	* io.c (gfc_match_format): Check for missing format label.
+
+2003-11-30 Huang Chun  <chunhuang73@hotmail.com>
+
+	PR fortran/13155
+	* trans-decl.c (gfc_sym_mangled_function_id): Don't mangle symbols
+	from interfaces in modules.
+
+2003-11-30  Paul Brook  <paul@nowt.org>
+
+	* trans-array.c (gfc_trans_g77_array): Make non-static.
+	(gfc_trans_assumed_size): Remove.
+	(gfc_trans_dummy_array_bias): Explicitly free temporary.
+	* trans-array.h (gfc_trans_g77_array): Add prototype.
+	(gfc_trans_assumed_size): Remove.
+	* trans-decls.c (gfor_fndecl_push_context): Remove.
+	(gfor_fndecl_pop_context): Remove.
+	(gfc_build_function)decls): Don't create them.
+	(gfc_trans_deferred_vars): Update to match. Remove dead	code.
+	* trans-stmt.c (gfc_trans_pointer_assign_need_temp): Free temp.
+
+2003-11-30  Kejia Zhao  <kejia_zh@nudt.edu.cn>
+
+	* trans-array.c (gfc_conv_array_parameter): Simplify
+	array argument passing for array name actual argument.
+	* trans-expr.c (gfc_conv_function_call): Ditto
+	* trans-types.c (gfc_is_nodesc_array):Ditto.
+
+2003-11-30  Paul Brook  <paul@nowt.org>
+
+	* f95-lang.c (gfc_post_options): Move ...
+	* options.c (gfc_post_options): .. to here.  Handle inlining options.
+	* gfortran.h (gfc_post_options): Add prototype.
+
+2003-11-28  Richard Henderson  <rth@redhat.com>
+
+	* trans.c (gfc_create_var_np): Use create_tmp_var_raw.
+
+2003-11-28 Huang Chun  <chunhuang73@hotmail.com>
+
+	* trans.h (has_alternate_specifier): New global variable.
+	* match.c (gfc_match_call): Handle actual arguments associated with
+	alternate return indicators.
+	* trans-expr.c (gfc_conv_function_call): Ditto
+	* trans-stmt.c (gfc_trans_call): Ditto
+	(gfc_trans_return): Handle return statement with value.
+	* trans-decl.c (gfc_generate_function_code): Handle functions with
+	asterisk dummy.
+	(gfc_get_fake_result_decl): Ditto
+	* trans-types.c (gfc_get_function_type): Ditto
+	* resolve.c (resolve_actual_arglist): Check alternate return indicators.
+	(resolve_formal_arglist): Check asterisk dummy.
+
+2003-11-27  Paul Brook  <paul@nowt.org>
+
+	* trans-array.c (gfc_tran_allocate_array_storage): Use new memory
+	allocation interface.
+	(gfc_conv_ array_parameter): Ditto.
+	(gfc_trans_auto_array_allocation): Ditto. Also free the memory.
+	* trans-array.c: Update prototype.
+	* trans-decl.c (gfc_build_builtin_function_decls): Update prototypes.
+	(gfc_trans_auto_character_variable): Use new memory alloc interface.
+	* trans-expr.c (gfc_conv_string_tmp): Ditto.
+	(gfc_conv_function_call): Use gfc_conv_string_tmp.
+	* trans-stmt.c (gfc_do_allocate):  Use new memory alloc interface.
+	* trans-intrinsic.c (gfc_conv_intrinsic_trim): Ditto.
+	* trans.h (gfc_ss_info): Remove unused pdata field.
+	* trans.c (gfc_create_var_np): Change T to V.
+
+2003-11-26  Richard Henderson  <rth@redhat.com>
+
+	* mathbuiltins.def: Move acos, asin, cosh, log10, sinh, tanh from ...
+	* trans-intrinsic.c (gfc_intrinsic_map): ... here.  Add SCALE,
+	FRACTION, NEAREST, SET_EXPONENT.
+	(gfc_intrinsic_map_t): Add libm_name, complex_available, is_constant.
+	Fix GTY marking.  Remove unnecessary const's.
+	(LIBM_FUNCTION): Rename from I_LIB.
+	(LIBF_FUNCTION): New.
+	(gfc_get_intrinsic_lib_fndecl): Handle libm and libgfortran naming
+	conventions.  Assume the expr signature is correct.  Mark const.
+	(gfc_conv_intrinsic_exponent): Use library functions.
+	(gfc_conv_intrinsic_set_exponent): Remove.
+	(gfc_conv_intrinsic_scale): Remove.
+	(gfc_conv_intrinsic_nearest): Remove.
+	(gfc_conv_intrinsic_fraction): Remove.
+	(gfc_conv_intrinsic_function): Update.
+	* trans-decl.c (gfor_fndecl_math_exponent4): New.
+	(gfor_fndecl_math_exponent8): New.
+	(gfc_build_intrinsic_function_decls): Set them.
+	* trans.h: Declare them.
+
+2003-11-25  Canqun Yang  <canqun@nudt.edu.cn>
+
+	* trans-common.c (gfc_layout_global_equiv): Locate the error for
+	underflow COMMON block.
+	(gfc_trans_one_common): Fix bug for size of COMMON block containing
+	EQUIVALENCE object. Also fix typo in an error message.
+
+2003-11-25  Diego Novillo  <dnovillo@redhat.com>
+
+	* Make-lang.in: Add check-gfortran to lang_checks.
+	(check-f95): Alias for check-gfortran.
+
+2003-11-25  Jason Merrill  <jason@redhat.com>
+
+	* Make-lang.in (f95.tags): Create TAGS.sub files in each
+	directory and TAGS files that include them for each front end.
+
+2003-11-24  Paul Brook  <paul@nowt.org>
+
+	PR fortran/13154
+	* trans-decl.c (gfc_greate_module_variable): Skip COMMON blocks.
+
+2003-11-24  Paul Brook  <paul@nowt.org>
+
+	* expr.c (simplify_const_ref): Return SUCCESS for things we don't
+	handle.
+	* resolve.c (gfc_resolve_expr): Resolve contents before rank/shape.
+
+2003-11-24  Paul Brook  <paul@nowt.org>
+
+	PR fortran/13105
+	* array.c (gfc_array_ref_shape): Handle elemental dimensions.
+	* trans-array.c (gfc_trans_preloop_setup): Use correct dim lookup.
+
+2003-11-20  Richard Henderson  <rth@redhat.com>
+
+	* trans-array.c (gfc_trans_allocate_array_storage): Use convert.
+	(gfc_conv_array_base): Likewise.
+	* trans-decl.c (gfc_trans_auto_character_variable): Likewise.
+	* trans-expr.c (gfc_conv_string_tmp): Likewise.
+	* trans-intrinsic.c (gfc_conv_intrinsic_trim): Likewise.
+	* trans-stmt.c (gfc_trans_character_select): Likewise.
+
+2003-11-13  Paul Brook  <paul@nowt.org>
+
+	* trans-decl.c (gfc_sym_mangled_function_id): Dont mangle externals.
+
+2003-11-13  Canqun Yang  <canqun@nudt.edu.cn>
+
+	* resolve.c (gfc_resolve): Also resolve EQUIVALENCE objects.
+	(resolve_equivalence): New function.
+	(resolve_equivalence_derived): New function.
+
+2003-11-12  Richard Henderson  <rth@redhat.com>
+
+	* trans.c (gfc_trans_code): Use annotate_with_locus instead of
+	annotate_all_with_locus.
+
+2003-11-11  Canqun Yang  <canqun@nudt.edu.cn>
+
+	* options.c (gfc_init_options): Set flag_max_stack_var_size as 32768.
+	* trans-decl.c (gfc_finish_var_decl): Modified.
+
+2003-11-08  Paul Brook  <paul@nowt.org>
+
+	PR fortran/12704
+	* trans-intrinsic.c (gfc_conv_intrinsics_minmaxloc): Handle zero-size
+	arrays.
+
+2003-11-06  Paul Brook  <paul@nowt.org>
+
+	* trans-intrinsic.c (gfc_conv_intrinsics_minmaxloc): Initialize pos.
+
+2003-11-02  Canqun Yang  <canqun@nudt.edu.cn>
+
+	* match.c (gfc_match_stopcode): Assign '0' to stop_code.
+
+2003-10-27  Anthony Green  <green@redhat.com>
+
+	* Make-lang.in (f95.stageprofile): Use tabs, not spaces.
+	(f95.stagefeedback): Ditto.
+
+2003-10-27  Andrew Pinski  <pinskia@physics.uc.edu>
+
+	PR fortran/12682
+	* Make-lang.in (f95.stageprofile): Add.
+	(f95.stagefeedback): Add.
+
+2003-10-23  Richard Henderson  <rth@redhat.com>
+
+	* f96-lang.c (gfc_gimplify_expr): Remove.
+	(LANG_HOOKS_GIMPLIFY_EXPR): Remove.
+	(LANG_HOOKS_GIMPLE_BEFORE_INLINING): New.
+
+2003-10-23  Richard Henderson  <rth@redhat.com>
+
+	* f95-lang.c (gfc_gimplify_expr): Return gimplify_status.
+
+2003-10-20  Paul Brook  <paul@nowt.org>
+
+	* trans-expr.c (gfc_conv_integer_power): Use boolean_type_node.
+	* trans-stmt.c (gfc_trans_do_while): Ditto.
+
+2003-10-17  Paul Brook  <paul@nowt.org>
+
+	* simplify.c (gfc_simplify_shape): Use gfc_array_dimen_size.
+
+2003-10-17  Paul Brook  <paul@nowt.org>
+
+	* trans-io.c (gfc_build_io_library_fndecls): Set TREE_PUBLIC.
+
+2003-10-17  Feng Wang  <wf_cs@yahoo.com>
+
+	* iresolve.c (gfc_resolve_maxloc): Change the result's kind and type.
+	(gfc_resolve_minloc): Ditto.
+	* trans-intrinsic.c (gfc_conv_intrinsic_minmaxloc): Use correct types.
+	Return the value after subtracting the lower bound.
+
+2003-10-16  Richard Henderson  <rth@redhat.com>
+
+	* f95-lang.c (expand_function_body): Don't check flag_disable_gimple.
+
+2003-10-16  Steven Bosscher  <steven@gcc.gnu.org>
+
+	* lang.c: Remove -M option for now, it's in the way for C.
+
+2003-10-14  Jason Merrill  <jason@redhat.com>
+
+	* Make-lang.in (f95.tags): New rule.
+
+2003-10-13  Richard Henderson  <rth@redhat.com>
+
+	* trans.c (gfc_trans_code): Use annotate_all_with_locus.
+
+2003-10-13  Paul Brook  <paul@nowt.org>
+
+	* trans-decl.c (generate_local_decl): Don't create junk variables.
+
+2003-10-13  Paul Brook  <paul@nowt.org>
+
+	* resolve.c (resolve_formal_arglist): Use function result decl in
+	preference to function decl.
+
+2003-10-12  Richard Henderson  <rth@redhat.com>
+
+	* f95-lang.c (gfc_define_builtin): New const_p argument.  Set
+	TREE_READONLY.  Update all callers.
+
+2003-10-12  Feng Wang  <wf_cs@yahoo.com>
+
+	* iresolve.c (gfc_resolve_cshift): Change to match implementation.
+	* trans-intrinsic.c (gfc_conv_intrinsic_function): Remove CSHIFT.
+	(gfc_is_intrinsic_libcall): Add CSHIFT.
+
+2003-10-12  Richard Henderson  <rth@redhat.com>
+
+	* trans-array.c (gfc_trans_static_array_pointer): Set TREE_INVARIANT.
+	(gfc_trans_array_constructor_value): Likewise.
+	(gfc_conv_array_initializer): Likewise.
+	* trans-stmt.c (gfc_trans_character_select): Likewise.
+
+2003-11-12  Kejia Zhao  <kejia_zh@yahoo.com.cn>
+
+	* trans-intrinsic.c (integer_kind_info, real_kind_info): Remove.
+
+2003-10-11  Huang Chun  <jiwang@mail.edu.cn>
+
+	* check.c (gfc_check_repeat): Check arguments are scalar.
+	(gfc_check_trim): New function.
+	* intrinsic.h (gfc_check_trim): Add prototype.
+	* intrinsic.c (add_functions): Use it.
+	* trans.h (gfor_fndecl_string_trim, gfor_fndecl_string_repeat):
+	Decalare.
+	* trans-decl.c: Ditto.
+	(gfc_build_intrinsic_fucntion_decls): Set them.
+	* trans-intrinsic.c (gfc_conv_intrinsic_len): Handle result vars.
+	(gfc_conv_intrinsic_trim): New function.
+	(gfc_conv_intrinsic_repeat): New function.
+	(gfc_conv_intrinsic_function): Use them.
+
+2003-10-11  Huang Chun  <jiwang@mail.edu.cn>
+
+	* trans-types.c (gfc_sym_type): Handle result variables.
+
+2003-10-11  Huang Chun  <jiwang@mail.edu.cn>
+
+	* trans-intrinsic.c (gfc_conv_intrinsic_char): Don't use
+	gfc_get_character_type.
+
+2003-10-11  Feng Wang  <wf_cs@yahoo.com>
+
+	* trans-expr.c (gfc_conv_variable): Check sym->ts, not the decl.
+
+2003-10-11  Paul Brook  <paul@nowt.org>
+
+	* iresolve.c (gfc_resolve_dint, gfc_resolve_dnint): New functions.
+	(gfc_resolve_dprod): New function.
+	(gfc_resolve_aint, gfc_resolve_anint): Only base name on arg type.
+	* intrinsic.h (gfc_resolve_dint, gfc_resolve_dnint): Declare.
+	(gfc_resolve_dprod): Declare.
+	* intrinsic.c (add_functions): Use them.
+	* trans-decl.c (gfc_get_extern_function_decl): Only pass one arg.
+
+2003-10-06  Richard Henderson  <rth@redhat.com>
+
+	* f95-lang.c (gfc_init_builtin_functions): Add clzll.
+	* trans-intrinsic.c (call_builtin_clz): Use it.
+
+2003-10-05  Paul Brook  <paul@nowt.org>
+
+	* f95-lang.c (expand_function_body): Call (push|pop)_function_context.
+	* trans-decl.c (gfc_generate_function_code): Set
+	cfun->function_end_locus.
+
+2003-09-24  Jason Merrill  <jason@redhat.com>
+
+	* f95-lang.c, trans-decl.c: Use DECL_SOURCE_LOCATION instead of
+	TREE_LOCUS.
+
+2003-09-21  Lifang Zeng  <zlf605@hotmail.com>
+	Paul Brook  <paul@nowt.org>
+
+	* Make-lang.in (F95_OBJS): Add fortran/data.o.
+	* array.c (gfc_inser_constructor): New function.
+	(gfc_get_constructor): New function.
+	(gfc_free_constructor): Initialize offset and repeat.
+	(iterator_stack): Remove.
+	(expand_info): Add offset, component and repeat fields.
+	(expand_constructor): Set them.
+	(expand): Set new fields.
+	(gfc_copy_constructor): Ditto. Avoid recursion.
+	* gfortran.h: Add prototypes for new functions.
+	(gfc_constructor): Add offset, component and repeat.
+	(iteratio_stack): Move to here.
+	* resolve.c (check_data_variable): Convert data values into variable
+	initializers.
+	(traverse_data_list): Build implicit loop chain.
+	(gfc_resolve): Ditto.
+	* trans-array.c (gfc_conv_array_intializer): Handle repeat count.
+	* trans-decl.c (gfc_get_symbol_decl): Use gfc_conv_structure.
+	* trans-expr.c (gfc_conv_structure): Handle array initializers.
+	(gfc_conv_expr): Update to match.
+	* trans.h (gfc_conv_structure): Declare.
+	* data.c: New file.
+
+2003-09-20  Kejia Zhao  <kejia_zh@yahoo.com.cn>
+
+	* trans.h: Add declarations for gfor_fndecl_si_kind and
+	gfor_fndecl_sr_kind.
+	* trans-decl.c (g95_build_intrinsic_function_decls): Build them.
+	* trans-intrinsic.c (g95_conv_intrinsic_si_kind): New function.
+	(g95_conv_intrinsic_sr_kind): New function.
+	(g95_conv_intrinsic_function): Add SELECTED_INT_KIND and
+	SELECTED_REAL_KIND.
+
+2003-09-17  Lars Segerlund  <Lars.Segerlund@comsys.se>
+
+	* iresolve.c (gfc_resolve_random_number): Generate _r4 & _r8
+	instead of _4 and _8 as postfix for libgfortran calls.
+
+2003-09-16  Paul Brook  <paul@nowt.org>
+
+	* array.c (compare_bounds): New function.
+	(gfc_compare_array_spec): Use it.
+
+2003-09-14  Paul Brook  <paul@nowt.org>
+
+	* primary.c (gfc_match_rvalue): Make sure sym->result is set.
+	* trans-expr.c (gfc_conv_string_parameter): Also allow PRAM_DECLs.
+
+2003-09-14  Paul Brook  <paul@nowt.org>
+
+	* check.c (dim_rank_check): Allow assumed bounds if requested.
+	(gfc_check_lbound): Call it.
+	(gfc_check_ubound): Ditto.
+	(gfc_check_size): Change to match.
+	* simplify.c (gfc_simplify_bound): New function.
+	(gfc_simplify_lbound): New function.
+	(gfc_simplify_ubound): New function.
+	* intrinsic.h: Declare them.
+	* intrinsic.c (add_functions): Use them.
+
+2003-09-14  Paul Brook  <paul@nowt.org>
+
+	* io.c (format_lex): Initialize negative_flag.
+	(check_format): Intialize repeat.
+	* trans-io.c (gfc_new_nml_name_expr): Declare static.
+	(gfc_new_var_expr): Ditto.
+
+2003-09-14  Paul Brook  <paul@nowt.org>
+
+	* trans-array.c (gfc_conv_array_initializer): Handle derived types.
+	* trans-decl.c (gfc_get_symbol_decl): Only do local scalar values.
+
+2003-09-12  Paul Brook  <paul@nowt.org>
+
+	* trans-intrinsic.c (gfc_conv_intrinsic_sign): Call fold.
+
+2003-09-12  Zdenek Dvorak  <rakdver@atrey.karlin.mff.cuni.cz>
+
+	* fortran/trans.c (gfc_finish_block): Call rationalize_compound_expr
+	for a correct expression.
+
+2003-09-10  Kejia Zhao  <kejia_zh@yahoo.com.cn>
+
+	* trans-intrinsic.c (real_compnt_info): New struct.
+	(prepare_arg_info): New function.
+	(gfc_conv_intrinsic_set_exponent): New function.
+	(gfc_conv_intrinsic_scale): New function.
+	(gfc_conv_intrinsic_nearest): New function.
+	(gfc_conv_intrinsic_fraction): New function.
+	(gfc_conv_intrinsic_exponent): New function.
+	(gfc_conv_intrinsic_spacing): New function.
+	(gfc_conv_intrinsic_rrspacing): New function.
+	(gfc_conv_intrinsic_function): Use them.
+
+2003-08-24 XiaoQiang Zhang  (zhangapache@yahoo.com>
+
+	* trans-const.c (gfc_conv_mpz_to_tree): Fix bug, parameter for
+	build_int_2 changed from (high, low) to (low, high).
+	* trans-io.c (ioparm_namelist_name, ioparm_namelist_name_len,
+	ioparm_namelist_read_mode, iocall_set_nml_val_int,
+	iocall_set_nml_val_float, iocall_set_nml_val_char,
+	iocall_set_nml_val_complex, iocall_set_nml_val_log): New declaration.
+	(gfc_build_io_library_fndecls): Add variable initialization.
+	(gfc_new_nml_name_expr, get_new_var_expr): New function.
+	(build_dt): Add namelist support.
+	* io.c (value): New variable.
+	(check_format): Support FMT_H now.
+
+2003-09-07  Paul Brook  <paul@nowt.org>
+
+	* io.c (gfc_resolve_dt): Error if format label is not defined.
+
+2003-09-07  Kejia Zhao  <kejia_zh@yahoo.com.cn>
+
+	* trans-intrinsic.c (gfc_conv_intrinsic_aint): Fix two bugs. One is
+	about case_switch's break. The other is about building the condition
+	statement tree, which judges the argument in the range of the
+	corresponding integer type.
+	* trans-intrinsic.c (gfc_conv_intrinsic_mod): MOD and MODULO can work
+	for the large values.
+
+2003-09-05  Paul Brook  <paul@nowt.org>
+
+	* f95-lang.c (expand_function_body): Gimplify the function.
+
+2003-09-04  Jeff Law  <law@redhat.com>
+
+	* f95-lang.c (DEFINE_MATH_BUILTIN): C arrays start at
+	index zero!
+
+2003-09-04  Paul Brook  <paul@nowt.org>
+
+	* f95-lang.c (gfc_define_builtin): Also set implicit_built_in_decls.
+	(gfc_expand_stmt): New function.
+	(LANG_HOOKS_RTL_EXPAND_STMT): Define.
+	(expand_function_body): Use tree_rest_of_compilation.
+	* trans-decl.c (gfc_generate_function_code): Don't free cfun.
+
+2003-09-03  Jeff Law  <law@redhat.com>
+
+	* f95-lang.c (gfc_init_builtin_functions): C arrays start at
+	index zero!
+
+2003-08-30  Paul Brook  <paul@nowt.org>
+
+	* f95-lang.c (builtin_function): Remove #if 0 code.
+	(gfc_define_builtin): New function.
+	(gfc_init_builtin_functions): Use mathbuiltins.def not ../builtins.def.
+	* mathbuiltins.def: New file.
+	* trans-intrinsic.c (gfc_intrinsic_map_t): Add builtin code fields.
+	(gfc_intrinsic_map): Use mathbuiltins.def.
+	(gfc_intrinsic_builtin_t): Remove.
+	(gfc_build_intrinsic_lib_fndecls): Update.
+	* trans-types.c (gfc_init_types): Remove redundant initilaization of
+	signed_size_type_node.
+
+2003-08-29  Paul Brook  <paul@nowt.org>
+
+	* arith.c (gfc_real_kinds): Use correct minimum exponents.
+
+2003-08-22  Kejia Zhao  <kejia_zh@yahoo.com.cn>
+
+	* trans-instinsic.c (gfc_conv_intrinsic_mod): Also do MODULO.
+	(gfc_conv_intrinsic_function): Add MODULO.
+
+2003-08-22  Jason Merrill  <jason@redhat.com>
+
+	* trans-array.c (gfc_conv_expr_descriptor): Update use of predicates.
+
+2003-08-22  Andreas Jaeger  <aj@suse.de>
+
+	* Make-lang.in (f95.install-common): Add DESTDIR support.
+	* (f95.install-info): Likewise.
+	(f95.uninstall): Likewise.
+
+2003-08-19  Diego Novillo  <dnovillo@redhat.com>
+
+	* trans-types.c (gfc_init_types): Initialize
+	signed_size_type_node with size_type_node.
+
+2003-08-18  Paul Brook  <paul@nowt.org>
+
+	* dependency.c (gfc_dependency): New enum.
+	(check_another_array_ref): Remove.
+	(gfc_get_array_from_component): Remove.
+	(get_x): Remove.
+	(get_range): Remove.
+	(get_no_of_elements): Use mpz_t, not mpf_t.
+	(transform_sections): New function.
+	(gfc_check_range_range): Rename ...
+	(gfc_check_section_vs_section): ... to this.  Use new function.
+	(gfc_is_inside_range): Rewrite to match.
+	(gfc_check_element_vs_section): Ditto.
+	(gfc_check_element_vs_element): Ditto.
+	(get_deps): Ditto.
+	(gfc_dep_resolver): Ditto.  Remove unused parameter.
+	* Dependency.h (gfc_check_range_range, gfc_check_element_vs_section,
+	gfc_check_element_vs_element, gfc_is_inside_range,
+	gfc_get_array_from_component): Remove prototypes for static functions.
+	(gfc_dep_resolver): Update prototype.
+	* trans-array.c (gfc_conv_resolve_dependencies): Change to match.
+
+2003-08-15  Paul Brook  <paul@nowt.org>
+
+	* trans-decl.c (gfc_build_qualified_array): Don't add symbols for
+	return values to parent scope.
+	(gfc_build_dummy_array_decl): Ditto.
+
+2003-08-14  Paul Brook  <paul@nowt.org>
+
+	* trans-stmt.c (gfc_trans_allocate): Handle NULL refs. Allocate the
+	size of	the type, not the pointer.
+	* resolve.c (resolve_symbol): Give more accurate error message.
+
+2003-08-10  Paul Brook  <paul@nowt.org>
+
+	* trans-decl.c (gfc_build_function_decl): Only mangle global symbols.
+
+2003-08-10  Paul Brook  <paul@nowt.org>
+
+	* trans-stmt.c (gfc_trans_allocate): Correctly handle non-array derived
+	type components.
+
+2003-08-10  Chun Huang  <compiler@sohu.com>
+
+	* resolve.c (resolve_formal_arglist): Resolve STATEMENT function.
+	(resolve_symbol): Ditto.
+	* trans-expr.c (gfc_conv_statement_function): New function.
+	(gfc_conv_function_expr): Use it.
+
+2003-08-10  Paul Brook  <paul@nowt.org>
+
+	* trans-array.c (gfc_conv_ss_startstride): Handle functions.
+	(walk_function_expr): Set section rank.
+	* trans-intrinsic.c (gfc_walk_intrinsic_libfunc): Ditto.
+
+2003-08-10  Paul Brook  <paul@nowt.org>
+
+	* intrinsic.c (add_sym): Prefix names with correct string.
+	(add_sym_0s): New function.
+	(add_subroutines): Register abort.
+
+2003-08-10  Erik Schnetter  <schnetter@uni-tuebingen.de>
+
+	* gfortran.h: Introduce options to control the mangling.
+	* lang.opt: Likewise.
+	* options.c (gfc_init_options): Handle the options.
+	* trans-common.c (gfc_sym_mangled_common_id): New function.
+	(gfc_build_common_decl): Call it.
+	* trans-decl.c (gfc_sym_mangled_function_id): New function.
+	(gfc_get_extern_function_decl, gfc_build_function_decl): Call it.
+
+2003-08-09  Paul Brook  <paul@nowt.org>
+
+	* module.c (mio_symbol): Always ouput a namespace for formal args.
+	(load_needed): Namespace now belong to their proper symbol.
+	(gfc_dump_module): Change G95=>GFORTRAN.
+
+2003-08-05  Paul Brook  <paul@nowt.org>
+
+	* options.c: Force -fg77-calls.
+
+2003-08-02  Paul Brook  <paul@nowt.org>
+
+	* Makelang.in: Rename G95_* to GFORTRAN_*.
+	* All sources: Rename G95_* to GFC_*.
+
+2003-08-01  Paul Brook  <paul@nowt.org>
+
+	* fortran/Make-lang.in: Use GMPLIBS.
+	* fortran/config-lang.in: Set need_gmp.
+	* trans-expr.c (gfc_conv_variable): Remove incorrect assertion.
+
+2003-07-27  Andreas Jaeger  <aj@suse.de>
+
+	* trans-decl.c (gfc_generate_constructors): Convert prototype to
+	ISO C90.
+	* trans-const.c (gfc_init_constants): Likewise.
+	* trans-intrinsic.c (gfc_build_intrinsic_lib_fndecls): Likewise.
+
+	* gfortranspec.c: Convert to ISO C90.
+	(lang_specific_driver): Correct copyright, remove ALT_LIBM usage.
+
+2003-07-26  Paul Brook  <paul@nowt.org>
+
+	* lang.opt: Add -fdump-parse-tree.
+	* options.c (gfc_handle_option): Ditto.
+	* resolve.c (resolve_forall_iterators): Convert to proper type.
+	* trans-stmt.c (gfc_trans_forall_1): Create temp var with correct type.
+
+2003-07-26  Paul Brook  <paul@nowt.org>
+
+	* Makefile.in: Add build dependencies on files common with rest of gcc.
+
+2003-07-26  Lifang Zeng  <zlf605@hotmail.com>
+
+	* trans.h: Declare g95_trans_pointer_assignment.
+	* trans-expr.c (g95_trans_pointer_assignment): New function.
+	(g95_trans_pointer_assign): Use it.
+	* trans-stmt.c (g95_trans_forall_1): Handle pointer assignment.
+	(g95_trans_pointer_assign_need_temp): New function.
+
+2003-07-26  Paul Brook  <paul@nowt.org>
+
+	* gfortran.texi: Replace references to g95.
+
+2003-07-26  Paul Brook  <paul@nowt.org>
+
+	Rename g95_* to gfc_*.
+
+2003-07-25  Paul Brook  <paul@nowt.org>
+
+	* gfortran.h: Rename from g95.h.
+	* trans-types.c (boolean_type_node, booelan_true_node,
+	boolean_false_node): Remove.
+	* trans-types.h: Ditto.
+
+2003-07-25  Chun Huang  <compiler@sohu.com>
+
+	* parse.c (accept_statement): Implement BLOCK DATA statement.
+	* trans-expr.c (g95_conv_variable): Fix bug for dereference pointer
+	variables.
+
+2003-07-24  Lifang Zeng  <zlf605@hotmail.com>
+
+	* trans-stmt.c (temporary_list): Define.
+	(g95_trans_assign_need_temp): New function.
+	(g95_trans_forall_1): Modified for WHERE.
+	(g95_trans_where_assign): Modified.
+	(g95_trans_where_2): Modified.
+	(g95_evaluate_where_mask): Modified.
+	(g95_trans_where): Modified.
+	(g95_get_temp_expr): Removed.
+	(g95_add_to_where_stmt_list): Removed.
+	(compute_overall_iter_number): Modified for WHERE.
+	* trans.h: Remove where_stmt_list.
+
+2003-07-24  Arnaud Desitter  <arnaud.desitter@geography.oxford.ac.uk>
+
+	* lang.opt: Correct description of options -J and -M.
+
+2003-07-23  Steven Bosscher   <steven@gcc.gnu.org>
+
+	* lang.opt: Move help text to here.
+	* lang-options.h: Remove.
+
+2003-07-23  Arnaud Desitter  <arnaud.desitter@geography.oxford.ac.uk>
+	* iresolve.c (g95_resolve_transpose): Proper variable in switch.
+	* simplify.c (g95_simplify_nearest): Fix typo and use a correct test
+	on kind.
+
+2003-07-22  Steven Bosscher  <steven@gcc.gnu.org>
+	Paul Brook  <paul@nowt.org>
+
+	* check.c (check_rest): Use global pedantic flag.
+	* io.c (data_desc): Ditto.
+	* error.c (g95_warning, g95_warning_now): Use global flag.
+	* f95-lang.c (LANG_HOOKS_HANDLE_OPTION): Rename from DECODE.
+	(expand_function_body): Update to new prototypes.
+	(g95_init): Use new option names.
+	* g95.h (g95_option_t): Standardize names.
+	(g95_init_options, g95_handle_option): Update prototypes.
+	* interface.c: Use new option names.
+	* match.c: Ditto.
+	* module.c: Ditto.
+	* parse.c: Ditto.
+	* primary.c: Ditto.
+	* resolve.c: Ditto.
+	* scanner.c: Ditto.
+	* simplify.c: Ditto.
+	* symbol.c: Ditto.
+	* trans-array.c: Ditto.
+	* trans-expr.c: Ditto.
+	* trans-types.c: Ditto.
+	* trans-decl.c: Ditto.
+	(g95_build_library_function_decl): Remove obsolete VPARAMS.
+	* trans.h: Ditto.
+	* options.c (g95_display_help): Remove.
+	(g95_init_options): Convert to new scheme.
+	(set_Wall): Ditto
+	(g95module_option): Ditto, rename from g95_parse_arg.
+	(g95_handle_module_path_options): New function.
+	* trans-equivalence.c: Fix error message.
+	* lang.opt: Corrections.
+
+2003-07-21  Steven Bosscher  <steven@gcc.gnu.org>
+
+	* lang.opt: New file.
+
+2003-07-21  Arnaud Desitter  <arnaud.desitter@geography.oxford.ac.uk>
+
+	* decl.c (match_attr_spec): Set colon_seen.
+
+2003-07-14  Paul Brook  <paul@nowt.org>
+
+	* trans-array.c: Update comment.
+	(g95_trans_array_constructor_subarray): Cleanup loopinfo data.
+	* trans-intrinsic.c (g95_conv_intrinsic_anyall,count,arith,
+	minmaxloc,minmaxval): Ditto.
+	* trans-io.c (g95_trans_transfer): Ditto.
+	* trans-stmt.c: Remove unneeded prototypes.
+	(generate_loop_for_lhs_to_rhs): Rename vars. Add loop post chain.
+	(generate_loop_for_rhs_to_temp): Rename vars. Don't share loopinfo.
+	(compute_inner_temp_size): Remove bits of dead code. Add comments.
+	Don't share loopinfo.
+	(compute_overall_iter_number): Declare as static.
+	(allocate_temp_for_forall_nest): Ditto.
+	(g95_trans_forall_1): Don't pass shared loopinfo.
+	* trans.c (g95_start_block): Expand comment.
+
+2003-07-12  Paul Brook  <paul@nowt.org>
+
+	* arith.c (g95_index_integer_kind): Remove unused initializer.
+	* trans-stmt.c (generate_loop_for_temp_to_lhs): Don't multiply array
+	index by size of element.
+	(generate_loop_for_rhs_to_temp): Ditto.
+	(allocate_temp_for_forall_nest): Use element size, not index size.
+
+2003-07-11  Arnaud Desitter  <arnaud.desitter@geography.oxford.ac.uk>
+
+	* arith.c (g95_index_integer_kind): Add a TODO.
+	* simplify.c (g95_simplify_nearest): Add a TODO.
+
+2003-07-09  Chun Huang  <compiler@sohu.com>
+
+	* trans.h: Add declarations for gfor_fndecl_string_scan and
+	gfor_fndecl_string_verify.
+	* trans-decl.c (g95_build_intrinsic_function_decls): Build them.
+	* trans-intrinsic.c (g95_conv_intrinsic_scan): New function.
+	(g95_conv_intrinsic_verify): New function.
+	(g95_conv_intrinsic_function): Add SCAN and VERIFY.
+	* simplify.c (g95_simplify_scan, g95_simplify_verify): Fix bug in case
+	of parameter 'BACK=.TRUE.'
+
+2003-07-05  Lifang Zeng  <zlf605@hotmail.com>
+
+	* trans-stmt.c (iter_info, forall_info): Define.
+	(g95_trans_forall_block): Remove.
+	(g95_trans_forall_loop): Use forall info blocks.
+	(g95_trans_nested_forall_loop): New function.
+	(g95_do_allocate): Handle things other than logical masks.
+	(generate_loop_for_temp_to_lhs): New function.
+	(generate_loop_for_rsh_to_temp): New function.
+	(compute_inner_temp_size): New function.
+	(compute_overall_iter_number): New function.
+	(allocate_temp_for_forall_nest): New function.
+	(g95_trans_forall): Move body ...
+	(g95_trans_forall_1): ... to here.  Handle loops with temporaries.
+
+2003-07-02  Paul Brook  <paul@nowt.org>
+
+	* trans-decl.c (create_index_var, g95_build_qualified_array): Put vars
+       	in correct scope.  Change callers to match.
+	* trans-types.c (g95_get_dtype_cst): Allow rank 7 arrays.
+	* iresolve.c (g95_resolve_reshape): Only use constant shapes.
+
+2003-07-02  Paul Brook  <paul@nowt.org>
+
+	* trans-array.c (g95_conv_loop_setup): Remove dead var.  Use
+	expression shape for all expressions.
+	* trans-decl.c (g95_symbol_init): Allow adding at very end of list.
+
+2003-07-03  Arnaud Desitter  <arnaud.desitter@geography.oxford.ac.uk>
+
+	* g95.h (g95_option_t), lang-options.h, options.c (g95_init_options,
+	g95_parse_arg), intrinsic.c (g95_convert_type): support of
+	-Wconversion.
+	* intrinsic.c, g95.h: Add g95_convert_type_warn,
+	* resolve.c (g95_resolve_index): Call it.
+
+2003-07-02  Paul Brook  <paul@nowt.org>
+
+	* iresolve.c (g95_resolve_reshape): Set expression shape.
+	(g95_resolve_shape): Ditto.
+	* simplify.c (g95_simplify_shape): Move common code outside condition.
+	* trans-array.c (g95_conv_array_initializer): Teach it how to count.
+
+2003-07-01  Arnaud Desitter  <arnaud.desitter@geography.oxford.ac.uk>
+
+	* array.c (g95_array_dimen_size): Deal with EXPR_ARRAY to improve
+	conformance checks.
+
+2003-06-29  Paul Brook  <paul@nowt.org>
+
+	* array.c (g95_simplify_iterator_var): Don't bother with return value.
+	* expr.c (find_array_element, find_component_ref): New functions.
+	(remove_subobject_ref): New function.
+	(simplify_const_ref): Use them.  Rename from simplify_component_ref.
+	(simplify_ref_chain): New function.
+	(g95_simplify_expr): Use it.  Simplify parameter variable subobjects.
+	(g95_specification_expr): Simplify the expression.
+	* resolve.c (resolve_operator): Check simplifications return code.
+	(g95_resolve_expr): Ditto.
+
+2003-06-26  Paul Brook  <paul@nowt.org>
+
+	* expr.c (simplify_component_ref): New function.
+	(g95_simplify_expr): Use it.
+	* resolve.c (resolve_structure_cons): Handle references.
+
+2003-06-25  Paul Brook  <paul@nowt.org>
+
+	* trans-io.c (build_dt): Handle internal units.
+
+2003-06-25  Canqun Yang  <canqun@yahoo.com.cn>
+
+	* trans-common.c (g95_build_common_decl): Array index range starts at 0.
+	(g95_build_common_decl, g95_layout_global_equiv, g95_trans_one_common):
+	Use g95_array_index_type instead of integer_type_node.
+	(g95_build_common_decl, g95_set_common_master_type): Use
+	g95_character1_type_node instead of char_type_node.
+	* trans-equivalence.c (g95_layout_local_equiv): As above.
+
+2003-06-24  Steven G. Kargl  <kargls@attbi.com>
+
+	* g95.h (g95_option_t), options.c (g95_init_options, g95_parse_arg):
+	remove last remains of -fquiet.
+
+2003-06-22  Paul Brook  <paul@nowt.org>
+
+	* resolve.c (resolve_operator): Don't fail if we can't simplify.
+	(g95_resolve_expr): Ditto.
+	(resolce_code): Mark as static.
+	* trans-stmt.c (g95_trans_chaaracter_select): Mark labels because the
+	gimplifer doesn't (yet).
+
+2003-06-20  Paul Brook  <paul@nowt.org>
+
+	* g95.h: Add ST_PAUSE and EXEC_PAUSE.
+	* match.c (g95_match_if): Add ST_PAUSE.
+	(g95_match_stopcode): New function.
+	(g95_match_pause, g95_match_stop): Use it.
+	* parse.c (g95_ascii_statement): Handle ST_PAUSE.
+	(decode_stmt, next_statement, parse_executable): Ditto.
+	* resolve.c (resolve_code): Ditto.
+	* st.c (g95_free_statement): Ditto.
+	* trans-stmt.c (g95_trans_pause): New function.
+	* trans-stmt.h: Declare it.
+	* trans.c (g95_trans_code): Use it.
+	* trans-decl.c (gfor_fndecl_pause_numeric, gfor_fndecl_pause_string):
+	Declare.
+	(g95_build_builtin_function_decls): Initialize them.
+	* trans.h: Ditto.
+	* dump-parse-tree.c (g95_show_code_node): Handle EXEC_PAUSE.
+
+2003-06-18  Arnaud Desitter  <arnaud.desitter@geography.oxford.ac.uk>
+
+	* io.c (g95_match_open , g95_match_close, g95_match_inquire,
+	match_filepos): Fix error handling.
+
+2003-06-18  Arnaud Desitter  <arnaud.desitter@geography.oxford.ac.uk>
+
+	* array.c (spec_dimen_size, ref_dimen_size, g95_array_dimen_size):
+	Add assertions on arguments.
+	* resolve.c (expression_shape): Remove useless &.
+	* simplify.c (get_kind, g95_simplify_bit_size, g95_simplify_digits,
+	g95_simplify_ibclr, g95_simplify_ibits, g95_simplify_ibset,
+	g95_simplify_ishft,g95_simplify_ishftc, g95_simplify_maxexponent,
+	g95_simplify_minexponent, g95_simplify_radix, g95_simplify_range
+	g95_simplify_rrspacing, g95_simplify_scale, g95_simplify_spacing,
+	g95_simplify_tan, g95_simplify_tiny): Clean predicates and assertions.
+	(g95_simplify_not, g95_simplify_scale): Add assertions.
+
+2003-06-15  Paul Brook  <paul@nowt.org>
+
+	Clean up stuff to work with the ssa optimizers.
+	* convert.c (convert): Handle BOOLEAN_TYPEs.
+	* f95-lang.c (g95_truthvalue_conversion): Implement.
+	* trans-array.c (g95_trans_array_constructor_value): Group multiple
+	scalar values.
+	* trans.h (g95_truthvalue_conversion): Declare.
+	* trans-intrinsic.c (g95_conv_intrinsic_anyall): Use bool constants.
+	* trans-stmt.c (g95_trans_character_select): Don't create array
+	assignments.  Mark labels as indirect jump targets.
+	* trans-types.h (g95_init_types): Use BOOLEAN_TYPE nodes.
+	(g95_get_dtype_cst): Handle LOGICAL types.
+
+2003-06-14  Paul Brook  <paul@nowt.org>
+
+	* f95-lang.c (g95_gimplify_expr): New function.
+	* trans-array.c (g95_trans_array_constructor_value): Don't create
+	array assignments.
+	(g95_conv_expr_descriptor): Rename simple->gimple.
+	* trans-expr.c (conv_expr_op): Use proper logical operators.
+	* trans-intrinsic.c (build_fixbound_expr): New function.
+	(build_fix_expr): Ditto.
+	(g95_conv_intinsic_aint): Use them. Use builtin functions.
+	(g95_conv_intrinsic_function): Add FLOOR and CEILING.
+
+2003-06-10  Arnaud Desitter  <arnaud.desitter@geography.oxford.ac.uk>
+
+	* array.c (g95_compare_array_spec): Remove unreachable code.
+	* expr.c (g95_copy_expr): Likewise.
+	* intrinsic.c (g95_convert_type): Likewise.
+	* misc.c (g95_code2string): Likewise.
+	* simplify.c (g95_simplify_ishft, g95_simplify_real,
+	g95_simplify_reshape, g95_simplify_sign, g95_simplify_sqrt): Likewise.
+	* trans-stmt.c (g95_trans_select): Likewise.
+	* primary.c (extend_ref): Add an assertion.
+	* simplify.c (g95_convert_constant): Add const.
+	* intrinsic.h: Remove g95_check_x_ni.
+	* f95-lang.c (g95_finish): Call g95_release_include_path.
+
+2003-06-10  Arnaud Desitter  <arnaud.desitter@geography.oxford.ac.uk>
+
+	* resolve.c (resolve_contained_functions): Fix typo introduced on
+	2003-01-13.
+
+2003-06-09  Paul Brook  <paul@nowt.org>
+
+	* g95.h: Include system.h not hwint.h.
+	* many: use safe-ctype.h not ctype.h.  Change isalpha -> ISALPHA, etc.
+	* misc.c (g95_getmem): Use xmalloc/memset instead of calloc.
+
+2003-06-09  Paul Brook  <paul@nowt.org>
+
+	* g95.h (g95_symbol): Add fields for COMMON and EQUIVALENCE variables.
+	* Make-lang.in (F95_OBJS): Add files for COMMON and EQUIVALENCE.
+	* trans-decl.c (g95_add_decl_to_functions): Make non-static.
+	(g95_get_symbol_decl): Handle COMMON and EQUIVALENCE objects.
+	(g95_generate_function_code): Translate COMMON and EQUIVALENCE
+	objects.
+	* trans.h (g95_trans_equivalence, g95_trans_common,
+	g95_add_decl_to_function): Declare.
+	* trans-common.c, trans-equivalence.c: New files.
+
+2003-06-08  Steven Bosscher  <steven@gcc.gnu.org>
+
+	* intrinsic.c (g95_intrinsic_extension): Remove.
+	(add_functions): Substitute g95_check_x for g95_check_x_ni
+	everywhere.
+	(g95_init_expr_extensions): New function.
+	(g95_intrinsic_func_interface): Use it.
+	* intrinsic.h: Remove extern decl for g95_intrinsic_extension.
+	* check.c (g95_check_digit, g95_check_huge, g95_check_kind,
+	g95_check_precision, g95_check_present, g95_check_radix,
+	g95_check_range, g95_check_selected_real_kind): Do not set
+	g95_intrinsic_extension.
+	(g95_check_x_ni): Remove now duplicate of g95_check_x.
+
+	* expr.c (check_inquiry): Add FIXME, fixup some code style.
+
+2003-06-06  Arnaud Desitter  <arnaud.desitter@geography.oxford.ac.uk>
+
+	* g95.h (ref_type): Name this type explicitly.
+	* module.c (MIO_NAME): Add specialisations of mio_name.
+	(mio_symbol_attribute, mio_typespec, mio_array_ref,
+	mio_array_spec, mio_ref, mio_expr, mio_symbol): Use them.
+	(ab_attribute): Name this type explicitly.
+	(mio_symbol_attribute, mio_expr): Add cast to call to find_enum.
+
+2003-06-05  Kejia Zhao  <kejia_zh@yahoo.com.cn>
+
+	* trans-intrinsic.c (g95_conv_allocated): New function.
+	(g95_conv_intrinsic_function): Make G95_ISYM_ALLOCATED work.
+
+2003-06-05  Steven Bosscher  <steven@gcc.gnu.org>
+
+	* f95-lang.c: Don't include g95-support.h
+	(g95_mark_addressable): Add prototype.
+	(g95_init_decl_processing): Remove C front end hack.
+	* f95-tree.c: Remove file.
+	* support.c: Remove file.
+	* g95-support.h: Remove file.
+	* trans-types.c (g95_init_types): Set up boolean
+	type related tree nodes.
+	* Make-lang.in: Remove rules for dead files and
+	dependencies on them.
+
+2003-06-05  Steven Bosscher  <steven@gcc.gnu.org>
+
+	* Make-lang.in (F95_ADDITIONAL_OBJS): Remove the final
+	C front end dependency.  Also, convert.c does not depend on
+	g95-support.h anymore.
+	* convert.c: Don't include c-common.h and g95-support.h
+	* f95-lang.c: Don't inlude c-common.h and c-common.def (3x).
+	(g95_stmt_tree, g95_scope_stmt_stack, anon_aggr_type_p,
+	stmts_are_full_exprs_p, current_stmt_tree,
+	current_scope_stmt_stack): Remove.
+	* g95-support.h (unsigned_conversion_warning): Kill proto.
+	(boolean_type_node, boolean_true_node, boolean_false_node):
+	Don't define here.  Instead, make then true tree nodes in
+	trans-types.
+	* support.c (c_global_trees): Die, C front end, die!!!
+	(g95_init_c_decl_hacks): Don't touch intmax_type_node,
+ 	uintmax_type_node, string_type_node and const_string_type_node.
+	(decl_constant_value, overflow_warning): Make static functions.
+	They are in death row too, though.
+	(default_conversion, c_expand_asm_operands): Remove.
+	* trans-array.c, trans-expr.c, trans-intrinsic.c, trans-stmt.c,
+	trans.c: Don't include c-common.h.
+	* trans-types.c (boolean_type_node, boolean_true_node,
+	boolean_false_node): Make them real tree nodes.
+	* trans-types.h (intmax_type_node, string_type_node,
+	const_string_type_node): Hack to work around C dependencies
+	in builtin-types.def.
+
+2003-06-04  Arnaud Desitter  <arnaud.desitter@geography.oxford.ac.uk>
+
+	* decl.c (decl_types): Add some iterators-like sentinels.
+	* decl.c (match_attr_spec): Use them.
+	Use "decl_types" instead of "int".
+	Add cast in call to g95_match_strings.
+	* dump-parse-tree.c (g95_show_namespace):  Use "g95_intrinsic_op"
+	instead of "int".
+	* g95.h (g95_intrinsic_op): Add some iterators-like sentinels.
+	(g95_interface_info): Use "g95_intrinsic_op".
+	* dump-parse-tree.c (g95_show_namespace): Use them.
+	* interface.c (g95_check_interfaces): Use them.
+	* module.c (read_module, write_module): Use them.
+	* symbol.c (g95_get_namespace, g95_free_namespace): Use them.
+	Use "g95_intrinsic_op".
+	* interface.c (check_operator_interface): Use "g95_intrinsic_op".
+	Add a default case in switch statement.
+	* intrinsic.h (g95_generic_isym_id): Moved to...
+	* g95.h (g95_generic_isym_id): here.
+	(g95_intrinsic_sym): Use "g95_generic_isym_id".
+	* intrinsic.c (make_generic): Use "g95_generice_isym_id".
+	* trans-intrinsic.c (g95_intrinsic_map_t,
+	 g95_conv_intrinsic_lib_funtion): Use "g95_generice_isym_id".
+	* match.c (g95_match_intrinsic_op): Add cast in call to
+	g95_match_strings.
+
+2003-06-03  Steven Bosscher  <steven@gcc.gnu.org>
+
+	* support.c (skip_evaluation, warn_conversion, lvalue_p,
+	lvalue_or_else, pedantic_lvalue_warning, warn_for_assignment,
+	constant_fits_type_p, convert_and_check,
+	unsigned_conversion_warning): Remove these ugly remnants
+	we inherited from the C front end.
+	(function_types_compatible): Remove '#if 0'-edcode.
+	(build_modify_expr): Likewise.
+	(convert_for_assignment): Don't use the deceased functions.
+	The parameter fundecl is now unused.
+	(decl_constant_value): Always just return decl.  In fact
+	this function is not used at present, but it might be in
+	the future, when we start using the tree inliner.
+	(overflow_warning, default_conversion, c_expand_asm_operands):
+	Abort when these are called, they are part of the C type
+	checking implementation and therefore poison to Fortran.
+
+2003-06-04  Steven Bosscher  <steven@gcc.gnu.org>
+
+	* Make-lang.in (F95_ADDITIONAL_OBJS): Don't depend on
+	c-pretty-print.o and c-dump.o.  Add a comment on why we
+	depend on c-semantics.c.
+	* f95-lang.c (LANG_HOOKS_TREE_DUMP_DUMP_TREE_FN):
+	Don't use the C front end tree dumper hook to dump the
+	language specific tree representation -- we don't have
+	one.  So instead, inherit the default langhook.
+
+2003-06-02  Paul Brook  <paul@nowt.org>
+
+	* trans-expr.c (g95_conv_variable): Remove incorrent assertion.
+
+2003-06-02  Arnaud Desitter  <arnaud.desitter@geography.oxford.ac.uk>
+
+	* check.c (g95_check_associated): Use proper types.  Remove
+	extraneous argument in call to g95_error().
+
+2003-06-02  Kejia Zhao  <kejia_zh@yahoo.com.cn>
+
+	* resolve.c (resolve_operator): Make logical operands convert to the
+	type with higher kind.
+
+2003-06-02  Kejia Zhao  <kejia_zh@yahoo.com.cn>
+
+	* check.c (g95_check_associated): Make sure both pointer and target has
+	the same type and rank. Null pointer or array section with vector
+	subscript as target are not allowed.
+	* trans.h: Declare gfor_fndecl_associated.
+	* trans-decl.c: (g95_build_builtin_function_decls): Initialize
+	gfor_fndecl_associated.
+	* trans-intrinsic.c (g95_conv_associated): New function.
+	(g95_conv_intrinsic_function): Make G95_ISYM_ASSOCIATED work.
+
+2003-06-02  Kejia Zhao  <kejia_zh@yahoo.com.cn>
+
+	* trans-array.c (g95_conv_expr_descriptor): Set the base of POINTER
+	according to POINTER itself rather than TARGET.
+	(g95_conv_expr_descriptor): Make lbound start at 1.
+	* trans-expr.c (g95_trans_pointer_assign): Fix a bug for Nullify.
+
+2003-06-01  Paul Brook  <paul@nowt.org>
+
+	* expr.c (g95_type_convert_binary): Make it match the standard.
+	* g95.texi: Remove dead link.
+
+2003-06-01  Steven Bosscher  <steven@gcc.gnu.org>
+
+	* g95.texi: Cleanup somewhat in preparation for inclusion
+	in GCC CVS.
+
+2003-05-23  Arnaud Desitter  <arnaud.desitter@geography.oxford.ac.uk>
+	    Canqun Yang  <canqun@yahoo.com.cn>
+
+	* resolve.c (compare_bound_int, resolve_where_shape): Proper return
+	type.
+	(g95_find_forall_index): Return proper value.
+	(g95_resolve_assign_in_forall, g95_resolve_forall): Use proper type to
+	compare the return value from g95_find_forall_index.
+
+2003-05-23  Arnaud Desitter  <arnaud.desitter@geography.oxford.ac.uk>
+	* g95.h, io.c (g95_st_label): Remove "length".
+	(g95_symtree): Remove "link".
+	(g95_case): Remove "code".
+	* arith.c, arith.h (g95_compare_string, g95_convert_integer,
+	g95_convert_real): Make an argument pointer to const.
+	* decl.c (colon_seen): Add a TODO.
+	* interface.c (g95_compare_types): Fix typo.
+	* interface.c (compare_interfaces): Preserve value of "p".
+	* intrinsic.c (sort_actual): Remove "i".
+	* match.c (g95_match_assign): Proper type in call to g95_match().
+	* parse.c (next_free): Avoid duplicate call due to macro.
+	* parse.c (check_statement_label): wrong type in call to g95_error.
+	* primary.c (match_real_constant): Add a TODO.
+	* resolve.c (resolve_select):  Remove useless conditional.
+	* simplify.c (g95_simplify_repeat): Proper assignment to
+	"value.character.string".
+	* simplify.c (g95_simplify_reshape): Wrong variable in call to
+	g95_error.
+
+2003-05-20  Canqun Yang  <canqun@yahoo.com.cn>
+
+	* trans-stmt.c: Remove unnecessary include file defaults.h.
+
+2003-05-19  Lifang Zeng  <zlf605@hotmail.com>
+
+	* trans-stmt.c (g95_trans_forall_loop): Handle FORALL with negative
+	stride.
+	(g95_trans_forall): Allow arbitrary number of FORALL indexes and
+	actual variables used as FORALL indexes.
+
+2003-05-15  Paul Brook  <paul@nowt.org>
+
+	* trans-array.c (g95_trans_static_array_pointer): Use
+	null_pointer_node.
+	(g95_trans_deferred_array): Initialize static array pointers.
+	* trans-expr.c (g95_conv_function_call): Use formal arglist to
+	correctly pass POINTER and absent CHARACTER arguments.
+
+2003-05-14  Lifang Zeng  <zlf605@hotmail.com>
+
+	* resolve.c (g95_resolve_forall): Resolve FORALL construct/statement.
+	(g95_resolve_forall_body): Resolve FORALL body.
+	(g95_resolve_where_code_in_forall): Resolve WHERE inside FORALL.
+	(g95_resolve_assign_in_forall): Resolve assignment inside FORALL.
+	(g95_find_forall_index): Check whether the FORALL index appears in
+	the expression or not.
+	(resolve_code): Modified.
+
+2003-05-14  Paul Brook  <paul@nowt.org>
+
+	* iresolve.c (g95_resolve_spread): Convert ncopies to index_type.
+
+2003-05-13  Paul Brook  <paul@nowt.org>
+
+	* trans-types.c (g95_max_array_element_size): Now a tree node.
+	(g95_init_types): Work out max size properly.
+	(g95_get_dtype_cst): Modify to match.
+
+2003-05-11  Paul Brook  <paul@nowt.org>
+
+	* trans-io.c (add_case): Create a label decl for case labels.
+
+2003-05-11  Paul Brook  <paul@nowt.org>
+
+	* arith.c (g95_integer_index_kind): New variable.
+	* f95-lang.c (g95_init): Move frontend initialization here ...
+	(g95_post_options): ... from here.
+	* g95.h (g95_index_integer_kind, g95_resolve_index): Declare.
+	* intrinsic.c (add_functions): Use index kinds.
+	* iresolve.c: Convert to index_kind where needed.
+	* resolve.c (g95_resolve_index): Make public, use index_kind.
+	(resolve_array_ref): Adjust to match.
+	* trans-array.c: Rename g95_array_index_kind to g95_index_integer_kind.
+	* trans-stmt.c: Ditto.
+	* trans-types.c: Ditto.
+	* trans-types.h (g95_array_index_kind): Remove declaration.
+	* trans-expr.c (g95_conv_expr_present): Use null_pointer_node.
+
+2003-05-07  Paul Brook  <paul@nowt.org>
+
+	* trans-const.c (g95_conv_mpz_to_tree): Typecast constant.
+	* trans-intrinsic.c (g95_conv_intrinsic_bound): Convert type
+	of bound indices.
+
+2003-05-07  Paul Brook  <paul@nowt.org>
+
+	* trans-array.c (trans_static_array_pointer,
+	g95_trans_array_constructor_value, g95_conv_array_initializer,
+	g95_conv_structure): CONSTRUCTOR nodes only have one operand.
+	(g95_add_loop_ss_code): Convert subscripts to the correct type.
+	* trans-stmt.c (g95_trans_character_select): Ditto.
+	* trans-types.c (g95_init_types): Ditto.
+
+2003-05-07  Steven Bosscher  <steven@gcc.gnu.org>
+
+	* f95-lang.c (expand_function_body): Use input_line, not lineno.
+	* trans-decl.c (g95_generate_function_code,
+	g95_generate_constructors): Likewise.
+	* trans.c (g95_trans_runtime_check, g95_add_block_to_block,
+	g95_get_backend_locus, g95_set_backend_locus, g95_trans_code):
+	Likewise.
+
+2003-05-07  Kejia Zhao  <kejia_zh@yahoo.com.cn>
+	* trans-types.c (g95_get_derived_type): Fix bug for DERIVED type
+	with components point to the DERIVED type itself, and two DERIVED
+	type with components point to each other.
+	* trans-expr.c (g95_conv_componet_ref): Modified
+
+2003-05-07  Kejia Zhao  <kejia_zh@yahoo.com.cn>
+	* trans-expr.c (g95_conv_expr): Translate EXPR_NULL into
+	null_pointer_node.
+	(g95_trans_pointer_assign): Implement Nullify.
+
+2003-05-01  Paul Brook  <paul@nowt.org>
+
+	* trans-array.c (g95_walk_function_expr): Cope with NULL esym.
+	* trans-decl.c (g95_get_symbol_decl): Don't mangle dummy functions.
+
+2003-05-01  Paul Brook  <paul@nowr.org>
+
+	* trans-array.c, trans.c, trans-expr.c, trans-intrinsic.c,
+	trans-stmt.c: Replace empty_stmt_node with build_empty_stmt () and
+	IS_EMPTY_STMT.
+
+2003-05-01  Canqun Yang  <canqun@yahoo.com.cn>
+
+	* trans-stmt.c (g95_trans_integer_select): Add a parameter to build
+	CASE_LABEL_EXPR.
+
+2003-04-28  Paul Brook  <paul@nowt.org>
+
+	* iresolve.c (g95_resolve_transpose): COMPLEX types are twice as big
+	as their kind suggests.
+	(g95_resolve_reshape): Ditto.
+
+2003-04-28  Chun Huang  <compiler@sohu.com>
+
+	* trans-expr.c (g95_conv_substring_expr): New function.
+	(g95_conv_expr): Use it.
+
+2003-04-28  Paul Brook  <paul@nowt.org>
+
+	* iresolve.c (g95_resolve_transpose): Make it match the
+	implementation.
+	* trans-intrinsic.c (g95_is_intrinsic_libcall): Add TRANSPOSE.
+
+2003-04-18  Steven Bosscher  <steven@gcc.gnu.org>
+
+	* trans-types.c (g95_add_field_to_struct): New function to
+	add a field to a UNION_TYPE or RECORD_TYPE.
+	* trans-types.h (g95_add_field_to_struct): Prototype.
+	(g95_get_derived_type): Use g95_add_field_to_struct to add
+	components.
+	* trans-io.c (g95_add_field): Remove.
+	(ADD_FIELD): Use new g95_add_field_to_struct function.
+	(ADD_STRING): Likewise.
+	* trans-stmt.c (g95_trans_select): Likewise.
+	(g95_add_field): Remove duplicated function.
+
+2003-04-18  Canqun Yang  <canqun@yahoo.com.cn>
+
+	Port implementation for CHARACTER SELECT from Andy's tree.
+	* trans-stmt.c (g95_trans_character_select): Implement character
+	select. (g95_add_field): New function.
+	* trans-decl.c: Declare 'gfor_gndecl_select_string'.
+	(g95_build_builtin_function_decls): Add 'gfor_fndecl_select_string'.
+	* g95.h (struct g95_case): Add field 'int n'.
+	* trans.h: Declare 'gfor_fndecl_select_string'.
+
+2003-04-18  Steven Bosscher  <steven@gcc.gnu.org>
+
+	* bbt.c (duplicate_key, g95_insert_bbt_with_overlap): Remove.
+	(g95_insert_bbd): Die on duplicates.
+	* g95.h (g95_insert_bbt_with_overlap): Delete prototype.
+
+2003-04-14  Steven Bosscher  <steven@gcc.gnu.org>
+
+	* g95.texi: Require GMP 4.0 -- like we actually
+	do.  Explain the testsuite and what-goes-where.
+	Don't use undefined texinfo symbol.  Break very
+	long line.  Remove finished item from the list
+	of open projects.
+
+2003-04-11  Canqun Yang  <canqun@yahoo.com.cn>
+
+	* trans-stmt.c (g95_evaluate_where_mask): Give mask temporaries
+	LOGICAL type.
+
+2003-04-10  Canqun Yang  <canqun@yahoo.com.cn>
+
+	* trans-stmt.c (g95_trans_forall): Implement WHERE inside FORALL.
+	(g95_trans_forall_body): New function.
+
+2003-04-10  Canqun Yang  <canqun@yahoo.com.cn>
+
+	* resolve.c (resove_where): New function.
+	(resolve_where_shape): New function.
+	(resolve_code): Add call to 'resolve_where'
+	* trans-stmt.c (g95_trans_where): Modified.
+	(g95_trans_where_2): New function.
+	(g95_trans_where_assign): New function.
+	(g95_evaluate_where_mask): New function.
+	(g95_add_to_stmt_list): New function.
+	(g95_get_temp_expr): New function.
+	* trans.h (where_stmt_list): New structure.
+
+2003-04-10  Paul Brook  <paul@nowt.org>
+
+	* g95spec.c (DEFAULT_SWITCH_TAKES_ARG): Remove.
+	(DEFAULT_WORD_SWITCH_TAKES_ARG): Ditto.
+
+2003-04-10  Steven Bosscher  <steven@gcc.gnu.org>
+
+	Update after mainline -> tree-ssa-branch merge.
+	* f95-lang.c (g95_mark_addressable): Update put_var_into_stack
+	call.
+	(g95_init): Update for new lang_hooks definition.
+	(g95_post_options): New langhook.
+	(LANG_HOOK_POST_OPTIONS): Clear, then define to g95_post_options.
+	* scanner.c (g95_new_file): Comment update.
+
+2003-04-09  Arnaud Desitter  <arnaud.desitter@geography.oxford.ac.uk>
+
+	* g95.h, lang-options.h: Add -Wimplicit-interface.
+	* options.c (g95_init_options, g95_parse_arg): Set it.
+	* interface.c (check_intents): Warn about call with implicit
+	interface.
+	* resolve.c (resolve_unknown_f, resolve_unknown_s): Call
+	g95_procedure_use.
+
+2003-04-05  Paul Brook  <paul@nowt.org>
+
+	* iresolve.c (g95_resolve_spread): Don't resole based on type.
+	* trans-intrinsic.c (g95_is_intrinsic_libcall): Add G95_ISYM_SPREAD.
+
+2003-03-29  Paul Brook  <paul@nowt.org>
+
+	* iresolve.c (g95_resolve_pack): Don't bother resolving based on type.
+	(g95_resolve_unpack): Ditto.
+	* trans-intrinsic.c (g95_conv_intrinsic_merge): New Function.
+	(g95_conv_intrinsic_function): Use it.  Remove PACK and UNPACK.
+	(g95_is_intrinsic_libcall): Add PACK and UNPACK.
+
+2003-03-25  Paul Brook  <paul@nowt.org>
+
+	* arith.c (g95_unary_user, g95_user): Remove dead functions.
+	* arith.h: Ditto.
+	* array.c (g95_free_array_ref): Ditto.
+	* g95.h: Ditto.
+	* symbol.c (g95_use_derived_tree): Ditto.
+	* intrinsic.c (add_functions): Use simplification for SCALE.
+	* primary.c (g95_match_rvalue): Test sym, not symtree.
+
+2003-03-25  Paul Brook  <paul@nowt.org>
+
+	* trans-decl.c (build_function_decl): Add parameter before it gets
+	turned into a constant.
+	* iresolve.c (g95_resolve_eoshift): Resolve to a useful name.
+	* trans-intrinsic.c (g95_is_intrinsic_libcall): Add G95_ISYM_EOSHIFT.
+	* trans-decl.c (g95_create_module_variable): Don't pushdecl constants.
+
+2003-03-22  Paul Brook  <paul@nowt.org>
+
+	* trans-array.c (g95_conv_array_initializer): Allow scalar
+	expressions.
+	* trans-decl.c (g95_finish_var_decl): Result variables are not
+	module variables.
+	* trans-intrinsic.c (g95_conv_intrinsic_transfer): New function.
+	(g95_conv_intrinsic_function): Use it.
+	* trans-types.h (g95_type_spec): Remove dead declaration.
+
+2003-03-21  Paul Brook  <paul@nowt.org>
+
+	* trans-decl.c (g95_build_function_decl): Mark string parameters.
+
+2003-03-20  Paul Brook  <paul@nowt.org>
+
+	* trans-decl.c (g95_build_function_decl): Put character length
+	parameters at the end of the function declaration.
+	* trans-expr.c (g95_conv_function_call): Ditto.
+	* trans-types.c (g95_get_function_type): Ditto.
+
+2003-03-20  Arnaud Desitter  <arnaud.desitter@geography.oxford.ac.uk>
+
+	* resolve.c (resolve_formal_arglist): Don't impose intent for
+	procedure arguments of pure functions.
+	(resolve_select): Remove redundant assignment.
+
+2003-03-19  Arnaud Desitter  <arnaud.desitter@geography.oxford.ac.uk>
+
+	* arith.c (validate_logical), g95.h, options.c (g95_init_options):
+	Remove option l1.
+	* g95.h, intrinsic.c(g95_get_intrinsic_sub_symbol): Add const.
+	* iresolve.c(g95_resolve_cpu_time, g95_resolve_random_number): Add
+	const.
+	* lang-options.h: Remove -finline-repack-arrays. Add -fg77-calls.
+	Order list.
+	* symbol.c (g95_add_type): Fix typo in comment.
+
+
+2003-03-16  Paul Brook  <paul@nowt.org>
+
+	* dump-parse-tree.c (g95_show_code_node): Print resolved sym name.
+	* expr.c (g95_build_call): Remove.
+	* f95-lang.c (puchdecl_top_level): New function.
+	* g95.h (g95_code): Store resolved symbol, not just the name.
+	* intrinsic.c (g95_intrinsic_namespace): New global namespace.
+	(g95_intirinsic_init_1, g95_intrinsic_done_1): Use it.
+	(g95_get_intrinsic_sub_symbol): New function.
+	* iresolve.c (g95_resolve_cpu_time): Use it.
+	(g95_resolve_random_number): Ditto.
+	* resolve.c: Set code->resolved_sym instead of code->sub_name.
+	* trans-decl.c (g95_get_extern_function_decl): Give external decls
+	the correct DECL_CONTEXT.  Add global symbold to the global scope.
+	* trans-stmt.c (g95_trans_code): Remove hacks now the fronted is
+	fixed.
+
+2003-03-16  Paul Brook  <paul@nowt.org>
+
+	* g95.h (g95_option_t): Add g77_calls. Remove inline_repack_arrays.
+	* options.c (g95_parse_arg): Ditto.
+	* module.c (mio_symbol_attribute): Handle the always_explicit bit.
+	* resolve.c (resolve_formal_arglist): The always_explicit sould be set
+	for the procedure, not the parameter.
+	* trans-array.c (g95_trans_g77_array): New function.
+	(g95_trans_assumed_size): Use it.
+	(g95_trans_dummy_array_bias): Ditto.
+	(g95_conv_array_parameter): Handle g77 arrays. Move existing body ...
+	(g95_conv_expr_descriptor): ... to here.  Update callers.
+	* trans-decl.c (g95_build_dummy_array_decl): Handle g77 arrays.
+	(g95_get_symbol_decl): Avoid processing g77 arrays multiple times.
+	* trans-expr.c (g95_conv_function_call): Handle g77 arrays.
+	* trans-intrinsic.c (g95_get_symbol_for_expr): Never use g77 arrays.
+	* trans-types.c (g95_is_nodesc_array): Handle g77 arrays.
+	(g95_sym_type): Ditto.
+
+2003-03-15  Paul Brook  <paul@nowt.org>
+
+	* trans-array.c (g95_walk_elemental_function_args): Don't amputate the
+	first chain.
+	* trans-expr.c (g95_conv_function_call): Use the resolved symbol.
+
+2003-03-14  Paul Brook  <paul@nowt.org>
+
+	* trans-array.c (g95_array_is_packed): Remove.
+	(g95_conv_array_base): Correctly handle all descriptorless cases.
+	(g95_conv_array_stride): Use descriptorless strides.
+	(g95_trans_dummy_array_bias): Don't always repack the array.
+	(g95_build_dummy_array_decl): Automatic dummy arrays are only partial
+	packed.
+	* trans-types.c (g95_get_nodesc_array_type): Differentiate between
+	dummy and non-dummy arrays...
+	(g95_sym_type, g95_get_derived_type): ... like these.
+	(g95_get_array_type_bounds): Allow discontiguous arrays.
+
+2003-03-12  Paul Brook  <paul@nowt.org>
+
+	* array.c (g95_resolve_array_spec): Fix comment.
+	* g95.h (symbol_attributes): New flag always_explicit.
+	* resolve.c (resolve_formal_arglist): Set it always_explicit.
+	* iresolve.c (g95_resolve_lbound, g95_resolve_ubound): Simplify.
+	* trans-array.c (g95_conv_descriptor_dimension): Remove dead assert.
+	(g95_trans_array_bounds): Allow assumed shape arrays.
+	(g95_trans_repack_array): Remove.
+	(g95_trans_dummy_array_bias): Rewite to use descriptorless arrays.
+	* trans-decl.c (g95_build_qualified_array): Only ignore absent
+	bounds for assumed size arrays.
+	(g95_build_dummy_array_decl): Use descriptorless arrays.
+	* trans-expr.c (g95_conv_expr_present): Allow descriptorless arrays.
+	(g95_trans_pointer_assign): Fix typo.
+	* trans-intrinsic.c (g95_conv_intrinsic_function_args): Remove dead
+	code.
+	(g95_conv_intrinsic_bound): Rewrite to handle descriptorless arrays.
+	* trans-types.c (g95_get_nodesc_array_type): Allow non-packed arrays.
+	Also modify callers.
+	* trans-types.h (g95_get_nodesc_array_type): Modify prototype.
+
+2003-03-08  Paul Brook  <paul@nowt.org>
+
+	* trans-array.c (g95_walk_elemental_functions): Don't reverse the SS.
+	(g95_conv_array_ubound): Provide dummy value for assumed size arrays.
+	* resolve.c (compare_spec_to_ref): Allow full array sections.
+
+2003-03-08  Paul Brook  <paul@nowt.org>
+
+	* expr.c (g95_simplify_expr): Also simplify array index and
+	substring expressions.
+	* resolve.c (compare_spec_to_ref): Check for assumed size bounds.
+	* trans-array.c (g95_trans_array_bounds): New function.
+	(g95_trans_auto_array_allocation): Use it.
+	(g95_trans_assumed_size): Rewrite.
+	* trans-decl.c (gfor_fndecl_in_pack, gfor_fndecl_in_unpack): Declare.
+	(gfor_fndecl_repack): Remove.
+	(g95_build_qualified_array): Handle absent upper bounds.
+	(g95_build_dummy_array_decl): Assumed shape arrays are descriptorless.
+	(g95_get_symbol_decl): Update.
+	(g95_build_intrinsic_function_decls): Initialize new decls.
+	* trans.h (gfor_fndecl_in_pack, gfor_fndecl_in_unpack): Declare.
+	(gfor_fndecl_repack): Remove.
+	* trans-io.c (g95_build_io_library_fndecls): Correct prototypes.
+	* trans-types.c: (g95_build_array_type): Merge duplicated code..
+	(g95_get_nodesc_array_type): Handle absent bounds.
+	* trans-types.h (g95_get_nodesc_array_type): Declare.
+
+2003-03-04  Paul Brook  <paul@nowt.org>
+
+	* f95-lang.c (DEF_FUNCTION_TYPE_VAR_3): Define before including
+	builtin-types.def.
+
+2003-03-02  Paul Brook  <paul@nowt.org>
+
+	* options.c (g95_init_options): Drfault to 1.
+	(g95_pasrse_arg): Add -frepack-arrays, use strcmp.
+	* trans-array.c (g95_conv_array_data, g95_conv_array_base,
+	g95_conv_array_stride,g95_conv_array_lbound, g95_conv_array_ubound):
+	Handle non-constant size automatic arrays.
+	(g95_conv_section_upper_bound, g95_conv_section_startstride): Use
+	generic bound functions.
+	(g95_trans_auto_array_allocation): Don't create a descriptor.
+	(g95_trans_assumed_size): New function (broken).
+	(g95_trans_dummy_array_bias): Remove unused var.
+	* trans-array.h (g95_trans_assumed_size): Declare.
+	* trans-decl.c (create_index_var): New fuction.
+	(g95_build_qualified_array): New function.
+	(g95_get_symbol_decl): Use it.
+	(g95_trans_deferred_vars): Handle assumed shape seperately.
+	* trans-types.c (get_element_type): Handle heap allocated arrays.
+	(g95_is_nodesc_array): Include non-const size arrays.
+	(g95_get_nodesc_array_type): Ditto.
+
+2003-02-23  Paul Brook  <paul@nowt.org>
+
+	* trans-array.c (g95_array_init_size): Should use stride, not size of
+	last dimension.
+
+2003-02-18  Paul Brook  <paul@nowt.org>
+
+	* trans-expr.c (g95_trans_arrayfunc_assign): Nove elemental check
+	after intrinsic function check.
+
+2003-02-18  Arnaud Desitter  <arnaud.desitter@geography.oxford.ac.uk>
+
+	* io.c (match_io): Fix missing return value and remove useless
+	assignment.
+	* match.c (g95_match): Remove useless assignment.
+	* module.c (parse_string):  Remove useless post increment.
+	* simplify.c (g95_simplify_verify): Remove useless assignment.
+
+2003-02-15  Paul Brook  <paul@nowt.org>
+
+	* expr.c (restricted_intrinsic): Handle bad values gracefully.
+	* g95.h (symbol_attribute): Add referenced member.
+	(g95_symbol): Add dummy_order member.
+	(g95_set_sym_referenced): Declare.
+	* match.c (g95_match_assignment, g95_match_call): Use it
+	* primary.c (match_actual_arg, g95_match_rvalue,
+	g95_match_variable): Ditto.
+	* symbol.c (next_dummy_order): New variable.
+	(g95_set_sym_referenced): New function.
+	(check_done): New function.
+	(g95_add_*): Use it.
+	* trans-decl.c: Make formatting conform to GCC standards.
+	(g95_defer_symbol_init): Add dummy variables in the right order.
+	(g95_get_symbol_decl): Only accept referenced variables.
+	(g95_create_module_variable): Module variables are always required.
+	(generatr_local_decls): New function.
+	(generate_local_vars): New function.
+	(g95_generate_function_code): Use it.
+
+2003-02-13  Paul Brook  <paul@nowt.org>
+
+	* trans-decl.c (g95_conv_struct_cons): Remove.
+	(g95_get_symbol_decl): Use g95_conv_expr for structure initializers.
+	* trans-expr.c (g95_conv_structure): New function.
+	(g95_conv_expr): Use it.
+
+2003-02-09  Paul Brook  <paul@nowt.org>
+
+	* trans-array.c (g95_array_init_size): Don't evaluate the linit
+	expressions multiple times.
+	(g95_trans_auto_arry_allocation): Use pointer not tmp.
+
+2003-02-08  Paul Brook  <paul@nowt.org>
+
+	* module.c (mio_symtree_ref): Declare as static.
+	(mio_expr): Remove dead code.
+	(read_module): Set the symtree link for fixups.
+	* trans-intrinsic.c (g95_conv_intrinsic_round): Rename...
+	(build_round_expr): ... to this.
+	(g95_conv_intrinsic_aint): New function.
+	(g95_conv_intrinsic_function): Use it.
+
+2003-02-08  Paul Brook  <paul@nowt.org>
+
+	* trans-array.c (g95_trans_array_constructor_value): Use the acutal
+	offset after modificaton, not the increment expression.
+	* dependency.c: Kill excess whitespace.
+
+2003-02-07  Sanjiv Gupta  <sanjivg@noida.hcltech.com>
+
+	* dependency.h: Remove some function declarations.
+	* dependency.c (get_no_of_elements): Change this function not to
+	return int.
+	* other: Add comments for all modified functions.
+
+2003-02-06  Paul Brook  <paul@nowt.org>
+
+	* g95spec.c (lang_specific_functions): Fix initializer warning.
+	* dump-parse-tree.c (g95_show_expr): Use typespec instead of symtree
+	for structure type names.
+	* trans-decl.c (g95_cons_structure_cons): New function.
+	(g95_get_symbol_decl): Use it.
+	* trans-expr.c (g95_conv_component_ref): Remove duplicate pointer
+	referencing code.
+
+2003-02-06  Arnaud Desitter  <arnaud.desitter@geography.oxford.ac.uk>
+
+	* resolve.c (compare_cases): Add const to casts.
+
+2003-01-30  Arnaud Desitter  <arnaud.desitter@geography.oxford.ac.uk>
+
+	* g95.h (g95_check_f): Change a1 to f1m.
+	* intrinsic.c (add_sym_1m, check_specific,
+	g95_intrinsic_func_interface): Use it.
+
+	* module.c (init_pi_tree): Remove useless cast.
+	(fp2): Fix argument type.
+
+	* parse.c (parse_select_block): Add comment.
+
+2003-02-05  Toon Moene  <toon@moene.indiv.nluug.nl>
+
+	* lang-options.h: Fix warning involving C90 concatenated
+	strings.
+
+2003-02-06  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+	    Arnaud Desitter  <arnaud.desitter@geography.oxford.ac.uk>
+
+	* io.c (format_asterisk): Complete initializer to kill warning.
+	* arith.c (DEF_G95_INTEGER_KIND, DEF_G95_LOGICAL_KIND,
+	DEF_G95_REAL_KIND, MPZ_NULL, MPF_NULL): New #defines.
+	(g95_integer_kinds, g95_logical_kinds, g95_real_kinds): Use the
+	new defines to complete initializers.  Kills all warnings.
+
+	* Make-lang.in: Comment cleanup.
+
+2003-02-05  Paul Brook  <paul@nowt.org>
+
+	* array.c (g95_free_constructor): Handle NULL expressions.
+	* resolve.c (resolve_structure_cons): Ditto.
+	* decl.c (g95_match_null): New Function.
+	(variable_decl): Use it.
+	* module.c (mio_expr): Don't bother saving symtree for EXPR_STRUCTURE.
+	* primary.c (g95_match_runtime): Don't use symtree for EXPR_STRUCTURE.
+	* trans-types.c (g95_set_decl_attributes): Remove empty function.
+
+2003-02-05  Paul Brook  <paul@nowt.org>
+
+	* trans.h (build1_v): New macro.
+	(build_v): Remove pointless and incorrect prototype.
+	* various: Use build1_v for GOTO_EXPR and LABEL_EXPRs.
+	* f95-lang.c (g95_init_builtin_decls): DEF_BUILTIN takes 10 args.
+
+2003-02-01  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* Make-lang.in (F95_OBJS): Remove one more dead file.
+
+2003-02-01  Paul Brook  <paul@nowt.org>
+
+	* lang-specs.h: Don't pass -ffixed-form to the linker.
+	* trans-decl.c (g95_generate_function_code): Clear saved decl chain.
+
+2003-02-01  Paul Brook  <paul@nowt.org>
+
+	* Make-lang.in (F95_OBJS): Remove dead files.
+	* trans-array.c (g95_array_init_size): Do the right thing when
+	ubound=NULL.
+	* trans-decl.c (g95_generate_function_code): Initialize deffered
+	symbol list before translating contained subroutines.
+	* trans-expr.c (g95_conv_expr, g95_conv_expr_reference): Substitute
+	scalar invariant values	here...
+	(g95_conv_variable, g95_conv_function_call): ... instead of here ...
+	* trans-intrinsic.c (g95_conv_intrinsic_function_args): .. and here.
+
+2003-01-29  Paul Brook  <paul@nowt.org>
+
+	* trans-array.c (g95_add_loop_code): Put pre code in the right block.
+	(g95_walk_elemental_function_args): Reverse chains before adding.
+	(g95_reverse_ss): Move about a bit.
+	* trans-expr.c (g95_conv_function_call): Handle scalar intrinsic
+	function arguments.
+
+2003-01-28  Paul Brook  <paul@nowt.org>
+
+	* intrinsic.c (resolve_intrinsic): Use correct union member.
+	* trans-array.c (g95_trans_dummy_array_bias): Don't touch absent
+	parameters.
+	* trans-decl.c (g95_get_symbol_decl): Don't translate initializers for
+	use associated variables.
+	* trans-intrinsic.c (g95_conv_intrinsic_present): Move body ...
+	* trans-expr.c (g95_conv_expr_present): ... to here.
+	* trans.h: Declare it.
+	* trans-types.c (g95_sym_type): Assume subroutine if not specified.
+
+2003-01-28  Arnaud Desitter  <arnaud.desitter@geography.oxford.ac.uk>
+
+	* array.c (expand_iterator): Suppress useless assignment.
+	* decl.c (match_char_spec): Ditto.
+	* io.c (match_io_iterator): Ditto.
+	* primary.c (match_real_constant): Ditto.
+	* interface.c (fold_unary, g95_free_interface, g95_extend_expr):
+	Ditto.  Also, use g95_intrinsic_op not int for intrinsic operators.
+	* matchexp.c (match_add_operand, match_level_5): Likewise.
+	* module.c (parse_atom, find_enum): Likewise.
+	* resolve.c: move #include <string.h>
+	(resolve_select): Fix serious typo.
+
+2003-01-28  Steven Bosscher  <s.bosscher@student.tudelft.n>
+
+	* Make-lang.in: Don't build with broken tree-ssa-pre.
+
+2003-01-28  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* resolve.c (resolve_index): Add a TODO.
+	* symbol.c: Remove useless "#include <ctype.h>".
+
+2003-01-27  Paul Brook  <paul@nowt.org>
+
+	* check.c (check_rest): Allow different type kinds as an extension.
+	* g95.h (g95_resolve_f): Add f1m.
+	* intrinsic.c (add_sym_1m, resolve_intrinsic): Use it.
+	* intrinsic.h: Chenge prototypes for MIN and MAX.
+	* iresolve.c (g95_resolve_minmax): New function.
+	(g95_resolve_min, g95_resolve_max): Use it.
+	* trans-intrinsic.c (g95_trans_intrinsic_minmax): Only evaluate
+	arguments once.
+	(g95_conv_intrinsic_present): Fix logic.
+
+2003-01-27  Steven Bossche  <s.bosscher@student.tudelft.nl>
+
+	* g95.h (g95_case): Don't be a tree, be a double linked list.
+	* match.c (match_case_selector): Remove redundant semantics check.
+	Clean up a few goto's to make it a tiny little bit faster.
+	* resolve.c (case_tree): Die.
+	(compare_cases): Accept and compare unbounded cases too.
+	(check_case_overlap): Don't build a tree.  Instead, merge-sort the
+	whole list of g95_cases passed from resolve_select.
+	(sane_logical_select): Die.
+	(check_case_expr): Return FAILURE if a CASE label is of the wrong
+	type kind.
+	(resolve_select): Fixup case expression for computed GOTOs, put it
+	in expr, not expr2, for easier handing in the parse tree dumper and
+	the code generator.  Rewrite the rest of the function: Kill
+	unreachable case labels and unreachable case blocks.
+	* dump-parse-tree.c (g95_show_code_node): Always dump expr for
+	an EXEC_SELECT, not case2 anymore.
+	* trans-const.c (g95_conv_constant_to_tree): New function.
+	(g95_conv_constant): Use it.
+	* trans-const.h: Declare prototype for the new function.
+	* trans-stmt.c (g95_trans_integer_select, g95_trans_logical_select,
+	g95_trans_character_select): New static functions.
+	(g95_trans_select): Rewrite.
+
+2003-01-26  Paul Brook  <paul@nowt.org>
+
+	* intrinsic.c (add_fnctions): Properly add dreal.
+	* trans-intrinsic.c (g95_conv_intrinsic_present): New function.
+	(g95_conv_intrinsic_function): Use it.
+	* trans-io.c (build_dt): Abort on internal files (unimplemented).
+
+2003-01-26  Paul Brook  <paul@nowt.org>
+
+	Widespread changes to the handling of symbols in expressions.  These
+	are now linked via g95_symtree nodes.
+	* parse.c (g95_fixup_sibling symbols): New function.
+	(parse_contained): Use it.
+	* g95.h (symbol_attribute): Add contained.  Indicates a symbol is a
+	contained procedure that has bee correctly fixed up.
+	(g95_code, g95_expr): Point to a g95_symtree, not a g95_symbol.
+
+2003-01-24  Paul Brook  <paul@nowt.org>
+
+	* trans-array.c (g95_walk_expr): Function result attributes are in
+	sym->result.
+	* trans-expr.c (g95_conv_function_call,
+	g95_trans_arrayfunc_assign): Ditto.
+	* trans-decl.c (g95_get_symbol_for_expr): Set sym->result.
+
+2003-01-23  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* expr.c (check_restricted): Fix error message.
+	* symbol.c (free_st_labels): Plug memleak.
+
+2003-01-22  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* arith.c (reduce_unary, reduce_binary_ac, reduce_binary_ca,
+	reduce_binary_aa, reduce_binary, eval_intrinsic,
+	eval_intrinsic_f2): Use typesafe prototypes for eval functions.
+	* g95.h (g95_check_f, g95_simplify_f, g95_resolve_f): New unions
+	for typesafe intrinsics helper functions.
+	(g95_intrinsic_sym): Use them.
+	* intrinsic.c (do_check, add_sym, add_sym_0, add_sym_1,
+	add_sym_1s, add_sym_1m, add_sym_2, add_sym_3, add_sym_4,
+	add_sym_5, add_conv, resolve_intrinsic, do_simplify,
+	check_specific, g95_intrinsic_func_interface,
+	g95_intrinsic_sub_interface): Adjust all calls to intrinsics
+	helper functions.
+	* trans-decl.c (g95_get_extern_function_decl): Likewise.
+	* Make-lang.in: Don't disable warnings for strict prototypes
+	any longer, everything is typesafe now.
+
+2003-01-22  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* bbt.c (duplicate_node): Make static.
+	* module.c (module_name): Make static.
+	* scanner.c (include_dirs): Make static.
+
+2003-01-20  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	Hard coded _gfor_'s should not show up anymore.
+	* g95.h (PREFIX): New macro.
+	* iresolve.c (g95_resolve_cpu_time): Use PREFIX, not
+	hard-coded "_gfor".
+	(g95_resolve_random_number): Likewise.
+	* trans-decl.c (g95_build_intrinsic_function_decls): Likewise.
+	* trans-io.c: Remove 'prefix' macro.  Replace all uses with
+	the new PREFIX macro from g95.h.
+
+2003-01-20  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	The troubles of forking... Andy implemented this just now too.
+	Let's stick to that and keep the trees close.
+	* g95.h (g95_st_label): 'format' member is now a g95_expr.
+	* io.c: Revert previous changes.
+	(g95_match_format): Match the format string as a character
+	literal expression.
+	* match.h (g95_statement_label): Declare external.
+	* parse.c: Revert previous changes.
+	* symbol.c (g95_free_st_label): Free a g95_expr instead
+	if a 'char *'.
+	* trans-io.c: Revert previous changes.
+	(build_dt): Use set_string to set the format string.
+
+2003-01-20  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* io.c (format_string): Make non-static.
+	(g95_match_format): Remember the format string.
+	(terminate_io): Add I/O termination for empty I/O lists.
+	* match.h: Declare external format_string.
+	* parse.c (check_statement_label): Attack the format string
+	to a format label for FORMAT statements.
+	* trans-io.c (g95_add_field): Define prefix macro.  Replace
+	all uses of PREFIX define with a use of this macro.
+	(build_dt): Implement formatted I/O for format labels.
+
+2003-01-20  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* lang-options.h: Kill "-std=F".
+	* options.c: Remove unimplemented "-std=F".  Modify
+	web address.
+	* misc.c (g95_terminal_width): New function.
+	* error.c (g95_error_init_1): Use g95_terminal_width.
+	* g95.h: Add prototype for g95_terminal_width, remove
+	fmode flag.
+
+2003-01-19  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* Make-lang.in: Fix typo.
+
+2003-01-18  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* g95.h (struct g95_case): Remove unused cruft, new member
+	'where' to keep track of the locus of the default case.
+	* match.c (g95_match_case): Add locus to the current case.
+	(match_case_selector): Likewise.
+	* parse.c (parse_select_block): Move semantics check for
+	multiple DEFAULT cases out of here to...
+	* resolve.c (check_case_overlap): ...here.  Return sooner
+	when possible.
+	(check_case_expr): Take two g95_cases now, use to sure the
+	expression kinds are the same.
+	(resolve_select): Cleanup.
+
+2003-01-18  Paul Brook  <paul@nowt.org>
+
+	* trans-io.c: Fix typos in ported IO work (set_fla[tg]).
+	* trans-decl.c (g95_set_symbol_decl): Handle non-array result
+	variables.
+	(g95_get_extern_function_decl): Put decls in the correct context.
+
+2003-01-18  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* trans-io.c: Port changes from Andy to set ERR flag.
+
+2003-01-17  Paul Brook  <paul@nowt.org>
+
+	* trans-array.c: Add various comments.
+	(g95_ss_terminator): Declare as const.
+	(g95_walk_expr): Remove first parameter and update all callers.
+	(g95_walk_op_expr): Initialize scalar SS properly.
+	* trans-array.h (g95_walk_expr): Update prototype.
+	* trans-expr.c: Update for new g95_walk_expr.
+	* trans-intrinsic.c: Ditto.
+	* trans-io.c: Ditto.
+	* trans.h: Various comments for SS chains.
+
+2003-01-17  Paul Brook  <paul@nowt.org>
+
+	* intrinsic.h (g95_generic_isym_id): Add G95_ISYM_S?_KIND, SPACING
+	and RRSPACING.
+	* intrinsic.c (add_functions): Use them.
+	* trans-intrinsic.c (g95_conv_intrinsic_function): Ditto.
+	* trans-expr.c (g95_conv_expr_lhs): Abort on impossible error.
+
+2003-01-17  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	Fallout of a small merge conflict:
+	* intrinsic.c: Un-revert lost patch (G95_ISYM_SCALE).
+
+2003-01-17  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* initrinsic.c: New add_sym_* functions for strong typing.
+	(add_conv): Make prototype strict.
+	* dump-parse-tree.c, dependency.c: Include config.h
+	* resolve.c, trans-io.c: Fix typos.
+
+2003-01-17  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* dump-parse-tree.c (g95_show_code_node): Show the
+	condition for a computed GOTO that was transformed
+	to a SELECT CASE construct.
+	* resolve.c (check_case_overlap): Revert previous switch
+	to treaps, it was too slow and didn't catch all trouble.
+	(resolve_symbol): Be more flexible about module procedures.
+	* symbol.c (check_conflict): Point to relevant section in
+	the standard for dubious conflict.  Allow procedure
+	dummy arguments to be optional again.
+	* trans-io (add_field): Rename to g95_add_field.  Change
+	all callers.
+	* trans-stmt (trans_select): Handle unbounded cases for
+	integer SELECT CASE constructs.  Fix/add more comment.
+
+2003-01-17  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* g95.h: Uses GCC's function attribute macros.
+	* error.c, module.c, parse.c, g95.h: More function attributes.
+
+2003-01-16  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+	Forgot a file...
+	* trans-decl.c (get_label_decl): Use TREE_LINENO instead
+	of DECL_SOURCE_LINE, and TREE_FILENAME instead of
+	DECL_SOURCE_FILE.
+
+2003-01-16  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* f95-lang.c (pushdecl): Use TREE_LINENO instead of
+	DECL_SOURCE_LINE.
+	* trans.c (g95_trans_code): Use annotate_all_with_file_line
+	instead of nowdead wrap_all_with_wfl.
+
+2003-01-14  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* parse.c (g95_parse_file): In verbose mode, dump the parse tree
+	before generating code, so we can still see it even if the code
+	generation phase dies.
+
+2003-01-14  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* decl.c (build_sym): Split out initialization expression parts...
+	(add_init_expr_to_sym): ...to here.
+	(variable_decl): Add the symbol following an attribute list to the
+	symbol tree before parsing the optional initialization expression
+	if the symbol is not of a derived type.
+	* primary.c (g95_match_rvalue): Don't assume a symbol always has
+	a value if it is a PARAMETER.
+
+2003-01-14  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* misc.c: Don't #include <mcheck.h>
+	* module.c: Ditto.  Kill uses of mtrace, muntrace.  If there
+	ever was a glibc bug, then either this was never reported to
+	glibc people, or it has been fixed for so long that there's
+	no information you can find about it, anywhere.
+
+2003-01-14  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	Fix warnings:
+	* module.c (attr_bits, bt_types, array_spec_types):
+	Switch 'const' and 'static'.
+	* iresolve.c (g95_resolve_reshape): Make __resolve0 non-'const'.
+
+	GNU'ify source code:
+	* trans-io.c: Numerous fixes, one fixed warning and a few
+	TODO markers so that we don't forget about them.
+
+2003-01-13  Paul Brook  <paul@nowt.org>
+
+	* intrinsic.c (add_functions): Add G95_ISYM_SCALE.
+	* intrinsic.h (g95_generic_isym_id): Remove bogus G95_ISYM_ANINIT.
+	Add G95_ISYM_SCALE.
+	* trans-intrinsic.c (g95_conv_intrinsic_function): Ditto
+	* match.c (g95_match_stop): Fix dumb == -> != error.
+
+2003-01-13  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* dump-parse-tree.c (show_indent): Add line breaks.  This
+	whole dumping process needs cleanups.
+	* f95-lang.c (g95_mark_addressable): Fix prototype to match
+	the langhook.  Fix 'return's accordingly.
+	* g95-support.h: Adjust prototype.
+	* g95.h: Add 'no_backend' member to 'g95_option_t' struct.
+	* lang-options.h: Add '-fsyntax-only'.
+	* options.c (g95_init_options): Init 'no_backend'.
+	(g95_parse_arg): Deal with '-fsyntax-only'.
+	* parse.c (g95_parse_file): Do not generate code if 'no_backend'
+	is set.
+
+2003-01-13  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+	Patch from Arnaud
+	* resolve.c (resolve_symbol): Assumed shape arrays must be dummy
+	arguments.  Also make sure that if a symbol is marked INTRINSIC,
+	an intrinsic with the symbol's name actually exists.
+	(check_conflict): Make EXTERNAL and DIMENSION attributes conflict.
+	Do not allow PROCEDURES to have the SAVE, POINTER, TARGET,
+	ALLOCATABLE, RESULT, IN_NAMESPACE, OPTIONAL or FUNCTION attribute.
+
+2003-01-13  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* resolve.c (resolve_contained_functions): Fix condition, don't
+	throw internal_error if a child namespace has no name.  Apparently
+	this can be the case?
+
+2003-01-11  Paul Brook  <paul@nowt.org>
+
+	Port changes from Andy's tree:
+	* g95.h (g95_code): Add stop_code.
+	* match.c (g95_match_stop): Detter syntax checking.
+	* resolve.c (resolve_generic_f0): Return match type.
+	(resolve_generic_f): Remove dead/duplicated code.
+	(resolve_specific_f): Ditto.
+	* dump-parse-tree.c (g95_show_code_node): Handle new STOP format.
+	* trans-decl.c (gfor_fndel_stop_*): New fndecl nodes.
+	* trans-stmt.c (g95_trans_stop): Handle new STOP format.
+
+2003-01-11  Paul Brook  <paul@nowt.org>
+
+	* trans-array.c: Various documentation/comment changes.
+	* trans-stmt.c: Ditto.
+
+
+2003-01-10  Paul Brook  <paul@nowt.org>
+
+	* options.c/h: Add -fdump-parse-tree as alias of -v.
+
+2003-01-10  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* dump-parse-tree.c (g95_show_namespace): Fixed another
+	typo.  Sorry, it's Friday...
+
+2003-01-10  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	Spotted by Tobi:
+	* trans-array.c, trans-array.h, trans.c, trans-const.c,
+	trans-const.h, trans-decl.c, trans-expr.c, trans.h
+	trans-intrinsic.c, trans-io.c, trans-stmt.c, trans-stmt.h
+	trans-types.c: Fix bogus copyright years, add 2003.
+	* trans-types.h: Give copyright header.
+
+2003-01-10  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* dump-parse-tree.c (g95_show_namespace): Fixed typo.
+	* expr.c, options.c, scanner.c: Add some more 'const' markers.
+	* intrinsic.c: Some constant strings moved to read-only memory.
+	* io.c (format_asterisk): Move to...
+	* g95.h: ...here.
+
+2003-01-10  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* dump-parse-tree.c (g95_show_namespace): Dump implicit
+	types for ranges instead of per-letter.  Indent the
+	'CONTAINS' just like everything else.
+	* resolve.c (resolve_contained_functions): Clarify comment.
+	Explain non-obvious conditional expression.  Improve
+	diagnostics if tyoe cannot be resolved.
+	Port semi-fix from Andy's tree:
+	(was_declared): Move up before first use.
+	(generic_sym, specific_sym): New functions.  Code moved
+	out if procedure_kind.
+	(procedure_kind): Simplify using new functions.
+	(resolve_generic_f): Make sure the functions we find in
+	a parent namespace is generic.
+	(resolve_specific_f): Ditto for specific functions.
+
+2003-01-10  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* trans-stmt.c, trans.c: Fix some code style issues. Add
+	some more comment (but still not enough!).
+
+2003-01-10  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* symbol.c (flavors, procedures, intents, acces_types,
+	access_types, ifsrc_types): Make const.
+	* misc.c (g95_string2code): Make 'm' param 'const'.
+	* module.c (find_enum, write_atom, mio_name): Make
+	'm' param 'const'.
+	(attr_bits, bt_types, array_spec_types, array_ref_types,
+	ref_types, expr_types): Make const.
+	* g95.h: Adjust external decls.
+
+2003-01-09  Paul Brook  <paul@nowt.org>
+
+	* Testsuite: Add a load of new cases.
+
+2003-01-08  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* Make-file.in: Add dependency on back end header files;
+	a parallel build should work now.
+	* f95-lang-c (lang_identifier): Remove bogus comment.
+	(g95_be_parse_file): Fix prototype.
+	(g95_init): Make static.
+	(g95_finish): Make static.
+	* error.c (g95_syntax_error): Kill. Make define in...
+	* g95.h (g95_syntax_error): Define.
+	(g95.options): Make 'source' member 'const'.
+	* interface.c (g95_match_interface): Explain
+	hard-to-read condition.
+	(g95_match_end_interface): Ditto.
+	* trans_const.c (g95_build_string_const): Make 's' parameter
+	'const'.
+	* trans_const.h: Adjust protoype accordingly.
+	* trans-decl.c: Include tree-dump.h
+	(g95_generate_function_code): Build fixes for recent changes
+	in the tree-ssa branch.
+
+2003-01-08  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* format.c: Kill, move code from here...
+	* io.c: ...to here.
+	* Make-lang.in: Adjust.
+	* MANIFEST: Ditto.
+	* match.h: Ditto.
+	* BUGS: Mention where to submit bugs.  Move old content...
+	* TODO: ...to here.  New file.
+
+2003-01-08  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+	Fix most warnings, and suppress the ones we can't fix for now.
+	* Make-lang.in: Suppress warnings about bad proto's in g95.h,
+	these warnings just clutter the screen and there's not much
+	we can do about them for now anyway.
+	* check.c, iresolve.c: Mark unused function parameters.
+	* dump-parse-tree.c (g95_show_array_spec): Punt on AS_UNKNOWN,
+	they should be resolved before they get here.
+	* error.c: Remove unused FILE *status_out.
+	* f95-lang.c (g95_init): Remove bogus cast.
+	* Many files: Make things 'const' where required.
+	* g95.h: Fix prototypes for all modified functions above.
+	(g95_options): Remove 'object' member.
+
+2003-01-07  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* Make-file.in: Cleanup bogus targets.  Add more comment.
+	* lang-options.h: New option '-w'.
+	* g95.h: add no_options field to struct g95_options.
+	* options.c (g95_init_options): Default no_warnings to off.
+	(g95_parse_arg): Recognise the '-w' switch and its alias,
+	'-fno-warnings'.
+	* error.c (g95_warning, g95_warning_now): Don't emit warning if
+	no_warning option is set.
+	* iresolve.c (g95_resolve_shape): Fix warning.
+
+2003-01-07  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* primary.c (g95_next_string_char): Rename next_string_char, and
+	make static.  Adjust callers accordingly.
+	* resolve.c (resolve_generic_f0): Return try, not match.  Adjust
+	callers accordingly.
+	* g95.h: Split out all g95_match* functions to...
+	* match.h: ...here. New file.
+	* array.c, decl.c, expr.c, format.c, interface.c, io.c, match.c,
+	matchexp.c, module.c, parse.c, primary.c: Inlcude match.h
+
+2003-01-07  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* symbol.c (g95_clear_new_implicit, g95_add_new_implicit_range,
+	g95_merge_new_implicit): New functions.
+	(g95_match_implicit_none, g95_match_implicit): Move from here...
+	* match.c (g95_match_implicit_none, g95_match_implicit): ... to here.
+	Modify to use the new functions in symbol.c.
+	* g95.h: Add and move prototypes.
+
+2003-01-06  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* bbt.c (insert): Use a typedef'ed compare_fn prototype for the
+	node compare function.
+	(g95_insert_bbt): Likewise.
+	(g95_insert_bbt_with_overlap): Likewise.
+	(g95_delete_bbt): Likewise.
+	(delete_treap): Likewise. Also fix a potential bug when calling it.
+	* module.c (compare_pointers): Change proto to compare_fn.
+	(compare_integers): Likewise.
+	(compare_true_names): Likewise.
+	(find_true_name): Adjust call to compare_true_names to match proto.
+	(require_atom, write_atom, mio_name): Fix 'const' warnings.
+	(init_pi_tree): Make compare a compare_fn instead of (int *).
+	* resolve.c (compare_cases): Change proto to compare_fn.
+	* symbol.c (g95_compare_symtree): Change proto to compare_fn, make
+	it static, and rename to compare_symtree.
+	(delete_symtree, g95_undo_symbols, g95_new_symtree): Use renamed
+	function.
+	* g95.h: Kill g95_compare_symtree prototype. Adjust prototypes
+	of g95_insert_bbt, g95_insert_bbt_with_overlap, and g95_delete_bbt.
+
+2003-01-06  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+	* Make-lang.in: Fix spaces/tabs issues from previous patch.
+	* patch.options: Blow away Paul's checkin mistake :-)
+	* io.c (terminate_io): Fix memory leak (Arnaud).
+
+2003-01-06  Steven Bosscher  <s.bosscher@student.tudelft.nl>
+
+	* Make-lang.in: Teach about building DVI, info manual.
+	* g95.texi: New file.
+
+2003-01-02  Paul Brook  <paul@nowt.org>
+
+	* trans-array.c (g95_reverse_ss): Make static and don't use.
+	(g95_conv_ss_descriptor): Don't use g95_loopinfo
+	(g95_conv_array_parameters): Modify for pointer assignments.
+	(g95_walk_subexpr): New function.
+	(g95_walk_expr*): Use it.
+	* trans-array.h (g95_reverse_ss): Remove prototype.
+	* trans-expr.c (g95_trans_pointer_assign): Implement.
+	(Many): Set se.want_pointer before calling g95_conv_array_parameter.
+	* trans-intrinsic.c: Sync with scalarizer changes.
+	* trans-io.c: Ditto.
+
+
+Copyright (C) 2003 Free Software Foundation, Inc.
+
+Copying and distribution of this file, with or without modification,
+are permitted in any medium without royalty provided the copyright
+notice and this notice are preserved.
diff --git a/gcc-4.9/gcc/fortran/ChangeLog-2004 b/gcc-4.9/gcc/fortran/ChangeLog-2004
new file mode 100644
index 000000000..d5d665406
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/ChangeLog-2004
@@ -0,0 +1,2853 @@
+2004-12-29  Steven G. Kargl  <kargls@comcast.net>
+
+	* gfortran.h (gfc_case): fix typo in comment.
+
+2004-12-27  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* trans-intrinsic.c (gfc_conv_intrinsic_ishft): Change to
+	logical	shift.  Call fold.  Remove 0-bit shift shortcut.
+	(gfc_conv_intrinsic_ishftc): Convert first argument to at least
+	4 bytes bits.  Convert 2nd and 3rd argument to 4 bytes.  Convert
+	result if width(arg 1) < 4 bytes.  Call fold.
+
+	PR fortran/19032
+	* trans-intrinsic.c (gfc_conv_intrinsic_mod): Update comment
+	in front of function to match the standard.  Correct handling
+	of MODULO.
+
+2004-12-27  Andrew Pinski  <pinskia@physics.uc.edu>
+
+	* trans-expr.c (gfc_conv_cst_int_power): Only check for
+	flag_unsafe_math_optimizations if we have a float type.
+
+2004-12-23  Steven G. Kargl  <kargls@comcast.net>
+
+	* gfortran.texi: Fix typo.
+
+2004-12-16  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* trans-intrinsic.c (build_fixbound_expr): Clarify comment, fix
+	comment typo.
+
+2004-12-15  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/18993
+	* match.c (gfc_match_if): Don't explicitly skip optional whitespace.
+	(gfc_match_nullify): Make sure that ')' is in front of the end of
+	statement.
+
+	* scanner.c (skip_fixed_comments): Fix typo in comment preceding
+	function.
+
+2004-12-14  Richard Henderson  <rth@redhat.com>
+
+	* gfortran.h (gfc_expr.function.name): Make const.
+	(gfc_iresolve_init_1, gfc_iresolve_done_1): Remove.
+	(gfc_get_string): Update prototype.
+	* iresolve.c: Include tree.h.
+	(string_node, HASH_SIZE, string_head, hash): Remove.
+	(gfc_get_string): Use vsnprintf, get_identifier.
+	(free_strings, gfc_iresolve_init_1, gfc_iresolve_done_1): Remove.
+	* misc.c (gfc_init_1): Don't call gfc_iresolve_init_1.
+	(gfc_done_1): Don't call gfc_iresolve_done_1.
+	* module.c (mio_allocated_string): Take and return const char *,
+	instead of modifying char**.
+	(mio_expr): Update to match.
+	* resolve.c (pure_function): Constify name argument.
+	(resolve_function): Constify name.
+	* trans-intrinsic.c (gfc_conv_intrinsic_function): Likewise.
+
+2004-12-12  Richard Henderson  <rth@redhat.com>
+
+	* iresolve.c (gfc_resolve_all, gfc_resolve_any, gfc_resolve_count,
+	gfc_resolve_cshift, gfc_resolve_dot_product, gfc_resolve_eoshift,
+	gfc_resolve_matmul, gfc_resolve_maxloc, gfc_resolve_maxval,
+	gfc_resolve_minloc, gfc_resolve_minval, gfc_resolve_pack,
+	gfc_resolve_product, gfc_resolve_reshape, gfc_resolve_shape,
+	gfc_resolve_spread, gfc_resolve_sum, gfc_resolve_transpose,
+	gfc_resolve_unpack: Use PREFIX.
+
+2004-12-12  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/18869
+	* match.c (gfc_match_common): Skip whitespace.
+
+2004-12-12  Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/16581
+	* check.c (gfc_check_iand, gfc_check_ibclr, gfc_check_ibits,
+	gfc_check_ibset, gfc_check_ieor, gfc_check_ior): Remove default
+	integer kind check; Issue error for -std=f95 when needed.
+	* intrinsic.c (add_functions): Change ieor from GFC_STD_GNU to
+	GFC_STD_F95.
+	* iresolve.c (gfc_resolve_iand, gfc_resolve_ieor, gfc_resolve_ior):
+	Promote arguments to same kind.
+
+2004-12-12  Steven G. Kargl  <kargls@comcast.net>
+	Paul Brook  <paul@codesourcery.com>
+
+	PR fortran/16222
+	* resolve.c (gfc_resolve_iterator_expr): New function.
+	(gfc_resolve_iterator): Use it.  Add real_ok argument.  Convert
+	start, end and stride to correct type.
+	(resolve_code): Pass extra argument.
+	* array.c (resolve_array_list): Pass extra argument.
+	* gfortran.h (gfc_resolve): Add prototype.
+	* trans-stmt.c (gfc_trans_do): Remove redundant type conversions.
+	Handle real type iterators.
+
+2004-12-11  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/17175
+	* iresolve.c (gfc_resolve_scale): Convert 'I' argument if not of
+	same kind as C's 'int'.
+	(gfc_resolve_set_exponent): Convert 'I' argument if not of kind 4.
+
+2004-12-08  Richard Henderson  <rth@redhat.com>
+
+	* intrinsic.c (gfc_convert_type_warn): Propagate the input shape
+	to the output expression.
+	* iresolve.c (gfc_resolve_cshift, gfc_resolve_eoshift): Suppress
+	warning conversion.
+	(gfc_resolve_reshape): Force convert SHAPE and ORDER parameters
+	to index kind.
+
+2004-12-08  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/18826
+	* resolve.c (resolve_code): Impose correct restrictions on
+	assigned variable.
+
+	* decl.c (gfc_match_end): Use locus of END when eos is an error.
+
+2004-12-02  Steven G. Kargl  <kargls@comcast.net>
+	Paul Brook  <paul@codesourcery.com>
+
+	* check.c (gfc_check_flush, gfc_check_fnum): New functions.
+	(gfc_check_fstat, gfc_check_fstat_sub): New functions.
+	(gfc_check_stat, gfc_check_stat_sub): New functions.
+	* gfortran.h (GFC_ISYM_FNUM,GFC_ISYM_FSTAT,GFC_ISYM_STAT): New symbols
+	* intrinsic.c (add_functions,add_subroutines): Add flush, fnum,
+	fstat, and stat to intrinsics symbol tables.
+	* intrinsic.h (gfc_check_flush, gfc_resolve_stat_sub): Add prototypes.
+	(gfc_resolve_fstat_sub, gfc_resolve_stat): Ditto.
+	* iresolve.c (gfc_resolve_fnum, gfc_resolve_fstat): New functions.
+	(gfc_resolve_stat, gfc_resolve_flush): New functions.
+	(gfc_resolve_stat_sub,gfc_resolve_fstat_sub): New functions
+	* trans-intrinsic.c (gfc_conv_intrinsic_function): Add new intrinsics.
+
+2004-12-02  Steven G. Kargl  <kargls@comcast.net>
+
+	* intrinsic.c: Fix and add comments, fix function declarations
+	(OPTIONAL,REQUIRED): New symbols
+	(add_functions,add_subroutines): Use symbols
+	(gmp.h): Remove unused include
+
+2004-11-25  Joseph S. Myers  <joseph@codesourcery.com>
+
+	* f95-lang.c, gfortranspec.c, trans-decl.c: Avoid ` as left quote
+	in diagnostics.
+
+2004-11-24  Steven Bosscher  <stevenb@suse.de>
+
+	* options.c (gfc_post_options): Don't clear flag_inline_functions.
+
+2004-11-20  Steven G. Kargl  <kargls@comcast.net>
+
+	* check.c (gfc_check_getcwd_sub): Fix seg fault.
+
+	* check.c (gfc_check_exit,gfc_check_umask,gfc_check_umask_sub,
+	gfc_check_unlink,gfc_check_unlink_sub): New functions
+	* gfortran.h (GFC_ISYM_UMASK,GFC_ISYM_UNLINK): New symbols
+	* intrinsic.c (add_functions,add_subroutines): Add umask, unlink,
+	exit to intrinsics symbol tables.
+	* intrinsic.h (gfc_check_umask,gfc_check_unlink,gfc_check_exit,
+	gfc_check_umask_sub,gfc_check_unlink_sub,gfc_resolve_umask,
+	gfc_resolve_unlink,gfc_resolve_exit,gfc_resolve_umask_sub,
+	gfc_resolve_unlink_sub): Add and sort prototypes.
+	* iresolve.c (gfc_resolve_umask,gfc_resolve_unlink,gfc_resolve_exit,
+	gfc_resolve_umask_sub,gfc_resolve_unlink_sub): New functions
+	* trans-intrinsic.c (gfc_conv_intrinsic_function): Use symbols
+
+2004-11-16  Paul Brook  <paul@codesourcery.com>
+
+	PR fortran/13010
+	* trans-array.c (gfc_trans_allocate_temp_array): Use gfc_get_dtype.
+	(gfc_array_init_size, gfc_conv_expr_descriptor): Ditto.
+	* trans-types.c (gfc_get_dtype): Accept array type rather than element
+	type.
+	(gfc_get_nodesc_array_type): Don't set GFC_TYPE_ARRAY_DTYPE.
+	(gfc_get_array_type_bounds): Ditto.
+	(gfc_get_derived_type): Recurse into derived type pointers.
+	* trans-types.h (gfc_get_dtype): Add prototype.
+	* trans.h (GFC_TYPE_ARRAY_DTYPE): Add comment.
+
+2004-11-15  Paul Brook  <paul@codesourcery.com>
+
+	* trans-types.c (gfc_get_dtype): Remove obsolete TODO.
+
+2004-11-10  Paul Brook  <paul@codesourcery.com>
+
+	PR fortran/18375
+	* trans-expr.c (gfc_trans_subarray_assign): Free shape before ss.
+	* trans-io.c (transfer_array_component): Ditto.
+
+2004-11-10  Paul Brook  <paul@codesourcery.com>
+
+	* invoke.texi: Fix typo.
+
+2004-11-08  Kazu Hirata  <kazu@cs.umass.edu>
+
+	* arith.c, array.c, decl.c, expr.c, f95-lang.c, gfortran.h,
+	gfortranspec.c, interface.c, intrinsic.c, iresolve.c, match.c,
+	module.c, parse.c, parse.h, primary.c, resolve.c, scanner.c,
+	trans-array.c, trans-array.h, trans-expr.c, trans-intrinsic.c,
+	trans-io.c, trans-stmt.c, trans.h: Fix comment formatting.
+
+2004-11-06  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/18023
+	* io.c (resolve_tag): Tighten up exception for assigned FORMAT.
+
+2004-11-06  Kazu Hirata  <kazu@cs.umass.edu>
+
+	* gfortranspec.c: Replace GNU CC with GCC.
+
+2004-11-05  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* gfortranspec.c (lang_specific_driver): Change year to 2004.
+
+2004-11-05  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/18111
+	*  trans-decl.c (create_function_arglist): Set DECL_ARTIFICIAL for
+	hidden parameters.
+
+2004-11-05  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/15164
+	* trans-decl.c (gfc_finish_var_decl): Don't declare arguments to
+	module procedures as if they were module variables.
+
+2004-11-03  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/17535
+	PR fortran/17583
+	PR fortran/17713
+	* module.c (write_symbol1): Set module_name for dummy arguments.
+
+2004-11-02  Paul Brook  <paul@codesourcery.com>
+
+	* intrinsic.c (check_intrinsic_standard): Include error locus.
+	Remove VLA.
+	(gfc_intrinsic_func_interface, gfc_intrinsic_sub_interface): Pass
+	locus to check_intrinsic_standard.
+
+2004-10-31  Janne Blomqvist  <jblomqvi@cc.hut.fi>
+
+	PR fortran/17590
+	* gfortran.h: Change GFC_STD_* flags to more appropriate
+	ones. (struct gfc_intrinsic_isym): Add field for standard. (struct
+	gfc_option_t): Add field for warning about use of nonstandard
+	intrinsics.
+	* intrinsic.c (add_sym): Add parameter for standard version, check
+	this against current standard.
+	(add_sym_0): Pass standard parameter to add_sym.
+	(add_sym_1, add_sym_0s, add_sym_1s, add_sym_1m, add_sym_2): Ditto.
+	(add_sym_2s, add_sym_3, add_sym_3ml, add_sym_3red, add_sym_3s): Ditto.
+	(add_sym_4, add_sym_4s, add_sym_5, add_sym_5s): Ditto.
+	(make_generic): Add parameter for standard, check this
+	against currently selected standard.
+	(add_functions, add_subroutines): Add parameter to tell which
+	standard an intrinsic belongs to.
+	(check_intrinsic_standard): New function.
+	(gfc_intrinsic_func_interface): Add call to check_intrinsic_standard.
+	(gfc_intrinsic_sub_interface): Ditto.
+	* lang.opt: Add Wnonstd-intrinsics option.
+	* options.c (gfc_init_options): Change to use new GFC_STD_* flags,
+	init new warning.
+	(set_Wall): Add warning about nonstd intrinsics.
+	(gfc_handle_option): Change to use new GFC_STD_* flags,
+	handle new warning.
+	* invoke.texi: Update manual to include -Wnonstd-intrinsics.
+
+2004-10-30  Andrew Pinski  <pinskia@physics.uc.edu>
+
+	* f95-lang.c (lang_tree_node): Add chain_next to be the TREE_CHAIN.
+
+2004-10-30  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* simplify.c (twos_complement): Calculate mask in GMP arithmetic.
+
+2004-10-30  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* trans.c (gfc_trans_code): Set global locus after recursing. Fix
+	comment typo.
+
+2004-10-30  Canqun Yang  <canqun@nudt.edu.cn>
+
+	* check.c (gfc_check_rand): Allow missing optional argument.
+	(gfc_check_irand): Ditto.
+	* intrinsic.c (add_functions): Set arg optional flag for {i,}rand.
+
+2004-10-28  Scott Robert Ladd  <scott.ladd@coyotegulch.com>
+
+	PR fortran/13490, PR fortran/17912
+	* gcc/fortran/gfortran.h: Added pedantic_min_int to gfc_integer_info
+	* gcc/fortran/gfortran.h: Added ARITH_ASYMMETRIC to arith
+	* gcc/fortran/arith.c: Added support for an "asymmetric integer"
+	warning when compiling with pedantic.
+	* gcc/fortran/arith.c: Set minimum integer values to reflect
+	realities of two's complement signed integers. Added
+	pedantic minimum.
+
+2004-10-17  Andrew Pinski  <pinskia@physics.uc.edu>
+
+	* Make-lang.in (F95_ADDITIONAL_OBJS): Kill.
+	(f951): Do not depend on F95_ADDITIONAL_OBJS and don't
+	link it in.
+
+2004-10-14  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* trans-decl.c (generate_local_decl): Simplify logic, fix comment
+	typo.
+	(gfc_generate_function_code): Fix formatting issue.
+
+2004-10-10  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* module.c: Fix formatting issues.
+
+2004-10-09  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* module.c (mio_interface_rest): Set where member of interface
+	while loading.
+
+2004-10-08  Andrew Pinski  <pinskia@physics.uc.edu>
+
+	PR fortran/17901
+	* options.c (gfc_handle_option): Add break after handing the
+	J/M option.
+
+2004-10-08  Tobias Schlueter  <tobias.shclueter@physik.uni-muenchen.de>
+
+	* arith.c: Fix formatting issues.
+
+2004-10-07  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/17676
+	* resolve.c (resolve_operator): Use correct operator name in message.
+
+2004-10-07  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* primary.c (match_boz_constant): Allow kind parameter suffixes.
+	Move standard warning further to the front.
+
+2004-10-07  Kazu Hirata  <kazu@cs.umass.edu>
+
+	* trans-stmt.c: Fix a comment typo.
+
+2004-10-07  Paul Brook  <paul@codesourcery.com>
+
+	PR fortran/17678
+	* trans-array.c (gfc_trans_deferred_array): Leave use associated
+	variables alone.
+
+2004-10-06  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/17568
+	* simplify.c (twos_complement): New function.
+	(gfc_simplify_ishft, gfc_simplify_ishftc): Revise.
+
+	* simplify.c (gfc_simplify_abs): Use mpfr_hypot for CABS.
+
+2004-10-06  Paul Brook  <paul@codesourcery.com>
+
+	* trans-stmt.c (gfc_trans_simple_do): New function.
+	(gfc_trans_do): Use it.  Evaluate iteration bounds before entering
+	loop.  Update comments.
+
+2004-10-04  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/17283
+	* iresolve.c (gfc_resolve_pack): Choose function depending if mask
+	is scalar.
+
+	PR fortran/17631
+	* intrinsic.c (add_sym_5): Remove.
+	(add_subroutines): Add resolution function for MVBITS.
+	* intrinsic.h (gfc_resolve_mvbits): Declare resolution function for
+	MVBITS
+	* iresolve.c (gfc_resolve_mvbits): New function.
+	(gfc_resolve_random_number): Remove empty line at end of function.
+
+	* trans-const.c (gfc_build_cstring_const): New function.
+	(gfc_init_cst): Use new function.
+	* trans-const.h (gfc_build_cstring_const): Add prototype.
+	* trans-io.c (set_string, set_error_locus): Use new function.
+	* trans-stmt.c (gfc_trans_goto): Use new function.
+
+	PR fortran/17708
+	* parse.c (accept_statement): Don't treat END DO like END IF and
+	END SELECT.
+	(parse_do_block): Generate possible END DO label inside END DO
+	block.
+
+	PR fortran/17776
+	* check.c (gfc_check_system_sub): New function.
+	* gfortran.h (gfc_generic_isym_id): Add GFC_ISYM_SYSTEM.
+	* intrinsic.c (add_functions): Add 'system'.
+	(add_subroutines): Add 'system'.
+	* intrinsic.h (gfc_check_etime_sub, gfc_check_getcwd_sub):
+	Move prototypes to other suborutines.
+	(gfc_check_system_sub, gfc_resolve_system, gfc_resolve_system_sub):
+	Add prototype.
+	(gfc_resolve_system_clock): Fix formatting of prototype.
+	* iresolve.c (gfc_resolve_system, gfc_resolve_system_sub): New
+	functions.
+	* trans-intrinsic.c (gfc_conv_intrinsic_function): Deal with
+	GFC_ISYM_SYSTEM.
+
+2004-10-04  Erik Schnetter  <schnetter@aei.mpg.de>
+
+	* scanner.c (preprocessor_line): Accept preprocessor lines without
+	file names.  Check file names for closing quotes.  Handle escaped
+	quotes in file names.
+
+2004-10-04  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+	Paul Brook  <paul@codesourcery.com>
+
+	* trans-array.c (gfc_conv_expr_descriptor): Check for substriungs.
+	Use gfc_get_expr_charlen.
+	* trans-expr.c (gfc_get_expr_charlen): New function.
+	* trans.h (gfc_get_expr_charlen): Add prototype.
+
+2004-10-04  Kazu Hirata  <kazu@cs.umass.edu>
+
+	* trans-intrinsic.c: Fix a comment typo.
+
+2004-10-03  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* simplify.c (range_check): Remove blank line at beginning of function.
+	(gfc_simplify_dint): Same at end of function.
+	(gfc_simplify_exponent, gfc_simplify_fraction): Simplify calculations.
+	(gfc_simplify_bound): Fix indentation.
+	(gfc_simplify_log10): Simplify calculation.
+	(gfc_simplify_min, gfc_simplify_max): Remove blank line at beginning
+	of function.
+	(gfc_simplify_nearest): Same at end of function.
+	(gfc_simplify_nint, gfc_simplify_idnint): Same at beginning of
+	function.
+	(gfc_simplify_rrspacing, gfc_simplify_set_exponent,
+	gfc_simplify_spacing): Simplify calulations.
+
+2004-10-03  Feng Wang  <fengwang@nudt.edu.cn>
+
+	* trans-intrinsic.c: Fix comments on spacing and rrspacing
+	(gfc_conv_intrinsic_rrspacing): Add fold on constant trees.
+
+2004-10-01  Jan Hubicka  <jh@suse.cz>
+
+	* f95-lang.c (gfc_expand_function): Update call of
+	tree_rest_of_compilation.
+	* trans-decl.c (gfc_generate_constructors): Likewise.
+
+2004-09-26  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* trans-intrinsic.c: Comment fixes.
+
+2004-09-25  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* decl.c (add_init_expr_to_sym, variable_decl): Comment fixes.
+
+2004-09-24  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* trans-types.c (gfc_return_by_reference): Remove superfluous
+	assertion.
+
+	* intrinsic.h (gfc_resolve_getcwd): Update prototype.
+	* iresolve.c (gfc_resolve_getcwd): Add second argument to function.
+
+	PR fortran/17615
+	* trans-expr.c (gfc_trans_arrayfunc_assign): Look at resolved
+	function to determine return type.
+
+2004-09-20  Jan Hubicka  <jh@suse.cz>
+
+	* trans-decl.c (build_entry_thunks): Finalize the function; do not lower
+	tree.
+	(gfc_generate_function_code): Likewise.
+
+2004-09-20  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/15957
+	* simplify.c (gfc_simplify_reshape): Set shape of return value
+	correctly.
+
+2004-09-17  Jeffrey D. Oldham  <oldham@codesourcery.com>
+	    Zack Weinberg  <zack@codesourcery.com>
+
+	* f95-lang.c, trans-expr.c, trans.c: Update for new tree-class
+	enumeration constants.
+
+2004-09-17  Paul Brook  <paul@codesourcery.com>
+
+	* gfortran.h (struct gfc_linebuf): Don't use C99 empty arrays.
+	(gfc_linebuf_header_size): Define.
+	* scanner.c (load_file): Use it.
+
+2004-09-16  Kazu Hirata  <kazu@cs.umass.edu>
+
+	* array.c, data.c, decl.c, dependency.c, error.c, f95-lang.c,
+	interface.c, intrinsic.c, io.c, misc.c, module.c, parse.h,
+	resolve.c, scanner.c, trans-array.c, trans-array.h,
+	trans-common.c, trans-const.h, trans-decl.c, trans-expr.c,
+	trans-intrinsic.c, trans-stmt.c, trans-types.c, trans.c,
+	trans.h: Fix comment typos.  Follow spelling conventions.
+
+2004-09-16  Victor Leikehman  <lei@il.ibm.com>
+
+	PR/15364
+	* trans-io.c (transfer_array_component): New function.
+	(transfer_expr): For array fields, call transfer_array_component.
+
+2004-09-16  Kazu Hirata  <kazu@cs.umass.edu>
+
+	* gfortran.texi: Fix a typo.
+
+2004-09-15  Aaron W. LaFramboise  <aaronavay62@aaronwl.com>
+
+	* parse.c (eof_buf): Rename eof to eof_buf.
+	(unexpected_eof): Same.
+	(gfc_parse_file): Same.
+
+2004-09-15  Steven G. Kargl  <kargls@comcast.net>
+
+	* check.c (gfc_check_getcwd_sub): New function.
+	* gfortran.h (GFC_ISYM_GETCWD): New symbol.
+	* intrinsic.c (add_functions): Add function definition;
+	Use symbol.
+	* intrinsic.c (add_subroutines): Add subroutine definitions.
+	* intrinsic.h: Add prototypes.
+	* iresolve.c (gfc_resolve_getcwd, gfc_resolve_getcwd_sub):
+	New functions.
+	* trans-intrinsic.c (gfc_conv_intrinsic_function): Use symbol.
+
+2004-09-15  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/16485
+	* module.c (write_symbol): Don't fill in module name here.
+	(write_symbol0): Fill in here instead.
+
+2004-09-14  Kazu Hirata  <kazu@cs.umass.edu>
+
+	* data.c, decl.c, f95-lang.c, gfortran.h, match.c,
+	trans-array.c, trans-common.c, trans-expr.c,
+	trans-intrinsic.c, trans-stmt.c, trans-types.c, trans.h: Fix
+	comment typos.  Follow spelling conventions.
+
+2004-09-09  Paul Brook  <paul@codesourcery.com>
+
+	* scanner.c (get_file): Add ATTRIBUTE_UNUSED.
+
+2004-09-08  Paul Brook  <paul@codesourcery.com>
+
+	* array.c: Don't include assert.h.
+	* data.c: Don't include assert.h.  Replace assert and abort with
+	gcc_assert and gcc_unreachable.
+	* dependency.c: Ditto.
+	* f95-lang.c: Ditto.
+	* iresolve.c: Ditto.
+	* resolve.c: Ditto.
+	* simplify.c: Ditto.
+	* symbol.c: Ditto.
+	* trans-array.c: Ditto.
+	* trans-common.c: Ditto.
+	* trans-const.c: Ditto.
+	* trans-decl.c: Ditto.
+	* trans-expr.c: Ditto.
+	* trans-intrinsic.c: Ditto.
+	* trans-io.c: Ditto.
+	* trans-stmt.c: Ditto.
+	* trans-types.c: Ditto.
+	* trans.c: Ditto.
+
+2004-09-07  Per Bothner  <per@bothner.com>
+	Paul Brook  <paul@codesourcery.com>
+
+	* error.c (show_locus): Handle mapped locations.
+	* f95-lang.c (gfc_be_parse_file): Initialize mapped locations.
+	* gfortran.h: Include input.h.
+	(struct gfc_linebuf): Use source_location.
+	* scanner.c (get_file): Initialize linemap.
+	(preprocessor_line): Pass extra argument to get_file.
+	(load_file): Ditto.  Setup linemap.
+	(gfc_new_file): Handle mapped locations.
+	* trans-common.c (build_field, build_equiv_decl, build_common_decl):
+	Set decl source locations.
+	(gfc_trans_common): Set blank common block location.
+	* trans-decl.c (gfc_set_decl_location): New function.
+	(gfc_get_label_decl, gfc_get_symbol_decl): Use it.
+	(trans_function_start): Move call to gfc_set_backend_locus..
+	(build_function_decl): ... to here.
+	(build_entry_thunks): Set and restore the backend locus.
+	(gfc_generate_constructors): Remove excess arguments to
+	init_function_start.
+	(gfc_generate_block_data): Add comments.  Set the decl locus.
+	* trans-io.c (set_error_locus): Handle mapped locations.
+	* trans.c (gfc_get_backend_locus, gfc_get_backend_locus): Ditto.
+	(gfc_trans_code): Use SET_EXPR_LOCATION.
+	(gfc_generate_code): Override the location of the new symbol.
+	* trans.h (gfc_set_decl_location): Add prototype.
+
+2004-08-31  Paul Brook  <paul@codesourcery.com>
+
+	* trans-types.c (gfc_type_for_mode): Return NULL for unknown modes.
+
+2004-09-01  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/15327
+	* trans-intrinsic.c (gfc_conv_intrinsic_merge): Do the right thing for
+	strings.
+
+2004-09-01  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/16400
+	PR fortran/16404
+	(port from g95)
+	* resolve.c (resolve_transfer): New function.
+	(resolve_code): Call resolve_transfer in case of EXEC_TRANSFER.
+
+2004-08-31  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/16579
+	* trans-types.c (gfc_init_types): Make gfc_character1_type_node an
+	unsigned char.
+
+2004-08-31  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* CONTRIB, NEWS, README, TODO: Remove obsolete files.
+
+2004-08-31  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/17244
+	* trans-types.c (gfc_return_by_reference): Remove TODO error,
+	add comment pointing out possible issue WRT compatibility with g77.
+
+2004-08-31  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* trans-decl.c, trans-expr.c, trans-io.c, trans-types.c: Replace
+	all occurences of 'gfc_strlen_type_node' by
+	'gfc_charlen_type_node'.
+	* trans-types.h: Same. Also update comment accordingly.
+
+2004-08-31  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* primary.c: Update copyright boilerplate to say GCC.
+	* f95-lang.c: Change initial comment to say gfortran.
+
+2004-08-31  Paul Brook  <paul@codesourcery.com>
+
+	* trans-types.h: Add comments.
+	(intmax_type_node, string_type_node, const_string_type_node): Remove.
+
+2004-08-30  Richard Henderson  <rth@redhat.com>
+
+	* Make-lang.in (fortran/f95-lang.o): Update dependencies.
+	(fortran/trans-decl.o, fortran/trans-types.o): Likewise.
+	* gfortran.h (gfc_integer_info): Add c_char, c_short, c_int,
+	c_long, c_long_long.
+	(gfc_logical_info): Add c_bool.
+	(gfc_real_info): Add mode_precision, c_float, c_double, c_long_double.
+	* trans-array.c (gfc_array_allocate): Use TYPE_PRECISION
+	rather than gfc_int[48]_type_node for allocate choice.
+	* trans-decl.c (gfc_build_intrinsic_function_decls): Cache
+	local copies of some kind type nodes.
+	(gfc_build_builtin_function_decls): Likewise.
+	* trans-expr.c (gfc_conv_power_op): Likewise.
+	* trans-intrinsic.c (gfc_conv_intrinsic_index,
+	gfc_conv_intrinsic_scan, gfc_conv_intrinsic_verify,
+	gfc_conv_intrinsic_trim, gfc_conv_intrinsic_repeat): Likewise.
+	* trans-stmt.c (gfc_trans_pause, gfc_trans_stop,
+	gfc_trans_character_select, gfc_trans_allocate): Likewise.
+	* trans-io.c (gfc_pint4_type_node): Move into ...
+	(gfc_build_io_library_fndecls): ... here.  Cache local copies of
+	some kind type nodes.
+	* trans-types.c (gfc_type_nodes): Remove.
+	(gfc_character1_type_node, gfc_strlen_type_node): New.
+	(gfc_integer_types, gfc_logical_types): New.
+	(gfc_real_types, gfc_complex_types): New.
+	(gfc_init_kinds): Fill in real mode_precision.
+	(gfc_build_int_type, gfc_build_real_type): New.
+	(gfc_build_complex_type, gfc_build_logical_type): New.
+	(c_size_t_size): New.
+	(gfc_init_types): Loop over kinds.
+	(gfc_get_int_type, gfc_get_real_type): Use gfc_validate_kind.
+	(gfc_get_complex_type, gfc_get_logical_type): Likewise.
+	(gfc_get_character_type_len): Likewise.
+	(gfc_type_for_size): Loop over kinds; use a reduced set of
+	unsigned type nodes.
+	(gfc_type_for_mode): Loop over kinds.
+	(gfc_signed_or_unsigned_type): Use gfc_type_for_size.
+	(gfc_unsigned_type, gfc_signed_type): Use gfc_signed_or_unsigned_type.
+	* trans-types.h (F95_INT1_TYPE, F95_INT2_TYPE, F95_INT4_TYPE,
+	F95_INT8_TYPE, F95_INT16_TYPE, F95_REAL4_TYPE, F95_REAL8_TYPE,
+	F95_REAl16_TYPE, F95_COMPLEX4_TYPE, F95_COMPLEX8_TYPE,
+	F95_COMPLEX16_TYPE, F95_LOGICAL1_TYPE, F95_LOGICAL2_TYPE,
+	F95_LOGICAL4_TYPE, F95_LOGICAL8_TYPE, F95_LOGICAL16_TYPE,
+	F95_CHARACTER1_TYPE, NUM_F95_TYPES, gfc_type_nodes,
+	gfc_int1_type_node, gfc_int2_type_node, gfc_int4_type_node,
+	gfc_int8_type_node, gfc_int16_type_node, gfc_real4_type_node,
+	gfc_real8_type_node, gfc_real16_type_node, gfc_complex4_type_node,
+	gfc_complex8_type_node, gfc_complex16_type_node,
+	gfc_logical1_type_node, gfc_logical2_type_node,
+	gfc_logical4_type_node, gfc_logical8_type_node,
+	gfc_logical16_type_node, gfc_strlen_kind): Remove.
+	(gfc_character1_type_node): Turn in to a variable.
+	(gfc_strlen_type_node): Likewise.
+
+2004-08-30  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* gfortran.h (gfc_namespace): Add new field is_block_data.
+	* parse.c (accept_statement): Remove special handling for BLOCK DATA.
+	(parse_block_data): Record BLOCK DATA name, set is_block_data field.
+	* trans.c (gfc_generate_code): Handle BLOCK DATA units.
+	* trans.h (gfc_generate_block_data): Add prototype.
+	* trans-decl.c (gfc_generate_block_data): New function.
+
+2004-08-29  Richard Henderson  <rth@redhat.com>
+
+	* trans-const.c (gfc_conv_mpz_to_tree): Use mpz_export.
+	* trans-types.c (gfc_init_kinds): Reject integer kinds larger
+	than two HOST_WIDE_INT.
+
+2004-08-29  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/13910
+	* decl.c (free_variable, free_value, gfc_free_data, var_list,
+	var_element, top_var_list, match_data_constant, top_val_list,
+	gfc_match_data): Move here from match.c.
+	(match_old_style_init): New function.
+	(variable_decl): Match old-style initialization.
+	* expr.c (gfc_get_variable_expr): New function.
+	* gfortran.h (gfc_get_variable_expr): Add prototype.
+	* gfortran.texi: Start documentation for supported extensions.
+	* match.c: Remove the functions moved to decl.c.
+	* match.h (gfc_match_data): Move prototype to under decl.c.
+	* symbol.c (gfc_find_sym_tree, gfc_find_symbol): Add/correct
+	comments.
+
+2004-08-29  Steven G. Kargl  <kargls@comcast.net>
+	Paul Brook  <paul@codesourcery.com>
+
+	* check.c (gfc_check_besn, gfc_check_g77_math1): New functions.
+	* f95-lang.c (DO_DEFINE_MATH_BUILTIN): Define.
+	(DEFINE_MATH_BUILTIN, DEFINE_MATH_BUILTIN_C): Use it.
+	(build_builtin_fntypes): New function.
+	(gfc_init_builtin_functions): Use it.
+	* gfortran.h (enum gfc_generic_isym_id): Add GFC_ISYM_{J,Y}{0,1,N}
+	and GFC_ISYM_ERF{,C}.
+	(gfc_c_int_kind): Declare.
+	* intrinsic.c (add_functions): Add [d]bes* and [d]erf*.
+	* intrinsic.h (gfc_check_besn, gfc_check_g77_math1, gfc_resolve_besn,
+	gfc_resolve_g77_math1): Add prototypes.
+	* resolve.c (gfc_resolve_besn, gfc_resolve_g77_math1): New functions.
+	* mathbuiltins.def: Add comment.  Change third argument.  Use
+	DEFINE_MATH_BUILTIN_C.  Add bessel and error functions.
+	* trans-intrinsic.c (BUILT_IN_FUNCTION): Define.
+	(DEFINE_MATH_BUILTIN, DEFINE_MATH_BUILTIN_C): Use it.
+	* trans-types.c (gfc_c_int_kind): Declare.
+	(gfc_init_kinds): Set it.
+
+2004-08-29  Steven G. Kargl  <kargls@comcast.net>
+	Paul Brook  <paul@codesourcery.com>
+
+	* gfortran.h (enum gfc_generic_isym_id): Add GFC_ISYM_GET?ID.
+	(gfc_check_f, gfc_simplify_f): Add f0.
+	* intrinsic.c (do_check): Call f0.  Flatten.
+	(add_sym_0): Fix prototype.  Set f0.
+	(add_functions): Add getgid, getgid and getuid.
+	(resolve_intrinsic): Remove obsolete comment.
+	(do_simplify): Call f0.
+	* intrinsic.h (gfc_resolve_getgid, gfc_resolve_getpid,
+	gfc_resolve_getuid): Add prototypes.
+	* iresolve.c (gfc_resolve_getgid, gfc_resolve_getpid,
+	gfc_resolve_getuid): New functions.
+	* trans-intrinsic.c (gfc_conv_intrinsic_function): Handle
+	GFC_ISYM_GET?ID.
+
+2004-08-28  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* error.c (gfc_error_init_1): Remove blank line in front of
+	function body. Add missing blank.
+	(gfc_buffer_error, error_char, error_string): Remove blank line in
+	front of function body.
+	(show_locus): Add comma in comment.
+	(gfc_clear_warning, gfc_warning_check, gfc_clear_error,
+	gfc_push_error, gfc_pop_error): Remove blank line in front of
+	function body.
+	(gfc_get_errors): Typo fix in comment in front of function. Remove
+	blank line in front of function body.
+
+2004-08-27  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* gfortran.h (gfc_default_*_kind): Remove prototypes, add extern
+	variable declaration of same name.
+	* arith.c, check.c, decl.c, dump_parse_tree.c, expr.c,
+	intrinsic.c, io.c, iresolve.c, match.c, options.c, primary.c,
+	resolve.c, simplify.c, symbol.c, trans-const.c, trans-io.c:
+	Replace all calls to gfc_default_*_kind with variable accesses.
+	* trans-types.c: Same as above.
+	(gfc_default_*_kind_1): Rename to gfc_default_*_kind, remove
+	static qualifier. Replace all occurences.
+	(gfc_default_*_kind): Remove functions.
+
+2004-08-26  Richard Henderson  <rth@redhat.com>
+
+	* arith.c: Include system.h, not real system headers.
+	(MPZ_NULL, MPF_NULL, DEF_GFC_INTEGER_KIND, DEF_GFC_LOGICAL_KIND,
+	DEF_GFC_REAL_KIND, GFC_SP_KIND, GFC_SP_PREC, GFC_SP_EMIN, GFC_SP_EMAX,
+	GFC_DP_KIND, GFC_DP_PREC, GFC_DP_EMIN, GFC_DP_EMAX, GFC_QP_KIND,
+	GFC_QP_PREC, GFC_QP_EMIN, GFC_QP_EMAX): Remove.
+	(gfc_integer_kinds, gfc_logical_kinds, gfc_real_kinds,
+	gfc_index_integer_kind, gfc_default_integer_kind,
+	gfc_default_real_kind,gfc_default_double_kind,
+	gfc_default_character_kind, gfc_default_logical_kind,
+	gfc_default_complex_kind, validate_integer, validate_real,
+	validate_logical, validate_character,
+	gfc_validate_kind): Move to trans-types.c.
+	(gfc_set_model_kind): Use gfc_validate_kind.
+	(gfc_set_model): Just copy the current precision to default.
+	(gfc_arith_init_1): Use mpfr precision 128 for integer setup.
+	* f95-lang.c (gfc_init_decl_processing): Invoke gfc_init_kinds.
+	* gfortran.h: Update file commentary.
+	* trans-types.c (MAX_INT_KINDS, MAX_REAL_KINDS): New.
+	(gfc_default_integer_kind_1, gfc_default_real_kind_1,
+	gfc_default_double_kind_1, gfc_default_character_kind_1,
+	gfc_default_logical_kind_1, gfc_default_complex_kind_1): New.
+	(gfc_init_kinds): New.
+	(gfc_init_types): Don't set gfc_index_integer_kind here.
+	* trans-types.h (gfc_init_kinds): Declare.
+	* doc/invoke.texi: Clarify DOUBLE PRECISION behaviour wrt -r8.
+
+2004-08-26  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* check.c (gfc_check_atan2): New function.
+	* intrinsic.c (add_functions): Use gfc_check_atan2 for ATAN2
+	* intrinsic.h (gfc_check_atan2): Add prototype.
+
+2004-08-25  Richard Henderson  <rth@redhat.com>
+
+	* arith.c (gfc_validate_kind): Add may_fail argument; abort if
+	false and we don't validate the kind.
+	(gfc_check_integer_range, gfc_check_real_range): Update to match.
+	* check.c (kind_check): Likewise.
+	* decl.c (gfc_match_old_kind_spec, gfc_match_kind_spec): Likewise.
+	(match_char_spec, match_logical_spec): Likewise.
+	* gfortran.h (gfc_validate_kind): Likewise.
+	* options.c (gfc_handle_option): Likewise.
+	* primary.c (match_integer_constant, match_real_constant,
+	match_string_constant, match_logical_constant,
+	match_const_complex_part): Likewise.
+	* simplify.c (get_kind, gfc_simplify_bit_size, gfc_simplify_digits,
+	gfc_simplify_epsilon, gfc_simplify_huge, gfc_simplify_ibclr,
+	gfc_simplify_ibset, gfc_simplify_ishft, gfc_simplify_ishftc,
+	gfc_simplify_maxexponent, gfc_simplify_minexponent,
+	gfc_simplify_nearest, gfc_simplify_not, gfc_simplify_precision,
+	gfc_simplify_radix, gfc_simplify_range, gfc_simplify_rrspacing,
+	gfc_simplify_scale, gfc_simplify_spacing, gfc_simplify_tan,
+	gfc_simplify_tiny): Likewise.
+	* trans-intrinsic.c (gfc_conv_intrinsic_aint, gfc_conv_intrinsic_mod,
+	gfc_conv_intrinsic_minmaxloc, gfc_conv_intrinsic_minmaxval,
+	prepare_arg_info): Likewise.
+
+2004-08-25  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* expr.c (gfc_check_assign): Add comment. Add new warning.
+	* trans-expr.c (gfc_conv_function_call): Correctly dereference
+ 	result of pointer valued function when not in pointer assignment.
+
+2004-08-25  Paul Brook  <paul@codesourcery.com>
+
+	* config-lang.in: Remove dead commented line.
+	* module.c: Replace g95 with gfortran in comment.
+
+2004-08-25  Paul Brook  <paul@codesourcery.com>
+
+	PR fortran/17190
+	* arith.c (gfc_mpfr_to_mpz): Workaround mpfr bug.
+
+2004-08-25  Paul Brook  <paul@codesourcery.com>
+
+	PR fortran/17144
+	* trans-array.c (gfc_trans_allocate_temp_array): Remove
+	string_length argument.
+	(gfc_trans_array_ctor_element): New function.
+	(gfc_trans_array_constructor_subarray): Use it.
+	(gfc_trans_array_constructor_value): Ditto.  Handle constant
+	character arrays.
+	(get_array_ctor_var_strlen, get_array_ctor_strlen): New functions.
+	(gfc_trans_array_constructor): Use them.
+	(gfc_add_loop_ss_code): Update to new gfc_ss layout.
+	(gfc_conv_ss_descriptor): Remember section string length.
+	(gfc_conv_scalarized_array_ref): Ditto.  Remove dead code.
+	(gfc_conv_resolve_dependencies): Update to new gfc_ss layout.
+	(gfc_conv_expr_descriptor): Ditto.
+	(gfc_conv_loop_setup): Ditto.  Spelling fixes.
+	* trans-array.h (gfc_trans_allocate_temp_array): Update prototype.
+	* trans-const.c (gfc_conv_constant):  Update to new gfc_ss layout.
+	* trans-expr.c (gfc_conv_component_ref): Turn error into ICE.
+	(gfc_conv_variable): Set string_length from section.
+	(gfc_conv_function_call): Remove extra argument.
+	(gfc_conv_expr, gfc_conv_expr_reference): Update to new gfc_ss layout.
+	* trans-types.c (gfc_get_character_type_len): New function.
+	(gfc_get_character_type): Use it.
+	(gfc_get_dtype): Return zero for internal types.
+	* trans-types.h (gfc_get_character_type_len): Add prototype.
+	* trans.h (struct gfc_ss): Move string_length out of union.
+
+2004-08-25  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* trans.h (build2_v, build3_v): New macros.
+	(build_v): Remove.
+	* f95-lang.c (gfc_truthvalue_conversion): Use build2 instead of
+	build.
+	* trans-array.c (gfc_conv_descriptor_data,
+	gfc_conv_descriptor_offset, gfc_conv_descriptor_dimension,
+	gfc_conv_descriptor_stride, gfc_conv_descriptor_lbound,
+	gfc_conv_descriptor_ubound, gfc_trans_allocate_array_storage,
+	gfc_trans_allocate_temp_array,
+	gfc_trans_array_constructor_subarray,
+	gfc_trans_array_constructor_value, gfc_conv_array_index_ref,
+	gfc_trans_array_bound_check, gfc_conv_array_index_offset,
+	gfc_conv_scalarized_array_ref, gfc_conv_array_ref,
+	gfc_conv_array_ref, gfc_trans_preloop_setup,
+	gfc_trans_scalarized_loop_end, gfc_conv_ss_startstride,
+	gfc_conv_loop_setup, gfc_array_init_size,
+	gfc_conv_array_initializer, gfc_trans_array_bounds,
+	gfc_trans_auto_array_allocation, gfc_trans_dummy_array_bias,
+	gfc_conv_expr_descriptor, gfc_conv_array_parameter,
+	gfc_trans_deferred_array): Use buildN and buildN_v macros instead
+	of build and build_v as appropriate.
+	* trans-common.c (create_common): Same.
+	* trans-decl.c (gfc_trans_auto_character_variable,
+	gfc_trans_entry_master_switch, gfc_generate_function_code): Same.
+	* trans-expr.c (gfc_conv_expr_present, gfc_conv_substring,
+	gfc_conv_component_ref, gfc_conv_unary_op, gfc_conv_powi,
+	gfc_conv_cst_int_power, gfc_conv_string_tmp, gfc_conv_concat_op,
+	gfc_conv_expr_op, gfc_conv_function_call,
+	gfc_trans_structure_assign): Same.
+	* trans-intrinsic.c (build_fixbound_expr, build_round_expr,
+	gfc_conv_intrinsic_aint, gfc_conv_intrinsic_bound,
+	gfc_conv_intrinsic_cmplx, gfc_conv_intrinsic_mod,
+	gfc_conv_intrinsic_dim, gfc_conv_intrinsic_sign,
+	gfc_conv_intrinsic_dprod, gfc_conv_intrinsic_minmax,
+	gfc_conv_intrinsic_anyall, gfc_conv_intrinsic_count,
+	gfc_conv_intrinsic_arith, gfc_conv_intrinsic_minmaxloc,
+	gfc_conv_intrinsic_minmaxval, gfc_conv_intrinsic_btest,
+	gfc_conv_intrinsic_bitop, gfc_conv_intrinsic_singlebitop,
+	gfc_conv_intrinsic_ibits, gfc_conv_intrinsic_ishft,
+	gfc_conv_intrinsic_merge, gfc_conv_intrinsic_strcmp,
+	gfc_conv_allocated, gfc_conv_associated, prepare_arg_info,
+	gfc_conv_intrinsic_spacing, gfc_conv_intrinsic_rrspacing,
+	gfc_conv_intrinsic_trim, gfc_conv_intrinsic_repeat,
+	gfc_conv_intrinsic_iargc): Same.
+	* trans-io.c (set_parameter_value, set_parameter_ref, set_string,
+	set_flag, add_case, io_result, transfer_namelist_element,
+	transfer_expr): Same.
+	* trans-stmt.c (gfc_trans_goto, gfc_trans_return, gfc_trans_if_1,
+	gfc_trans_arithmetic_if, gfc_trans_do, gfc_trans_do_while,
+	gfc_trans_integer_select, gfc_trans_logical_select,
+	gfc_trans_character_select, gfc_trans_forall_loop,
+	gfc_trans_nested_forall_loop, gfc_do_allocate,
+	generate_loop_for_temp_to_lhs, generate_loop_for_rhs_to_temp,
+	compute_inner_temp_size, compute_overall_iter_number,
+	allocate_temp_for_forall_nest, gfc_trans_pointer_assign_need_temp,
+	gfc_trans_forall_1, gfc_evaluate_where_mask,
+	gfc_trans_where_assign, gfc_trans_allocate): Same.
+	* trans-types.c (gfc_get_dtype, gfc_get_array_type_bounds): Same.
+	* trans.c (gfc_add_modify_expr, gfc_finish_block,
+	gfc_build_array_ref, gfc_build_function_call,
+	gfc_trans_runtime_check): Same.
+
+2004-08-25  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* trans-const.c (gfc_conv_mpz_to_tree): Change call to
+	build_int_cst to build_int_cst_wide in accordance to Nathan's
+	previous patch.
+
+2004-08-25  Nathan Sidwell  <nathan@codesourcery.com>
+
+	* trans-array.c (gfc_trans_array_constructor_value): Adjust
+	build_int_cst calls.
+	* trans-const.c (gfc_build_string_const, gfc_init_constants,
+	gfc_conv_mpz_to_tree, gfc_conv_constant_to_tree): Likewise.
+	* trans-decl.c (gfc_get_symbol_decl, build_entry_thunks,
+	gfc_trans_entry_master_switch): Likewise.
+	* trans-intrinsic.c (gfc_conv_intrinsic_ibits,
+	gfc_conv_intrinsic_len, prepare_arg_info): Likewise.
+	* trans-io.c (add_case, set_error_locus,
+	transfer_namelist_element, transfer_expr): Likewise.
+	* trans-stmt.c (gfc_trans_label_assign, gfc_trans_pause,
+	gfc_trans_stop, gfc_trans_character_select): Likewise.
+	* trans-types.c (gfc_init_types, gfc_get_dtype): Likewise.
+	* trans.c (gfc_trans_runtime_check): Likewise.
+
+2004-08-24  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* trans-decl.c, trans-types.c: Add and remove blank lines as
+	required.
+
+2004-08-24  Richard Henderson  <rth@redhat.com>
+
+	* trans-const.c (gfc_conv_mpz_to_tree): Fix 64-bit shift warning.
+
+2004-08-24  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* resolve.c (merge_argument_lists): Revert unintentionally
+	committed change.
+
+2004-08-24  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* trans-decl.c (build_function_decl): Fix spelling in comment.
+	(build_entry_thunks): Remove code with no function.
+	(gfc_build_intrinsic_function_decls): Remove empty line.
+
+	* resolve.c (resolve_entries): Fix a bunch of comment typos.
+
+2004-08-24  Nathan Sidwell  <nathan@codesourcery.com>
+
+	* f95-lang.c (gfc_init_decl_processing): Adjust
+	build_common_tree_nodes call.
+
+2004-08-24  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* trans-types.c: Spelling and formatting fixes.
+
+2004-08-23  Richard Henderson  <rth@redhat.com>
+
+	* trans-const.c (gfc_conv_mpz_to_tree): Use mpz_getlimbn instead
+	of going through an intermediate string.  Fix 32/64 int/long bug.
+
+2004-08-23  Eric Christopher  <echristo@redhat.com>
+
+	* trans-types.c (gfc_type_for_mode): Remove VECTOR_TYPE_SUPPORTED_P
+	usage. Use build_vector_type_for_mode for vector types.
+
+2004-08-22  Richard Henderson  <rth@redhat.com>
+
+	PR 13465
+	* data.c (find_con_by_offset): Search ordered list; handle
+	elements with repeat counts.
+	(gfc_assign_data_value_range): New.
+	* gfortran.h (struct gfc_data_value): Make repeat unsigned.
+	(gfc_assign_data_value_range): Declare.
+	* match.c (top_val_list): Extract repeat count into a temporary.
+	* resolve.c (values): Make left unsigned.
+	(next_data_value): Don't decrement left.
+	(check_data_variable): Use gfc_assign_data_value_range.
+
+2004-08-22  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* trans-const.c, trans-decl.c, trans-expr.c: Spelling fixes.
+
+2004-08-22  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* check.c (gfc_check_reduction): Rename to ...
+	(check_reduction): ... this. Make static. Don't check type of
+	first argument.
+	(gfc_check_minval_maxval, gfc_check_prodcut_sum): New functions.
+	* intrinsic.c (add_functions): Change MAXVAL, MINVAL, PRODUCT and
+	SUM to use new check functions.
+	(check_specific): Change logic to call new functions.
+	* intrinsic.h (gfc_check_minval_maxval, gfc_check_product_sum):
+	Add prototypes.
+	(gfc_check_reduction): Remove prototype.
+
+2004-08-20  Paul Brook  <paul@codesourcery.com>
+	Canqun Yang  <canqun@nudt.edu.cn>
+
+	PR fortran/17077
+	* trans-array.c (gfc_conv_array_parameter): Pass correct pointer
+	for automatic arrays.
+	* trans-types.c (gfc_get_nodesc_array_type): Add comment.
+
+2004-08-19  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+	(Port from g95)
+
+	PR fortran/17074
+	* match.c (match_simple_forall, match_simple_where): Forward-declare.
+	(gfc_match_if): Order statement list alphabetically, add WHERE and
+	FORALL, remove double PAUSE.
+	(gfc_match_simple_where, match_forall_header,
+	gfc_match_simple_forall): New functions.
+	(gfc_match_forall): Use match_forall_header.
+
+2004-08-19  Paul Brook  <paul@codesourcery.com>
+
+	PR fortran/17091
+	* gfortran.h (gfc_access): Give ACCESS_UNKNOWN value 0.
+	* symbol.c (gfc_clear_attr): Use memset.
+
+2004-08-19  Paul Brook  <paul@codesourcery.com>
+
+	PR fortran/14976
+	PR fortran/16228
+	* data.c (assign_substring_data_value): Remove.
+	(create_character_intializer): New function.
+	(gfc_assign_data_value): Track the typespec for the current
+	subobject.  Use create_character_intializer.
+
+2004-08-19  Erik Schnetter  <schnetter@aei.mpg.de>
+
+	PR fortran/16946
+	* check.c (gfc_check_reduction): New function.
+	(gfc_check_minval_maxval): Removed.
+	(gfc_check_product): Removed.
+	(gfc_check_sum): Removed.
+	* intrinsic.h: Add/remove declarations for these.
+	* gfortran.h: Add field f3red to union gfc_check_f.
+	* intrinsic.c (add_sym_3red): New function.
+	(add_functions): Register maxval, minval, product, and sum intrinsics
+	through add_sym_3red.
+	(check_specific): Handle f3red union field.
+	* iresolve.c: Whitespace change.
+
+2004-08-18  Paul Brook  <paul@codesourcery.com>
+
+	* trans-types.c (gfc_sym_type): Use pointer types for optional args.
+
+2004-08-18  Victor Leikehman  <lei@il.ibm.com>
+
+	PR fortran/13278
+	* trans-io.c (transfer_namelist_element): New. Recursively handle
+	derived-type variables.  Pass string lengths.
+	(build_dt): Code moved to build_namelist, with some
+	changes and additions.
+	(gfc_build_io_library_fndecls): Declare the fifth
+	argument in st_set_nml_var_char -- string_length.
+
+2004-08-17  Paul Brook  <paul@codesourcery.com>
+	Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/13082
+	* decl.c (get_proc_name): Update mystery comment.
+	(gfc_match_entry): Check for errors earlier.  Add entry point to list.
+	* dump-parse-tree.c (gfc_show_code_node): Print EXEC_ENTRY nodes.
+	* gfortran.h (symbol_attribute): Add entry_master.  Document entry.
+	(struct gfc_entry_list): Define.
+	(gfc_get_entry_list): Define.
+	(struct gfc_namespace): Add refs and entries.
+	(enum gfc_exec_op): Add EXEC_ENTRY.
+	(struct gfc_code): Add ext.entry.
+	* module.c (ab_attribute, attr_bits): Remove AB_ENTRY.
+	(mio_symbol_attribute): Don't save/reture addr->entry.
+	(mio_namespace_ref): Refcount namespaces.
+	* parse.c (accept_statement): Handle ST_ENTRY.
+	(gfc_fixup_sibling_symbols): Mark symbol as referenced.
+	(parse_contained): Fixup sibling references to entry points
+	after parsing the procedure body.
+	* resolve.c (resolve_contained_fntype): New function.
+	(merge_argument_lists, resolve_entries): New functions.
+	(resolve_contained_functions): Use them.
+	(resolve_code): Handle EXEC_ENTRY.
+	(gfc_resolve): Call resolve_entries.
+	* st.c (gfc_free_statement): Handle EXEC_ENTRY.
+	* symbol.c (gfc_get_namespace): Refcount namespaces.
+	(gfc_free_namespace): Ditto.
+	* trans-array.c (gfc_trans_dummy_array_bias): Treat all args as
+	optional when multiple entry points are present.
+	* trans-decl.c (gfc_get_symbol_decl): Remove incorrect check.
+	(gfc_get_extern_function_decl): Add assertion.  Fix coment.
+	(create_function_arglist, trans_function_start, build_entry_thunks):
+	New functions.
+	(gfc_build_function_decl): Rename ...
+	(build_function_decl): ... to this.
+	(gfc_create_function_decl): New function.
+	(gfc_generate_contained_functions): Use it.
+	(gfc_trans_entry_master_switch): New function.
+	(gfc_generate_function_code): Use new functions.
+	* trans-stmt.c (gfc_trans_entry): New function.
+	* trans-stmt.h (gfc_trans_entry): Add prototype.
+	* trans-types.c (gfc_get_function_type): Add entry point argument.
+	* trans.c (gfc_trans_code): Handle EXEC_ENTRY.
+	(gfc_generate_module_code): Call gfc_create_function_decl.
+	* trans.h (gfc_build_function_decl): Remove.
+	(gfc_create_function_decl): Add prototype.
+
+2004-08-15  Andrew Pinski  <apinski@apple.com>
+
+	PR fortran/17030
+	* f95-lang.c (gfc_init_builtin_functions): Initialize the builtins
+	for cabs{,f} and copysign{,f}.
+	* trans-decl.c (gfor_fndecl_math_cabsf): Delete.
+	(gfor_fndecl_math_cabs): Delete.
+	(gfor_fndecl_math_sign4): Delete.
+	(gfor_fndecl_math_sign8): Delete.
+	(gfc_build_intrinsic_function_decls): Remove the
+	initializing of cabs{,f} and copysign{,f} functions.
+	* trans-intrinsic.c (gfc_conv_intrinsic_abs): Use the builtins
+	instead of the functions definitions.
+	(gfc_conv_intrinsic_sign): Likewise.
+	* trans.h (gfor_fndecl_math_cabsf): Delete.
+	(gfor_fndecl_math_cabs): Delete.
+	(gfor_fndecl_math_sign4): Delete.
+	(gfor_fndecl_math_sign8): Delete.
+
+2004-08-15  Nathan Sidwell  <nathan@codesourcery.com>
+
+	* trans-array.c (gfc_trans_array_constructor_value): Use
+	build_int_cst.
+	* trans-const.c (gfc_build_string_const,
+	gfc_init_constants, gfc_conv_mpz_to_tree,
+	gfc_conv_constant_to_tree): Likewise.
+	* trans-decl.c (gfc_get_symbol_decl): Likewise.
+	* trans-intrinsic.c (gfc_conv_intrinsic_ibits,
+	gfc_conv_intrinsic_len, prepare_arg_info): Likewise.
+	* trans-io.c (add_case, set_error_locus, build_dt,
+	transfer_expr): Likewise.
+	* trans-stmt.c (gfc_trans_label_assign, gfc_trans_pause,
+	gfc_trans_stop, gfc_trans_character_select): Likewise.
+	* trans-types.c (gfc_init_types, gfc_get_dtype): Likewise.
+	* trans.c (gfc_trans_runtime_check): Likewise.
+
+2004-08-14  Paul Brook  <paul@codesourcery.com>
+
+	* trans-decl.c (gfc_build_function_decl): Remove dead code.
+
+2004-08-14  Paul Brook  <paul@codesourcery.com>
+
+	* trans-arry.c (gfc_trans_auto_array_allocation): Remove unused var.
+
+2004-08-13  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* gfortran.h: Add comments.
+	* parse.c (parse_contained): Fix comment typo.
+	* resolve.c (was_declared): Ditto.
+	* symbol.c: Ditto.
+
+2004-08-11  Paul Brook  <paul@codeourcery.com>
+
+	PR fortran/16917
+	* intrinsic.c (add_functions): Add dfloat as an alias for dble.
+
+2004-08-10  Richard Henderson  <rth@redhat.com>
+
+	* f95-lang.c (gfc_init_builtin_functions): Remove
+	 __builtin_stack_alloc, add __builtin_alloca.
+	* trans-array.c (gfc_trans_auto_array_allocation): Use DECL_EXPR.
+	* trans-decl.c (gfc_trans_auto_character_variable): Likewise.
+
+2004-08-10  Paul Brook  <paul@codesourcery.com>
+
+	* trans-io.c (transfer_expr): Handle pointters.
+
+2004-08-10  Paul Brook  <paul@codesourcery.com>
+
+	PR fortran/16919
+	* trans-array.c (gfc_add_loop_ss_code): Handle GFC_SS_COMPONENT.
+	(gfc_conv_array_index_offset): Allow "temporary" with nonzero delta.
+	(gfc_trans_preloop_setup, gfc_trans_scalarized_loop_boundary):
+	Handle GFC_SS_COMPONENT.
+	(gfc_conv_ss_startstride): Ditto.  Set ss->shape.
+	(gfc_conv_loop_setup): Tweak commends. Remove dead code.
+	Use ss->shape.
+	(gfc_conv_array_initializer): Call specific initializer routines.
+	* trans-expr.c (gfc_trans_structure_assign): New function.
+	(gfc_trans_subarray_assign): New function.
+	(gfc_trans_subcomponent_assign): New fucntion
+	(gfc_conv_structure): Use them.
+	* trans.h (gfc_ss_type): Add GFC_SS_COMPONENT.
+	(gfc_ss): Add shape.
+
+2004-08-08  Victor Leikehman  <lei@il.ibm.com>
+
+	* simplify.c (gfc_simplify_shape): Bugfix.
+	* expr.c (gfc_copy_shape_excluding): New function.
+	* gfortran.h (gfc_get_shape): Bugfix.
+	(gfc_copy_shape_excluding): Added declaration.
+	* iresolve.c (gfc_resolve_all, gfc_resolve_any, gfc_resolve_count,
+	gfc_resolve_cshift, gfc_resolve_eoshift, gfc_resolve_lbound,
+	gfc_resolve_ubound, gfc_resolve_transpose): Added compile
+	time resolution of shape.
+
+2004-08-06  Janne Blomqvist  <jblomqvi@cc.hut.fi>
+
+	* intrinsic.c (add_subroutines): Add getenv and
+	get_environment_variable. (add_sym_5s): New function.
+	* intrinsic.h (gfc_resolve_get_environment_variable): Add
+	prototype.
+	* iresolve.c (gfc_resolve_get_environment_variable): New
+	function.
+
+2004-08-06  Feng Wang  <fengwang@nudt.edu.cn>
+
+	* f95-lang.c (gfc_init_builtin_functions): Fix the number of
+	__builtin_pow[f] arguments.
+
+2004-08-06  Steven G. Kargl  <kargls@comcast.net>
+
+	* arith.c: Add #define for model numbers.  Remove global GMP variables.
+	(natural_logarithm,common_logarithm,exponential,sine,
+	cosine,arctangent,hypercos,hypersine ): Remove.
+	(gfc_mpfr_to_mpz,gfc_set_model_kind,gfc_set_model): New functions.
+	(arctangent2,gfc_arith_init_1,gfc_arith_done_1
+	gfc_check_real_range, gfc_constant_result, gfc_range_check,
+	gfc_arith_uminus,gfc_arith_plus, gfc_arith_minus, gfc_arith_times,
+	gfc_arith_divide,complex_reciprocal,complex_pow_ui,
+	gfc_arith_power,gfc_compare_expr,compare_complex,gfc_convert_real,
+	gfc_convert_complex,gfc_int2real,gfc_int2complex,
+	gfc_real2int,gfc_real2real,gfc_real2complex,
+	gfc_complex2int,gfc_complex2real,gfc_complex2complex): Convert GMP
+	to MPFR, use new functions.
+	* arith.h: Remove extern global variables.
+	(natural_logarithm,common_logarithm,exponential, sine, cosine,
+	arctangent,hypercos,hypersine): Remove prototypes.
+	(arctangent2): Update prototype from GMP to MPFR.
+	(gfc_mpfr_to_mpz, gfc_set_model_kind,gfc_set_model): Add prototypes.
+	* dump-parse-tree.c (gfc_show_expr): Convert GMP to MPFR.
+	* expr.c (free_expr0,gfc_copy_expr): Convert GMP to MPFR.
+	* gfortran.h (GFC_REAL_BITS): Remove.
+	(arith): Add ARITH_NAN.
+	Include mpfr.h.  Define GFC_RND_MODE.
+	Rename GCC_GFORTRAN_H GFC_GFC_H.
+	(gfc_expr): Convert GMP to MPFR.
+	* module.c: Add arith.h, correct type in comment.
+	(mio_gmp_real): Convert GMP to MPFR.
+	(mio_expr):  Use gfc_set_model_kind().
+	* primary.c:  Update copyright date with 2004.
+	(match_real_constant,match_const_complex_part): Convert GMP to MPFR.
+	* simplify.c: Remove global GMP variables
+	(gfc_simplify_abs,gfc_simplify_acos,gfc_simplify_aimag,
+	gfc_simplify_aint,gfc_simplify_dint,gfc_simplify_anint,
+	gfc_simplify_dnint,gfc_simplify_asin,gfc_simplify_atan,
+	gfc_simplify_atan2,gfc_simplify_ceiling,simplify_cmplx,
+	gfc_simplify_conjg,gfc_simplify_cos,gfc_simplify_cosh,
+	gfc_simplify_dim,gfc_simplify_dprod,gfc_simplify_epsilon,
+	gfc_simplify_exp,gfc_simplify_exponent,gfc_simplify_floor,
+	gfc_simplify_fraction,gfc_simplify_huge,gfc_simplify_int,
+	gfc_simplify_ifix,gfc_simplify_idint,gfc_simplify_log,
+	gfc_simplify_log10,simplify_min_max,gfc_simplify_mod,
+	gfc_simplify_modulo,gfc_simplify_nearest,simplify_nint,
+	gfc_simplify_rrspacing,gfc_simplify_scale,
+	gfc_simplify_set_exponent,gfc_simplify_sign,gfc_simplify_sin,
+	gfc_simplify_sinh,gfc_simplify_spacing,gfc_simplify_sqrt,
+	gfc_simplify_tan,gfc_simplify_tanh,gfc_simplify_tiny,
+	gfc_simplify_init_1,gfc_simplify_done_1):  Convert GMP to MPFR.
+	Use new functions.
+	* trans-const.c (gfc_conv_mpfr_to_tree): Rename from
+	gfc_conv_mpf_to_tree.  Convert it to use MPFR
+	(gfc_conv_constant_to_tree): Use it.
+	* trans-const.h: Update prototype for gfc_conv_mpfr_to_tree().
+	* trans-intrinsic.c: Add arith.h, remove gmp.h
+	(gfc_conv_intrinsic_aint,gfc_conv_intrinsic_mod): Convert GMP to MPFR.
+
+2004-08-06  Victor Leikehman  <lei@il.ibm.com>
+	Paul Brook  <paul@codesourcery.com>
+
+	* trans-array.c (gfc_trans_allocate_array_storage,
+	gfc_trans_allocate_temp_array, gfc_add_loop_ss_code,
+	gfc_conv_loop_setup): For functions, if the shape of the result
+	is not known in compile-time, generate an empty array descriptor for
+	the result and let the callee to allocate the memory.
+	(gfc_trans_dummy_array_bias): Do nothing for pointers.
+	(gfc_conv_expr_descriptor): Use function return values directly.
+	* trans-expr.c (gfc_conv_function_call): Always add byref call
+	insn to pre chain.
+	(gfc_trans_pointer_assignment): Add comments.
+	(gfc_trans_arrayfunc_assign): Don't chain on expression.
+
+2004-08-01  Roger Sayle  <roger@eyesopen.com>
+
+	* options.c (gfc_init_options): Don't warn about the use GNU
+	extensions by default.
+	(gfc_post_options): Warn about GNU extensions with -pedantic.
+	(gfc_handle_option): Don't warn about GNU extensions with -std=gnu.
+
+2004-07-30  Richard Henderson  <rth@redhat.com>
+
+	* trans-expr.c (gfc_conv_expr_reference): Create a CONST_DECL
+	for TREE_CONSTANTs.
+
+2004-07-25  Richard Henderson  <rth@redhat.com>
+
+	* trans-decl.c (gfc_build_function_decl): Set DECL_ARTIFICIAL
+	and DECL_IGNORED_P on RESULT_DECL.
+	(gfc_generate_constructors): Likewise.
+
+2004-07-18  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/16465
+	* lang.opt (ffixed-line-length-none, ffixed-line-length-): New
+	options.
+	(ffixed-line-length-80, ffixed-line-length-132): Remove.
+	* options.c (gfc_handle_options): Deal with changed options.
+	* scanner.c (load_line): Change second arg to 'char **',
+	allocate if pointing to NULL. Keep track of buffer's length.
+	Adapt buffer size to overlong lines. Pad lines to full length
+	in fixed form.
+	(load_file): Adapt to new interface of load_line.
+
+2004-07-17  Joseph S. Myers  <jsm@polyomino.org.uk>
+
+	* trans.h (builtin_function): Declare.
+
+2004-07-16  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/16404
+	(parts ported from g95)
+	* parse.h (gfc_state_data): New field do_variable.
+	(gfc_check_do_variable): Add prototype.
+	* parse.c (push_state): Initialize field 'do_variable'.
+	(gfc_check_do_variable): New function.
+	(parse_do_block): Remember do iterator variable.
+	(parse_file): Initialize field 'do_variable'.
+	* match.c (gfc_match_assignment, gfc_match_do,
+	gfc_match_allocate, gfc_match_nullify, gfc_match_deallocate):
+	Add previously missing checks.
+	(gfc_match_return): Reformat error message.
+	* io.c (match_out_tag): New function.
+	(match_open_element, match_close_element,
+	match_file_element, match_dt_element): Call match_out_tag
+	instead of match_vtag where appropriate.
+	(match_io_iterator, match_io_element): Add missing check.
+	(match_io): Reformat error message.
+	(match_inquire_element): Call match_out_tag where appropriate.
+
+	* parse.c (gfc_check_do_variable): Fix error locus.
+
+2004-07-15  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/15129
+	* trans-decl.c (gfc_build_function_decl): Create a new chardecl
+	for every assumed length character dummy argument.
+
+	PR fortran/15140
+	* trans-decl.c (gfc_trans_deferred_vars): Remove bogus assertion.
+
+	PR fortran/13792
+	* simplify.c (gfc_simplify_bound): Copy the bound expression.
+
+2004-07-15  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+ 	PR fortran/15324
+	* trans-array.c gfc_trans_g77_array,
+	gfc_trans_dummy_array_bias): Don't call gfc_trans_string_init
+	for assumed length characters.
+	(gfc_conv_expr_descriptor): Set se->string_length if dealing
+	with a character expression.
+	(gfc_cvonv_array_parameter): Pass string length when passing
+	character array according to g77 conventions.
+
+2004-07-12  Paul Brook  <paul@codesourcery.com>
+
+	* expr.c (gfc_check_assign_symbol): Handle pointer assignments.
+	* trans-array.c (gfc_trans_auto_array_allocation): Remove
+	initialization code.
+	* trans-common.c (create_common): Use gfc_conv_initializer.
+	* trans-decl.c (gfc_get_symbol_decl): Use gfc_conv_initializer.
+	* trans-expr.c (gfc_conv_initializer): New function.
+	(gfc_conv_structure): Use it.
+	* trans.h (gfc_conv_initializer): Add prototype.
+
+2004-07-11  Paul Brook  <paul@codesourcery.com>
+
+	PR fortran/15986
+	* parse.c (gfc_fixup_sibling_symbols): Also look for untyped
+	variables.
+	(parse_contained): Mark contained symbols as referenced.
+
+2004-07-11  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/16455
+	* module.c (gfc_dump_module, gfc_use_module): Print locus
+	when opening of module file fails.
+
+	PR fortran/16404
+	* io.c (match_io): Flag 'WRITE(...), ...' as extension.
+
+	PR fortran/16404
+	* match.c (gfc_match_program): A program name is obligatory.
+	(gfc_match_return): RETURN in main program is an extension.
+	(gfc_match_block_data): A space is required before a block data
+	name.
+
+	PR fortran/16433
+	* primary.c (match_boz_constant): Call gfc_notify_std only if
+	we actually have a non-standard boz-literal-constant.
+
+	PR fortran/15754
+	* expr.c (gfc_check_assign): Print ranks if incompatible. Issue
+	warning if assigning NULL().
+
+2004-07-11  Joseph S. Myers  <jsm@polyomino.org.uk>
+
+	* f95-lang.c (set_block): Remove.
+	(gfc_clear_binding_stack): New.
+	(LANG_HOOKS_CLEAR_BINDING_STACK): Define.
+	(struct binding_level): Remove block_created_by_back_end.
+	(clear_binding_level): Likewise.
+	(poplevel): Don't handle block_created_by_back_end.
+
+2004-07-10  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* trans-decl.c (gfc_create_module_variable): Nothing to do if
+	symbol is in common, because we ...
+	(gfc_generate_module_vars): Call gfc_trans_common.
+
+2004-07-10  Paul Brook  <paul@codesourcery.com>
+
+	* trans-array.c (gfc_build_null_descriptor): New function.
+	(gfc_trans_static_array_pointer): Use it.
+	* trans-array.h (gfc_build_null_descriptor): Add prototype.
+	* trans-expr.c (gfc_conv_structure): Handle array pointers.
+
+2004-07-10  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/16336
+	* decl.c (gfc_match_save): Use-associated common block
+	doesn't collide.
+	* gfortran.h (gfc_common_head): Add new field 'name'.
+	Fix typo in comment after #endif.
+	* match.c (gfc_get_common): Add new argument from_common,
+	mangle name if flag is set, fill in new field in structure
+	gfc_common_head.
+	(match_common): Set new arg in call to gfc_get_common,
+	use-associated common block doesn't collide.
+	* match.h (gfc_get_common): Adapt prototype.
+	* module.c (load_commons): Set new arg in call to
+	gfc_get_common.
+	* symbol.c (free_common_tree): New function.
+	(gfc_free_namespace): Call new function.
+	* trans-common.c (several functions): Remove argument
+	'name', use name from gfc_common_head instead.
+
+2004-07-10  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* expr.c (gfc_check_pointer_assign): Verify that rank of the LHS
+	and RHS match. Return early if the RHS is NULL().
+
+	PR fortran/16336
+	* match.c (match_common): Fix error reporting for used common.
+
+	PR fortran/15969
+	* trans-expr.c (gfc_conv_structure): Handle initialization
+	of scalar pointer components.
+
+	* parse.c (decode_statement): Fix matching of BLOCK DATA.
+
+	* trans-decl.c (generate_local_decl): Remove workaround obsoleted
+	by fix for PR 15481.
+
+2004-07-10  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* trans-common.c: Fix whitespace issues, make variable names
+	more readable.
+	(create_common): Additionally, make loop logic more obvious.
+
+2004-07-10  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+	Paul Brook  <paul@codesourcery.com>
+
+	PR fortran/13415
+	* trans-common.c (calculate_length): Remove ...
+	(get_segment_info): Merge into here.  Save field type.
+	(build_field): Use saved type.
+	(create_common, new_condition, new_segment, finish_equivalences):
+	Use new get_segment_info.
+	* trans-types.c: Update comment.
+
+2004-07-09  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/14077
+	* moduele.c (mio_symbol): Don't I/O initial values unless
+	symbol is a parameter.
+
+2004-07-09  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/13201
+	* resolve.c (resolve_symbol): Verify that the shape of a
+	parameter array is not only explicit, but also constant.
+	* array.c (gfc_is_compile_time_shape): New function.
+	* gfortran.h (gfc_is_compile_time_shape): Add prototype.
+
+2004-07-09  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/15481
+	PR fortran/13372
+	PR fortran/13575
+	PR fortran/15978
+	* module.c (write_symbol, write_symtree): Remove workaround.
+	* primary.c (match_actual_arglist): Enhance comment.
+	(gfc_match_rvalue): Handle function call with first argument
+	a keyword argument correctly.
+	* resolve.c (resolve_symbol): Change call to
+	gfc_set_default_type to issue error if no implicit type
+	can be found.
+	* trans-decl.c (gfc_create_module_variable): Remove workaround.
+
+2004-07-08  Paul Brook  <paul@codesourcery.com>
+
+	* intrinsic.c (add_sym_4s): New function.
+	(add_subroutines): Change gfc_add_sym_? to gfc_add_sym_?s.
+
+2004-07-04  Janne Blomqvist  <jblomqvi@cc.hut.fi>
+	Paul Brook  <paul@codesourcery.com>
+
+	PR fortran/15280
+	PR fortran/15665
+	* gfortran.h (enum gfc_generic_isym_id): Add GFC_ISYM_IARGC and
+	GFC_ISYM_COMMAND_ARGUMENT_COUNT.
+	* intrinsic.c (add_functions):  Identify iargc.  Add
+	command_argument_count.
+	(add_subroutines): Resolve getarg.  Add get_command and
+	get_command_argument.
+	* intrinsic.h (gfc_resolve_getarg, gfc_resolve_get_command,
+	gfc_resolve_get_command_argument): Add prototypes.
+	* iresolve.c (gfc_resolve_getarg, gfc_resolve_get_command,
+	gfc_resolve_get_command_argument): New functions.
+	* trans-decl.c (gfor_fndecl_iargc): New variable.
+	(gfc_build_intrinsic_function_decls): Set it.
+	* trans-intrinsic.c (gfc_conv_intrinsic_iargc): New function.
+	(gfc_conv_intrinsic_function): Use it.
+	* trans.h (gfor_fndecl_iargc): Declare.
+
+2004-07-04  Matthias Klose  <doko@debian.org>
+
+	* Make-lang.in: Generate and install gfortran man page.
+	* invoke.texi: Remove extra '@c man end'.
+
+2004-07-04  Richard Henderson  <rth@redhat.com>
+
+	* f95-lang.c (gfc_mark_addressable): Don't put_var_into_stack.
+
+2004-07-04  Paul Brook  <paul@codesourcery.com>
+
+	* decl.c (gfc_match_implicit_range): Don't use typespec.
+	(gfc_match_implicit): Handle character selectors.
+	* gfortran.h (gfc_set_implicit): Remove prototype.
+	(gfc_add_new_implicit_range, gfc_merge_new_implicit): Update.
+	* parse.c (accept_statement): Don't call gfc_set_implicit.
+	* symbol.c (new_ts): Remove.
+	(gfc_set_implicit_none): Use same loop bounds as other functions.
+	(gfc_set_implicit): Remove.
+	(gfc_clear_new_implicit, gfc_add_new_implicit_range): Only set flags.
+	(gfc_merge_new_implicit): Combine with gfc_set_implicit.
+
+2004-06-30  Richard Henderson  <rth@redhat.com>
+
+	* match.c (var_element): Remove unused variable.
+
+	* trans-decl.c (gfc_generate_function_code): Don't set
+	x_whole_function_mode_p.
+	(gfc_generate_constructors): Likewise.
+
+2004-06-30  Richard Henderson  <rth@redhat.com>
+
+	* trans-decl.c (gfc_generate_function_code): Don't set
+	immediate_size_expand.
+	(gfc_generate_constructors): Likewise.
+
+2004-06-30  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/16161
+	* decl.c (gfc_match_type_spec): Rename second argument to
+	'implicit_flag', reverse meaning. Don't match_char_spec if
+	'implicit_flag' is set. Rename to ...
+	(match_type_spec): ... this.
+	(gfc_match_implicit_none, match_implicit_range): Move here
+	from match.c.
+	(gfc_match_implicit): Move here from match.c, try to
+	match_char_len if match_implicit_range doesn't succeed for
+	CHARACTER implicits. Call renamed fucntion match_type_spec.
+	(gfc_match_data_decl, match_prefix): Call renamed function
+	match_type_spec.
+	* match.c (gfc_match_implicit_none, match_implicit_range,
+	gfc_match_implicit): Move to decl.c.
+	* match.h (gfc_match_implicit_none, gfc_match_implicit):
+	Move protoypes to section 'decl.c'.
+	(gfc_match_type_spec): Remove prototype.
+
+2004-06-29  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* decl.c, interface.c, symbol.c, trans-common.c: Add 2004 to
+	copyright years.
+
+2004-06-29  Steven Bosscher  <stevenb@suse.de>
+
+	Make sure types in assignments are compatible.  Mostly mechanical.
+	* trans-const.h (gfc_index_one_node): New define.
+	* trans-array.c (gfc_trans_allocate_array_storage,
+	gfc_trans_allocate_temp_array, gfc_trans_array_constructor_subarray,
+	gfc_trans_array_constructor_value, gfc_trans_array_constructor,
+	gfc_conv_array_ubound, gfc_conv_array_ref,
+	gfc_trans_scalarized_loop_end, gfc_conv_section_startstride,
+	gfc_conv_ss_startstride, gfc_conv_loop_setup, gfc_array_init_size,
+	gfc_trans_array_bounds, gfc_trans_dummy_array_bias,
+	gfc_conv_expr_descriptor, gfc_trans_deferred_array): Use the correct
+	types in assignments, conversions and conditionals for expressions.
+	* trans-expr.c (gfc_conv_expr_present, gfc_conv_substring,
+	gfc_conv_unary_op, gfc_conv_cst_int_power, gfc_conv_string_tmp,
+	gfc_conv_function_call, gfc_trans_pointer_assignment,
+	gfc_trans_scalar_assign): Likewise.
+	* trans-intrinsic.c (build_fixbound_expr, gfc_conv_intrinsic_bound,
+	gfc_conv_intrinsic_anyall, gfc_conv_intrinsic_count,
+	gfc_conv_intrinsic_minmaxloc, gfc_conv_intrinsic_btest,
+	gfc_conv_intrinsic_singlebitop, gfc_conv_intrinsic_ishft,
+	gfc_conv_intrinsic_ishftc, gfc_conv_intrinsic_strcmp,
+	gfc_conv_allocated, gfc_conv_associated,
+	gfc_conv_intrinsic_rrspacing, gfc_conv_intrinsic_trim): Likewise.
+	* trans-io.c (set_string): Likewise.
+	* trans-stmt.c (gfc_trans_do, gfc_trans_forall_loop,
+	gfc_do_allocate, generate_loop_for_temp_to_lhs,
+	generate_loop_for_rhs_to_temp, compute_inner_temp_size,
+	compute_overall_iter_number, gfc_trans_assign_need_temp,
+	gfc_trans_pointer_assign_need_temp, gfc_trans_forall_1,
+	gfc_evaluate_where_mask, gfc_trans_where_assign,
+	gfc_trans_where_2): Likewise.
+	* trans-types.c (gfc_get_character_type, gfc_build_array_type,
+	gfc_get_nodesc_array_type, gfc_get_array_type_bounds): Likewise.
+
+	* trans.c (gfc_add_modify_expr): Add sanity check that types
+	for the lhs and rhs are the same for scalar assignments.
+
+2004-06-29  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* dump-parse-tree.c (show_common): New function.
+	(gfc_show_namespace): Show commons.
+
+2004-06-29  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+	Andrew Vaught  <andyv@firstinter.net>
+
+	PR fortran/13249
+	PR fortran/15481
+	* decl.c (gfc_match_save): Adapt to new common structures,
+	don't allow saving USE-associated common.
+	* dump-parse-tree (gfc_show_attr): (saved_)common are not
+	symbol attributes any longer.
+	(gfc_show_symbol): Don't show old-style commons any longer.
+	(gfc_show_namespace): Adapt call to gfc_traverse_symtree to new
+	interface.
+	* gfortran.h (symbol_attribute): Remove common and saved_common
+	attributes.
+	(gfc_symbol): Remove common_head element.
+	(gfc_common_head): New struct.
+	(gfc_get_common_head): New macro.
+	(gfc_symtree): Add field 'common' to union.
+	(gfc_namespace): Add field 'common_root'; change type of field
+	'blank_common' to blank_common.
+	(gfc_add_data): New prototype.
+	(gfc_traverse_symtree): Expect a symtree as first argument
+	instead of namespace.
+	* match.c (gfc_get_common): New function.
+	(match_common_name): Change to take char * as argument, adapt,
+	fix bug with empty name.
+	(gfc_match_common): Adapt to new data structures. Disallow
+	redeclaration of USE-associated COMMON-block. Fix bug with
+	empty common.
+	(var_element): Adapt to new common structures.
+	* match.h (gfc_get_common): Declare.
+	* module.c: Add 2004 to copyright years, add commons to module
+	file layout description.
+	(ab_attribute, attr_bits, mio_symbol_attributes): Remove code
+	for removed attributes.
+	(mio_symbol): Adapt to new way of storing common relations.
+	(load_commons): New function.
+	(read_module): Skip common list on first pass, load_commons at
+	second.
+	(write_commons): New function.
+	(write_module): Call write_commons().
+	* symbol.c (gfc_add_saved_comon, gfc_add_common): Remove
+	functions related to removed attributes.
+	(gfc_add_data): New function.
+	(gfc_clear_attr): Don't set removed attributes.
+	(gfc_copy_attr): Don't copy removed attributes.
+	(traverse_symtree): Remove.
+	(gfc_traverse_symtree): Don't traverse symbol
+	tree of the passed namespace, but require a symtree to be passed
+	instead. Unify with traverse_symtree.
+	(gfc_traverse_ns): Call gfc_traverse_symtree according to new
+	interface.
+	(save_symbol): Remove setting of removed attribute.
+	* trans-common.c (gfc_sym_mangled_common_id): Change to
+	take 'char *' argument instead of 'gfc_symbol'.
+	(build_common_decl, new_segment, translate_common): Adapt to new
+	data structures, add new
+	argument name.
+	(create_common): Adapt to new data structures, add new
+	argument name. Fix typo in intialization of derived types.
+	(finish_equivalences): Add second argument in call to
+	create_common.
+	(named_common): take 'gfc_symtree' instead of 'gfc_symbol'.
+	(gfc_trans_common): Adapt to new data structures.
+	* trans-decl.c (gfc_create_module_variables): Remove test for
+	removed attribute.
+
+2004-06-29  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* io.c: Add 2004 to copyright years.
+
+2004-06-29  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+	Andrew Vaught  <andyv@firstinter.net>
+
+	* gfortran.h (gfc_gsymbol): New typedef.
+	(gfc_gsym_root): New variable.
+	(gfc_get_gsymbol, gfc_find_gsym): New prototypes.
+	* parse.c (global_used): New function.
+	(parse_block_data): Check for double empty BLOCK DATA,
+	use global symbol table.
+	(parse_module): Use global symbol table.
+	(add_global_procedure, add_global_program): New functions.
+	(gfc_parse_file): Use global symbol table.
+	* symbol.c (gfc_gsym_root): New variable.
+	(gfc_find_gsym, gsym_compare, gfc_get_gsymbol): New
+	functions.
+
+2004-06-29  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* module.c (mio_gmp_real): Correct writing of negative numbers.
+
+2004-06-29  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/15963
+	* expr.c (check_intrinsic_op): Allow comparison of characters.
+	Make logic easier.
+
+2004-06-26  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+	Andrew Vaught  <andyv@firstinter.net>
+
+	* decl.c (contained_procedure): New function.
+	(match_end): Verify correctness of END STATEMENT in
+	all cases.
+
+2004-06-26  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+	Andrew Vaught  <andyv@firstinter.net>
+
+	PR fortran/15190
+	* decl.c (gfc_match_type_spec), io.c (match_io), parse.c
+	(decode_statement): Enforce required space in free-form.
+
+2004-06-22  Richard Kenner  <kenner@vlsi1.ultra.nyu.edu>
+
+	* f95-lang.c (LANG_HOOKS_GIMPLE_BEFORE_INLINING): Deleted.
+	* trans-array.c (gfc_conv_descriptor_data): Add operand
+	for COMPONENT_REF.
+	(gfc_conv_descriptor_offset, gfc_conv_descriptor_dtype): Likewise.
+	(gfc_conv_descriptor_dimension, gfc_conv_descriptor_stride): Likewise.
+	(gfc_conv_descriptor_lbound, gfc_conv_descriptor_ubound): Likewise.
+	* trans-common.c (create_common): Likewise.
+	* trans-expr.c (gfc_conv_component_ref): Likewise.
+	* trans-io.c (set_parameter_value): Likewise.
+	(set_parameter_ref, set_string, set_flag, io_result): Likewise.
+	(transfer_expr): Likewise.
+	* trans-decl.c (gfc_trans_auto_character_variable):
+	Set up to get DECL_SIZE and DECL_SIZE_UNIT gimplified.
+	(gfc_gimplify_function): New function.
+	(gfc_generate_function-code): Properly handle nested functions.
+	* trans.c (gfc_build_array_ref): Add two new operands for ARRAY_REF.
+
+2004-06-22  Janne Blomqvist  <jblomqvi@cc.hut.fi>
+
+	PR fortran/15750
+	* io.c (gfc_match_inquire): Bugfix for iolength related stuff.
+	(gfc_resolve_inquire): Resolve the iolength tag.  Return
+	SUCCESS at end of function if no failure has occured.
+	* resolve.c (resolve_code): Resolve if iolength is encountered.
+	* trans-io.c: (ioparm_iolength, iocall_iolength,
+	iocall_iolength_done): New variables.
+	(last_dt): Add IOLENGTH.
+	(gfc_build_io_library_fndecls ): Set iolength related variables.
+	(gfc_trans_iolength): Implement.
+	(gfc_trans_dt_end): Treat iolength as a third form of data transfer.
+
+2004-06-21  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de
+
+	PR fortran/15511
+	* scanner.c (load_line): Don't truncate preprocessor lines.
+	Reformat error message.
+	(preprocessor_line): Issue warning in case of malformed
+	preprocessor line.
+
+2004-06-21  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* resolve.c (resolve_symbol): Add comment in function body.
+	(check_data_variable): Change type of mark to ar_type, adapt code
+	accordingly.
+
+2004-06-21  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* array.c (gfc_insert_constructor): Avoid redundant call to
+	mpz_comp. Add 2004 to copyright years.
+
+2004-06-21  Joseph S. Myers  <jsm@polyomino.org.uk>
+
+	* trans.h (stmtblock_t): Change has_scope to unsigned int.
+
+2004-06-20  Steven G. Kargl  <kargls@comcast.net>
+
+	* arith.c (gfc_range_check): correct complex underflow.
+
+2004-06-15  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/15962
+	* match.c (match_case_selector): Call gfc_match_init_expr
+	instead of gfc_match_expr.
+	* resolve.c (validate_case_label_expr): No need to check for
+	constant, since it wouldn't have been matched with the fix to
+	match.c.
+
+2004-06-14  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/15211
+	* trans-intrinsic.c (gfc_conv_intrinsic_len): Deal with arrays
+	of strings.
+
+2004-06-14  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/15510
+	* trans-deecl.c (generate_local_decl): Do not issue warning for
+	unused variables if they're use associated.
+
+2004-06-14  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+	Andrew Vaught  <andyv@firstinter.net>
+
+	PR fortran/14928
+	* gfortran.h (gfc_check_f): Add new field f3ml.
+	* check.c (gfc_check_minloc_maxloc): Take argument list instead
+	of individual arguments, reorder if necessary.
+	* intrinsic.h (gfc_check_minloc_maxloc): ... adapt prototype.
+	* intrinsic.c (add_sym_3ml): New function.
+	(add_functions): Change to add_sym_3ml for MINLOC, MAXLOC.
+	(check_specific): Catch special case MINLOC, MAXLOC.
+
+2004-06-14  Paul Brook  <paul@codesourcery.com>
+
+	* intrinsic.c (add_sym_2s): Use correct function types.
+
+2004-06-12  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* Make-lang.in (F95_OBJS, F95_PARSER_OBJS): Alphabetize.  Move data.c
+	* data.c (gfc_get_section_index):  Remove dependency on trans.h.
+
+2004-06-12  Steven G. Kargl  <kargls@comcast.net>
+
+	* check.c (gfc_check_second_sub, gfc_check_irand, gfc_check_rand
+	gfc_check_srand, gfc_check_etime, gfc_check_etime_sub): New functions.
+	* gfortran.h (gfc_generic_isym_id): New symbols GFC_ISYM_ETIME,
+	GFC_ISYM_IRAND, GFC_ISYM_RAND, GFC_ISYM_SECOND.
+	* trans-intrinsic.c:  Use symbols.
+	* intrinsic.c (add_sym_2s): New function.
+	* intrinsic.c: Add etime, dtime, irand, rand, second, srand.
+	* intrinsic.h: Function prototypes.
+	* iresolve.c (gfc_resolve_etime_sub, gfc_resolve_second_sub
+	gfc_resolve_srand):  New functions.
+
+2004-06-12  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/14957
+	* decl.c (gfc_match_end): Require END {SUBROUTINE|FUNCTION} for
+	contained procedure.
+
+2004-06-12  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/12841
+	* interface.c (compare_parameter, compare_actual_formal): Don't
+	check types and array shapes for NULL()
+	* trans-expr.c (conv_function_call): No double indirection for
+	NULL()
+
+2004-06-09  Toon Moene  <toon@moene.indiv.nluug.nl>
+
+	* trans-expr.c (gfc_conv_cst_int_power): Compute
+	x**(-n) by converting it to (1/x)**n instead of
+	1/x**n.
+
+2004-06-09  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/13372
+	* module.c (write_symbol, write_symtree): Don't write symbols
+	wrongly added to namespace.
+	* trans-decl.c (gfc_create_module_variable): Don't create a
+	backend decl for a symbol incorrectly added to namespace.
+
+2004-06-09  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/13201
+	* resolve.c (resolve_symbol): Verify that parameter array has an
+	explicit shape. Fix typos and coding style issues in surrounding
+	lines.
+
+2004-06-05  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/15478
+	* gfortran.texi: The documentation doesn't contain infomration on
+	how to report bugs, and shouldn't, so remove the line which
+	says it does.
+
+2004-06-05  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* intrinsic.c (sort_actual): Keep track of type of missing
+	arguments. (Missing from previous commit.)
+
+2004-06-03  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* gfortran.h (gfc_actual_arglist): New field missing_arg_type.
+	* interface.c (compare_actual_formal): Keep type of omitted
+	optional arguments.
+	* trans-expr.c (gfc_conv_function_call): Add string length
+	argument for omitted string argument.
+
+2004-06-03  Paul Brook  <paul@codesourcery.com>
+
+	* trans.c (gfc_finish_block, gfc_add_expr_to_block): Build statement
+	lists instead of compound expr chains.
+	(gfc_trans_code): Annotate statement lists.
+
+2004-06-03  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* trans-array.c: Fix spelling in comments.
+
+2004-06-02  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/15557
+	* data.c (assign_substring_data_value): New function.
+	(gfc_assign_data_value): Call the new function if we're dealing
+	with a substring LHS.
+
+2004-06-01  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/15477
+	* gfortran.h (GFC_VERSION): Remove.
+	* gfortran.texi (version-gfortran): Remove, replace by version-GCC
+	where used.
+
+2004-05-31  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* trans-types.c: Fix spelling & layout in comments.
+
+2004-05-30  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/14067
+	* trans-const.c (gfc_conv_string_init): Allow variable string
+	length lower than initialization string length.
+
+2004-05-30  Paul Brook  <paul@codesourcery.com>
+
+	PR fortran/15620
+	* trans-decl.c (gfc_shadow_sym, gfc_restore_sym): New functions.
+	* trans-expr.c (gfc_trans_string_copy): New function.
+	(gfc_conv_statement_function): Use them.  Create temp vars.  Enforce
+	character lengths.
+	(gfc_conv_string_parameter): Use gfc_trans_string_copy.
+	* trans-stmt.c (gfc_trans_forall_1): Use gfc_{shadow,restore}_sym.
+	* trans.h (struct gfc_saved_var): Define.
+	(gfc_shadow_sym, gfc_restore_sym): Add prototypes.
+
+2004-05-30  Steven G. Kargl  <kargls@comcast.net>
+
+	* iresolve.c (gfc_resolve_random_number): Clean up conditional.
+
+2004-05-29  Steven G. Kargl  <kargls@comcast.net>
+
+	* simplify.c (gfc_simplify_log): Remove useless line of code.
+
+2004-05-29  Paul Brook  <paul@codesourcery.com>
+
+	* trans-common.c (find_equivalence): Find multiple rules.
+
+2004-05-27  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* gfortran.h (gfc_current_locus, gfc_set_locus): Remove.
+	(gfc_current_locus): Declare new global variable.
+	* scanner.c (gfc_current_locus, gfc_set_locus): Remove.
+	(gfc_current_locus1): Rename ...
+	(gfc_current_locus): ... to this.
+	(gfc_at_eof, gfc_at_bol, gfc_at_eol, gfc_advance_line, next_char,
+	skip_fixed_comments, skip_free_comments, gfc_next_char_literal,
+	gfc_peek_char, gfc_gobble_whitespace, gfc_new_file): Use
+	gfc_current_locus instead of gfc_current_locus1, gfc_set_locus()
+	and gfc_current_locus(), respectively.
+	* array.c (match_subscript, gfc_match_array_ref, match_array_list,
+	match_array_cons_element, gfc_match_array_constructor):
+	Read/modify gfc_current_locus instead of calling gfc_set_locus()
+	and gfc_current_locus().
+	* decl.c (gfc_match_null, variable_decl, gfc_match_kind_spec,
+	match_attr_spec, gfc_match_function_decl, gfc_match_end,
+	attr_decl1, gfc_match_save): Likewise.
+	* error.c (error_print, gfc_internal_error): Likewise.
+	* expr.c (gfc_int_expr, gfc_default_logical_kind): Likewise.
+	* interface.c (gfc_add_interface): Likewise.
+	* io.c (gfc_match_format, match_dt_format, match_dt_element,
+	match_io_iterator, match_io): Likewise.
+	* match.c (gfc_match_space, gfc_match_eos,
+	gfc_match_small_literal_int, gfc_match_st_label,
+	gfc_match_strings, gfc_match_name, gfc_match_iterator,
+	gfc_match_char, gfc_match, gfc_match_assignment,
+	gfc_match_pointer_assignment, gfc_match_if, gfc_match_do,
+	gfc_match_nullify, gfc_match_call, match_implicit_range,
+	gfc_match_implicit, gfc_match_data, match_case_selector,
+	gfc_match_case, match_forall_iterator): Likewise.
+	* matchexp.c (gfc_match_defined_op_name, next_operator,
+	match_level_1, match_mult_operand, match_ext_mult_operand,
+	match_add_operand, match_ext_add_operand, match_level_2,
+	match_level_3, match_level_4, match_and_operand, match_or_operand,
+	match_equiv_operand, match_level_5, gfc_match_expr): Likewise.
+	* module.c (gfc_match_use, mio_array_ref, mio_expr): Likewise.
+	* parse.c (match_word, decode_statement, next_free, next_fixed,
+	add_statement, verify_st_order, parse_if_block, gfc_parse_file):
+	Likewise.
+	* primary.c (match_digits, match_integer_constant,
+	match_boz_constant, match_real_constant, match_substring,
+	next_string_char, match_charkind_name, match_string_constant,
+	match_logical_constant, match_const_complex_part,
+	match_complex_constant, match_actual_arg, match_keyword_arg,
+	gfc_match_actual_arglist, gfc_match_structure_constructor,
+	gfc_match_rvalue, gfc_match_variable): Likewise.
+	* st.c (gfc_get_code): Likewise.
+	* symbol.c (check_conflict, check_used, check_done,
+	duplicate_attr, add_flavor, gfc_add_procedure, gfc_add_intent,
+	gfc_add_access, gfc_add_explicit_interface, gfc_add_type,
+	gfc_add_component, gfc_reference_st_label, gfc_new_symbol): Likewise.
+
+2004-05-26  Roger Sayle  <roger@eyesopen.com>
+
+	* io.c (format_asterisk): Silence compiler warnings by correcting
+	the number of elements of a "locus" initializer.
+
+2004-05-25  Roger Sayle  <roger@eyesopen.com>
+
+	PR fortran/13912
+	* matchexp.c: Allow unary operators after arithmetic operators
+	as a GNU extension.
+	(match_ext_mult_operand, match_ext_add_operand): New functions.
+	(match_mult_operand): Tweak to call match_ext_mult_operand.
+	(match_add_operand): Tweak to call match_ext_mult_operand.
+	(match_level_2): Rearrange to call match_ext_add_operand.
+
+2004-05-25  Paul Brook  <paul@codesourcery.com>
+
+	* expr.c (check_inquiry): Remove bogus tests.
+
+2004-05-23  Paul Brook  <paul@codesourcery.com>
+
+	PR fortran/13773
+	* expr.c (restricted_args): Remove redundant checks/argument.
+	(external_spec_function): Update to match.
+	(restricted_intrinsic): Rewrite.
+
+2004-05-23  Paul Brook  <paul@codesourcery.com>
+	Victor Leikehman  <lei@haifasphere.co.il>
+
+	* gfortran.h (struct gfc_symbol): Add equiv_built.
+	* trans-common.c: Change int to HOST_WIDE_INT.  Capitalize error
+	messages.
+	(current_length): Remove.
+	(add_segments): New function.
+	(build_equiv_decl): Create initialized common blocks.
+	(build_common_decl): Always add decl to bindings.
+	(create_common): Create initializers.
+	(find_segment_info): Reformat to match coding conventions.
+	(new_condition): Use add_segments.
+	(add_condition, find_equivalence, add_equivalences): Move iteration
+	inside functions.  Only process each segment once.
+	(new_segment, finish_equivalences, translate_common): Simplify.
+
+2004-05-23  Steven G. Kargl  <kargls@comcast.net>
+
+	* check.c (gfc_check_random_seed): Issue for too many arguments.
+
+2004-05-22  Steven G. Kargl  <kargls@comcast.net>
+
+	* intrinsic.c (add_subroutines): Use add_sym_3s for random_seed.
+
+2004-05-22  Paul Brook  <paul@codesourcery.com>
+
+	* dump-parse-tree.c (gfc_show_equiv): New function.
+	(gfc_show_namespace): Use it.
+
+2004-05-22  Victor Leikehman  <lei@haifasphere.co.il>
+
+	PR fortran/13249
+	* symbol.c (gfc_add_common): Disable checks to work around other more
+	fundamental inadequacies.
+
+2004-05-22  Tobias Schlüter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* trans-decl.c (gfc_get_extern_function_decl): Set DECL_IS_PURE
+	only for functions.
+	(gfc_build_function_decl): Likewise.
+
+2004-05-22  Steven G. Kargl  <kargls@comcast.net>
+
+	* check.c (gfc_check_system_clock): New function.
+	* intrinsic.c (add_sym_3s): New function.
+	(add_subroutines): Use it.
+	* intrinsic.h (gfc_check_system_clock, gfc_resolve_system_clock):
+	Add prototypes.
+	* iresolve.c (gfc_resolve_system_clock): New function.
+
+2004-05-22  Steven G. Kargl  <kargls@comcast.net>
+
+	* invoke.texi: Document -Wunderflow and spell check.
+	* lang.opt: Add Wunderflow.
+	* gfortran.h (gfc_option_t): Add warn_underflow option.
+	* options.c (gfc_init_options, set_Wall): Use it.
+	* primary.c (match_real_constant): Explicitly handle UNDERFLOW.
+	* arith.c (gfc_arith_uminus, gfc_arith_plus, gfc_arith_minus,
+	gfc_arith_times, gfc_arith_divide, gfc_arith_power, gfc_real2real,
+	gfc_real2complex, gfc_complex2real, gfc_complex2complex): Ditto.
+	* arith.c (common_logarithm): Fix typo in comment.
+
+2004-05-21  Roger Sayle  <roger@eyesopen.com>
+
+	* io.c (check_format): As a GNU extension, allow the comma after a
+	string literal to be optional in a format.  Use gfc_notify_std to
+	issue an error/warning as appropriate.
+
+2004-05-21  Roger Sayle  <roger@eyesopen.com>
+
+	* io.c (check_format): Use gfc_notify_std to determine whether to
+	issue an error/warning for omitting the digits from the X format.
+
+2004-05-20  Roger Sayle  <roger@eyesopen.com>
+
+	* io.c (check_format): Allow the number before the X format to
+	be optional when not -pedantic.
+
+2004-05-18  Feng Wang  <fengwang@nudt.edu.cn>
+	Paul Brook  <paul@codesourcery.com>
+
+	* f95-lang.c (gfc_init_builtin_functions): Use vold_list_node.
+	Create decls for __builtin_pow{,f}.
+	* gfortran.h (PREFIX_LEN): Define.
+	* trans-decl.c (gfor_fndecl_math_powi): Add.
+	(gfor_fndecl_math_powf, gfor_fndecl_math_pow): Remove.
+	(gfc_build_intrinsic_function_decls): Create decls for powi.
+	* trans-expr.c (powi_table): Add.
+	(gfc_conv_integer_power): Remove.
+	(gfc_conv_powi): New function.
+	(gfc_conv_cst_int_power): New function.
+	(gfc_conv_power_op): Use new powi routines.
+	* trans.h (struct gfc_powdecl_list): Add.
+	(gfor_fndecl_math_powi): Add.
+	(gfor_fndecl_math_powf, gfor_fndecl_math_pow): Remove.
+
+2004-05-18  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* trans.c, trans-decl.c: Fix comment typos.
+
+2004-05-18  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* trans-const.c (gfc_conv_mpf_to_tree): Fix typo.
+
+2004-05-18  Steve Kargl  <kargls@comcast.net>
+
+	* arith.c (gfc_int2complex): Fix incorrect range checking.
+
+2004-05-18  Paul Brook  <paul@codesourcery.com>
+
+	PR fortran/13930
+	* decl.c (add_init_expr_to_sym): Remove incorrect check.
+	(default_initializer): Move to expr.c.
+	(variable_decl): Don't assign default initializer to variables.
+	* expr.c (gfc_default_initializer): Move to here.
+	* gfortran.h (gfc_default_initializer): Add prototype.
+	* resolve.c (resolve_symbol): Check for illegal initializers.
+	Assign default initializer.
+
+2004-05-17  Steve Kargl  <kargls@comcast.net>
+
+	* arith.c (gfc_arith_power): Complex number raised to 0 power is 1.
+
+2004-05-17  Steve Kargl  <kargls@comcast.net>
+
+	* arith.c (gfc_real2complex): Range checking wrong part of complex
+	number.
+
+2004-05-16  Paul Brook  <paul@codesourcery.com>
+
+	* options.c (gfc_handle_module_path_options): Fix buffer overrun.
+
+2004-05-16  Paul Brook  <paul@codesourcery.com>
+
+	* arith.c (gfc_range_check): Fix logic error.
+
+2004-05-16  Steve Kargl  <sgk@troutmask.apl.washington.edu>
+
+	* arith.c: Fix comment typos.
+
+2004-05-15  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/13742
+	* decl.c (add_init_expr_to_sym): Verify that COMMON variable is
+	not initialized in a disallowed fashion.
+	* match.c (gfc_match_common): Likewise.
+	(var_element): Verify that variable is not in the blank COMMON,
+	if it is in a common.
+
+2004-05-15  Joseph S. Myers  <jsm@polyomino.org.uk>
+
+	* Make-lang.in (f95.generated-manpages): Remove.
+	(f95.srcextra): New.
+	(f95.info, fortran/gfortran.info, fortran/gfortran.dvi,
+	f95.maintainer-clean): Generate info and dvi files in objdir/doc.
+	(f95.dvi): Remove.
+	(dvi): New.
+	(f95.install-info): Remove.
+	(install-info): New.
+
+2004-05-15  Victor Leikehman  <lei@haifasphere.co.il>
+
+	* decl.c (add_init_expr_to_sym): Check for variable size arrays.
+
+2004-05-15  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* primary.c (match_boz_constant): Use gfc_notify_std() for
+	issuing a warning or an error.
+
+2004-05-15  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/13826
+	* primary.c (match_structure_constructor): Rename ...
+	(gfc_match_structure_constructor): ... to this. Make non-static.
+	(gfc_match_rvalue): Call renamed function.
+	* match.h (gfc_match_structure_constructor): Declare.
+	* match.c (gfc_match_data_constant): Handle structure
+	constructor.
+
+2004-05-15  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/13702
+	(Port from g95)
+	* gfortran.h (gfc_linebuf): New typedef.
+	(linebuf): Remove.
+	(gfc_file): Revamped, use new gfc_linebuf.
+	(locus): Revamped, use new types.
+	(gfc_current_file): Remove.
+	(gfc_current_form, gfc_source_file): New global variables.
+	* match.c (gfc_match_space, gfc_match_strings): Use
+	gfc_current_form to find source form.
+	* module.c (gfc_dump_module): Use gfc_source_file when printing
+	module header.
+	* error.c (show_locus, show_loci) Use new data structures to print
+	locus.
+	* scanner.c (first_file, first_duplicated_file, gfc_current_file):
+	Remove.
+	(file_head, current_file, gfc_current_form, line_head, line_tail,
+	gfc_current_locus1, gfc_source_file): New global variables.
+	(gfc_scanner_init1): Set new global variables.
+	(gfc_scanner_done1): Free new data structures.
+	(gfc_current_locus): Return pointer to gfc_current_locus1.
+	(gfc_set_locus): Set gfc_current_locus1.
+	(gfc_at_eof): Set new variables.
+	(gfc_at_bol, gfc_at_eol, gfc_advance_line, gfc_next_char): Adapt
+	to new locus structure.
+	(gfc_check_include): Remove.
+	(skip_free_comments, skip_fixed_comments): Use gfc_current_locus1.
+	(gfc_skip_comments): Use gfc_current_form, find locus with
+	gfc_current_locus1.
+	(gfc_next_char): Use gfc_current_form.
+	(gfc_peek_char, gfc_gobble_whitespace): Use gfc_current_locus1.
+	(load_line): Use gfc_current_form. Recognize ^Z as EOF. Fix
+	comment formatting.
+	(get_file): New function.
+	(preprocessor_line, include_line): New functions.
+	(load_file): Move down, rewrite to match new data structures.
+	(gfc_new_file): Rewrite to match new data structures.
+	* parse.c (next_statement): Remove code which is now useless. Use
+	gfc_source_form and gfc_source_file where appropriate.
+	* trans-decl.c (gfc_get_label_decl): adapt to new data structures
+	when determining locus of frontend code.
+	* trans-io.c (set_error_locus): Same.
+	* trans.c (gfc_get_backend_locus, gfc_set_backend_locus): Likewise.
+	* lang-specs.h (@f77-cpp-input, @f95-cpp-input): Remove '-P' from
+	preprocessor flags.
+	(all): Add missing initializers.
+
+2004-05-15  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* Make-lang.in (trans-common.o): Remove redundant dependency.
+	(data.c): Replace object file name ...
+	(data.o): ... by the correct one.
+
+2004-05-14  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* dump-parse-tree.c (gfc_show_array_ref): Print colon only
+	for ranges when dumping array references.
+
+2004-05-14  Victor Leikehman  <lei@haifasphere.co.il>
+
+	* decl.c (variable_decl): Always apply default initializer.
+
+2004-05-08  Tobias Schlüter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/15206
+	* trans-intrinsic.c (gfc_conv_intrinsic_rrspacing): Fixed to
+	handle zero correctly.
+
+2004-05-14  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* match.c (gfc_match): Eliminate dead code.
+
+2004-05-14  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* parse.c (gfc_statement_next_fixed): (Change from Andy's tree)
+	Detect bad continuation line in fixed form sources.
+
+2004-05-14  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/15205
+	* iresolve.c (gfc_resolve_nearest): Add new function.
+	* intrinsic.h: ... declare it here.
+	* intrinsic.c (add_functions): ... add it as resolving function
+	for NEAREST.
+
+2004-05-14  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/14066
+	* match.c (gfc_match_do): Allow infinite loops with
+	label-do-stmt. Do not enforce space after comma.
+
+2004-05-14  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/15051
+	* parse.c (parse_interface): Allow empty INTERFACE, remove
+	seen_body.
+
+2004-05-14  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* Make-lang.in, arith.c, arith.h, array.c, bbt.c, check.c,
+	decl.c, dependency.c, dependency.h, dump-parse-tree.c, error.c,
+	expr.c, f95-lang.c, gfortran.h, interface.c, intrinsic.c,
+	intrinsic.h, io.c, iresolve.c, lang-specs.h, match.c, match.h,
+	matchexp.c, misc.c, module.c, options.c, parse.c, parse.h,
+	primary.c, resolve.c, scanner.c, simplify.c, st.c, symbol.c,
+	trans-array.c, trans-array.h, trans-common.c, trans-const.c,
+	trans-const.h, trans-decl.c, trans-expr.c, trans-intrinsic.c,
+	trans-io.c, trans-stmt.c, trans-stmt.h, trans-types.c,
+	trans-types.h, trans.c, trans.h: Update copyright years and
+	boilerplate.
+	* data.c: Likewise, also removed two whitespace-only lines.
+	* gfortranspec.c, lang.opt: Update copyright years.
+
+2004-05-14  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/14568
+	* trans-decl.c (generate_local_decl): Don't warn for unused
+	variables which are in common blocks.
+
+2004-05-13  Diego Novillo  <dnovillo@redhat.com>
+
+	* Make-lang.in, f95-lang.c, trans-array.c, trans-decl.c,
+	trans-expr.c, trans-intrinsic.c, trans-io.c, trans-stmt.c,
+	trans.c: Rename tree-simple.[ch] to tree-gimple.[ch].
+
+2004-05-13  Victor Leikehman  <lei@haifasphere.co.il>
+
+	PR fortran/15314
+	* trans-expr.c (gfc_conv_structure): Use field type, not expr type.
+
+2004-05-13  Joseph S. Myers  <jsm@polyomino.org.uk>
+
+	* gfortran.texi: Use @table @emph instead of @itemize @emph.
+	Remove "set DEVELOPMENT".
+	(Compiling GFORTRAN): Remove.
+
+2004-05-09  Tobias Schlüter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* array.c (match_subscript, match_array_ref): Add comments
+	explaining argument 'init'.
+	* decl.c, f95-lang.c, match.c, resolve.c, trans-array.c,
+	trans-expr.c, trans.c: Fix some typos in comments.
+	* dump-parse-tree.c (gfc_show_expr): Remove wrong comment.
+	* primary.c (match_digits, match_integer_constant): Add comment
+	explaining signflag.
+
+2004-05-01  Tobias Schlüter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/13940
+	* primary.c: Include system.h and flags.h, needed for pedantic.
+	(match_boz_constant): Allow "x" for hexadecimal constants, warn if
+	pedantic is set.
+
+2004-05-01  Tobias Schlüter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/13940
+	* match.c (match_data_constant): Handle case where
+	gfc_find_symbol	sets sym to NULL
+
+2004-04-28  Tobias Schlüter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* Make-lang.in (f95-lang.o, trans-intrinsic.o): Add missing
+	dependency on mathbuiltins.def
+
+2004-04-24  Victor Leikehman  <lei@il.ibm.com>
+
+	* trans-io.c (transfer_expr): Implemented recursive printing
+	of derived types.
+
+2004-04-24  Andrew Pinski  <pinskia@physics.uc.edu>
+
+	* gfortranspec.c: Do not include multilib.h.
+
+2004-04-24  Tobias Schlüter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* trans-intrinsic.c: Fix comment, this is not trans-expr.c. Add
+	2004 to copyright years.
+	* trans-expr.c, trans-decl.c: Comment update, we now generate
+	GENERIC, not SIMPLE. Add 2004 to copyright years.
+
+2004-04-24  Paul Brook  <paul@codesourcery.com>
+
+	* Make-lang.in (gfortranspec.o): Add dependency on $(TM_H).
+
+2004-04-24  Feng Wang  <fengwang@nudt.edu.cn>
+
+	PR 14817
+	* arith.c (gfc_arith_divide): Fix complex divide.
+
+2004-04-23  Andrew Pinski  <pinskia@physics.uc.edu>
+
+	* gfortranspec.c: Include the target headers.
+
+2004-04-18  Feng Wang  <fengwang@nudt.edu.cn>
+
+	PR fortran/14921
+	PR fortran/14540
+	* arith.c (arctangent2): New function.
+	* arith.h (arctangent2): Add function prototype.
+	* simplify.c (gfc_simplify_atan2): Use it.
+	(gfc_simplify_log): Use it.
+
+2004-04-12  Diego Novillo  <dnovillo@redhat.com>
+
+	* fortran/f95-lang.c (gfc_expand_stmt): Remove.
+	(LANG_HOOKS_RTL_EXPAND_STMT): Remove.
+
+2004-04-11  Bud Davis  <bdavis9659@comcast.net>
+
+	PR fortran/14872
+	* trans-io.c (build_dt): Change REC to value.
+
+2004-04-11  Feng Wang  <fengwang@nudt.edu.cn>
+
+	PR 14394
+	* trans-const.c (gfc_conv_mpf_to_tree): Loosen the maximum digits of
+	the real value when converting mpf to string.
+
+2004-04-11  Feng Wang  <fengwang@nudt.edu.cn>
+
+	PR 14395
+	* trans-intrinsic.c (gfc_conv_intrinsic_cmplx): Fix the imag part of
+	the result.
+
+2004-04-11  Feng Wang  <fengwang@nudt.edu.cn>
+
+	PR fortran/14377
+	* simplify.c (simplify_min_max): Convert the type of the result.
+
+2004-04-11  Paul Brook  <paul@codesourcery.com>
+
+	* gfortran.texi: Use full target triplet.
+
+2004-04-11  Paul Brook  <paul@codesourcery.com>
+
+	* Make-lang.in (GFORTRAN_TEXI): Set it.
+	(fortran/dfortran.dvi): Use it.  Add fortran to include paths.
+	(fortran/gfortran.info): Ditto.
+	* gfortran.texi: Major update.
+	* invoke.texi: New file.
+
+2004-04-10  Paul Brook  <paul@codesourcery.com>
+
+	* trans-array.c (gfc_trans_allocate_temp_array,
+	gfc_conv_tmp_array_ref): Don't use GFC_DECL_STRING.
+	* trans-decl.c (gfc_build_dummy_array_decl,
+	gfc_get_symbol_decl, gfc_build_function_decl,
+	gfc_create_module_variable): Ditto.
+	* trans-expr.c (gfc_conv_variable): Ditto.
+	* trans-intrinsic.c (gfc_conv_intrinsic_len): Ditto.
+	* trans.h (GFC_DECL_STRING): Remove.
+	(GFC_DECL_PACKED_ARRAY, GFC_DECL_PARTIAL_PACKED_ARRAY,
+	GFC_DECL_ASSIGN): Renumber flags.
+
+2004-04-05  Paul Brook  <paul@codesourcery.com>
+
+	PR 13252
+	PR 14081
+	* f95-lang.c (gfc_init_builtin_functions): Add stack_alloc, stack_save
+	and stack_restore.
+	* gfortran.h (struct gfc_charlen): Add backend_decl.
+	* trans-array.c (gfc_trans_allocate_temp_array,
+	gfc_conv_temp_array_ref, gfc_conv_resolve_dependencies,
+	(gfc_conv_loop_setup, gfc_array_allocate, gfc_conv_array_init_size):
+	Remove old, broken string handling.
+	(gfc_trans_auto_array_allocation, gfc_trans_g77_array,
+	gfc_trans_dummy_array_bias, gfc_conv_expr_descriptor,
+	gfc_trans_deferred_array): Handle character arrays.
+	* trans-const.c (gfc_conv_const_charlen): New function.
+	* trans-const.h (gfc_conv_const_charlen): Add prototype.
+	* trans-decl.c (gfc_finish_var_decl): Don't mark automatic variables
+	as static.
+	(gfc_build_dummy_array_decl): Handle arrays with unknown element size.
+	(gfc_create_string_length): New function.
+	(gfc_get_symbol_decl): Create lengths for character variables.
+	(gfc_get_fake_result_decl): Ditto.
+	(gfc_build_function_decl): Only set length for assumed length
+	character arguments.
+	(gfc_trans_dummy_character): New function.
+	(gfc_trans_auto_character_variable): Rewrite.
+	(gfc_trans_deferred_vars): Handle more types of character variable.
+	(gfc_create_module_variable): String lengths have moved.
+	(gfc_generate_function_code): Initialize deferred var chain earlier.
+	* trans-expr.c (gfc_conv_init_string_length): Rename ...
+	(gfc_trans_init_string_length):  ... to this.
+	(gfc_conv_component_ref, gfc_conv_variable, gfc_conv_concat_op,
+	gfc_conv_function_call): Update to new format for character variables.
+	(gfc_conv_string_length): Remove.
+	(gfc_conv_string_parameter): Update assertion.
+	* trans-intrinsic.c (gfc_conv_intrinsic_len): Use new location.
+	* trans-io.c (set_string): Use new macro names.
+	* trans-stmt.c (gfc_trans_label_assign. gfc_trans_goto): Ditto.
+	* trans-types.c (gfc_get_character_type): Use existing length expr.
+	(gfc_is_nodesc_array): Make public.
+	(gfc_get_dtype_cst): Rename ...
+	(gfc_get_dtype): ... to this.  Handle unknown size arrays.
+	(gfc_get_nodesc_array_type): Use new name.
+	(gfc_sym_type): New character variable code.
+	(gfc_get_derived_type): Ditto.
+	(gfc_get_function_type): Evaluate character variable lengths.
+	* trans-types.h (gfc_strlen_kind): Define.
+	(gfc_is_nodesc_array): Add prototype.
+	* trans.h: Update prototypes.
+	(struct lang_type): Update comments.
+	(GFC_DECL_STRING_LEN): New name for GFC_DECL_STRING_LENGTH.
+	(GFC_KNOWN_SIZE_STRING_TYPE): Remove.
+
+2004-04-04  Paul Brook  <paul@codesourcery.com>
+
+	* gfortran.h (struct gfc_option_t): Remove flag_g77_calls.
+	* options.c (gfc_init.options, gfc_handle_option): Ditto.
+	* trans-expr.c (gfc_conv_function_call): Ditto.
+	* trans-types.c (gfc_is_nodesc_array): Ditto
+	* lang.opt (fg77-calls): Remove.
+
+2004-04-04  Paul Brook  <paul@codesourcery.com>
+
+	* trans-array.c (OFFSET_FIELD): Rename from BASE_FIELD.
+	(gfc_conv_descriptor_base): Rename ...
+	(gfc_conv_descriptor_offset): ... to this.
+	(gfc_trans_allocate_array_storage): Set offset to zero.
+	(gfc_conv_array_base): Rename ...
+	(gfc_conv_array_offset): ... to this.
+	(gfc_conv_array_index_ref): Add offset parameter.
+	(gfc_conv_array_ref): Include offset.
+	(gfc_trans_preloop_setup): Use existing offset.
+	(gfc_trans_allocate_temp_array,  gfc_array_allocate,
+	gfc_trans_auto_array_allocation, gfc_trans_g77_array,
+	gfc_trans_dummy_array_bias, gfc_conv_expr_descriptor,
+	gfc_conf_ss_descriptor): Set offset.
+	* trans-array.h: Rename prototypes.
+	* trans-const.h (gfc_index_zero_node): Define.
+	* trans-decl.c (gfc_build_qualified_array): Change base to offset.
+	* trans-types.c (gfc_get_array_type_bounds): Ditto.
+	(gfc_get_nodesc_array_type): Calculate offset before upper bound.
+
+2004-03-25  Diego Novillo  <dnovillo@redhat.com>
+
+	* convert.c (convert): Don't handle WITH_RECORD_EXPR.
+
+2004-03-24  Bud Davis  <bdavis9659@comcast.net>
+
+	PR 14055
+	* arith.c (gfc_convert_integer,gfc_convert_real):  Removed leading '+'
+	before conversion by gmp library call.
+
+2004-03-24  Bud Davis  <bdavis9659@comcast.net>
+
+	PR 12921
+	* trans-io.c (gfc_trans_open): Change RECL= to a value parameter.
+
+2004-02-24  Richard Henderson  <rth@redhat.com>
+
+	* trans-array.c (gfc_trans_dummy_array_bias): Fix typo.
+
+2004-02-19  Loren J. Rittle  <ljrittle@acm.org>
+
+	* Make-lang.in ($(srcdir)/fortran/gfortran.info): Move...
+	(fortran/gfortran.info): ... to here.
+	(f95.srcinfo): New.
+
+2004-02-16  Richard Henderson  <rth@redhat.com>
+
+	* Make-lang.in (f95-lang.o, trans-decl.o): Depend on cgraph.h.
+	* f95-lang.c (LANG_HOOKS_EXPAND_DECL): Remove.
+	(LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION): New.
+	(gfc_expand_function): Rename from expand_function_body, make static,
+	don't do anything except invoke tree_rest_of_compilation.
+	(gfc_be_parse_file): Invoke cgraph.
+	(gfc_expand_decl): Remove.
+	(gfc_init_builtin_functions): Add __builtin_init_trampoline and
+	__builtin_adjust_trampoline.
+	* trans-decl.c (gfc_get_extern_function_decl): Don't set DECL_CONTEXT.
+	(gfc_finalize): New.
+	(gfc_generate_function_code): Use it.  Lower nested functions.
+	* trans-expr.c (gfc_conv_function_call): Add static chain operand
+	to call_expr.
+	* trans.c (gfc_build_function_call): Likewise.
+	* trans.h (expand_function_body): Remove.
+
+2004-02-15  Victor Leikehman  <lei@il.ibm.com>
+
+	PR gfortran/13433
+	* trans-decl.c (gfc_build_function_decl) For functions
+	returning CHARACTER pass an extra length argument,
+	following g77 calling conventions.
+	* trans-types.c (gfc_get_function_type) Ditto.
+	* trans-expr.c (gfc_conv_function_call) Ditto.
+
+2004-02-14  Paul Brook  <paul@codesourcery.com>
+
+	* f95-lang.c (gfc_init_builtin_functions): Build chain properly.
+
+2004-02-12  Paul Brook  <paul@nowt.org>
+
+	* BUGS: Remove.
+
+2004-02-08  Steve Kargl  <sgk@troutmask.apl.washington.edu>
+
+	* gfortran.texi: Fix typos.
+
+2004-02-07  Bud Davis  <bdavis9659@comcast.net>
+
+	PR gfortran/13909
+	* intrinsic.c (add_conversions) Use logical conversion instead
+	of real.
+	* trans-types.c (gfc_get_logical_type) implemented logical*1
+	and logical*2.
+
+2004-01-17  Paul Brook  <paul@codesourcery.com>
+
+	* lang-specs.h: Remove %<fixed-form.
+
+2004-01-15  Toon Moene  <toon@moene.indiv.nluug.nl>
+
+	* lang-specs.h: Enable preprocessing of source files
+	ending in .F, .fpp, .FPP, .F90 and .F95.
+
+2004-01-13  Toon Moene  <toon@moene.indiv.nluug.nl>
+
+	PR fortran/12912
+	* lang-specs.h: Enable compilation of files ending
+	in .f, .for and .FOR.
+
+2004-01-11  Paul Brook  <paul@codesourcery.com>
+
+	* trans-stmt.c (gfc_trans_if_1): New function.
+	(gfc_trans_if): Use it.
+
+2004-01-11  Erik Schnetter  <schnetter@uni-tuebingen.de>
+
+	* gfortran.h (GFC_MAX_SYMBOL_LEN): Increase.
+	(gfc_option_t): Add max_identifier_length.
+	* lang.opt: Add fmax-identifier-length.
+	* match.c (parse_name): Use limit.
+	* options.c (gfc_init_options): Set max_identifier_length.
+	(gfc_handle_option): Ditto.
+
+2004-01-11  Feng Wang  <fengwang@nudt.edu.cn>
+
+	* intrinsic.c (add_functions): Add resolve function to dcmplx.
+	* intrinsic.h (gfc_resolve_dcmplx): Add prototype.
+	* iresolve.c (gfc_resolve_dcmplx): New function.
+
+2004-01-10  Paul Brook  <paul@codesourcery.com>
+
+	* trans-decl.c (gfc_get_symbol_decl): Don't set subroutine attr.
+	* trans-types.c (gfc_sym_type): Handle external dummy procedures.
+	(gfc_return_by_reference): Correct condition.
+	(gfc_get_function_type): Ditto.
+
+2004-01-10  Paul Brook  <paul@codesourcery.com>
+
+	* trans-intrinsic.c (gfc_conv_intrinsic_minmax): Convert mismatched
+	types.
+
+2004-01-10  Huang Chun  <chunhuang73@hotmail.com>
+
+	* iresolve.c: Use correct kind.
+
+2004-01-10  Huang Chun  <chunhuang73@hotmail.com>
+
+	PR fortran/13467
+	* trans-decl.c (gfc_create_module_variable):  Output array valued
+	parameters.
+
+2004-01-10  Paul Brook  <paul@codesourcery.com>
+
+	* resolve.c (resolve_branch): Get error message right way round.
+
+2004-01-10  Canqun Yang  <canqun@nudt.edu.cn>
+
+	* trans-array (gfc_conv_loop_setup): Adjust comment to track
+	reality.
+	(gfc_array_allocate): Don't count size of element twice.
+
+2004-01-04  Paul Brook  <paul@codesourcery.com>
+
+	* lang.opt (i8, r8, std=*): Remove RejectNegative.
+
+2004-01-04  Paul Brook  <paul@codesourcery.com>
+
+	* error.c (gfc_notify_std): New function.
+	* gfortran.h (gfc_notify_std): Declare.
+	(GFC_STD_*): Define.
+	(gfc_option_t): Add warn_std and allow_std.
+	* intrinsic.c (gfc_init_expr_extensions): Fix logic.
+	(gfc_intrinsic_func_interface): Use gfc_notify_std.
+	* check.c (check_rest): Use gfc_notify_std.
+	* match.c (gfc_match_pause): Ditto.
+	(gfc_match_assign): Ditto.
+	(gfc_match_goto): Ditto.
+	* resolve.c (resolve_branch): Ditto.
+	* lang.opt: Add std=<foo> and w.
+	* options.c (gfc_init_options): Set allow_std and warn_std.
+	(gfc_handle_option): Handle OPT_std_* and OPT_w.
+
+2004-01-01  Paul Brook  <paul@codesourcery.com>
+
+	* array.c (gfc_append_constructor): Take constructor, not expression.
+	* data.c (struct gfc_expr_stack): Remove.
+	(expr_stack): Remove.
+	(find_con_by_offset): Rename from find_expr_in_con.
+	(find_con_by_component): Rename from find_component_in_con.
+	(gfc_get_expr_stack): Remove.
+	(gfc_assign_data_value): Rewrite.
+	(gfc_expr_push): Remove.
+	(gfc_expr_pop): Remove.
+	(gfc_advance_section): Rename from
+	gfc_modify_index_and_calculate_offset.  Handle unbounded sections.
+	(gfc_get_section_index): Handle unbounded sections.
+	* gfortran.h: Update prototypes.
+	* resolve.c (check_data_variable): Array section maight not be the
+	last ref.
+
+2004-01-01  Paul Brook  <paul@codesourcery.com>
+
+	PR fortran/13432
+	* resolve.c (resolve_symbol): Allow assumed length function results.
+
+2004-01-01  Steve Kargl  <sgk@troutmask.apl.washington.edu>
+
+	* match.c (gfc_match_pause): Fix spelling.
+
+2004-01-01  Steven Bosscher  <stevenb@suse.de>
+
+	PR fortran/13251
+	* trans-expr.c (gfc_conv_variable): Take the type kind of a substring
+	reference from the expression.
+
+
+Copyright (C) 2004 Free Software Foundation, Inc.
+
+Copying and distribution of this file, with or without modification,
+are permitted in any medium without royalty provided the copyright
+notice and this notice are preserved.
diff --git a/gcc-4.9/gcc/fortran/ChangeLog-2005 b/gcc-4.9/gcc/fortran/ChangeLog-2005
new file mode 100644
index 000000000..d9fa6a587
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/ChangeLog-2005
@@ -0,0 +1,3730 @@
+2005-12-30  Erik Edelmann  <eedelman@gcc.gnu.org>
+
+	PR fortran/22607
+	* trans-decl.c(gfc_get_extern_function_decl): Don't set
+	DECL_IS_PURE (fndecl) = 1 for return-by-reference
+	functions.
+
+	fortran/PR 25396
+	* interface.c (gfc_extend_expr): Initialize
+	e->value.function.name to NULL.
+
+2005-12-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/25532
+	* trans-types.c (copy_dt_decls_ifequal): Copy declarations for
+	components of derived type components by recursing into
+	gfc_get_derived_type.
+
+2005-12-28  Andrew Pinski  <pinskia@physics.uc.edu>
+
+	PR fortran/25587
+	* trans-io.c (gfc_build_st_parameter): Correct off by one error.
+
+2005-12-28  Rafael Ávila de Espíndola  <rafael.espindola@gmail.com>
+
+	* Make-lang.in: Remove distdir from comment.
+
+2005-12-24  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/25029
+	PR fortran/21256
+	* resolve.c (check_assumed_size_reference, resolve_assumed_size_actual):
+	Remove because of regressions caused by patch.
+	(resolve_function, resolve_call, resolve_variable): Remove assumed size
+	checks because of regressionscaused by patch.
+
+2005-12-23  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/25029
+	PR fortran/21256
+	*resolve.c(resolve_function): Remove assumed size checking for SIZE
+	and UBOUND and rely on their built-in checking.
+
+2005-12-22  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/18990
+	* gfortran.h (gfc_charlen): Add resolved field.
+	* expr.c (gfc_specification_expr): Accept NULL argument.
+	* resolve.c (gfc_resolve_charlen, gfc_resolve_derived): New.
+	(gfc_resolve_symbol): Resolve derived type definitions.  Use
+	resolve_charlen to resolve character lengths.
+
+2005-12-22  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/20889
+	*resolve.c(resolve_structure_cons): Do not attempt to convert
+	the type of mismatched pointer type components, except when
+	the constructor component is BT_UNKNOWN; emit error instead.
+
+	PR fortran/25029
+	PR fortran/21256
+	*resolve.c(check_assumed_size_reference): New function to check for upper
+	bound in assumed size array references.
+	(resolve_assumed_size_actual): New function to do a very restricted scan
+	of actual argument expressions of those procedures for which incomplete
+	assumed size array references are not allowed.
+	(resolve_function, resolve_call): Switch off assumed size checking of
+	actual arguments, except for elemental procedures and array valued
+	intrinsics; excepting LBOUND.
+	(resolve_variable): Call check_assumed_size_reference.
+
+	PR fortran/19362
+	PR fortran/20244
+	PR fortran/20864
+	PR fortran/25391
+	*interface.c(gfc_compare_types): Broken into two.
+	(gfc_compare_derived_types): Second half of gfc_compare_types with
+	corrections for a missing check that module name is non-NULL and
+	a check for private components.
+	*symbol.c(gfc_free_dt_list): New function.
+	(gfc_free_namespace): Call gfc_free_dt_list.
+	*resolve.c(resolve_symbol): Build the list of derived types in the
+	symbols namespace.
+	*gfortran.h: Define the structure type gfc_dt_list.  Add a new field,
+	derived_types to gfc_namespace.  Provide a prototye for the new
+	function gfc_compare_derived_types.
+	*trans_types.c(gfc_get_derived_type): Test for the derived type being
+	available in the host namespace. In this case, the host backend
+	declaration is used for the structure and its components.  If an
+	unbuilt, equal structure that is not use associated is found in the
+	host namespace, build it there and then.  On exit,traverse the
+	namespace of the derived type to see if there are equal but unbuilt.
+	If so, copy the structure and its component declarations.
+	(copy_dt_decls_ifequal): New functions to copy declarations to other
+	equal structure types.
+
+	PR fortran/20862
+	* io.c (gfc_match_format): Make the appearance of a format statement
+	in a module specification block an error.
+
+	PR fortran/23152
+	* match.c (gfc_match_namelist): Set assumed shape arrays in
+	namelists as std=GFC_STD_GNU and assumed size arrays as an
+	unconditional error.
+
+	PR fortran/25069
+	* match.c (gfc_match_namelist): Set the respecification of a USE
+	associated namelist group as std=GFC_STD_GNU.  Permit the concatenation
+	on no error.
+
+	PR fortran/25053
+	PR fortran/25063
+	PR fortran/25064
+	PR fortran/25066
+	PR fortran/25067
+	PR fortran/25068
+	PR fortran/25307
+	* io.c (resolve_tag): Change std on IOSTAT != default integer to
+	GFC_STD_GNU and change message accordingly.  Add same error for
+	SIZE.
+	(match_dt_element, gfortran.h): Add field err_where to gfc_dt and
+	set it when tags are being matched.
+	(gfc_resolve_dt): Remove tests that can be done before resolution
+	and add some of the new ones here.
+	(check_io_constraints): New function that checks for most of the
+	data transfer constraints. Some of these were previously done in
+	match_io, from where this function is called, and some were done
+	in gfc_resolve_dt.
+	(match_io): Remove most of the tests of constraints and add the
+	call to check_io_constraints.
+
+2005-12-21  Erik Edelmann  <eedelman@gcc.gnu.org>
+
+	PR fortran/25423
+	* parse.c (parse_where_block): break instead of "fall
+	through" after parsing nested WHERE construct.
+
+2005-12-18  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/25018
+	*expr.c(check_inquiry): Return FAILURE if there is no symtree to
+	provide a name. Error/warning for assumed character length argument
+	to LEN for an initialization expression, using GFC_GNU_STD. Add an
+	argument to flag that the expression is not restricted.
+	(check_init_expr): Improve the message for a failing variable.
+	(gfc_match_init_expr): Call check_enquiry again to make sure that
+	unsimplified expressions are not causing unnecessary errors.
+
+2005-12-17  Steven G. Kargl  <kargls@comcast.net>
+	    Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/25458
+	* simplify.c (gfc_simplify_ibset, gfc_simplify_not): Add call to
+	twos_complement.
+
+2005-12-17  Steven G. Kargl  <kargls@comcast.net>
+
+	* decl.c (gfc_match_old_kind_spec,match_type_spec): Use gfc_std_notify
+	to report nonstandard intrinsic type declarations.
+
+2005-12-16  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/24268
+	* io.c (format_lex): Allow whitespace within text of format specifier.
+
+2005-12-16  Steven G. Kargl <kargls@comcast.net>
+ 
+	PR fortran/25106
+	PR fortran/25055
+	* match.c (gfc_match_small_literal_int): Add cnt argument;
+	(gfc_match_st_label,gfc_match_stopcode): Account for cnt argument.
+	* match.h (gfc_match_small_literal_int): Update prototype.
+	* decl.c (match_char_length,gfc_match_old_kind_spec): Account for cnt.
+	* parse.c (next_free): Ditto.
+	* primary.c (match_kind_param): Ditto.
+
+2005-12-16  Richard Guenther  <rguenther@suse.de>
+
+	* trans.h (tree): Remove declaration of gfc_build_function_call.
+	* trans.c (gfc_build_function_call): Remove.
+	(gfc_build_array_ref): Use build_function_call_expr.
+	(gfc_trans_runtime_check): Likewise.
+	* trans-array.c (gfc_trans_allocate_array_storage): Likewise.
+	(gfc_grow_array): Likewise.
+	(gfc_trans_array_ctor_element): Likewise.
+	(gfc_trans_array_constructor_value): Likewise.
+	(gfc_array_allocate): Likewise.
+	(gfc_array_deallocate): Likewise.
+	(gfc_trans_auto_array_allocation): Likewise.
+	(gfc_trans_dummy_array_bias): Likewise.
+	(gfc_conv_array_parameter): Likewise.
+	* trans-expr.c (gfc_conv_power_op): Likewise.
+	(gfc_conv_string_tmp): Likewise.
+	(gfc_conv_concat_op): Likewise.
+	(gfc_conv_expr_op): Likewise.
+	(gfc_trans_string_copy): Likewise.
+	* trans-decl.c (build_entry_thunks): Likewise.
+	(gfc_generate_function_code): Likewise.
+	(gfc_generate_constructors): Likewise.
+	* trans-io.c (gfc_trans_open): Likewise.
+	(gfc_trans_close): Likewise.
+	(build_filepos): Likewise.
+	(gfc_trans_inquire): Likewise.
+	(transfer_namelist_element): Likewise.
+	(build_dt): Likewise.
+	(gfc_trans_dt_end): Likewise.
+	(transfer_expr): Likewise.
+	(transfer_array_desc): Likewise.
+	* trans-stmt.c (gfc_trans_pause): Likewise.
+	(gfc_trans_stop): Likewise.
+	(gfc_trans_character_select): Likewise.
+	(gfc_do_allocate): Likewise.
+	(gfc_trans_assign_need_temp): Likewise.
+	(gfc_trans_pointer_assign_need_temp): Likewise.
+	(gfc_trans_forall_1): Likewise.
+	(gfc_trans_where): Likewise.
+	(gfc_trans_allocate): Likewise.
+	(gfc_trans_deallocate): Likewise.
+	* trans-intrinsic.c (gfc_conv_intrinsic_aint): Likewise.
+	(gfc_conv_intrinsic_lib_function): Likewise.
+	(gfc_conv_intrinsic_exponent): Likewise.
+	(gfc_conv_intrinsic_abs): Likewise.
+	(gfc_conv_intrinsic_sign): Likewise.
+	(gfc_conv_intrinsic_ctime): Likewise.
+	(gfc_conv_intrinsic_fdate): Likewise.
+	(gfc_conv_intrinsic_ttynam): Likewise.
+	(gfc_conv_intrinsic_ishftc): Likewise.
+	(gfc_conv_intrinsic_len_trim): Likewise.
+	(gfc_conv_intrinsic_index): Likewise.
+	(gfc_conv_intrinsic_size): Likewise.
+	(gfc_conv_intrinsic_strcmp): Likewise.
+	(gfc_conv_intrinsic_adjust): Likewise.
+	(gfc_conv_associated): Likewise.
+	(gfc_conv_intrinsic_scan): Likewise.
+	(gfc_conv_intrinsic_verify): Likewise.
+	(call_builtin_clz): Likewise.
+	(gfc_conv_intrinsic_si_kind): Likewise.
+	(gfc_conv_intrinsic_sr_kind): Likewise.
+	(gfc_conv_intrinsic_trim): Likewise.
+	(gfc_conv_intrinsic_repeat): Likewise.
+	(gfc_conv_intrinsic_iargc): Likewise.
+
+2005-12-16  Richard Guenther  <rguenther@suse.de>
+
+	* trans.h (gfc_build_indirect_ref): Remove declaration.
+	* trans.c (gfc_build_indirect_ref): Remove.
+	* trans-array.c (gfc_trans_array_ctor_element): Use
+	build_fold_indirect_ref instead of gfc_build_indirect_ref.
+	(gfc_trans_array_constructor_value): Likewise.
+	(gfc_conv_array_index_offset): Likewise.
+	(gfc_conv_scalarized_array_ref): Likewise.
+	(gfc_conv_array_ref): Likewise.
+	(gfc_trans_dummy_array_bias): Likewise.
+	(gfc_conv_expr_descriptor): Likewise.
+	(gfc_conv_array_parameter): Likewise.
+	* trans-decl.c (gfc_finish_cray_pointee): Likewise.
+	(gfc_get_symbol_decl): Likewise.
+	* trans-expr.c (gfc_conv_substring): Likewise.
+	(gfc_conv_component_ref): Likewise.
+	(gfc_conv_variable): Likewise.
+	(gfc_add_interface_mapping): Likewise.
+	(gfc_conv_function_call): Likewise.
+	* trans-intrinsic.c (gfc_conv_intrinsic_ichar): Likewise.
+	(gfc_conv_intrinsic_transfer): Likewise.
+	* trans-io.c (nml_get_addr_expr): Likewise.
+	(transfer_namelist_element): Likewise.
+	(transfer_expr): Likewise.
+	* trans-stmt.c (gfc_trans_nested_forall_loop): Likewise.
+	(allocate_temp_for_forall_nest_1): Likewise.
+	(gfc_trans_forall_1): Likewise.
+
+2005-12-16  Richard Guenther  <rguenther@suse.de>
+
+	* trans-array.c (gfc_conv_descriptor_data_addr): Use
+	build_fold_addr_expr where appropriate.
+	(gfc_trans_allocate_array_storage): Likewise.
+	(gfc_trans_array_constructor_value): Likewise.
+	(gfc_conv_array_data): Likewise.
+	(gfc_conv_expr_descriptor): Likewise.
+	(gfc_conv_array_parameter): Likewise.
+	* trans-expr.c (gfc_conv_variable): Likewise.
+	(gfc_conv_function_val): Likewise.
+	(gfc_conv_function_call): Likewise.
+	(gfc_conv_expr_reference): Likewise.
+	* trans-intrinsic.c (gfc_conv_intrinsic_ctime): Likewise.
+	(gfc_conv_intrinsic_fdate): Likewise.
+	(gfc_conv_intrinsic_ttynam): Likewise.
+	(gfc_conv_intrinsic_si_kind): Likewise.
+	(gfc_conv_intrinsic_trim): Likewise.
+	* trans-io.c (set_parameter_ref): Likewise.
+	(gfc_convert_array_to_string): Likewise.
+	(gfc_trans_open): Likewise.
+	(gfc_trans_close): Likewise.
+	(build_filepos): Likewise.
+	(gfc_trans_inquire): Likewise.
+	(nml_get_addr_expr): Likewise.
+	(transfer_namelist_element): Likewise.
+	(build_dt): Likewise.
+	(gfc_trans_dt_end): Likewise.
+	(transfer_array_component): Likewise.
+	(transfer_expr): Likewise.
+	(transfer_array_desc): Likewise.
+	(gfc_trans_transfer): Likewise.
+	* trans-stmt.c (gfc_trans_allocate): Likewise.
+	(gfc_trans_deallocate): Likewise.
+
+2005-12-16  Kazu Hirata  <kazu@codesourcery.com>
+
+	* dependency.c, resolve.c, trans-array.c: Fix comment typos.
+	* gfortran.texi: Fix typos.
+
+2005-12-14  Erik Edelmann  <eedelman@gcc.gnu.org>
+
+	PR fortran/18197
+	* resolve.c (resolve_formal_arglist): Remove code to set
+	the type of a function symbol from it's result symbol.
+
+2005-12-13  Richard Guenther  <rguenther@suse.de>
+
+	* trans-expr.c (gfc_conv_substring): Use fold_build2 and
+	build_int_cst.
+
+2005-12-13  Richard Sandiford  <richard@codesourcery.com>
+
+	* Make-lang.in (fortran/trans-resolve.o): Depend on
+	fortran/dependency.h.
+	* gfortran.h (gfc_expr): Add an "inline_noncopying_intrinsic" flag.
+	* dependency.h (gfc_get_noncopying_intrinsic_argument): Declare.
+	(gfc_check_fncall_dependency): Change prototype.
+	* dependency.c (gfc_get_noncopying_intrinsic_argument): New function.
+	(gfc_check_argument_var_dependency): New function, split from
+	gfc_check_fncall_dependency.
+	(gfc_check_argument_dependency): New function.
+	(gfc_check_fncall_dependency): Replace the expression parameter with
+	separate symbol and argument list parameters.  Generalize the function
+	to handle dependencies for any type of expression, not just variables.
+	Accept a further argument giving the intent of the expression being
+	tested.  Ignore	intent(in) arguments if that expression is also
+	intent(in).
+	* resolve.c: Include dependency.h.
+	(find_noncopying_intrinsics): New function.
+	(resolve_function, resolve_call): Call it on success.
+	* trans-array.h (gfc_conv_array_transpose): Declare.
+	(gfc_check_fncall_dependency): Remove prototype.
+	* trans-array.c (gfc_conv_array_transpose): New function.
+	* trans-intrinsic.c (gfc_conv_intrinsic_function): Don't use the
+	libcall handling if the expression is to be evaluated inline.
+	Add a case for handling inline transpose()s.
+	* trans-expr.c (gfc_trans_arrayfunc_assign): Adjust for the new
+	interface provided by gfc_check_fncall_dependency.
+
+2005-12-12  Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/25078
+	* match.c (gfc_match_equivalence):  Count number of objects.
+
+2005-12-11  Aldy Hernandez  <aldyh@redhat.com>
+
+        * lang.opt: Add RejectNegative to ffixed-form and ffree-form.
+
+2005-12-10  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/25068
+	* io.c (resolve_tag): Add correct diagnostic for F2003 feature.
+
+2005-12-10  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR fortran/23815
+	* io.c (top level):  Add convert to io_tag.
+	(resolve_tag):  convert is GFC_STD_GNU.
+	(match_open_element):  Add convert.
+	(gfc_free_open):  Likewise.
+	(gfc_resolve_open):  Likewise.
+	(gfc_free_inquire):  Likewise.
+	(match_inquire_element):  Likewise.
+	* dump-parse-tree.c (gfc_show_code_node):  Add
+	convet for open and inquire.
+	gfortran.h: Add convert to gfc_open and gfc_inquire.
+	* trans-io.c (gfc_trans_open):  Add convert.
+	(gfc_trans_inquire):  Likewise.
+	* ioparm.def:  Add convert to open and inquire.
+	* gfortran.texi:  Document CONVERT.
+
+2005-12-09  Roger Sayle  <roger@eyesopen.com>
+
+	PR fortran/22527
+	* f95-lang.c (gfc_truthvalue_conversion): Use a zero of the correct
+	integer type when building an inequality.
+
+2005-12-09  Richard Guenther  <rguenther@suse.de>
+
+	* f95-lang.c (build_builtin_fntypes): Use correct
+	return types, as indicated by comments.
+
+2005-12-08  Erik Edelmann  <eedelman@gcc.gnu.org>
+
+	PR fortran/25292
+	* check.c (gfc_check_associated): Allow function results
+	as actual arguments to ASSOCIATED.  Moved a misplaced
+	comment.
+
+2005-12-07  Rafael Ávila de Espíndola  <rafael.espindola@gmail.com>
+
+	* Make-lang.in (fortran.all.build, fortran.install-normal): Remove.
+
+2005-12-07  Rafael Ávila de Espíndola  <rafael.espindola@gmail.com>
+
+	* Make-lang.in: Remove all dependencies on s-gtype, except for
+	gt-fortran-trans.h.
+
+2005-12-03  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/25106
+	* parse.c (next_free): Use new prototype for gfc_match_st_label.
+	Correctly emit hard error if a label is zero.
+	* match.c (gfc_match_st_label): Never allow zero as a valid
+	label.
+	(gfc_match, gfc_match_do, gfc_match_goto): Use new prototype for
+	gfc_match_st_label.
+	* primary.c (): Use new prototype for gfc_match_st_label.
+	* io.c (): Likewise.
+	* match.h: Likewise.
+
+2005-12-02  Richard Guenther  <rguenther@suse.de>
+
+	* trans.h (build1_v): Use build1, not build to build the
+	void typed tree.
+
+2005-12-01  Erik Schnetter  <schnetter@aei.mpg.de>
+
+	* decl.c (gfc_match_old_kind_spec):  Improve handling of old style
+	COMPLEX*N
+
+2005-12-01  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/24789
+	* trans-decl.c (gfc_get_symbol_decl):  Move the expression for
+	unit size of automatic character length, dummy pointer array
+	elements down a few lines from the version that fixed PR15809.
+
+2005-11-30  Bernhard Fischer <rep.nop@aon.at>
+
+	PR fortran/21302
+	* lang.opt: New options -ffree-line-length- and -ffree-line-length-none.
+	* gfortran.h: Add free_line_length and add description of
+	free_line_length and fixed_line_length.
+	* options.c (gfc_init_options, gfc_handle_option): Initialize
+	and set free_line_length and fixed_line_length.
+	* scanner.c (load_line): Set free_line_length to 132 and
+	fixed_line_length to 72 or user requested values.
+	* scanner.c: Typo in comment.
+	* invoke.texi: Document -ffree-line-length- and
+	-ffree-line-length-none
+
+2005-11-30  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/15809
+	* trans-decl.c (gfc_get_symbol_decl):  In the case of automatic
+	character length, dummy pointer arrays, build an expression for
+	unit size of the array elements, to be picked up and used in the
+	descriptor dtype.
+	* trans-io.c (gfc_trans_transfer):  Modify the detection of
+	components of derived type arrays to use the gfc_expr references
+	instead of the array descriptor dtype.  This allows the latter
+	to contain expressions.
+
+2005-11-30  Erik Edelmann  <erik.edelmann@iki.fi>
+
+	PR fortran/15809
+	* trans-array.c (gfc_trans_deferred_array):  Allow PARM_DECLs past
+	in addition to VAR_DECLs.
+
+2005-11-29  Jakub Jelinek  <jakub@redhat.com>
+
+	* io.c (gfc_resolve_open): RESOLVE_TAG access field as well.
+
+2005-11-27 Bernhard Fischer <rep.nop@aon.at>
+
+	* gfortran.h: remove superfluous whitespace and use GNU
+	comment-style for the documentation of backend_decl.
+
+2005-11-27  Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/24917
+	* primary.c (match_boz_constant):  Implement postfix BOZ constants;
+	(match_string_constant): Peek for b, o, z, and x
+
+2005-11-27  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/23912
+	* iresolve.c (gfc_resolve_dim, gfc_resolve_mod,
+	gfc_resolve_modulo): When arguments have different kinds, fold
+	the lower one to the largest kind.
+	* check.c (gfc_check_a_p): Arguments of different kinds is not
+	a hard error, but an extension.
+	* simplify.c (gfc_simplify_dim, gfc_simplify_mod,
+	gfc_simplify_modulo): When arguments have different kinds, fold
+	the lower one to the largest kind.
+
+2005-11-21  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/14943
+	PR fortran/21647
+	* Make-lang.in (fortran/trans-io.o): Depend on fortran/ioparm.def.
+	* dump-parse-tree.c (gfc_show_code_node): Dump c->block for
+	EXEC_{READ,WRITE,IOLENGTH} nodes.
+	* io.c (terminate_io, match_io, gfc_match_inquire): Put data
+	transfer commands into EXEC_{READ,WRITE,IOLENGTH}'s code->block.
+	* resolve.c (resolve_blocks): Handle EXEC_{READ,WRITE,IOLENGTH}.
+	* trans-io.c (ioparm_unit, ioparm_err, ioparm_end, ioparm_eor,
+	ioparm_list_format, ioparm_library_return, ioparm_iostat,
+	ioparm_exist, ioparm_opened, ioparm_number, ioparm_named,
+	ioparm_rec, ioparm_nextrec, ioparm_size, ioparm_recl_in,
+	ioparm_recl_out, ioparm_iolength, ioparm_file, ioparm_file_len,
+	ioparm_status, ioparm_status_len, ioparm_access, ioparm_access_len,
+	ioparm_form, ioparm_form_len, ioparm_blank, ioparm_blank_len,
+	ioparm_position, ioparm_position_len, ioparm_action,
+	ioparm_action_len, ioparm_delim, ioparm_delim_len, ioparm_pad,
+	ioparm_pad_len, ioparm_format, ioparm_format_len, ioparm_advance,
+	ioparm_advance_len, ioparm_name, ioparm_name_len,
+	ioparm_internal_unit, ioparm_internal_unit_len,
+	ioparm_internal_unit_desc, ioparm_sequential, ioparm_sequential_len,
+	ioparm_direct, ioparm_direct_len, ioparm_formatted,
+	ioparm_formatted_len, ioparm_unformatted, ioparm_unformatted_len,
+	ioparm_read, ioparm_read_len, ioparm_write, ioparm_write_len,
+	ioparm_readwrite, ioparm_readwrite_len, ioparm_namelist_name,
+	ioparm_namelist_name_len, ioparm_namelist_read_mode, ioparm_iomsg,
+	ioparm_iomsg_len, ioparm_var): Remove.
+	(enum ioparam_type, enum iofield_type, enum iofield,
+	enum iocall): New enums.
+	(gfc_st_parameter_field, gfc_st_parameter): New typedefs.
+	(st_parameter, st_parameter_field, iocall): New variables.
+	(ADD_FIELD, ADD_STRING): Remove.
+	(dt_parm, dt_post_end_block): New variables.
+	(gfc_build_st_parameter): New function.
+	(gfc_build_io_library_fndecls): Use it.  Initialize iocall
+	array rather than ioparm_*, add extra first arguments to
+	the function types.
+	(set_parameter_const): New function.
+	(set_parameter_value): Add type argument, return a bitmask.
+	Changed to set a field in automatic structure variable rather
+	than set a field in a global _gfortran_ioparm variable.
+	(set_parameter_ref): Likewise.  If requested var has different
+	size than what field should point to, call with a temporary and
+	then copy into the user variable.  Add postblock argument.
+	(set_string): Remove var_len argument, add type argument, return
+	a bitmask.  Changed to set fields in automatic structure variable
+	rather than set a field in a global _gfortran_ioparm variable.
+	(set_internal_unit): Remove iunit, iunit_len, iunit_desc arguments,
+	add var argument.  Return a bitmask.  Changed to set fields in
+	automatic structure variable rather than set a field in a global
+	_gfortran_ioparm variable.
+	(set_flag): Removed.
+	(io_result): Add var argument.  Changed to read common.flags field
+	from automatic structure variable and bitwise AND it with 3.
+	(set_error_locus): Add var argument.  Changed to set fields in
+	automatic structure variable rather than set a field in a global
+	_gfortran_{filename,line} variables.
+	(gfc_trans_open): Use gfc_start_block rather than gfc_init_block.
+	Create a temporary st_parameter_* structure.  Adjust callers of
+	all above mentioned functions.  Pass address of the temporary
+	variable as first argument to the generated function call.
+	Use iocall array rather than ioparm_* separate variables.
+	(gfc_trans_close, build_filepos, gfc_trans_inquire): Likewise.
+	(build_dt): Likewise.  Change first argument to tree from tree *.
+	Don't dereference code->ext.dt if last_dt == INQUIRE.  Emit
+	IOLENGTH argument setup here.  Set dt_parm/dt_post_end_block
+	variables and gfc_trans_code the nested data transfer commands
+	in code->block.
+	(gfc_trans_iolength): Just set last_dt and call build_dt immediately.
+	(transfer_namelist_element): Pass address of dt_parm variable
+	to generated functions.  Use iocall array rather than ioparm_*
+	separate variables.
+	(gfc_trans_backspace, gfc_trans_endfile, gfc_trans_rewind,
+	gfc_trans_flush, gfc_trans_read, gfc_trans_write): Use iocall array
+	rather than ioparm_* separate variables.
+	(gfc_trans_dt_end): Likewise.  Pass address of dt_parm variable
+	as first argument to generated function.  Adjust io_result caller.
+	Prepend dt_post_end_block before io_result code.
+	(transfer_expr): Use iocall array rather than ioparm_* separate
+	variables.  Pass address of dt_parm variables as first argument
+	to generated functions.
+	* ioparm.def: New file.
+
+2005-11-21  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/24223
+	* resolve.c (resolve_contained_fntype) Error if an internal
+	function is assumed character length.
+
+	PR fortran/24705
+	* trans-decl.c (gfc_create_module_variable) Skip ICE in
+	when backend decl has been built and the symbol is marked
+	as being in an equivalence statement.
+
+2005-11-20  Toon Moene  <toon@moene.indiv.nluug.nl>
+
+	* invoke.texi: Remove superfluous @item.
+
+2005-11-19  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	PR fortran/24862
+	* trans-io.c (gfc_trans_transfer): Handle arrays of derived type.
+
+2005-11-17  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/20811
+	* scanner.c (gfc_open_included_file): Add an extra include_cwd
+	argument. Only include files in the current working directory if
+	its value is true.
+	* gfortran.h: Change prototype for gfc_open_included_file.
+	(load_file): Don't search for include files in the current working
+	directory.
+	* options.c (gfc_post_options): Add the directory of the source file
+	to the list of paths for included files.
+	* module.c (gfc_use_module): Look for module files in the current
+	directory.
+
+2005-11-16  Alan Modra  <amodra@bigpond.net.au>
+
+	PR fortran/24096
+	* trans-types.c (gfc_init_kinds): Use one less for max_exponent
+	of IBM extended double format.
+
+2005-11-13  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* intrinsic.c (add_functions): Add COMPLEX, FTELL, FGETC, FGET,
+	FPUTC, FPUT, AND, XOR and OR intrinsic functions.
+	(add_subroutines): Add FGETC, FGET, FPUTC, FPUT and FTELL intrinsic
+	subroutines.
+	* gfortran.h: Add GFC_ISYM_AND, GFC_ISYM_COMPLEX, GFC_ISYM_FGET,
+	GFC_ISYM_FGETC, GFC_ISYM_FPUT, GFC_ISYM_FPUTC, GFC_ISYM_FTELL,
+	GFC_ISYM_OR, GFC_ISYM_XOR.
+	* iresolve.c (gfc_resolve_and, gfc_resolve_complex,
+	gfc_resolve_or, gfc_resolve_fgetc, gfc_resolve_fget,
+	gfc_resolve_fputc, gfc_resolve_fput, gfc_resolve_ftell,
+	gfc_resolve_xor, gfc_resolve_fgetc_sub, gfc_resolve_fget_sub,
+	gfc_resolve_fputc_sub, gfc_resolve_fput_sub, gfc_resolve_ftell_sub):
+	New functions.
+	* check.c (gfc_check_complex, gfc_check_fgetputc_sub,
+	gfc_check_fgetputc, gfc_check_fgetput_sub, gfc_check_fgetput,
+	gfc_check_ftell, gfc_check_ftell_sub, gfc_check_and): New functions.
+	* simplify.c (gfc_simplify_and, gfc_simplify_complex, gfc_simplify_or,
+	gfc_simplify_xor): New functions.
+	* trans-intrinsic.c (gfc_conv_intrinsic_function): Add cases for
+	GFC_ISYM_AND, GFC_ISYM_COMPLEX, GFC_ISYM_FGET, GFC_ISYM_FGETC,
+	GFC_ISYM_FPUT, GFC_ISYM_FPUTC, GFC_ISYM_FTELL, GFC_ISYM_OR and
+	GFC_ISYM_XOR.
+	* intrinsic.h: Add prototypes for all functions added to iresolve.c,
+	simplify.c and check.c.
+
+2005-11-10  Paul Thomas  <pault@gcc.gnu.org>
+	    Steven G. Kargl <kargls@comcast.net>
+
+	PR fortran/15976
+	* resolve.c (resolve_symbol): Disallow automatic arrays in module scope.
+
+2005-11-10  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/24655
+	PR fortran/24755
+	* match.c (recursive_stmt_fcn): Add checks that symtree exists
+	for the expression to weed out inline intrinsic functions and
+	parameters.
+
+	PR fortran/24409
+	* module.c (mio_symtree_ref): Correct the patch of 0923 so that
+	a symbol is not substituted for by a the symbol for the module
+	itself and to prevent the promotion of a formal argument.
+
+2005-11-10  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/24643
+	* primary.c (match_varspec): Check for implicitly typed CHARACTER
+	variables before matching substrings.
+
+2005-11-09  Steven G. Kargl  <kargls@comcast.net>
+
+	* trans-intrinsic.c: Typo in comment.
+
+2005-11-09  Erik Edelmann  <eedelman@gcc.gnu.org>
+
+	PR fortran/22607
+	* trans-decl.c(build_function_decl): Don't set
+	DECL_IS_PURE (fndecl) = 1 for return-by-reference
+	functions.
+
+2005-11-08  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* dump-parse-tree.c: Fix comment typo, add a few blank lines.
+
+2005-11-07  Steven G. Kargl  <kargls@comcast.net>
+
+	* error.c: Use flag_fatal_error.
+	* invoke.texi:  Remove -Werror from list of options.
+
+2005-11-06  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/24534
+	* resolve.c (resolve_symbol): Exclude case of PRIVATE declared
+	within derived type from error associated with PRIVATE type
+	components within derived type.
+
+	PR fortran/20838
+	PR fortran/20840
+	* gfortran.h: Add prototype for gfc_has_vector_index.
+	* io.c (gfc_resolve_dt): Error if internal unit has a vector index.
+	* expr.c (gfc_has_vector_index): New function to check if any of
+	the array references of an expression have vector inidices.
+	(gfc_check_pointer_assign): Error if internal unit has a vector index.
+
+	PR fortran/17737
+	* data.c (gfc_assign_data_value): Remove gcc_assert that caused the ICE
+	and replace by a standard dependent warning/error if overwriting an
+	existing initialization.
+	* decl.c (gfc_data_variable): Remove old error for already initialized
+	variable and the unused error check for common block variables.  Add
+	error for hots associated variable and standard dependent error for
+	common block variables, outside of blockdata.
+	* symbol.c (check_conflict): Add constraints for DATA statement.
+
+2005-11-06  Janne Blomqvist <jb@gcc.gnu.org>
+
+	PR fortran/24174
+	PR fortran/24305
+	* fortran/trans-io.c (gfc_build_io_library_fndecls): Add kind
+	argument to transfer_array.
+	(transfer_array_desc): Add kind argument.
+
+2005-11-06  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* intrinsic.c (add_functions): Add ctime and fdate intrinsics.
+	(add_subroutines): Likewise.
+	* intrinsic.h: Prototypes for gfc_check_ctime,
+	gfc_check_ctime_sub, gfc_check_fdate_sub, gfc_resolve_ctime,
+	gfc_resolve_fdate, gfc_resolve_ctime_sub, gfc_resolve_fdate_sub.
+	* gfortran.h: Add GFC_ISYM_CTIME and GFC_ISYM_FDATE.
+	* iresolve.c (gfc_resolve_ctime, gfc_resolve_fdate,
+	gfc_resolve_ctime_sub, gfc_resolve_fdate_sub): New functions.
+	* trans-decl.c (gfc_build_intrinsic_function_decls): Add
+	gfor_fndecl_fdate and gfor_fndecl_ctime.
+	* check.c (gfc_check_ctime, gfc_check_ctime_sub,
+	gfc_check_fdate_sub): New functions.
+	* trans-intrinsic.c (gfc_conv_intrinsic_ctime,
+	gfc_conv_intrinsic_fdate): New functions.
+	(gfc_conv_intrinsic_function): Add cases for GFC_ISYM_CTIME
+	and GFC_ISYM_FDATE.
+	* intrinsic.texi: Documentation for the new CTIME and FDATE
+	intrinsics.
+	* trans.h: Declarations for gfor_fndecl_ctime and gfor_fndecl_fdate.
+
+2005-11-05  Kazu Hirata  <kazu@codesourcery.com>
+
+	* decl.c, trans-decl.c: Fix comment typos.
+	* gfortran.texi: Fix a typo.
+
+2005-11-05  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* intrinsic.c (add_functions): Add function version of TTYNAM.
+	* intrinsic.h: Add prototypes for gfc_check_ttynam and
+	gfc_resolve_ttynam.
+	* gfortran.h: Add case for GFC_ISYM_TTYNAM.
+	* iresolve.c (gfc_resolve_ttynam): New function.
+	* trans-decl.c (gfc_build_intrinsic_function_decls): Add a tree
+	for function call to library ttynam.
+	* check.c (gfc_check_ttynam): New function.
+	* trans-intrinsic.c (gfc_conv_intrinsic_ttynam): New function.
+	(): Call gfc_conv_intrinsic_ttynam.
+	* trans.h: Add prototype for gfor_fndecl_ttynam.
+
+2005-11-04  Steven G. Kargl <kargls@comcast.net>
+
+	PR fortran/24636
+	* match.c (gfc_match_stopcode):  Set stop_code = -1.
+
+2005-11-04  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/18452
+	* lang-specs.h: Pass -lang-fortran to the preprocessor.
+
+2005-11-02  Andrew Pinski  <pinskia@physics.uc.edu>
+
+	PR fortran/18157
+	* trans-array.c (gfc_conv_resolve_dependencies): Use the correct
+	type for the temporary array.
+	* trans-expr.c (gfc_trans_assignment): Pass lss
+	instead of lss_section
+	to gfc_conv_resolve_dependencies to get the
+	correct type.
+
+2005-11-02  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* decl.c (gfc_match_entry): Function entries don't need an argument
+	list if there's no RESULT clause.
+
+2005-11-01  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/24008
+	* decl.c (gfc_match_entry): Function entries need an argument list.
+
+2005-11-01  Erik Edelmann  <eedelman@gcc.gnu.org>
+
+	PR 24245
+	* trans.c (gfc_generate_code): Move code to create a main
+	program symbol from here ...
+	* parse.c (main_program_symbol): ... to this new
+	function, setting the locus from gfc_current_locus
+	instead of ns->code->loc.
+	(gfc_parse_file):  Call main_program_symbol for main programs.
+
+2005-11-01  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/24404
+	* resolve.c (resolve_symbol): Output symbol names in more error
+	messages, clarify error message.
+
+2005-11-01  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* dump-parse-tree.c (show_symtree): Revert change unintentionally
+	committed in r106246.
+
+2005-11-01  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/21565
+	* symbol.c (check_conflict): An object cannot be in a namelist and in
+	block data.
+
+	PR fortran/18737
+	* resolve.c (resolve_symbol): Set the error flag to
+	gfc_set_default_type, in the case of an external symbol, so that
+	an error message is emitted if IMPLICIT NONE is set.
+
+	PR fortran/14994
+	* gfortran.h (gfc_generic_isym_id): Add GFC_ISYM_SECNDS to enum.
+	* check.c (gfc_check_secnds): New function.
+	* intrinsic.c (add_functions): Add call to secnds.
+	* iresolve.c (gfc_resolve_secnds): New function.
+	* trans-intrinsic (gfc_conv_intrinsic_function): Add call to
+	secnds via case GFC_ISYM_SECNDS.
+	* intrinsic.texi: Add documentation for secnds.
+
+2005-10-31  Andreas Schwab  <schwab@suse.de>
+
+	* Make-lang.in (GFORTRAN_TARGET_INSTALL_NAME): Define.
+	(GFORTRAN_CROSS_NAME): Remove.
+	(fortran.install-common): Correctly install a cross compiler.
+	(fortran.uninstall): Use GFORTRAN_TARGET_INSTALL_NAME instead of
+	GFORTRAN_CROSS_NAME.
+
+2005-10-30  Erik Edelmann  <eedelman@gcc.gnu.org>
+
+	* gfortran.texi: Update contributors.
+
+2005-10-30  Erik Edelmann  <eedelman@gcc.gnu.org>
+
+	PR fortran/18883
+	* trans-decl.c (gfc_finish_var_decl): Add decl to the
+	current function, rather than the parent.  Make
+	assertion accept fake result variables.
+	* trans-expr.c (gfc_conv_variable): If the character
+	length of an ENTRY isn't set, get the length from
+	the master function instead.
+
+2005-10-30  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	* gfortran.texi:  Remove reservations about I/O usability.  Document
+	that array intrinsics mostly work.
+
+2005-10-30  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* gfortran.texi: Move license stuff to back.  Add information
+	on ENUM and ENUMERATOR.
+	* invoke.texi: Document -fshort-enums.
+
+2005-10-30  Gaurav Gautam  <gauravga@noida.hcltech.com>
+	    Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* arith.c (gfc_enum_initializer): New function.
+	(gfc_check_integer_range): Made extern.
+	* decl.c (enumerator_history): New typedef.
+	(last_initializer, enum_history, max_enum): New variables.
+	(create_enum_history, gfc_free_enum_history): New functions.
+	(add_init_expr_to_sym): Call create_enum_history if parsing ENUM.
+	(variable_decl): Modified to parse enumerator definition.
+	(match_attr_spec): Add PARAMETER attribute to ENUMERATORs.
+	(gfc_match_data_decl): Issues error, if match_type_spec do not
+	return desired return values.
+	(set_enum_kind, gfc_match_enum, gfc_match_enumerator_def): New
+	functions.
+	(gfc_match_end): Deal with END ENUM.
+	* gfortran.h (gfc_statement): ST_ENUM, ST_ENUMERATOR, ST_END_ENUM
+	added.
+	(symbol_attribute): Bit field for enumerator added.
+	(gfc_options): Add fshort_enums.
+	(gfc_enum_initializer, gfc_check_integer_range): Add prototypes.
+	* options.c: Include target.h
+	(gfc_init_options): Initialize fshort_enums.
+	(gfc_handle_option): Deal with fshort_enums.
+	* parse.c (decode_statement): Match ENUM and ENUMERATOR statement.
+	(gfc_ascii_statement): Deal with the enumerator statements.
+	(parse_enum): New function to parse enum construct.
+	(parse_spec): Added case ST_ENUM.
+	* parse.h (gfc_compile_state): COMP_ENUM added.
+	(gfc_match_enum, gfc_match_enumerator_def, gfc_free_enum_history):
+	Prototype added.
+	* symbol.c (gfc_copy_attr): Copy enumeration attribute.
+	* lang.opt (fshort-enums): Option added.
+
+2005-10-30  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* check.c (gfc_check_malloc, gfc_check_free): New functions.
+	* gfortran.h (gfc_generic_isym_id): Add GFC_ISYM_MALLOC.
+	* intrinsic.c (add_functions): Add symbols for MALLOC function.
+	(add_subroutines): Add symbol for FREE subroutine.
+	* intrinsic.h: Prototypes for gfc_check_malloc, gfc_check_free,
+	gfc_resolve_malloc and gfc_resolve_free.
+	* intrinsic.texi: Add doc for FREE and MALLOC intrinsics.
+	* iresolve.c (gfc_resolve_malloc, gfc_resolve_free): New
+	functions.
+	* trans-intrinsic.c (gfc_conv_intrinsic_function): Add case for
+	GFC_ISYM_MALLOC.
+
+2005-10-30  Steven Bosscher  <stevenb@suse.de>
+
+	* gfortran.texi: Update contributors.
+
+2005-10-29  Steven Bosscher  <stevenb@suse.de>
+
+	* interface.c: Fix previous checkin (an incomplete patch
+	was commited for me).
+
+2005-10-29  Joseph S. Myers  <joseph@codesourcery.com>
+
+	* intrinsic.texi: Remove empty @cindex line.
+
+2005-10-28  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* check.c (gfc_check_alarm_sub, gfc_check_signal,
+	gfc_check_signal_sub): New functions.
+	* gfortran.h (gfc_generic_isym_id): Add GFC_ISYM_SIGNAL.
+	* intrinsic.c (add_functions): Add signal intrinsic.
+	(add_subroutines): Add signal and alarm intrinsics.
+	* intrinsic.texi: Document the new intrinsics.
+	* iresolve.c (gfc_resolve_signal, gfc_resolve_alarm_sub,
+	gfc_resolve_signal_sub): New functions.
+	* trans-intrinsic.c (gfc_conv_intrinsic_function): Add case
+	for GFC_ISYM_SIGNAL.
+	* intrinsic.h: Add prototypes for gfc_check_alarm_sub,
+	gfc_check_signal, gfc_check_signal_sub, gfc_resolve_signal,
+	gfc_resolve_alarm_sub, gfc_resolve_signal_sub.
+
+2005-10-28  Steven Bosscher  <stevenb@suse.de>
+
+	PR fortran/24545
+	* interface.c (gfc_match_end_interface): Fix typo in 
+	INTERFACE_USER_OP case.
+
+2005-10-26  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/15586
+	* resolve.c (resolve_symbol): Remove the use of whynot, so that
+	error messages are not built from pieces.
+
+2005-10-26  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/24158
+	* decl.c (gfc_match_data_decl): Correct broken bit of code
+	that prevents undefined derived types from being used as
+	components of another derived type.
+	* resolve.c (resolve_symbol): Add backstop error when derived
+	type variables arrive here with a type that has no components.
+
+2005-10-25  Jakub Jelinek  <jakub@redhat.com>
+
+	* trans.h (gfc_conv_cray_pointee): Remove.
+	* trans-expr.c (gfc_conv_variable): Revert 2005-10-24 change.
+	* trans-array.c (gfc_conv_array_parameter): Likewise.
+	* trans-decl.c (gfc_conv_cray_pointee): Remove.
+	(gfc_finish_cray_pointee): New function.
+	(gfc_finish_var_decl): Use it.  Don't return early for Cray
+	pointees.
+	(gfc_create_module_variable): Revert 2005-10-24 change.
+	* decl.c (cray_pointer_decl): Update comment.
+	* gfortran.texi: Don't mention Cray pointees aren't visible in the
+	debugger.
+
+	* symbol.c (check_conflict): Add conflict between cray_pointee
+	and in_common resp. in_equivalence.
+	* resolve.c (resolve_equivalence): Revert 2005-10-24 change.
+
+	* module.c (ab_attribute): Add AB_CRAY_POINTER and AB_CRAY_POINTEE.
+	(attr_bits): Likewise.
+	(mio_symbol_attribute): Save and restore cray_pointe{r,e} attributes.
+	(mio_symbol): For cray_pointee write/read cp_pointer reference.
+
+2005-10-25  Feng Wang  <fengwang@nudt.edu.cn>
+
+	PR fortran/22290
+	* trans-decl.c (gfc_add_assign_aux_vars): New function. Add two
+	auxiliary variables.
+	(gfc_get_symbol_decl): Use it when a variable, including dummy
+	argument, is assigned a label.
+	(gfc_trans_assign_aux_var): New function. Set initial value of
+	the auxiliary variable explicitly.
+	(gfc_trans_deferred_vars): Use it.
+	* trans-stmt.c (gfc_conv_label_variable): Handle dummy argument.
+
+2005-10-24  Asher Langton  <langton2@llnl.gov>
+
+	PR fortran/17031
+	PR fortran/22282
+	* check.c (gfc_check_loc): New function.
+	* decl.c (variable_decl): New variables cp_as and sym.  Added a
+	check for variables that have already been declared as Cray
+	Pointers, so we can get the necessary attributes without adding
+	a new symbol.
+	(attr_decl1): Added code to catch pointee symbols and "fix"
+	their array specs.
+	(cray_pointer_decl): New method.
+	(gfc_match_pointer): Added Cray pointer parsing code.
+	(gfc_mod_pointee_as): New method.
+	* expr.c (gfc_check_assign): Added a check to catch vector-type
+	assignments to pointees with an unspecified final dimension.
+	* gfortran.h: (GFC_ISYM_LOC): New.
+	(symbol_attribute): Added cray_pointer and cray_pointee bits.
+	(gfc_array_spec): Added cray_pointee and cp_was_assumed bools.
+	(gfc_symbol): Added gfc_symbol *cp_pointer.
+	(gfc_option): Added flag_cray_pointer.
+	(gfc_add_cray_pointee): Declare.
+	(gfc_add_cray_pointer ): Declare.
+	(gfc_mod_pointee_as): Declare.
+	* intrinsic.c (add_functions): Add code for loc() intrinsic.
+	* intrinsic.h (gfc_check_loc): Declare.
+	(gfc_resolve_loc): Declare.
+	* iresolve.c (gfc_resolve_loc): New.
+	* lang.opt: Added fcray-pointer flag.
+	* options.c (gfc_init_options): Initialized.
+	gfc_match_option.flag_cray_pointer.
+	(gfc_handle_option): Deal with -fcray-pointer.
+	* parse.c:(resolve_equivalence): Added code prohibiting Cray
+	pointees in equivalence statements.
+	* resolve.c (resolve_array_ref): Added code to prevent bounds
+	checking for Cray Pointee arrays.
+	(resolve_equivalence): Prohibited pointees in equivalence
+	statements.
+	* symbol.c (check_conflict): Added Cray pointer/pointee
+	attribute checking.
+	(gfc_add_cray_pointer): New.
+	(gfc_add_cray_pointee): New.
+	(gfc_copy_attr): New code for Cray pointers and pointees.
+	* trans-array.c (gfc_trans_auto_array_allocation): Added code to
+	prevent space from being allocated for pointees.
+	(gfc_conv_array_parameter): Added code to catch pointees and
+	correctly set their base address.
+	* trans-decl.c (gfc_finish_var_decl): Added code to prevent
+	pointee declarations from making it to the back end.
+	(gfc_create_module_variable): Same.
+	* trans-expr.c (gfc_conv_variable): Added code to detect and
+	translate pointees.
+	(gfc_conv_cray_pointee): New.
+	* trans-intrinsic.c (gfc_conv_intrinsic_loc): New.
+	(gfc_conv_intrinsic_function): Added entry point for loc
+	translation.
+	* trans.h (gfc_conv_cray_pointee): Declare.
+
+	* gfortran.texi: Added section on Cray pointers, removed Cray
+	pointers from list of proposed extensions.
+	* intrinsic.texi: Added documentation for loc intrinsic.
+	* invoke.texi: Documented -fcray-pointer flag.
+
+2005-10-24  Asher Langton  <langton2@llnl.gov>
+
+	* decl.c (gfc_match_save): Changed duplicate SAVE errors to
+	warnings in the absence of strict standard conformance
+	* symbol.c (gfc_add_save): Same.
+
+2005-10-24  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/15586
+	* arith.c (gfc_arith_error): Change message to include locus.
+	(check_result, eval_intrinsic, gfc_int2int, gfc_real2real,
+	gfc_real2complex, gfc_complex2real, gfc_complex2complex): Use
+	the new gfc_arith_error.
+	(arith_error): Rewrite full error messages instead of building
+	them from pieces.
+	* check.c (must_be): Removed.
+	(type_check, numeric_check, int_or_real_check, real_or_complex_check,
+	kind_check, double_check, logical_array_check, array_check,
+	scalar_check, same_type_check, rank_check, kind_value_check,
+	variable_check, gfc_check_allocated, gfc_check_associated,
+	gfc_check_cmplx, gfc_check_dcmplx, gfc_check_dot_product,
+	gfc_check_index, gfc_check_kind, gfc_check_matmul, gfc_check_null,
+	gfc_check_pack, gfc_check_precision, gfc_check_present,
+	gfc_check_spread): Rewrite full error messages instead of
+	building them from pieces.
+	* decl.c (gfc_match_entry): Rewrite full error messages instead
+	of building them from pieces.
+	* parse.c (gfc_state_name): Remove.
+	* parse.h: Remove prototype for gfc_state_name.
+
+2005-10-23  Andrew Pinski  <pinskia@physics.uc.edu>
+
+	PR fortran/23635
+	* check.c (gfc_check_ichar_iachar): Move the code around so
+	that the check on the length is after check for
+	references.
+
+2005-10-23  Asher Langton  <langton2@llnl.gov>
+
+	* decl.c (match_type_spec): Add a BYTE type as an extension.
+
+2005-10-23  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/18022
+	* trans-expr.c (gfc_trans_arrayfunc_assign): Return NULL
+	if there is a component ref during an array ref to force
+	use of temporary in assignment.
+
+	PR fortran/24311
+	PR fortran/24384
+	* fortran/iresolve.c (check_charlen_present): New function to
+	add a charlen to the typespec, in the case of constant
+	expressions.
+	(gfc_resolve_merge, gfc_resolve_spread): Call.the above.
+	(gfc_resolve_spread): Make calls to library functions that
+	handle the case of the spread intrinsic with a scalar source.
+
+2005-10-22  Erik Edelmann  <eedelman@gcc.gnu.org>
+
+	PR fortran/24426
+	* decl.c (variable_decl): Don't assign default initializers to
+	pointers.
+
+2005-10-21  Jakub Jelinek  <jakub@redhat.com>
+
+	* interface.c (compare_actual_formal): Issue error when attempting
+	to pass an assumed-size array as assumed-shape array argument.
+
+2005-10-20  Erik Edelmann  <erik.edelmann@iki.fi>
+
+	PR fortran/21625
+	* resolve.c (expr_to_initialize): New function.
+	(resolve_allocate_expr): Take current statement as new
+	argument. Add default initializers to variables of
+	derived types, if they need it.
+	(resolve_code): Provide current statement as argument to
+	resolve_allocate_expr().
+
+2005-10-19  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/24440
+	* resolve.c (resolve_symbol): Correct error in check for
+	assumed size array with default initializer by testing
+	for arrayspec before dereferencing it.
+
+2005-10-17  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/23446
+	* gfortran.h: Primitive for gfc_is_formal_arg.
+	* resolve.c(gfc_is_formal_arg): New function to signal across
+	several function calls that formal argument lists are being
+	processed.
+	(resolve_formal_arglist): Set/reset the flag for gfc_is_formal_arg.
+	*expr.c(check_restricted): Add check, via gfc_is_formal_arg, if
+	symbol is part of an formal argument declaration.
+
+	PR fortran/21459
+	* decl.c (add_init_expr_to_sym): Make a new character
+	length for each variable, when the expression is NULL
+	and link to cl_list.
+
+	PR fortran/20866
+	* match.c (recursive_stmt_fcn): New function that tests if
+	a statement function resurses through itself or other other
+	statement functions.
+	(gfc_match_st_function): Call recursive_stmt_fcn to check
+	if this is recursive and to raise error if so.
+
+	PR fortran/20849
+	PR fortran/20853
+	* resolve.c (resolve_symbol): Errors for assumed size arrays
+	with default initializer and for external objects with an
+	initializer.
+
+	PR fortran/20837
+	* decl.c (match_attr_spec): Prevent PUBLIC from being used
+	outside a module.
+
+2005-10-16  Erik Edelmann  <erik.edelmann@iki.fi>
+
+	PR 22273
+	* expr.c (check_inquiry): Add "len" to inquiry_function.
+
+2005-10-14  Jakub Jelinek  <jakub@redhat.com>
+
+	* primary.c (match_boz_constant): Add missing break after gfc_error.
+
+2005-10-12  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/24092
+	* trans-types.c (gfc_get_derived_type): Insert code to obtain backend
+	declaration for derived types, building if necessary.  Return the
+	derived type if the fields have been built by this process.  Otherwise,
+	continue as before but using the already obtained backend_decls for the
+	derived type components.  Change the gcc_assert to act on the field.
+
+2005-10-12  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/18082
+	* decl.c (variable_decl): Make a new copy of the character
+	length for each variable, when the expression is not a
+	constant.
+
+2005-10-12  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* gfortran.h: Add bitmasks for different FPE traps. Add fpe
+	member to options_t.
+	* invoke.texi: Document the new -ffpe-trap option.
+	* lang.opt: Add -ffpe-trap option.
+	* options.c (gfc_init_options): Initialize the FPE option.
+	(gfc_handle_fpe_trap_option): New function to parse the argument
+	of the -ffpe-trap option.
+	(gfc_handle_option): Add case for -ffpe-trap.
+	* trans-decl.c: Declare a tree for the set_fpe library function.
+	(gfc_build_builtin_function_decls): Build this tree.
+	(gfc_generate_function_code): Generate a call to set_fpe at
+	the beginning of the main program.
+	* trans.h: New tree for the set_fpe library function.
+
+2005-10-12  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/20847
+	PR fortran/20856
+	* symbol.c (check_conflict): Prevent common variables and
+	function results from having the SAVE attribute,as required
+	by the standard.
+
+2005-10-12  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/24207
+	* resolve.c (resolve_symbol): Exclude use and host associated
+	symbols from the test for private objects in a public namelist.
+
+2005-10-12  Jakub Jelinek  <jakub@redhat.com>
+
+	* trans-common.c (build_field): Fix comment typo.
+	(create_common): Set backend_decl of COMMON or EQUIVALENCEd
+	variables to a VAR_DECL with the COMPONENT_REF in
+	DECL_HAS_VALUE_EXPR rather than COMPONENT_REF directly.
+	* f95-lang.c (gfc_expand_function): Emit debug info for
+	EQUIVALENCEd variables if the equiv union is going to be output.
+
+2005-10-11  Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/20786
+	* iresolve.c (gfc_resolve_aint, gfc_resolve_anint): Type conversion
+	of the argument.
+
+2005-10-11  Jakub Jelinek  <jakub@redhat.com>
+
+	* f95-lang.c (gfc_init_decl_processing): Initialize
+	void_list_node.
+
+2005-10-07  Erik Edelmann  <erik.edelmann@iki.fi>
+
+	PR 18568
+	* resolve.c (find_array_spec): Search through the list of
+	components in the symbol of the type instead of the symbol of the
+	variable.
+
+2005-10-05  Richard Guenther  <rguenther@suse.de>
+
+	PR fortran/24176
+	* parse.c (gfc_parse_file): Exit early for empty files.
+
+2005-10-03  Steve Ellcey  <sje@cup.hp.com>
+
+	* fortran/trans-types.c (gfc_init_kinds): Only pass float, double,
+	and long double floating point types through to Fortran compiler.
+
+2005-10-03  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/20120
+	* f95-lang.c (DO_DEFINE_MATH_BUILTIN): Add support for long
+	double builtin function.
+	(gfc_init_builtin_functions): Add mfunc_longdouble,
+	mfunc_clongdouble and func_clongdouble_longdouble trees. Build
+	them for round, trunc, cabs, copysign and pow functions.
+	* iresolve.c (gfc_resolve_reshape, gfc_resolve_transpose): Add
+	case for kind 10 and 16.
+	* trans-decl.c: Add trees for cpowl10, cpowl16, ishftc16,
+	exponent10 and exponent16.
+	(gfc_build_intrinsic_function_decls): Build nodes for int16,
+	real10, real16, complex10 and complex16 types. Build all possible
+	combinations for function _gfortran_pow_?n_?n. Build function
+	calls cpowl10, cpowl16, ishftc16, exponent10 and exponent16.
+	* trans-expr.c (gfc_conv_power_op): Add case for integer(16),
+	real(10) and real(16).
+	* trans-intrinsic.c: Add suppport for long double builtin
+	functions in BUILT_IN_FUNCTION, LIBM_FUNCTION and LIBF_FUNCTION
+	macros.
+	(gfc_conv_intrinsic_aint): Add case for integer(16), real(10) and
+	real(16) kinds.
+	(gfc_build_intrinsic_lib_fndecls): Add support for real10_decl
+	and real16_decl in library functions.
+	(gfc_get_intrinsic_lib_fndecl): Add cases for real and complex
+	kinds 10 and 16.
+	(gfc_conv_intrinsic_exponent): Add cases for real(10) and real(16)
+	kinds.
+	(gfc_conv_intrinsic_sign): Likewise.
+	(gfc_conv_intrinsic_ishftc): Add case for integer(16) kind.
+	* trans-types.c (gfc_get_int_type, gfc_get_real_type,
+	gfc_get_complex_type, gfc_get_logical_type): Doesn't error out in
+	the case of kinds not available.
+	* trans.h: Declare trees for cpowl10, cpowl16, ishftc16,
+	exponent10 and exponent16.
+
+2005-10-01  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/16404
+	PR fortran/20835
+	PR fortran/20890
+	PR fortran/20899
+	PR fortran/20900
+	PR fortran/20901
+	PR fortran/20902
+	* gfortran.h: Prototype for gfc_add_in_equivalence.
+	* match.c (gfc_match_equivalence): Make a structure component
+	an explicit,rather than a syntax, error in an equivalence
+	group.  Call gfc_add_in_equivalence to add the constraints
+	imposed in check_conflict.
+	* resolve.c (resolve_symbol): Add constraints: No public
+	structures with private-type components and no public
+	procedures with private-type dummy arguments.
+	(resolve_equivalence_derived): Add constraint that prevents
+	a structure equivalence member from having a default
+	initializer.
+	(sequence_type): New static function to determine whether an
+	object is default numeric, default character, non-default
+	or mixed sequence. Add corresponding enum typespec.
+	(resolve_equivalence): Add constraints to equivalence groups
+	or their members: No more than one initialized member and
+	that different types are not equivalenced for std=f95.  All
+	the simple constraints have been moved to check_conflict.
+	* symbol.c (check_conflict): Simple equivalence constraints
+	added, including those removed from resolve_symbol.
+	(gfc_add_in_equivalence): New function to interface calls
+	match_equivalence to check_conflict.
+
+2005-09-27  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/18518
+	* trans-common.c (build_equiv_decl): Add IS_SAVED argument.
+	If it is true, set TREE_STATIC on the decl.
+	(create_common): If any symbol in equivalence has SAVE attribute,
+	pass true as last argument to build_equiv_decl.
+
+2005-09-24  Janne Blomqvist  <jblomqvi@cc.hut.fi>
+
+	* trans-io.c (gfc_build_io_library_fndecls): Add entry
+	iocall_x_array for transfer_array.
+	(transfer_array_desc): New function.
+	(gfc_trans_transfer): Add code to call transfer_array_desc.
+
+2005-09-26  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/23677
+	* symbol.c (gfc_is_var_automatic): Return true if character length
+	is non-constant rather than constant.
+	* resolve.c (gfc_resolve): Don't handle !gfc_option.flag_automatic
+	here.
+	* options.c (gfc_post_options): Set gfc_option.flag_max_stack_var_size
+	to 0 for -fno-automatic.
+
+2005-09-23  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/16861
+	* module.c (mio_component_ref): Return if the symbol is NULL
+	and wait for another iteration during module reads.
+	(mio_symtree_ref): Suppress the writing of contained symbols,
+	when a symbol is available in the main namespace.
+	(read_module): Restrict scope of special treatment of contained
+	symbols to variables only and suppress redundant call to
+	find_true_name.
+
+2005-09-22  Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/24005
+	* interface.c (check_interface1): Fix NULL dereference.
+
+2005-09-22  Erik Edelmann  <erik.edelmann@iki.fi>
+
+	PR fortran/23843
+	* resolve.c (derived_inaccessible): New function.
+	(resolve_transfer): Use it to check for private
+	components.
+
+2005-09-22  Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/23516
+	* intrinsic.c (add_function): Add IMAG, IMAGPART, and REALPART
+	intrinsics.
+	* intrinsic.h: Prototypes for gfc_simplify_realpart and
+	gfc_resolve_realpart.
+	* intrinsic.texi: Document intrinsic procedures.
+	* simplify.c (gfc_simplify_realpart): New function.
+	* irseolve.c (gfc_resolve_realpart): New function.
+
+2005-09-21  Erik Edelmann  <erik.edelmann@iki.fi>
+
+	PR fortran/19929
+	* trans-stmt.c (gfc_trans_deallocate): Check if the
+	object to be deallocated is an array by looking at
+	expr->rank instead of expr->symtree->n.sym->attr.dimension.
+
+2005-09-20  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/23420
+	* io.c (resolve_tag): Don't allow non-CHARACTER constants as formats.
+	(match_io): Fix usage of gfc_find_symbol.
+
+2005-09-20  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/23663
+	* primary.c (match_actual_arg): Handle ENTRY the same way
+	as FUNCTION.
+
+2005-09-18  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* Make-lang.in: Make check-fortran alias for check-gfortran.
+
+2005-09-18  Andreas Jaeger  <aj@suse.de>
+
+	* module.c (read_module): Add missed line from last patch.
+
+2005-09-18  Erik Edelmann  <erik.edelmann@iki.fi>
+
+	PR fortran/15975
+	* resolve.c (resolve_symbol): Don't assign default
+	initializer to pointers.
+
+2005-09-18  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/16861
+	* module.c (read_module): Give symbols from module procedures
+	different true_name entries to those from the module proper.
+
+2005-09-17  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/15586
+	* arith.c (gfc_arith_error): Add translation support for error
+	messages.
+	* array.c (gfc_match_array_ref): Likewise.
+	(gfc_match_array_spec): Likewise.
+	* check.c (must_be): Add msgid convention to third argument.
+	(same_type_check): Add translation support for error message.
+	(rank_check): Likewise.
+	(kind_value_check): Likewise.
+	(gfc_check_associated): Correct typo.
+	(gfc_check_reshape): Add translation support for error message.
+	(gfc_check_spread): Likewise.
+	* error.c (error_printf): Add nocmsgid convention to argument.
+	(gfc_warning, gfc_notify_std, gfc_warning_now, gfc_warning_check)
+	(gfc_error, gfc_error_now): Likewise.
+	(gfc_status): Add cmsgid convention to argument.
+	* expr.c (gfc_extract_int): Add translation support for error
+	messages.
+	(gfc_check_conformance): Add msgid convention to argument.
+	(gfc_check_pointer_assign): Correct tabbing.
+	* gfortran.h: Include intl.h header. Remove prototype for gfc_article.
+	* gfortranspec.c: Include intl.h header.
+	(lang_specific_driver): Add translation support for --version.
+	* io.c (check_format): Add translation support for error message.
+	(format_item_1): Likewise.
+	(data_desc): Likewise.
+	* matchexp.c: Likewise.
+	* misc.c (gfc_article): Remove function.
+	* module.c (bad_module): Use msgid convention. Add translation support
+	for error messages.
+	(require_atom): Add translation support for error messages.
+	* parse.c (gfc_ascii_statement): Likewise.
+	(gfc_state_name): Likewise.
+	* primary.c (match_boz_constant): Reorganise error messages for
+	translations.
+	* resolve.c (resolve_entries): Likewise.
+	(resolve_operator): Add translation support for error messages.
+	(gfc_resolve_expr): Use msgid convention. Reorganise error messages
+	for translations.
+	(resolve_symbol): Add translation support for error messages.
+	* symbol.c (gfc_add_procedure): Remove use of gfc_article function.
+	* trans-const.c (gfc_build_string_const): Use msgid convention.
+
+2005-09-16  Paul Brook  <paul@codesourcery.com>
+
+	PR fortran/23906
+	* dependency.c (transform_sections): Divide by correct value.
+	Elaborate comment.
+
+2005-09-14  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/21875 Internal Unit Array I/O, NIST
+	* fortran/trans-io.c (gfc_build_io_library_fndecls): Add field for
+	array descriptor to IOPARM structure.
+	* fortran/trans-io.c (set_internal_unit): New function to generate code
+	to store the character (array) and the character length for an internal
+	unit.
+	* fortran/trans-io (build_dt): Use the new function set_internal_unit.
+
+2005-09-14  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/19358
+	* trans-array.c (gfc_trans_dummy_array_bias): correct the typo
+	which uses dim[i].upper for lbound, rather than dim[i].lower.
+
+2005-09-13  Erik Edelmann  <erik.edelmann@iki.fi>
+
+	PR fortran/17740
+	* trans-expr.c (gfc_trans_arrayfunc_assign): Check value
+	of attr.elemental for specific function instead of generic name.
+
+2005-09-13  Richard Sandiford  <richard@codesourcery.com>
+
+	PR fortran/18899
+	* trans-intrinsic.c (gfc_conv_intrinsic_bound): Move initialization
+	of argse.  Remove now-redundant want_pointer assignment.
+	* trans-array.c (gfc_conv_expr_descriptor): When not assigning to
+	a pointer, keep the original bounds of a full array reference.
+
+2005-09-13  Richard Sandiford  <richard@codesourcery.com>
+
+	PR target/19269
+	* iresolve.c (gfc_resolve_cshift, gfc_resolve_eoshift)
+	(gfc_resolve_pack, gfc_resolve_reshape, gfc_resolve_spread)
+	(gfc_resolve_transpose, gfc_resolve_unpack): Add "_char" to the name
+	for character-based operations.
+	(gfc_resolve_pack): Remove ATTRIBUTE_UNUSED from array argument.
+	(gfc_resolve_unpack): Copy the whole typespec from the vector.
+	* trans-array.c (gfc_conv_expr_descriptor): In the EXPR_FUNCTION
+	case, get the string length from the scalarization state.
+
+2005-09-14  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* Make-lang.in: Change targets prefixes from f95 to fortran.
+	* config-lang.in: Change language name to "fortran".
+	* lang.opt: Change language name to "fortran".
+	* options.c: Change CL_F95 to CL_Fortran.
+
+2005-09-09  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	gfortran.texi:  Document IOSTAT= specifier.
+
+2005-09-09  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	* gfortran.h:  Add iomsg to gfc_open, gfc_close, gfc_filepos,
+	gfc_inquire and gfc_dt.
+	* dump-parse-tree.c (gfc_show_code_node):  Add iomsg
+	for open, close, file positioning, inquire and namelist.
+	* io.c (io_tag):  Add tag_iomsg.
+	(resolve_tag): Add standards warning for iomsg.
+	(match_open_element):  Add iomsg.
+	(gfc_free_open):  Add iomsg.
+	(gfc_resolve_open):  Add iomsg.
+	(gfc_free_close):  Add iomsg.
+	(match_close_element):  Add iomsg.
+	(gfc_resolve_close):  Add iomsg.
+	(gfc_free_filepos):  Add iomsg.
+	(match_file_element):  Add iomsg.
+	(gfc_resolve_filepos):  Add iostat and iomsg.
+	(match-dt_element):  Add iomsg.
+	(gfc_free_dt):  Add iomsg.
+	(gfc_resolve_dt):  Add iomsg.
+	(gfc_free_inquire):  Add iomsg.
+	(match_inquire_element):  Add iomsg.
+	(gfc_resolve_inquire):  Add iomsg.
+	* trans_io.c:  Add ioparm_iomsg and ioparm_iomsg_len.
+	(gfc_build_io_library_fndecls):  Add iomsg as last field.
+	(gfc_trans_open):  Add iomsg.
+	(gfc_trans_close):  Add iomsg.
+	(build_fileos):  Call set_string for iomsg.
+	(gfc_trans_inquire):  Add iomsg.
+	(build_dt):  Add iomsg.
+
+2005-09-09  Richard Sandiford  <richard@codesourcery.com>
+
+	* match.h (gfc_match_equiv_variable): Declare.
+
+2005-09-09  Richard Sandiford  <richard@codesourcery.com>
+
+	PR fortran/19239
+	* Makefile.in (fortran/trans-expr.o): Depend on dependency.h.
+	* dependency.h (gfc_ref_needs_temporary_p): Declare.
+	* dependency.c (gfc_ref_needs_temporary_p): New function.
+	(gfc_check_fncall_dependency): Use it instead of inlined check.
+	By so doing, take advantage of the fact that character substrings
+	within an array reference also need a temporary.
+	* trans.h (GFC_SS_VECTOR): Adjust comment.
+	* trans-array.c (gfc_free_ss): Remove GFC_SS_VECTOR case.
+	(gfc_set_vector_loop_bounds): New function.
+	(gfc_add_loop_ss_code): Call it after evaluating the subscripts of
+	a GFC_SS_SECTION.  Deal with the GFC_SS_VECTOR case by evaluating
+	the vector expression and caching its descriptor for use within
+	the loop.
+	(gfc_conv_array_index_ref, gfc_conv_vector_array_index): Delete.
+	(gfc_conv_array_index_offset): Handle scalar, vector and range
+	dimensions as separate cases of a switch statement.  In the vector
+	case, use the loop variable to calculate a vector index and use the
+	referenced element as the dimension's index.  Perform bounds checking
+	on this final index.
+	(gfc_conv_section_upper_bound): Return null for vector indexes.
+	(gfc_conv_section_startstride): Give vector indexes a start value
+	of 0 and a stride of 1.
+	(gfc_conv_ss_startstride): Adjust for new GFC_SS_VECTOR representation.
+	(gfc_conv_expr_descriptor): Expand comments.  Generalize the
+	handling of the !want_pointer && !direct_byref case.  Use
+	gfc_ref_needs_temporary_p to decide whether the variable case
+	needs a temporary.
+	(gfc_walk_variable_expr): Handle DIMEN_VECTOR by creating a
+	GFC_SS_VECTOR index.
+	* trans-expr.c: Include dependency.h.
+	(gfc_trans_arrayfunc_assign): Fail if the target needs a temporary.
+
+2005-09-09  Richard Sandiford  <richard@codesourcery.com>
+
+	PR fortran/21104
+	* trans.h (gfc_interface_sym_mapping, gfc_interface_mapping): Moved
+	from trans-expr.c.
+	(gfc_init_interface_mapping, gfc_free_interface_mapping)
+	(gfc_add_interface_mapping, gfc_finish_interface_mapping)
+	(gfc_apply_interface_mapping): Declare.
+	* trans-array.h (gfc_set_loop_bounds_from_array_spec): Declare.
+	(gfc_trans_allocate_temp_array): Add pre and post block arguments.
+	* trans-array.c (gfc_set_loop_bounds_from_array_spec): New function.
+	(gfc_trans_allocate_array_storage): Replace loop argument with
+	separate pre and post blocks.
+	(gfc_trans_allocate_temp_array): Add pre and post block arguments.
+	Update call to gfc_trans_allocate_array_storage.
+	(gfc_trans_array_constructor, gfc_conv_loop_setup): Adjust for new
+	interface to gfc_trans_allocate_temp_array.
+	* trans-expr.c (gfc_interface_sym_mapping, gfc_interface_mapping):
+	Moved to trans.h.
+	(gfc_init_interface_mapping, gfc_free_interface_mapping)
+	(gfc_add_interface_mapping, gfc_finish_interface_mapping)
+	(gfc_apply_interface_mapping): Make extern.
+	(gfc_conv_function_call): Build an interface mapping for array
+	return values too.  Call gfc_set_loop_bounds_from_array_spec.
+	Adjust call to gfc_trans_allocate_temp_array so that code is
+	added to SE rather than LOOP.
+
+2005-09-09  Richard Sandiford  <richard@codesourcery.com>
+
+	PR fortran/12840
+	* trans.h (gfor_fndecl_internal_realloc): Declare.
+	(gfor_fndecl_internal_realloc64): Declare.
+	* trans-decl.c (gfor_fndecl_internal_realloc): New variable.
+	(gfor_fndecl_internal_realloc64): New variable.
+	(gfc_build_builtin_function_decls): Initialize them.
+	* trans-array.h (gfc_trans_allocate_temp_array): Add a fourth argument.
+	* trans-array.c (gfc_trans_allocate_array_storage): Add an argument
+	to say whether the array can grow later.  Don't allocate the array
+	on the stack if so.  Don't call malloc for zero-sized arrays.
+	(gfc_trans_allocate_temp_array): Add a similar argument here.
+	Pass it along to gfc_trans_allocate_array_storage.
+	(gfc_get_iteration_count, gfc_grow_array): New functions.
+	(gfc_iterator_has_dynamic_bounds): New function.
+	(gfc_get_array_constructor_element_size): New function.
+	(gfc_get_array_constructor_size): New function.
+	(gfc_trans_array_ctor_element): Replace pointer argument with
+	a descriptor tree.
+	(gfc_trans_array_constructor_subarray): Likewise.  Take an extra
+	argument to say whether the variable-sized part of the constructor
+	must be allocated using realloc.  Grow the array when this
+	argument is true.
+	(gfc_trans_array_constructor_value): Likewise.
+	(gfc_get_array_cons_size): Delete.
+	(gfc_trans_array_constructor): If the loop bound has not been set,
+	split the allocation into a static part and a dynamic part.  Set
+	loop->to to the bounds for static part before allocating the
+	temporary.  Adjust call to gfc_trans_array_constructor_value.
+	(gfc_conv_loop_setup): Allow any constructor to determine the
+	loop bounds.  Check whether the constructor has a dynamic size
+	and prefer to use something else if so.  Expect the loop bound
+	to be set later.  Adjust call to gfc_trans_allocate_temp_array.
+	* trans-expr.c (gfc_conv_function_call): Adjust another call here.
+
+2005-09-09  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/18878
+	* module.c (find_use_name_n): Based on original
+	find_use_name. Either counts number of use names for a
+	given real name or returns use name n.
+	(find_use_name, number_use_names): Interfaces to the
+	function find_use_name_n.
+	(read_module): Add the logic and calls to these functions,
+	so that mutiple reuses of the same real name are loaded.
+
+2005-09-09  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/22304
+	PR fortran/23270
+	PR fortran/18870
+	PR fortran/16511
+	PR fortran/17917
+	* gfortran.h: Move definition of BLANK_COMMON_NAME from trans-
+	common.c so that it is accessible to module.c. Add common_head
+	field to gfc_symbol structure. Add field for the equivalence
+	name AND new attr field, in_equivalence.
+	* match.c (gfc_match_common, gfc_match_equivalence): In loops
+	that flag common block equivalences, emit an error if the
+	common blocks are different, using sym->common_head as the
+	common block identifier. Ensure that symbols that are equivalence
+	associated with a common block are marked as being in_common.
+	* module.c (write_blank_common): New.
+	(write_common): Use unmangled common block name.
+	(load_equiv): New function ported from g95.
+	(read_module): Call load_equiv.
+	(write_equiv): New function ported from g95. Correct
+	string referencing for gfc functions. Give module
+	equivalences a unique name.
+	(write_module): Call write_equiv and write_blank_common.
+	* primary.c (match_variable) Old gfc_match_variable, made
+	static and third argument provided to indicate if parent
+	namespace to be visited or not.
+	(gfc_match_variable) New. Interface to match_variable.
+	(gfc_match_equiv_variable) New. Interface to match_variable.
+	* trans-common.c (finish_equivalences): Provide the call
+	to create_common with a gfc_common_header so that
+	module equivalences are made external, rather than local.
+	(find_equivalences): Ensure that all members in common block
+	equivalences are marked as used. This prevents the subsequent
+	call to this function from making local unions.
+	* trans-decl.c (gfc_generate_function_code): Move the call to
+	gfc_generate_contained_functions to after the call to
+	gfc_trans_common so the use-associated, contained common
+	blocks produce the correct references.
+	(gfc_create_module_variable): Return for equivalenced symbols
+	with existing backend declaration.
+
+2005-09-08  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/23765
+	* match.c (gfc_match_common): Remove unnecessary / wrong special
+	cases for end-of-statement.
+
+2005-09-08  Janne Blomqvist  <jblomqvi@cc.hut.fi>
+
+	* gfortran.texi: Add section about implemented F2003 features.
+
+2005-09-08  Richard Sandiford  <richard@codesourcery.com>
+
+	PR fortran/15326
+	* trans-array.c (gfc_add_loop_ss_code): Set ss->string_length in
+	the GFC_SS_FUNCTION case too.
+	* trans-expr.c (gfc_conv_function_val): Allow symbols to be bound
+	to function pointers as well as function decls.
+	(gfc_interface_sym_mapping, gfc_interface_mapping): New structures.
+	(gfc_init_interface_mapping, gfc_free_interface_mapping)
+	(gfc_get_interface_mapping_charlen, gfc_get_interface_mapping_array)
+	(gfc_set_interface_mapping_bounds, gfc_add_interface_mapping)
+	(gfc_finish_interface_mapping, gfc_apply_interface_mapping_to_cons)
+	(gfc_apply_interface_mapping_to_ref)
+	(gfc_apply_interface_mapping_to_expr)
+	(gfc_apply_interface_mapping): New functions.
+	(gfc_conv_function_call): Evaluate the arguments before working
+	out where the result should go.  Make the null pointer case provide
+	the string length in parmse.string_length.  Cope with non-constant
+	string lengths, using the above functions to evaluate such lengths.
+	Use a temporary typespec; don't assign to sym->cl->backend_decl.
+	Don't assign to se->string_length when returning a cached array
+	descriptor.
+
+2005-09-08  Richard Sandiford  <richard@codesourcery.com>
+
+	PR fortran/19928
+	* trans-array.c (gfc_conv_array_ref): Call gfc_advance_se_ss_chain
+	after handling scalarized references.  Make "indexse" inherit from
+	"se" when handling AR_ELEMENTs.
+	(gfc_walk_variable_expr): Add GFC_SS_SCALAR entries for each
+	substring or scalar reference that follows an array section.
+	* trans-expr.c (gfc_conv_variable): When called from within a
+	scalarization loop, start out with "ref" pointing to the scalarized
+	part of the reference.  Don't call gfc_advance_se_ss_chain here.
+
+2005-09-07  Richard Sandiford  <richard@codesourcery.com>
+
+	PR fortran/23373
+	* trans-expr.c (gfc_trans_pointer_assignment): Assign to a temporary
+	descriptor if the rhs is not a null pointer or variable.
+
+2005-09-07  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR fortran/20848
+	* symbol.c(check_conflict):  Add conflict for parameter/save,
+
+2005-09-06  Richard Sandiford  <richard@codesourcery.com>
+
+	PR fortran/19269
+	* simplify.c (gfc_simplify_transpose): Set the result's typespec from
+	the source, not the first element of the return value.
+
+2005-09-04  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/23661
+	* io.c (match_io): Correctly backup if PRINT followed by
+	symbol which is not a namelist.  Force blank between PRINT
+	and namelist in free form.
+
+2005-08-31  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/20592
+	* gfortran.h (gfc_option_t): Add flag_automatic.
+	* invoke.texi: Document the -fno-automatic option.
+	* lang.opt: Add a -fautomatic option.
+	* options.c (gfc_init_options): Default for -fautomatic is on.
+	(gfc_handle_option): Add handling of -fautomatic option.
+	* resolve.c (gfc_resolve): When -fno-automatic is used, mark
+	needed variables as SAVE.
+
+2005-08-27  Erik Edelmann  <erik.edelmann@iki.fi>
+
+	* trans-array.c (gfc_trans_deferred_array): Fix comments.
+
+2005-08-27  Erik Schnetter  <schnetter@aei.mpg.de>
+
+	* primary.c (match_charkind_name): Fix typo in comment leading to
+	function.
+
+2005-08-25  Erik Edelmann  <eedelman@acclab.helsinki.fi>
+
+	PR fortran/20363
+	* symbol.c (find_special): Remove.
+	(build_sym, add_init_expr, attr_decl1): Remove calls to
+	find_special in favor of calls to gfc_get_symbol.
+
+2005-08-24  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR fortran/17758
+	* gfortran.h (symbol_attribute):  Add noreturn to the structure.
+	(gfc_intrinsic_sym):  Add noreturn to the structure.
+	* intrinsic.c (make_noreturn):  New function.
+	(add_subroutines):  Mark subroutines abort and exit as noreturn.
+	(gfc_intrinsic_sub_interface):  Copy noreturn attribute from
+	isym to the resolved symbol.
+	* trans-decl.c (gfc_get_extern_function_decl): Set function
+	as VOLATILE (== noreturn) if the noreturn attribute is set.
+
+2005-08-21  Steven G. Kargl  <kargls@comcast.net>
+
+	* decl.c: Typo in comment.
+
+2005-08-21  Steven G. Kargl  <kargls@comcast.net>
+
+	* array.c: Bump GFC_MAX_AC_EXPAND from 100 to 65535.
+
+2005-08-21  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* gfortran.h (gfc_option_t): Remove source field.  Add
+	flag_d_lines field.
+	(gfc_new_file): Remove arguments in prototype.
+	(gfc_source_file): Make 'const char *'.
+	* f95-lang.c (gfc_init): Use gfc_source_file instead of
+	gfc_option.source.  Call gfc_new_file without arguments.
+	* invoke.texi: Document new options '-fd-lines-as-code' and
+	'-fd-lines-as-comment'.
+	* lang.opt: Add new options.  Alphabetize.
+	* options.c (gfc_init_options): Initialize gfc_source_file instead
+	of gfc_option.source.  Initialize gfc_option.flag_d_lines.
+	(form_from_filename): Move here from scanner.c.  Make
+	'filename' argument 'const'.
+	(gfc_post_options): Set gfc_source_file.  Determine source form.
+	Warn if 'd-lines*' are used in free form.
+	* scanner.c (gfc_source_file): Constify.
+	(skip_fixed_comments): Deal with d-lines.
+	(get_file): Constify argument 'name'.
+	(load_file): Constify argument 'filename'.
+	(form_from_filename): Moved to options.c.
+	(gfc_new_file): Remove arguments.  Don't initialize
+	gfc_source_file, don't determine source form.
+	* trans-const.c (gfc_init_constants): Use gfc_source_file instead
+	of gfc_option.source.
+
+2005-08-19  Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/23065
+	* gfortran.h: Remove PATH_MAX definition.
+	* module.c (write_module, gfc_dump_module): Use alloca to allocate
+	buffers.
+	* scanner.c (gfc_release_include_path, form_from_filename): Ditto.
+
+2005-08-16  Huang Chun  <chunhuang73@hotmail.com>
+
+	* trans-expr.c (gfc_conv_power_op): Evaluate the expression before
+	expand.
+
+2005-08-14  Asher Langton  <langton2@llnl.gov>
+
+	* parse.c (match): Enclose macro in do...while(0) and braces.
+
+2005-08-14  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/21432.
+	* gfortran.texi: Document PRINT namelist.
+
+2005-08-14  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/21432.
+	* io.c (match_io): Add code to implement PRINT namelist.
+
+2005-08-14  Canqun Yang  <canqun@nudt.edu.cn>
+
+	* trans-stmt.c (gfc_trans_arithmetic_if): Optimized in case of equal
+	labels.
+
+2005-08-11  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+	    Steven Bosscher  <stevenb@suse.de>
+
+	PR libfortran/20006
+	* gfortran.h: Add is_main_program member to symbol_attribute.
+	* trans-decl: Add a gfor_fndecl_set_std tree.
+	(gfc_build_builtin_function_decls): Create it.
+	(gfc_generate_function_code): Add this call at the beginning of
+	the main program.
+	* trans.c (gfc_generate_code): Move main_program and attr.
+	* trans.h: Add declaration for gfor_fndecl_set_std.
+
+2005-08-10  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR libfortran/22143
+	gfortran.h:  Declare new function gfc_resolve_dim_arg.
+	resolve.c:  New function gfc_resolve_dim_arg.
+	iresolve.c (gfc_resolve_all):  Use gfc_resolve_dim_arg.
+	(gfc_resolve_any):  Likewise.
+	(gfc_resolve_count):  Likewise.
+	(gfc_resolve_cshift):  Likewise.  If the kind of shift is less
+	gfc_default_integer_kind, convert it to default integer type.
+	(gfc_resolve_eoshift):  Likewise.
+	(gfc_resolve_maxloc):  Use gfc_resolve_dim_arg.
+	(gfc_resolve_maxval):  Likewise.
+	(gfc_resolve_minloc):  Likewise.
+	(gfc_resolve_minval):  Likewise.
+	(gfc_resolve_product):  Likewise.
+	(gfc_resolve_spread):  Likewise.
+	(gfc_resolve_sum):  Likewise.
+
+2005-08-09  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* check.c (gfc_check_ttynam_sub, gfc_check_isatty): Add check
+	functions for new intrinsics TTYNAM and ISATTY.
+	* intrinsic.c (add_functions, add_subroutines): Add new
+	intrinsics.
+	* intrinsic.h: Add prototypes for new check and resolve
+	functions.
+	* iresolve.c (gfc_resolve_isatty, gfc_resolve_ttynam_sub): New
+	resolve functions for intrinsics TTYNAM and ISATTY.
+	* gfortran.h (gfc_generic_isym_id): Add symbol for ISATTY.
+	* trans-intrinsic.c: Add case for GFC_ISYM_ISATTY.
+
+2005-08-09  Jakub Jelinek  <jakub@redhat.com>
+
+	* scanner.c (preprocessor_line): Don't write beyond the end of flag
+	buffer.
+
+2005-08-07   Janne Blomqvist  <jblomqvi@cc.hut.fi>
+
+	PR fortran/22390
+	* dump-parse-tree.c (gfc_show_code_node): Add case for FLUSH.
+	* gfortran.h: Add enums for FLUSH.
+	* io.c (gfc_free_filepos,match_file_element,match_filepos): Modify
+	comment appropriately.  (gfc_match_flush): New function.
+	* match.c (gfc_match_if): Add match for flush.
+	* match.h: Add prototype.
+	* parse.c (decode_statement): Add flush to 'f' case.
+	(next_statement): Add case for flush. (gfc_ascii_statement): Likewise.
+	* resolve.c (resolve_code): Add flush case.
+	* st.c (gfc_free_statement): Add flush case.
+	* trans-io.c: Add prototype for flush.
+	(gfc_build_io_library_fndecls): Build fndecl for flush.
+	(gfc_trans_flush): New function.
+	* trans-stmt.h: Add prototype.
+	* trans.c (gfc_trans_code): Add case for flush.
+
+2005-08-06  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* primary.c (match_hollerith_constant): Fix typo.
+
+2005-08-06  Kazu Hirata  <kazu@codesourcery.com>
+
+	* decl.c, dump-parse-tree.c, gfortran.texi, intrinsic.texi,
+	invoke.texi, resolve.c, trans-array.c, trans-array.h,
+	trans-common.c, trans-expr.c, trans-io.c, trans.h: Fix
+	comment/doc typos.  Follow spelling conventions.
+
+2005-08-06  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/18833
+	PR fortran/20850
+	* primary.c (match_varspec): If equiv_flag, don't look at sym's
+	attributes, call gfc_match_array_ref up to twice and don't do any
+	substring or component processing.
+	* resolve.c (resolve_equivalence): Transform REF_ARRAY into
+	REF_SUBSTRING or nothing if needed.  Check that substrings
+	don't have zero length.
+
+2005-08-05  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	* trans-expr.c  (gfc_build_builtin_function_decls):  Mark
+	stop_numeric and stop_string as non-returning.
+
+2005-08-04  Paul Brook  <paul@codesourcery.com>
+
+	* trans-expr.c (gfc_conv_expr, gfc_conv_expr_type): Update comments.
+	(gfc_conv_expr_lhs): Fix assertion.
+	(gfc_conv_expr_val): Merge post block.  Set se.expr to new value.
+
+2005-08-02  David Edelsohn  <edelsohn@gnu.org>
+
+	PR fortran/22491
+	* expr.c (simplify_parameter_variable): Do not copy the subobject
+	references if the expression value is a constant.
+
+	* expr.c (gfc_simplify_expr): Evaluate constant substrings.
+
+2005-07-31  Jerry DeLisle  <jvdelisle@verizon.net>
+
+	* intrinsic.texi: Add documentation for exponent, floor, and fnum and
+	fix description of ceiling in index.
+
+2005-07-31  Steven Bosscher  <stevenb@suse.de>
+
+	* trans-decl.c (gfc_build_builtin_function_decls): Give the internal
+	malloc functions the 'malloc' attribute.  Give runtime_error the
+	'noreturn' attribute.
+
+2005-07-31  Steven Bosscher  <stevenb@suse.de>
+
+	* trans-stmt.c (gfc_trans_goto): Jump to the known label instead
+	of the assigned goto variable.
+
+2005-07-29  Steven Bosscher  <stevenb@suse.de>
+
+	* trans-types.h (gfc_array_range_type): Add missing GTY decl for this.
+
+2005-07-28  Andrew Pinski  <pinskia@physics.uc.edu>
+
+	* fortran/f95-lang.c (language_function): Remove
+	named_labels, shadowed_labels, returns_value, returns_abnormally,
+	warn_about_return_type, and extern_inline fields.
+	(named_labels): Remove variable.
+	(gfc_init_decl_processing): Remove setting of named_labels.
+
+2005-07-27  Volker Reichelt  <reichelt@igpm.rwth-aachen.de>
+
+	PR fortran/22503
+	* resolve.c (resolve_operator): Improve diagnostic for comparison
+	of logicals with invalid operator.
+
+2005-07-25  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/20063
+	* data.c (gfc_assign_data_value_range): Call
+	create_character_initializer if last_ts is a character type.
+
+2005-07-22  Manfred Hollstein  <mh@suse.com>
+
+	* match.c (gfc_match_symbol): Fix uninitialised warnings.
+	* matchexp.c (gfc_match_expr): Likewise.
+
+2005-07-20  Giovanni Bajo  <giovannibajo@libero.it>
+
+	Make CONSTRUCTOR use VEC to store initializers.
+	* trans-array.c (gfc_build_null_descriptor,
+	gfc_trans_array_constructor_value, gfc_conv_array_initializer):
+	Update to cope with VEC in CONSTRUCTOR_ELTS.
+	* trans-common.c (create_common): Likewise.
+	* trans-expr.c (gfc_conv_structure): Likewise.
+	* trans-stmt.c (gfc_trans_character_select): Use
+	build_constructor_from_list instead of build_constructor.
+
+2005-07-19  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/16940
+	* resolve.c (resolve_symbol): A symbol with FL_UNKNOWN
+	is matched against interfaces in parent namespaces. If there
+	the symtree is set to point to the interface.
+
+2005-07-16  David Edelsohn  <edelsohn@gnu.org>
+
+	PR fortran/21730
+	* decl.c (do_parm): Adjust character initializer to character length
+	of symbol before assigning.
+
+2005-07-14  Steve Ellcey  <sje@cup.hp.com>
+
+	* trans-types.c (MAX_REAL_KINDS): Increase from 4 to 5.
+
+2005-07-14  Jakub Jelinek  <jakub@redhat.com>
+
+	* gfortran.h (MAX_ERROR_MESSAGE): Remove.
+	(gfc_error_buf): Add allocated and index fields.  Change message
+	field from array to a pointer.
+	* error.c (use_warning_buffer, error_ptr, warning_ptr): Remove.
+	(cur_error_buffer): New variable.
+	(error_char): Use cur_error_buffer->{message,index} instead of
+	{warning,error}_{buffer.message,ptr}.  Reallocate message buffer
+	if too small.
+	(gfc_warning, gfc_notify_std, gfc_error, gfc_error_now): Setup
+	cur_error_buffer and its index rather than {warning,error}_ptr
+	and use_warning_buffer.
+	(gfc_warning_check, gfc_error_check): Don't print anything if
+	message is NULL.
+	(gfc_push_error): Allocate saved message with xstrdup.
+	(gfc_pop_error): Free saved message with gfc_free.
+	(gfc_free_error): New function.
+	* primary.c (match_complex_constant): Call gfc_free_error if
+	gfc_pop_error will not be called.
+	* match.c (gfc_match_st_function): Likewise.
+
+	PR fortran/22417
+	* scanner.c (preprocessor_line): Don't treat flag 3 as the start of a new
+	file.  Fix file left but not entered warning.
+
+2005-07-14  Feng Wang  <fengwang@nudt.edu.cn>
+	Steven G. Kargl  <kargls@comcast.net>
+
+	* array.c (resolve_character_array_constructor): Allocate gfc_charlen
+	for the array and attach to namespace list for automatic deallocation.
+
+2005-07-13  Andreas Schwab  <schwab@suse.de>
+
+	* Make-lang.in (fortran/dependency.o): Depend on
+	$(GFORTRAN_TRANS_DEPS).
+
+2005-07-11  Jakub Jelinek  <jakub@redhat.com>
+
+	* trans-stmt.c (gfc_trans_forall_loop): Clear maskindex before
+	the outermost loop.
+	(gfc_trans_assign_need_temp, gfc_trans_pointer_assign_need_temp,
+	gfc_trans_forall_1, gfc_evaluate_where_mask, gfc_trans_where_2):
+	Don't clear maskindexes here.
+
+2005-07-08  Daniel Berlin  <dberlin@dberlin.org>
+
+	* trans-decl.c (create_function_arglist): DECL_ARG_TYPE_AS_WRITTEN
+	is removed.
+
+2005-07-08  Jakub Jelinek  <jakub@redhat.com>
+
+	* primary.c (gfc_match_rvalue): Handle ENTRY the same way
+	as FUNCTION.
+
+2005-07-07  Jakub Jelinek  <jakub@redhat.com>
+
+	* scanner.c (load_line): Add pbuflen argument, don't make
+	buflen static.  If maxlen == 0 or preprocessor_flag,
+	don't truncate at buflen, but at maxlen.  In xrealloc add
+	1 byte at the end for the terminating '\0'.  Don't fill
+	with spaces up to buflen, but gfc_option.fixed_line_length.
+	(load_file): Adjust load_line caller.  Add line_len variable.
+
+	* scanner.c (preprocessor_line): Only set current_file->line when errors
+	have not been encountered.  Warn and don't crash if a file leave
+	preprocessor line has no corresponding entering line.  Formatting.
+
+2005-07-07  Steven Bosscher  <stevenb@suse.de>
+
+	* primary.c (match_hollerith_constant): Use int, not unsigned int,
+	for the hollerith length.  Fix indentation.
+
+2005-07-07  Feng Wang  <fengwang@nudt.edu.cn>
+
+	PR fortran/16531
+	PR fortran/15966
+	PR fortran/18781
+	* arith.c (gfc_hollerith2int, gfc_hollerith2real,
+	gfc_hollerith2complex, gfc_hollerith2character, gfc_hollerith2logical):
+	New functions.
+	(eval_intrinsic): Don't evaluate if Hollerith constant arguments exist.
+	* arith.h (gfc_hollerith2int, gfc_hollerith2real,
+	gfc_hollerith2complex, gfc_hollerith2character, gfc_hollerith2logical):
+	Add prototypes.
+	* expr.c (free_expr0): Free memery allocated for Hollerith constant.
+	(gfc_copy_expr): Allocate and copy string if Expr is from Hollerith.
+	(gfc_check_assign): Enable conversion from Hollerith to other.
+	* gfortran.h (bt): Add BT_HOLLERITH.
+	(gfc_expr): Add from_H flag.
+	* intrinsic.c (gfc_type_letter): Return 'h' for BT_HOLLERITH.
+	(add_conversions): Add conversions from Hollerith constant to other.
+	(do_simplify): Don't simplify if  Hollerith constant arguments exist.
+	* io.c (resolve_tag): Enable array in FORMAT tag under GFC_STD_GNU.
+	* misc.c (gfc_basetype_name): Return "HOLLERITH" for BT_HOLLERITH.
+	(gfc_type_name): Print "HOLLERITH" for BT_HOLLERITH.
+	* primary.c (match_hollerith_constant): New function.
+	(gfc_match_literal_constant): Add match Hollerith before Integer.
+	* simplify.c (gfc_convert_constant): Add conversion from Hollerith
+	to other.
+	* trans-const.c (gfc_conv_constant_to_tree): Use VIEW_CONVERT_EXPR to
+	convert Hollerith constant to tree.
+	* trans-io.c (gfc_convert_array_to_string): Get array's address and
+	length to set string expr.
+	(set_string): Deal with array assigned Hollerith constant and character
+	array.
+	* gfortran.texi: Document Hollerith constants as extention support.
+
+2005-07-07  Feng Wang  <fengwang@nudt.edu.cn>
+
+	PR fortran/22327
+	* trans-array.c (gfc_trans_array_constructor_value): Fix index of data.
+
+2005-07-07  Jakub Jelinek  <jakub@redhat.com>
+
+	* decl.c (gfc_match_entry): Allow ENTRY without parentheses
+	even in FUNCTIONs.
+
+2005-07-03  Kazu Hirata  <kazu@codesourcery.com>
+
+	* gfortran.texi, intrinsic.texi: Fix typos.
+	* symbol.c: Fix a comment typo.
+
+2005-07-03  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
+
+	* error.c (error_printf, error_print): Use ATTRIBUTE_GCC_GFC.
+	* gfortran.h (ATTRIBUTE_GCC_GFC): New.
+	(gfc_warning, gfc_warning_now, gfc_error, gfc_error_now,
+	gfc_fatal_error, gfc_internal_error, gfc_notify_std): Use
+	ATTRIBUTE_GCC_GFC.
+
+2005-07-03  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/20842
+	* io.c (match_dt_element): Do not allow END tag in PRINT or
+	WRITE statement.
+
+2005-07-02  Joseph S. Myers  <joseph@codesourcery.com>
+
+	* lang.opt: Remove "." from end of help texts.
+
+2005-07-01  Jerry DeLisle  <jvdelisle@verizon.net>
+
+	* gfortran.texi: Fix typos and grammar.
+	* invoke.texi: Fix typos and grammar.
+	* intrinsic.texi: Add documentaion for eoshift, epsilon, etime, and
+	exit. Fixed alignment of text for dtime syntax. Fixed a few line
+	lengths.
+
+2005-06-25  Jakub Jelinek  <jakub@redhat.com>
+
+	* trans-stmt.c (gfc_trans_forall_1): Prefer to use smaller logical
+	type than boolean_type_node.
+
+2005-06-25  Kelley Cook  <kcook@gcc.gnu.org>
+
+	* all files: Update FSF address in copyright headers.
+
+2005-06-24  Jerry DeLisle  <jvdelisle@verizon.net>
+
+	PR fortran/21915
+	* gfortran.h: Add symbols for new intrinsic functions.
+	* intrinsic.c: Add new functions acosh, asinh, and atanh.
+	* intrinsic.h: Add prototypes for the new functions.
+	* iresolve.c (gfc_resolve_acosh): New function.
+	(gfc_resolve_asinh): New function.
+	(gfc_resolve_atanh): New function.
+	* mathbuiltins.def: Add defines.
+	* simplify.c (gfc_simplify_acosh): New function.
+	(gfc_simplify_asinh): New function.
+	(gfc_simplify_atanh): New function.
+
+2005-06-24  Feng Wang  <fengwang@nudt.edu.cn>
+
+	* simplify.c (gfc_simplify_modulo): Don't clear before get result.
+
+2005-06-22  Paul Brook  <paul@codesourcery.com>
+
+	PR fortran/21034
+	* symbol.c (gfc_is_var_automatic): New function.
+	(save_symbol): Use it.
+
+2005-06-21  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+	    Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/22010
+	Port from g95.
+	* module.c (mio_namelist): New function. Correct to set
+	namelist_tail and to give error on renaming namelist by use
+	association.
+	(mio_symbol): Call mio_namelist.
+
+2005-06-19  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* gfortran.h: Add flag_backslash compile-time option.
+	* lang.opt: Add support for -fbackslash option.
+	* options.c: Likewise.
+	* primary.c: Implement behavior for -fno-backslash.
+	* invoke.texi: Add doc for -fbackslash option.
+	* gfortran.texi: Remove mention of -fno-backslash as a
+	possible extension.
+
+2005-06-20  Steven G. Kargl  <kargls@comcast.net>
+	(port from g95)
+
+	PR fortran/21257
+	* match.c (gfc_match_label): Detect duplicate labels.
+
+
+2005-06-20  Erik Edelmann  <erik.edelmann@iki.fi>
+
+	* intrinsic.c (check_intrinsic_standard): Fix spelling error
+	in a warning message.
+
+2005-06-18  Erik Edelman  <eedelman@acclab.helsinki.fi>
+	    Steven G. Kargl  <kargls@comast.net>
+
+	PR fortran/19926
+	* primary.c (gfc_match_rvalue):  expr_type can be EXPR_CONSTANT
+	for an array; check that sym->as is NULL.
+
+
+2005-06-18  Steven G. Kargl  <kargls@comcast.net>
+
+	* intrinsic.c (gfc_intrinsic_func_interface): Enable errors for generic
+	functions whose simplification routine return FAILURE.
+
+2005-06-13  Geoffrey Keating  <geoffk@apple.com>
+
+	* Make-lang.in (fortran.install-man): Doesn't depend on installdirs.
+	(rule for installing f95.1 manpage): Does depend on installdirs.
+
+2005-06-13  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/22038
+	* trans-stmt.c (gfc_trans_forall_loop): Only increment maskindex
+	in the innermost loop.
+
+	* trans-expr.c (gfc_conv_function_call): Return int instead of
+	void.  Use a local variable for has_alternate_specifier and
+	return it.  Avoid modification of function type's return value
+	in place, since it may be shared.
+	* trans.h (has_alternate_specifier): Remove.
+	(gfc_conv_function_call): Change return type.
+	* trans-stmt.c (has_alternate_specifier): Remove.
+	(gfc_trans_call): Add a local has_alternate_specifier variable,
+	set it from gfc_conv_function_call return value.
+
+2005-06-12  Richard Henderson  <rth@redhat.com>
+
+	* trans-array.c (gfc_conv_descriptor_data_get): Rename from
+	gfc_conv_descriptor_data.  Cast the result to the DATAPTR type.
+	(gfc_conv_descriptor_data_set, gfc_conv_descriptor_data_addr): New.
+	(gfc_trans_allocate_array_storage): Use them.
+	(gfc_array_allocate, gfc_array_deallocate): Likewise.
+	(gfc_trans_dummy_array_bias, gfc_conv_expr_descriptor): Likewise.
+	(gfc_trans_deferred_array): Likewise.
+	* trans-expr.c (gfc_conv_function_call): Likewise.
+	(gfc_trans_subcomponent_assign): Likewise.
+	(gfc_trans_pointer_assignment): Likewise.
+	* trans-intrinsic.c (gfc_conv_allocated): Likewise.
+	* trans-types.c (gfc_array_descriptor_base): New.
+	(gfc_get_element_type): Use GFC_TYPE_ARRAY_DATAPTR_TYPE.
+	(gfc_get_array_descriptor_base): Break out from ...
+	(gfc_get_array_type_bounds): ... here.  Create type variants.
+	* trans-array.h (gfc_conv_descriptor_data_get): Declare.
+	(gfc_conv_descriptor_data_set, gfc_conv_descriptor_data_addr): Declare.
+
+2005-06-12  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* trans-expr.c (gfc_conv_variable): POINTER results don't need f2c
+	calling conventions.  Look at sym instead of sym->result.
+	* trans-types.c (gfc_sym_type): Remove workaround for frontend bug.
+	Remove condition which is always false with workaround removed.
+	(gfc_return_by_reference): Always look at sym, never at sym->result.
+
+2005-06-11  Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/17792
+	PR fortran/21375
+	* trans-array.c (gfc_array_deallocate): pstat is new argument
+	(gfc_array_allocate): update gfc_array_deallocate() call.
+	(gfc_trans_deferred_array): ditto.
+	* trans-array.h: update gfc_array_deallocate() prototype.
+	* trans-decl.c (gfc_build_builtin_function_decls): update declaration
+	* trans-stmt.c (gfc_trans_deallocate): Implement STAT= feature.
+
+2005-06-07  Jerry DeLisle  <jvdelisle@verizon.net>
+
+	* intrinsic.texi: Add documentation for	dcmplx, digits,
+	dim, idim, ddim, dot_product, dprod, dreal, and dtime.
+
+2005-06-05  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/21912
+	* trans-array.c (gfc_trans_array_constructor_value): Slightly reorder.
+	Generate correct exit condition in case of negative steps in
+	implied-do loops.
+
+	* invoke.texi: Fix description of flags required for compatibility
+	with g77.
+
+2005-06-04  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+	Erik Schnetter  <schnetter@aei.mpg.de>
+
+	PR fortran/19195
+	* trans.c (gfc_get_backend_locus): Remove unnecessary adjustment,
+	remove FIXME comment.
+
+2005-06-04  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* match.c (match_forall_iterator): Don't immediately give error if '='
+	is not followed by an expression.
+
+2005-06-04  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+	Erik Edelmann  <erik.edelmann@iki.fi>
+
+	* array.c (gfc_match_array_constructor): Disallow empty array
+	constructor.
+
+2005-06-03  Jerry DeLisle  <jvdelisle@verizon.net>
+
+	* fortran/intrinsic.texi: Add documentation for
+	command_argument_count, conjg, dconjg, count,
+	cpu_time, cshift, date_and_time, dble, dfloat.
+
+2005-06-01  Roger Sayle  <roger@eyesopen.com>
+
+	* intrinsic.c (add_conv): No longer take a "simplify" argument as
+	its always gfc_convert_constant, instead take a "standard" argument.
+	(add_conversions): Change all existing calls of add_conv to pass
+	GFC_STD_F77 as appropriate.  Additionally, if we're allowing GNU
+	extensions support integer-logical and logical-integer conversions.
+	(gfc_convert_type_warn): Warn about use the use of these conversions
+	as a extension when appropriate, i.e. with -pedantic.
+	* simplify.c (gfc_convert_constant): Add support for integer to
+	logical and logical to integer conversions, using gfc_int2log and
+	gfc_log2int.
+	* arith.c (gfc_log2int, gfc_int2log): New functions.
+	* arith.h (gfc_log2int, gfc_int2log): Prototype here.
+	* gfortran.texi: Document this new GNU extension.
+
+2005-06-01  Paul Thomas  <pault@gcc.gnu.org>
+
+	* fortran/trans-expr.c (gfc_conv_variable): Clean up bracketting.
+	* fortran/trans-expr.c (gfc_conv_function_call): Insert spaces.
+	Correct comments and replace convert of integer_one_node with
+	build_int_cst.
+
+2005-06-01  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/21729
+	* resolve.c (resolve_contained_fntype): Use sym->attr.untyped
+	to avoid giving error multiple times.
+	(resolve_entries): Don't error about BT_UNKNOWN here.
+	(resolve_unknown_f): Capitalize IMPLICIT for consistency.
+	(resolve_fntype): New function.
+	(gfc_resolve): Call resolve_fntype.
+
+2005-06-01  Feng Wang  <fengwang@nudt.edu.cn>
+
+	PR fortran/20883
+	* fortran/io.c (resolve_tag): Fix error message.
+
+2005-05-31  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
+
+	* fortran/trans-decl.c: Don't include errors.h.
+	* fortran/Make-lang.in: Updates dependencies.
+
+2005-05-31  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/18109
+	PR fortran/18283
+	PR fortran/19107
+	* fortran/trans-array.c (gfc_conv_expr_descriptor): Obtain the
+	string length from the expression typespec character length value
+	and set temp_ss->stringlength and backend_decl. Obtain the
+	tree expression from gfc_conv_expr rather than gfc_conv_expr_val.
+	Dereference the expression to obtain the character.
+	* fortran/trans-expr.c (gfc_conv_component_ref): Remove the
+	dereference of scalar character pointer structure components.
+	* fortran/trans-expr.c (gfc_trans_subarray_assign): Obtain the
+	string length for the structure component from the component
+	expression.
+
+2005-05-30  Roger Sayle  <roger@eyesopen.com>
+
+	* gfortran.h (GFC_STD_LEGACY): New "standard" macro.  Reindent.
+	* options.c (gfc_init_options): By default, allow legacy extensions
+	but warn about them.
+	(gfc_post_options): Make -pedantic warn about legacy extensions
+	even with -std=legacy.
+	(gfc_handle_option): Make -std=gnu follow the default behaviour
+	of warning about legacy extensions, but allowing them. Make the
+	new -std=legacy accept everything and warn about nothing.
+	* lang.opt (std=legacy): New F95 command line option.
+	* invoke.texi: Document both -std=f2003 and -std=legacy.
+	* gfortran.texi: Explain the two types of extensions and document
+	how they are affected by the various -std= command line options.
+
+2005-05-30  Kazu Hirata  <kazu@cs.umass.edu>
+
+	* trans-expr.c: Remove trailing ^M.
+
+	* trans-expr.c: Fix comment typos.
+
+2005-05-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/16939
+	PR fortran/17192
+	PR fortran/17193
+	PR fortran/17202
+	PR fortran/18689
+	PR fortran/18890
+	* fortran/trans-array.c (gfc_conv_resolve_dependencies): Add string
+	length to temp_ss for character pointer array assignments.
+	* fortran/trans-expr.c (gfc_conv_variable): Correct errors in
+	dereferencing of characters and character pointers.
+	* fortran/trans-expr.c (gfc_conv_function_call): Provide string
+	length as return argument for various kinds of handling of return.
+	Return a char[]* temporary for character pointer functions and
+	dereference the temporary upon return.
+
+2005-05-29  Janne Blomqvist  <jblomqvi@vipunen.hut.fi>
+	    Steven G. Kargl  <kargls@comcast.net>
+
+	fortran/PR20846
+	* io.c (gfc_match_inquire): Implement constraints on UNIT and FILE usage.
+
+2005-05-29  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR libfortran/20006
+	* io.c (format_item_1): Add check and extension warning for
+	$ edit descriptor.
+
+2005-05-28  Steven G. Kargl  <kargls@comcast.net>
+
+	* arith.c (gfc_arith_init_1): Fix off by one problem;
+	(gfc_check_integer_range): Chop extra bits in subnormal numbers.
+
+2005-05-28  Jerry DeLisle   <jvdelisle@verizon.net>
+	    Steven G. Kargl  <kargls@comcast.net>
+
+	* intrinsic.texi: added documentation for BIT_SIZE, BTEST, CHAR, CEILING
+	and CMPLX
+
+2005-05-27  Steven G. Kargl  <kargls@comcast.net>
+
+	* trans-array.c (gfc_trans_deferred_array): Use build_int_cst to force
+	like types in comparsion.
+
+2005-05-26  Kazu Hirata  <kazu@cs.umass.edu>
+
+	* data.c, parse.c, trans-array.c, trans-decl.c,
+	trans-intrinsic.c, trans-stmt.c, trans-types.c, trans.c,
+	trans.h: Fix comment typos.  Follow spelling conventions.
+
+2005-05-22  Roger Sayle  <roger@eyesopen.com>
+
+	* gfortran.texi: Document some more GNU extensions.
+
+2005-05-22  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* error.c (gfc_warning): Fix typo in comment.
+
+2005-05-18  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR libfortran/21127
+	* fortran/iresolve.c (gfc_resolve_reshape): Add
+	gfc_type_letter (BT_COMPLEX) for complex to
+	to resolved function name.
+
+2005-05-18  Erik Edelmann  <erik.edelmann@iki.fi>
+
+	* array.c (gfc_match_array_constructor): Support [ ... ]
+	style array constructors.
+
+2005-05-18  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* f95-lang.c (gfc_init_builtin_functions): Define BUILT_IN_TRUNC
+	and BUILT_IN_TRUNCF instead of BUILT_IN_FLOOR and BUILT_IN_FLOORF.
+	* trans-intrinsic.c (build_fix_expr): Change 'op' argument
+	to correct enum type.
+	(gfc_conv_intrinsic_aint): Likewise.  Clarify comment in front of
+	function.  Add default case to switch, deal with FIX_TRUNC_EXPR
+	instead of FIX_FLOOR_EXPR.
+
+2005-05-18  Feng Wang  <fengwang@nudt.edu.cn>
+
+	PR fortran/20954
+	* trans-const.c (gfc_conv_const_charlen): Use gfc_charlen_type_node to
+	build character length.
+
+2005-05-17  Zdenek Dvorak  <dvorakz@suse.cz>
+
+	* trans-types.c (gfc_array_range_type): New variable.
+	(gfc_init_types): Initialize gfc_array_range_type.
+	(gfc_get_array_type_bounds): Use gfc_array_range_type.
+
+2005-05-17  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/15080
+	* trans-stmt.c (generate_loop_for_temp_to_lhs): Remove SIZE and COUNT2
+	arguments.  If LSS is gfc_ss_terminator, increment COUNT1 by 1, instead
+	of incrementing COUNT2 and using COUNT1+COUNT2 increment COUNT1 and use
+	just that as index.
+	(generate_loop_for_rhs_to_temp): Likewise.
+	(compute_overall_iter_number): Add INNER_SIZE_BODY argument.
+	It non-NULL, add it to body.
+	(allocate_temp_for_forall_nest_1): New function, split from
+	allocate_temp_for_forall_nest.
+	(allocate_temp_for_forall_nest): Add INNER_SIZE_BODY argument,
+	propagate it down to compute_overall_iter_number.  Use
+	allocate_temp_for_forall_nest_1.
+	(gfc_trans_assign_need_temp): Remove COUNT2.  Call
+	compute_inner_temp_size into a new stmtblock_t.  Adjust calls to
+	allocate_temp_for_forall_nest, generate_loop_for_rhs_to_temp
+	and generate_loop_for_temp_to_lhs.
+	(gfc_trans_pointer_assign_need_temp): Adjust calls to
+	allocate_temp_for_forall_nest.
+	(gfc_evaluate_where_mask): Call compute_inner_temp_size into a new
+	stmtblock_t.  Call compute_overall_iter_number just once, then
+	allocate_temp_for_forall_nest_1 twice with the same size.
+	Initialize mask indexes if nested_forall_info != NULL.
+	(gfc_trans_where_2): Initialize mask indexes before calling
+	gfc_trans_nested_forall_loop.
+
+2005-05-15  Feng Wang  <fengwang@nudt.edu.cn>
+	Jerry DeLisle  <jvdelisle@verizon.net>
+
+	PR fortran/17432
+	* trans-stmt.c (gfc_trans_label_assign): fix pointer type, to
+	resolve ICE on assign of format label.
+	* trans-io.c (set_string): add fold-convert to properly
+	handle assigned format label in write.
+
+2005-05-13  Paul Brook  <paul@codesourcery.com>
+
+	* trans-stmt.c (gfc_trans_forall_1): Fix comment typo.
+
+2005-05-12  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* trans-types.c (gfc_is_nodesc_array): Remove redundant check.
+
+2005-05-11  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/21260
+	* io.c (check_format): Look for literal characters inside
+	hollerith constant.
+
+2005-05-11  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* resolve.c (resolve_symbol): Copy 'pointer' and 'dimension'
+	attribute from result symbol to function symbol.
+	* trans-expr.c (gfc_conv_function_call): Look at sym->attr.dimension
+	instead of sym->result->attr.dimension.
+
+2005-05-10  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/20178
+	* gfortran.h (gfc_option): Add flag_f2c.
+	* invoke.texi: Document '-ff2c' command line option.  Adapt
+	documentation for '-fno-second-underscore' and '-fno-underscoring'.
+	* lang.opt (ff2c): New entry.
+	* options.c (gfc-init_options): Set default calling convention
+	to -fno-f2c.  Mark -fsecond-underscore unset.
+	(gfc_post_options): Set -fsecond-underscore if not explicitly set
+	by user.
+	(handle_options): Set gfc_option.flag_f2c according to requested
+	calling	convention.
+	* trans-decl.c (gfc_get_extern_function_decl): Use special f2c
+	intrinsics where necessary.
+	(gfc_trans_deferred_vars): Change todo error to	assertion.
+	* trans-expr.c (gfc_conv_variable): Dereference access
+	to hidden result argument.
+	(gfc_conv_function_call): Add hidden result argument to argument
+	list if f2c calling conventions requested.  Slightly restructure
+	tests.  Convert result of default REAL function to requested type
+	if f2c calling conventions are used.  Dereference COMPLEX result
+	if f2c cc are used.
+	* trans-types.c (gfc_sym_type):  Return double for default REAL
+	function if f2c cc are used.
+	(gfc_return_by_reference): Slightly restructure logic.  Return
+	COMPLEX by reference depending on calling conventions.
+	(gfc_get_function_type): Correctly make hidden result argument a
+	pass-by-reference argument for COMPLEX.  Remove old code which does
+	this for derived types.
+
+2005-05-09  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* match.c (gfc_match_return): Only require space after keyword when
+	it is obligatory.  Only give stdwarn to after matching is successful.
+	* dump-parse-tree.c (gfc_show_symbol): Deal with alternate returns.
+
+2005-05-08  Kazu Hirata  <kazu@cs.umass.edu>
+
+	* intrinsic.texi: Fix typos.
+
+2005-05-07  Steven G. Kargl  <kargls@comcast.net>
+
+	* intrinsic.texi:  Document ASSOCIATED and ATAN2.  Update Bessel function
+	description to include information about scalar arguments.
+
+2005-05-03  Kazu Hirata  <kazu@cs.umass.edu>
+
+	* Make-lang.in, dump-parse-tree.c, invoke.texi, lang.opt,
+	match.h, trans-array.h: Update copyright.
+
+2005-04-29  Tom Tromey  <tromey@redhat.com>
+
+	* f95-lang.c (poplevel): Updated for change to build_block.
+
+2005-04-29  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/13082
+	PR fortran/18824
+	* trans-expr.c (gfc_conv_variable): Handle return values in functions
+	with alternate entry points.
+	* resolve.c (resolve_entries): Remove unnecessary string termination
+	after snprintf.  Set result of entry master.
+	If all entries have the same type, set entry master's type
+	to that common type, otherwise set mixed_entry_master attribute.
+	* trans-types.c (gfc_get_mixed_entry_union): New function.
+	(gfc_get_function_type): Use it for mixed_entry_master functions.
+	* gfortran.h (symbol_attribute): Add mixed_entry_master bit.
+	* decl.c (gfc_match_entry): Set entry->result properly for
+	function ENTRY.
+	* trans-decl.c (gfc_get_symbol_decl): For entry_master, skip over
+	__entry argument.
+	(build_entry_thunks): Handle return values in entry thunks.
+	Clear BT_CHARACTER's ts.cl->backend_decl, so that it is not
+	shared between multiple contexts.
+	(gfc_get_fake_result_decl): Use DECL_ARGUMENTS from
+	current_function_decl instead of sym->backend_decl.  Skip over
+	entry master's entry id argument.  For mixed_entry_master entries or
+	their results, return a COMPONENT_REF of the fake result.
+	(gfc_trans_deferred_vars): Don't warn about missing return value if
+	at least one entry point uses RESULT.
+	(gfc_generate_function_code): For entry master returning
+	CHARACTER, copy ts.cl->backend_decl to all entry result syms.
+	* trans-array.c (gfc_trans_dummy_array_bias): Don't consider return
+	values optional just because they are in entry master.
+
+2005-04-29  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* gfortran.h (gfc_namespace): Add seen_implicit_none field,
+	Tobias forgot this in previous commit.
+
+2005-04-29  Paul Brook   <paul@codesourcery.com>
+
+	* trans-expr.c (gfc_conv_expr_present): Fix broken assert.  Update
+	comment.
+
+2005-04-29  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* gfortran.h (gfc_namespace): Add seen_implicit_none field.
+	* symbol.c (gfc_set_implicit_none): Give error if there's a previous
+	IMPLICIT NONE, set seen_implicit_none.
+	(gfc_merge_new_implicit): Error if there's an IMPLICIT NONE statement.
+
+2005-04-28  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* gfortran.h (gfc_gsymbol): Make name a const char *.
+	* symbol.c (gfc_get_gsymbol): Allocate gsymbol name via
+	gfc_get_string.
+
+2005-04-28  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/20865
+	* resolve.c (resolve_actual_arglist): Issue an error if a statement
+	functions is used as actual argument.
+
+2005-04-27  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/21177
+	* interface.c (compare_parameter): Ignore type for EXPR_NULL
+	only if type is BT_UNKNOWN.
+
+2005-04-25  Paul Brook  <paul@codesourcery.com>
+	Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/20879
+	* check.c (gfc_check_ichar_iachar): New function.
+	* instinsic.h (gfc_check_ichar_iachar): Add prototype.
+	* intrinsic.c (add_functions): Use it.
+	* primary.c (match_varspec, gfc_match_rvalue): Clear incorrect
+	character expression lengths.
+
+2005-04-24  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/20059
+	* trans-common.c (translate_common): Cast offset and
+	common_segment->offset to type int for warning message.
+
+2005-04-23  DJ Delorie  <dj@redhat.com>
+
+	* trans-decl.c: Adjust warning() callers.
+
+2005-04-23  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* trans-const.c (gfc_conv_mpfr_to_tree): Use hexadecimal string as
+	intermediate representation.  Fix typo in comment.
+
+2005-04-21  Steven G. Kargl  <kargls@comcast.net>
+
+	* trans-const.c (gfc_conv_mpfr_to_tree): Remove unneeded computation;
+	simplify logic; Add a gcc_assert.
+
+2005-04-19  Steven G. Kargl  <kargls@comcast.net>
+
+	* trans-const.c (gfc_conv_mpz_to_tree): Fix comment.
+
+2005-04-19  Arnaud Desitter  <arnaud.desitter@ouce.ox.ac.uk>
+	    Steven G. Kargl  <kargls@comcast.net>
+
+	* invoke.texi: Update -Waliasing description
+
+2005-04-19  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/16861
+	* resolve.c (resolve_variable): If e->symtree is not set, this
+	ought to be a FAILURE, and not a segfault.
+
+2005-04-17  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/17472
+	PR fortran/18209
+	PR fortran/18396
+	PR fortran/19467
+	PR fortran/19657
+	* fortran/trans-io.c (gfc_build_io_library_fndecls): Create
+	declaration for	st_set_nml_var and st_set_nml_var_dim. Remove
+	declarations of old namelist functions.
+	(build_dt): Simplified call to transfer_namelist_element.
+	(nml_get_addr_expr): Generates address expression for start of
+	object data. New function.
+	(nml_full_name): Qualified name for derived type components. New
+	function.
+	(transfer_namelist_element): Modified for calls to new functions
+	and improved derived type handling.
+
+2005-04-17  Richard Guenther  <rguenth@gcc.gnu.org>
+
+	* scanner.c (gfc_next_char_literal): Reset truncation flag
+	for lines ending in a comment for both fixed and free form.
+	(load_line): Do not set truncated flag if only truncating
+	the EOL marker.
+
+2005-04-15  Richard Guenther  <rguenth@gcc.gnu.org>
+
+	PR fortran/14569
+	* gfortran.h (gfc_linebuf): Add truncated field.
+	* parse.c (next_statement): Handle warning for truncated
+	lines.
+	* scanner.c (load_line): Return if line was truncated.
+	No longer warn for truncated lines.  Remove unused parameters.
+	(load_file): Store load_line return value to linebuf.
+	(gfc_error_recovery): Do not advance line at the end.
+
+2005-04-14  Steven G. Kargl  <kargls@comcast.net>
+
+	* gfortran.h (gfc_real_info): Add subnormal struct member.
+	* arith.c (gfc_arith_init_1): Set it.
+	(gfc_check_real_range): Use it.
+	* simplify.c (gfc_simplify_nearest): Fix nearest(0.,1.).
+
+2005-04-12  Kazu Hirata  <kazu@cs.umass.edu>
+
+	* simplify.c: Fix a comment typo.
+
+2005-04-11  Richard Sandiford  <rsandifo@redhat.com>
+
+	* lang.opt: Refer to the GCC internals documentation instead of c.opt.
+
+2005-04-11  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* simplify.c (gfc_simplify_nearest): Overhaul.
+
+2005-04-10  Kazu Hirata  <kazu@cs.umass.edu>
+
+	* interface.c: Fix a comment typo.
+
+2005-04-10  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* match.c (match_arithmetic_if): Arithmetic IF is obsolete in
+	Fortran 95.
+
+2005-04-09  Steven G. Kargl  <kargls@comcast.net>
+
+	* simplify.c (gfc_simplify_anint): Use mpfr_round()
+	(gfc_simplify_dnint): ditto.
+	(gfc_simplify_nint): ditto.
+
+2005-04-09  Andrew Pinski  <pinskia@physics.uc.edu>
+
+	PR fortran/13257
+	* io.c (check_format): Allow an optional comma
+	between descriptors.
+
+2005-04-09  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* match.c (match_arithmetic_if): Remove gfc_ prefix and correct
+	comment according to GNU coding style.
+	(gfc_match_if): Remove gfc_ prefix in call to
+	match_arithmetic_if.
+
+2005-04-08  Diego Novillo  <dnovillo@redhat.com>
+
+	* match.c (gfc_match_arithmetic_if): Declare static.
+
+2005-04-08  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/17229
+	* match.c (gfc_match_arithmetic_if): New function to match an
+	arithmetic IF statement.
+	(gfc_match_if): Use gfc_match_arithmetic_if to match an
+	arithmetic IF statement embedded in a simple IF statement.
+
+2005-04-07  Steven G. Kargl  <kargls@comcast.net>
+
+	* simplify.c (gfc_simplify_exponent): Fix exponent(tiny(x))
+
+2005-04-06  Steven G. Kargl  <kargls@comcast.net>
+
+	* invoke.texi: Remove documentation of -std=f90
+
+2005-04-06  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* expr.c (gfc_check_assign): Don't allow NULL as rhs in a
+	non-pointer assignment.
+
+2005-04-05  Feng Wang  <fengwang@nudt.edu.cn>
+
+	PR fortran/15959
+	PR fortran/20713
+
+	* array.c (resolve_character_array_constructor): New function. Set
+	constant character array's character length.
+	(gfc_resolve_array_constructor): Use it.
+	* decl.c (add_init_expr_to_sym): Set symbol and initializer character
+	length.
+	(gfc_set_constant_character_len): New function. Set constant character
+	expression according the given length.
+	* match.h (gfc_set_constant_character_len): Add prototype.
+
+2005-04-04  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* intrinsic.texi: BES?? functions are not in the f95 standard.
+
+2005-04-03  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* intrinsic.texi: Document COS, EXP, LOG, LOG10, SIN, SQRT, TAN.
+
+2005-04-03  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* intrinsic.texi: Document BESJ0, BESJ1, BESJN, BESY0, BESY1,
+	BESYN, ATAN, COSH, ERF, ERC, SINH, TANH.
+
+2005-04-02  Steven G. Kargl  <kargls@comcast.net>
+
+	* intrinsic.texi: Document ALLOCATED, ANINT, ANY, ASIN; fix typos
+
+2005-04-01  Kazu Hirata  <kazu@cs.umass.edu>
+
+	* decl.c, f95-lang.c, interface.c, module.c, trans-stmt.c,
+	trans.h: Fix comment typos.
+
+2005-03-29  Steven G. Kargl  <kargls@comcast.net>
+
+	* gfortran.h (option_t): Change d8, i8, r8 to flag_default_double,
+	flag_default_integer, flag_default_real
+	* invoke.texi: Update documentation
+	* lang.opt: Remove d8, i8, r8 definitions; Add fdefault-double-8
+	fdefault-integer-8, and fdefault-real-8 definitions.
+	* options.c (gfc_init_options): Set option defaults
+	(gfc_handle_option): Handle command line options.
+	* trans-types.c (gfc_init_kinds): Use options.
+
+2005-03-29  Keith Besaw  <kbesaw@us.ibm.com>
+
+	* f95-lang.c (builtin_function): Process the attrs parameter
+	and apply the "const" attribute to the builtin if found.
+
+2005-03-27  Steven G. Kargl  <kargls@comcast.net>
+
+	* intrinsic.texi: Document AIMAG, AINT, ALL
+
+2005-03-26  Steven G. Kargl  <kargls@comcast.net>
+
+	* arith.c (check_result): Fix illogical logic.
+
+2005-03-26  Canqun Yang  <canqun@nudt.edu.cn>
+
+	* trans-common.c (create_common): Build RECORD_NODE for common blocks
+	contain no equivalence objects.
+	(add_equivalences): New argument saw_equiv.
+	(trans_common): New local variable saw_equiv.
+	(finish_equivalences): Add a local variable dummy, Always pass true
+	for the 3rd parameter to create_common.
+
+2005-03-25  Steven G. Kargl  <kargls@comcast.net>
+
+	* intrinsic.texi: Fix "make dvi"
+
+2005-03-24  Steven G. Kargl  <kargls@comcast.net>
+
+	* intrinsic.texi: New file.
+	* gfortran.texi: Include it; white space change; fix typo.
+
+2005-03-23  Joseph S. Myers  <joseph@codesourcery.com>
+
+	* f95-lang.c (LANG_HOOKS_TRUTHVALUE_CONVERSION): Remove.
+
+2005-03-23  Steven Bosscher  <stevenb@suse.de>
+
+	* convert.c (convert): Replace fold (buildN (...)) with fold_buildN.
+	* trans-array.c (gfc_trans_allocate_array_storage,
+	gfc_trans_allocate_temp_array gfc_trans_array_constructor_value,
+	gfc_conv_array_index_ref, gfc_trans_array_bound_check,
+	gfc_conv_array_index_offset, gfc_conv_scalarized_array_ref,
+	gfc_conv_array_ref, gfc_trans_preloop_setup, gfc_conv_ss_startstride,
+	gfc_conv_loop_setup, gfc_array_init_size, gfc_trans_array_bounds,
+	gfc_trans_auto_array_allocation, gfc_trans_dummy_array_bias,
+	gfc_conv_expr_descriptor): Likewise.
+	* trans-expr.c (gfc_conv_powi, gfc_conv_string_tmp,
+	gfc_conv_concat_op, gfc_conv_expr_op): Likewise.
+	* trans-intrinsic.c (build_round_expr, gfc_conv_intrinsic_bound,
+	gfc_conv_intrinsic_cmplx, gfc_conv_intrinsic_sign,
+	gfc_conv_intrinsic_minmaxloc, gfc_conv_intrinsic_minmaxval,
+	gfc_conv_intrinsic_btest, gfc_conv_intrinsic_bitop,
+	gfc_conv_intrinsic_singlebitop, gfc_conv_intrinsic_ibits,
+	gfc_conv_intrinsic_ishft, gfc_conv_intrinsic_ishftc,
+	gfc_conv_intrinsic_merge, prepare_arg_info,
+	gfc_conv_intrinsic_rrspacing, gfc_conv_intrinsic_repeat): Likewise.
+	* trans-stmt.c (gfc_trans_simple_do, gfc_trans_do, gfc_trans_do_while,
+	gfc_trans_forall_loop, gfc_do_allocate, generate_loop_for_temp_to_lhs,
+	generate_loop_for_rhs_to_temp, compute_inner_temp_size,
+	allocate_temp_for_forall_nest, gfc_trans_pointer_assign_need_temp,
+	gfc_trans_forall_1, gfc_evaluate_where_mask, gfc_trans_where_assign):
+	Likewise.
+	* trans-types.c (gfc_get_dtype, gfc_get_array_type_bounds): Likewise.
+	* trans.c (gfc_add_modify_expr): Likewise.
+
+2005-03-22  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* check.c (gfc_check_chdir, gfc_check_chdir_sub, gfc_check_kill,
+	gfc_check_kill_sub, gfc_check_link, gfc_check_link_sub,
+	gfc_check_symlnk, gfc_check_symlnk_sub, gfc_check_rename,
+	gfc_check_rename_sub, gfc_check_sleep_sub, gfc_check_gerror,
+	gfc_check_getlog, gfc_check_hostnm, gfc_check_hostnm_sub,
+	gfc_check_perror): new functions to check newly implemented
+	g77 intrinsics.
+	* gfortran.h: adding symbols for new intrinsics.
+	* intrinsic.c (add_functions): adding new intrinsics.
+	(add_subroutines): adding new intrinsics.
+	* intrinsic.h: prototype for all checking and resolving
+	functions.
+	* iresolve.c (gfc_resolve_chdir, gfc_resolve_chdir_sub,
+	gfc_resolve_hostnm, gfc_resolve_ierrno, gfc_resolve_kill,
+	gfc_resolve_link, gfc_resolve_rename, gfc_resolve_symlnk,
+	gfc_resolve_time, gfc_resolve_time8, gfc_resolve_rename_sub,
+	gfc_resolve_kill_sub, gfc_resolve_link_sub,
+	gfc_resolve_symlnk_sub, gfc_resolve_sleep_sub,
+	gfc_resolve_gerror, gfc_resolve_getlog, gfc_resolve_hostnm_sub,
+	gfc_resolve_perror): new functions to resolve intrinsics.
+	* trans-intrinsic.c (gfc_conv_intrinsic_function): add case
+	for new symbols.
+
+2005-03-19  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* dump-parse-tree.c (gfc_show_expr): Dump name of namespace
+	in which the variable is declared.
+
+	PR fortran/18525
+	* resolve.c (was_declared): Also check for dummy attribute.
+
+2005-03-19  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* gfortran.h (arith): Remove ARITH_0TO0.
+	* arith.c (gfc_arith_error): Remove handling of ARITH_0TO0.
+	(gfc_arith_power): Remove special casing of zero to integral
+	power zero.
+
+2005-03-18  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
+
+	* Make-lang.in (fortran-warn): Remove -Wno-error.
+	(expr.o-warn, resolve.o-warn, simplify.o-warn,
+	trans-common.o-warn): Specify -Wno-error.
+
+2005-03-17  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* trans-array.c (gfc_trans_static_array_pointer,
+	get_array_ctor_var_strlen, gfc_conv_array_index_offset): Fix
+	comment and formatting typos.
+
+2005-03-17  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* invoke.texi: Fix typos.
+
+2005-03-15  Zack Weinberg  <zack@codesourcery.com>
+
+	* Make-lang.in (GFORTRAN_TEXI): Add gcc-vers.texi.
+
+2005-03-15  Feng Wang  <fengwang@nudt.edu.cn>
+
+	* trans-stmt.c (gfc_trans_label_assign): Don't set DECL_ARTIFICIAL flag
+	to zero on label_tree.
+
+2005-03-15  Feng Wang  <fengwang@nudt.edu.cn>
+
+	PR fortran/18827
+	* io.c (resolve_tag): Add checking on assigned label.
+	(match_dt_format): Does not set symbol assign attribute.
+	* match.c (gfc_match_goto):Does not set symbol assign attribute.
+	* resolve.c (resolve_code): Add checking on assigned label.
+	* trans-common.c (build_field): Deals with common variable assigned
+	a label.
+	* trans-stmt.c (gfc_conv_label_variable): New function.
+	(gfc_trans_label_assign): Use it.
+	(gfc_trans_goto): Ditto.
+	* trans-io.c (set_string): Ditto.
+	* trans.h (gfc_conv_label_variable): Add prototype.
+
+2005-03-14  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/20467
+	* symbol.c (check_conflict): A dummy argument can't be a statement
+	function.
+
+2005-03-14  Zdenek Dvorak  <dvorakz@suse.cz>
+
+	* fortran/trans-intrinsic.c (gfc_conv_intrinsic_ishft): Convert
+	the argument of the shift to the unsigned type.
+
+2005-03-13  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/16907
+	* resolve.c (gfc_resolve_index): Allow REAL indices as an extension.
+
+2005-03-13  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/20323
+	* resolve.c (gfc_resolve): Check if character lengths are
+	specification expressions.
+
+2005-03-12  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/20361
+	* trans-array.c (gfc_stack_space_left): Remove unused variable.
+	(gfc_can_put_var_on_stack): Move to trans-decl.c, remove #if 0'ed
+	code.
+	* trans-array.h (gfc_stack_space_left, gfc_can_put_var_on_stack):
+	Remove declaration / prototype.
+	* trans-common.c (build_equiv_decl): Give union a name.  Check if
+	it can be put on the stack.
+	* trans-decl.c (gfc_stack_space_left): Move function here.
+	(gfc_build_qualified_array): Fix comment typo.
+	* trans.h (gfc_put_var_on_stack): Add prototype.
+
+2005-03-11  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
+
+	* Make-lang.in (fortran-warn): Set to $(STRICT_WARN) -Wno-error.
+	* decl.c, trans.c: Don't use C++ style comments.
+	* gfortran.h (sym_flavor, procedure_type, sym_intent, gfc_access,
+	ifsrc): Give names to enums and use ENUM_BITFIELD.
+	(gfc_access): Remove trailing comma.
+
+2005-03-05  Steven G. Kargl  <kargls@comcast.net>
+
+	PR 19936
+	* primary.c (match_complex_constant): Mangled complex constant may
+	be an implied do-loop.  Give implied do-loop matcher a chance.
+
+2005-03-05  Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/19754
+	* resolve.c (compare_shapes):  New function.
+	(resolve_operator): Use it.
+
+2005-03-05  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* trans-const.c (gfc_conv_constant_to_tree): Use correct tree
+	type for COMPLEX constants.
+
+2005-03-04  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/19673
+	* trans-expr.c (gfc_conv_function_call): Correctly dereference
+	argument from a pointer function also if it has a result clause.
+
+2005-03-04  Steven G. Kargl  <kargls@comcast.net>
+
+	* expr.c (gfc_copy_shape_excluding): Change && to ||.
+
+2005-03-04  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* trans-intrinsic.c (gfc_get_symbol_for_expr): Fix comment typo,
+	clarify comment.
+
+2005-02-28  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+	(port from g95)
+
+	PR fortran/19479
+	* simplify.c (gfc_simplify_bound): Rename to ...
+	(simplify_bound): ... this and overhaul.
+
+2005-02-28  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* trans-intrinsic.c (gfc_conv_intrinsic_iargc): remove boolean argument.
+	(gfc_conv_intrinsic_function): update function calls
+
+2005-02-27  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/20058
+	* trans-types.c (gfc_max_integer_kind): Declare
+	(gfc_init_kinds): Initialize it.
+	* gfortran.h (gfc_max_integer_kind): extern it.
+	* primary.c (match_boz_constant): Use it; remove gfortran extension
+	of kind suffixes on BOZ literal constants
+
+
+2005-02-27  Steven G. Kargl  <kargls@comcast.net>
+
+	* arith.c (gfc_check_real_range):  Remove multiple returns
+	(check_result): New function.
+	(gfc_arith_uminus,gfc_arith_plus,gfc_arith_times,
+	gfc_arith_divide,gfc_arith_power,gfc_arith_minus): Use it.
+
+
+2005-02-24  Volker Reichelt  <reichelt@igpm.rwth-aachen.de>
+
+	* decl.c, resolve.c, trans-array.c, trans.h: Fix comment typo(s).
+
+
+2005-02-24  Tobias Schl"uter  <tobias.schlueter@physik.uni-meunchen.de>
+
+	Unrevert previously reverted patch.  Adding this fix:
+	* module.c (find_true_name): Deal with NULL module.
+
+2005-02-24  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	Revert yesterday's patch:
+	2005-02-23  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+		* gfortran.h (gfc_component, gfc_actual_arglist, ...
+		... argument.  Copy string instead of pointing to it.
+
+2005-02-23  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* gfortran.h (gfc_get_namespace): Add second argument to prototype.
+	* intrinsic.c (gfc_intrinsic_init_1): Pass second argument to
+	gfc_get_namespace.
+	* module.c (mio_namespace_ref, load_needed): Likewise.
+	* parse.c (parse_interface, parse_contained): Likewise.  Here the
+	correct second argument matters.
+	* symbol.c (gfc_get_namespace): Add parent_types argument, only copy
+	parent's implicit types if this is set.
+	(gfc_symbol_init_2): Pass second argument to gfc_get_namespace.
+	* trans-common.c (build_common_decl): Likewise.
+
+	* gfortran.h (symbol_attribute): New 'untyped' field, fix comment
+	formatting.
+	* symbol.c (gfc_set_default_type): Issue error only once, by setting
+	and checking 'untyped' attribute.
+
+	* gfortran.h (gfc_expr): Move 'operator', 'op1', 'op2', and 'uop'
+	fields into new struct 'op' inside the 'value' union.
+	* arith.c (eval_intrinsic): Adapt all users.
+	* dependency.c (gfc_check_dependency): Likewise.
+	* dump-parse-tree.c (gfc_show_expr): Likewise.
+	* expr.c (gfc_get_expr): Don't clear removed fields.
+	(free_expr0, gfc_copy_expr, gfc_type_convert_binary,
+	gfc_is_constant_expr, simplify_intrinsic_op, check_init_expr,
+	check_intrinsic_op): Adapt to new field names.
+	* interface.c (gfc_extend_expr): Likewise.  Also explicitly
+	nullify 'esym' and 'isym' fields of new function call.
+	* iresolve.c (gfc_resolve_dot_product, gfc_resolve_matmul):
+	Adapt to renamed structure fields.
+	* matchexp.c (build_node, match_level_1, match_expr): Likewise.
+	* module.c (mio_expr): Likewise.
+	* resolve.c (resolve_operator): Likewise.
+	(gfc_find_forall_index): Likewise.  Only look through operands
+	if dealing with EXPR_OP
+	* trans-array.c (gfc_walk_op_expr): Adapt to renamed fields.
+	* trans-expr.c (gfc_conv_unary_op, gfc_conv_power_op,
+	gfc_conv_concat_op, gfc_conv_expr_op): Likewise.
+
+	[ Reverted ]
+	* gfortran.h (gfc_component, gfc_actual_arglist, gfc_user_op): Make
+	'name' a 'const char *'.
+	(gfc_symbol): Likewise, also for 'module'.
+	(gfc_symtree): Make 'name' a 'const char *'.
+	(gfc_intrinsic_sym): Likewise, also for 'lib_name'.
+	(gfc_get_gsymbol, gfc_find_gsymbol): Add 'const' qualifier to
+	'char *' argument.
+	(gfc_intrinsic_symbol): Use 'gfc_get_string' instead of 'strcpy' to
+	initialize 'SYM->module'.
+	* check.c (gfc_check_minloc_maxloc, check_reduction): Check for NULL
+	pointer instead of empty string.
+	* dump-parse-tree.c (gfc_show_actual_arglist): Likewise.
+	* interface.c (gfc_compare_types): Adapt check to account for possible
+	NULL pointer.
+	(compare_actual_formal): Check for NULL pointer instead of empty
+	string.
+	* intrinsic.c (gfc_current_intrinsic, gfc_current_intrinsic_arg):
+	Add 'const' qualifier.
+	(conv_name): Return a heap allocated string.
+	(find_conv): Add 'const' qualifier to 'target'.
+	(add_sym): Use 'gfc_get_string' instead of 'strcpy'.
+	(make_generic): Check for NULL pointer instead of empty	string.
+	(make_alias): Use 'gfc_get_string' instead of 'strcpy'.
+	(add_conv): No need to strcpy result from 'conv_name'.
+	(sort_actual): Check for NULL pointer instead of empty	string.
+	* intrinsic.h (gfc_current_intrinsic, gfc_current_intrinsic_arg):
+	Adapt prototype.
+	* module.c (compare_true_names): Compare pointers instead of strings
+	for 'module' member.
+	(find_true_name): Initialize string fields with gfc_get_string.
+	(mio_pool_string): New function.
+	(mio_internal_string): Adapt comment.
+	(mio_component_ref, mio_component, mio_actual_arg): Use
+	'mio_pool_string' instead of 'mio_internal_string'.
+	(mio_symbol_interface): Add 'const' qualifier to string arguments.
+	Add level of indirection. Use 'mio_pool_string' instead of
+	'mio_internal_string'.
+	(load_needed, read_module): Use 'gfc_get_string' instead of 'strcpy'.
+	(write_common, write_symbol): Use 'mio_pool_string' instead of
+	'mio_internal_string'.
+	(write_symbol0, write_symbol1): Likewise, also check for NULL pointer
+	instead of empty string.
+	(write_operator, write_generic): Pass correct type variable to
+	'mio_symbol_interface'.
+	(write_symtree): Use 'mio_pool_string' instead of
+	'mio_internal_string'.
+	* primary.c (match_keyword_arg): Adapt check to possible
+	case of NULL pointer.  Use 'gfc_get_string' instead of 'strcpy'.
+	* symbol.c (gfc_add_component, gfc_new_symtree, delete_symtree,
+	gfc_get_uop, gfc_new_symbol): Use 'gfc_get_string' instead of
+	'strcpy'.
+	(ambiguous_symbol): Check for NULL pointer instead of empty string.
+	(gfc_find_gsymbol, gfc_get_gsymbol): Add 'const' qualifier on string
+	arguments.
+	* trans-array.c (gfc_trans_auto_array_allocation): Check for NULL
+	pointer instead of empty string.
+	* trans-decl.c (gfc_sym_mangled_identifier,
+	gfc_sym_mangled_function_id, gfc_finish_var_decl, gfc_get_symbol_decl,
+	gfc_get_symbol_decl): Likewise.
+	* trans-io.c (gfc_new_nml_name_expr): Add 'const' qualifier to
+	argument.  Copy string instead of pointing to it.
+
+2005-02-23  Kazu Hirata  <kazu@cs.umass.edu>
+
+	* intrinsic.h, st.c: Update copyright.
+
+2005-02-20  Steven G. Kargl  <kargls@comcast.net>
+
+	* symbol.c: Typos in comments.
+
+2005-02-20  Steven G. Kargl  <kargls@comcast.net>
+
+	* expr.c (gfc_type_convert_binary): Typo in comment.
+
+2005-02-19  Steven G. Kargl  <kargls@comcast.net>
+
+	* check.c (gfc_check_selected_int_kind): New function.
+	* intrinsic.h: Prototype it.
+	* intrinsic.c (add_function): Use it.
+	* simplify (gfc_simplify_ceiling,gfc_simplify_floor): Change
+	  BT_REAL to BT_INTEGER and use gfc_default_integer_kind.
+
+2005-02-19  Steven G. Kargl  <kargls@comcast.net>
+
+	* check.c (gfc_check_int): improve checking of optional kind
+	* simplify.c (gfc_simplify_int): Change BT_REAL to BT_INTEGER
+
+2005-02-19  Steven G. Kargl  <kargls@comcast.net>
+
+	* check.c (gfc_check_achar): New function
+	* intrinsic.h: Prototype it.
+	* intrinsic.c (add_function): Use it.
+
+2005-02-13  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* trans-stmt.c (generate_loop_for_temp_to_lhs,
+	generate_loop_for_rhs_to_temp): Remove if whose condition is
+	always true.
+
+2005-02-12  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* symbol.c (gfc_use_ha_derived): Remove, fold functionality into ...
+	(gfc_use_derived): ... this function.
+
+2005-02-09  Richard Henderson  <rth@redhat.com>
+
+	* f95-lang.c (gfc_init_builtin_functions): Call
+	build_common_builtin_nodes; do not define any functions handled
+	by it.
+
+2005-02-08  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* expr.c (gfc_copy_expr): Don't copy 'op1' and 'op2' for
+	EXPR_SUBSTRING.
+	(gfc_is_constant_expr): Check 'ref' to determine if substring
+	reference is constant.
+	(gfc_simplify_expr): Simplify 'ref' instead of 'op1' and 'op2'.
+	(check_init_expr, check_restricted): Check 'ref' instead of 'op1'
+	and 'op2'.
+	* module.c (mio_expr): Read / write 'ref' instead of 'op1' and 'op2'.
+
+2005-02-07  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* gfortran.h (gfc_add_dimension, gfc_add_result, gfc_add_save,
+	gfc_add_dummy, gfc_add_generic, gfc_add_in_common, gfc_add_data,
+	gfc_add_in_namelist, gfc_add_sequence, gfc_add_function,
+	gfc_add_subroutine, gfc_add_access, gfc_add_flavor, gfc_add_entry,
+	gfc_add_procedure): Add argument.
+	* array.c (gfc_set_array_spec), decl.c (var_element, get_proc_name,
+	gfc_match_null, match_type_spec, match_attr_spec,
+	gfc_match_formal_arglist, match_result, gfc_match_function_decl):
+	Update callers to match.
+	(gfc_match_entry): Likewise, fix comment typo.
+	(gfc_match_subroutine, attr_decl1, gfc_add_dimension,
+	access_attr_decl, do_parm, gfc_match_save, gfc_match_modproc,
+	gfc_match_derived_decl): Update callers.
+	* interface.c (gfc_match_interface): Likewise.
+	* match.c (gfc_match_label, gfc_add_flavor,
+	gfc_match_call, gfc_match_common, gfc_match_block_data,
+	gfc_match_namelist, gfc_match_module, gfc_match_st_function):
+	Likewise.
+	* parse.c (parse_derived, parse_interface, parse_contained),
+	primary.c (gfc_match_rvalue, gfc_match_variable): Likewise.
+	* resolve.c (resolve_formal_arglist, resolve_entries): Update callers.
+	* symbol.c (check_conflict, check_used): Add new 'name' argument,
+	use when printing error message.
+	(gfc_add_dimension, gfc_add_result, gfc_add_save, gfc_add_dummy,
+	gfc_add_generic, gfc_add_in_common, gfc_add_data,
+	gfc_add_in_namelist, gfc_add_sequence, gfc_add_function,
+	gfc_add_subroutine, gfc_add_access, gfc_add_flavor, gfc_add_entry,
+	gfc_add_procedure): Add new 'name' argument.  Pass along to
+	check_conflict and check_used.
+	(gfc_add_allocatable, gfc_add_external, gfc_add_intrinsic,
+	gfc_add_optional, gfc_add_pointer, gfc_add_target, gfc_add_elemental,
+	gfc_add_pure, gfc_add_recursive, gfc_add_intent,
+	gfc_add_explicit_interface, gfc_copy_attr): Pass NULL for new
+	argument in calls to any of the modified functions.
+
+2005-02-06  Joseph S. Myers  <joseph@codesourcery.com>
+
+	* gfortran.texi: Don't give last update date.
+
+2005-01-30  Richard Henderson  <rth@redhat.com>
+
+	* options.c (gfc_init_options): Zero flag_errno_math.
+
+2005-01-29  Paul Brook  <paul@codesourcery.com>
+
+	PR fortran/18565
+	* check.c (real_or_complex_check): New function.
+	(gfc_check_fn_c, gfc_check_fn_r, gfc_check_fn_rc): New functions.
+	* intrinsic.c (add_functions): Use new check functions.
+	* intrinsic.h (gfc_check_fn_c, gfc_check_fn_r, gfc_check_fn_rc):
+	Add prototypes.
+
+2005-01-29  Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/19589
+	* expr.c (gfc_check_assign):  Check for conformance of logical operands
+
+2005-01-27  Steven Bosscher  <stevenb@suse.de>
+
+	* trans-decl.c (gfc_build_label_decl): Set DECL_ARTIFICAL and
+	TREE_USED for all labels.
+	(gfc_trans_entry_master_switch): Use it instead of building a
+	label by hand.
+	* trans-io.c (add_case): Likewise.
+	* trans-stmt.c (gfc_trans_integer_select): Likewise.
+
+2005-01-23  Paul Brook  <paul@codesourcery.com>
+	Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/17941
+	* arith.c (gfc_convert_real): Remove sign handling.
+	* primary.c (match_digits): Allow whitespace after initial sign.
+	(match_real_const): Handle signs here.  Allow whitespace after
+	initial sign.  Remove dead code.
+	(match_const_complex_part): Remove.
+	(match_complex_part): Use match_{real,integer}_const.
+	(match_complex_constant): Cross-promote integer types.
+
+2005-01-23  James A. Morrison  <phython@gcc.gnu.org>
+
+	PR fortran/19294
+	* iresolve.c (gfc_resolve_transpose): Resolve to transpose_c4 or
+	transpose_c8 for complex types.
+
+2005-01-23  Kazu Hirata  <kazu@cs.umass.edu>
+
+	* data.c, dependency.c, f95-lang.c, io.c, trans-array.c,
+	trans-decl.c, trans-expr.c, trans-intrinsic.c, trans-io.c,
+	trans-stmt.c, trans-types.c, trans.h: Fix comment typos.
+	Follow spelling conventions.
+
+2005-01-22  Bud Davis  <bdavis9659@comcast.net>
+
+	PR fortran/19313
+	* trans-io.c (gfc_trans_inquire): Added code to support
+	pad.
+
+2005-01-22  Steven G. Kargl  <kargls@comcast.net>
+
+	* intrinsic.c (make_alias):  Add standard argument.
+	(add_functions): Update make_alias calls.
+
+2005-01-22  Paul Brook  <paul@codesourcery.com>
+
+	* trans-expr.c (gfc_conv_function_call): Remove bogus TODO.
+
+2005-01-22  Paul Brook  <paul@codesourcery.com>
+
+	* gfortran.h (gfc_check_access): Add prototype.
+	* match.c (gfc_match_namelist): Remove TODO.
+	* module.c (check_access): Rename ...
+	(gfc_check_access): ... to this.  Boolify.  Update callers.
+	* resolve.c (resolve_symbol): Check for private objects in public
+	namelists.
+
+2005-01-22  Paul Brook  <paul@codesourcery.com>
+
+	* primary.c (gfc_match_rvalue): Only apply implicit type if variable
+	does not have an explicit type.
+	(gfc_match_variable): Resolve implicit derived types in all cases.
+	Resolve contained function types from their own namespace, not the
+	parent.
+	* resolve.c (resolve_contained_fntype): Remove duplicate sym->result
+	checking.  Resolve from the contained namespace, not the parent.
+
+2005-01-22  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/19543
+	* trans-const.c (gfc_conv_constant_to_tree): Give logical
+	constants the correct type.
+
+	PR fortran/19194
+	* trans-io.c (ADD_STRING): Use gfc_charlen_type_node for string
+	length parameters.
+	(gfc_build_io_library_fndecls): 'rec' and 'recl_in' are not
+	pointer fields.
+
+2005-01-18  Kazu Hirata  <kazu@cs.umass.edu>
+
+	* arith.c, array.c, check.c, decl.c, expr.c, f95-lang.c,
+	gfortran.h, interface.c, intrinsic.c, io.c, iresolve.c,
+	match.c, matchexp.c, misc.c, module.c, options.c, parse.c,
+	scanner.c, simplify.c, symbol.c, trans-array.c, trans-expr.c,
+	trans-io.c, trans-stmt.c, trans.c: Update copyright.
+
+2005-01-17  Ira Rosen  <irar@il.ibm.com>
+
+	* f95-lang.c (gfc_init_builtin_functions): Call targetm.init_builtins.
+
+2005-01-16  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/19182
+	* error.c (error_char): Line-buffer errors / warnings.
+
+2005-01-16  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* trans-intrinsic.c (gfc_conv_intrinsic_ishft): Fix signed /
+	unsigned issue.  Use build_int_cst instead of converting
+	integer_zero_node.  Remove unnecessary conversion.
+
+	* trans-types.c (gfc_get_character_type_len): Use
+	gfc_charlen_type_node as basic type for the range field.
+
+	* trans-intrinsic.c (build_fixbound_expr,
+	gfc_conv_intrinsic_bound, gfc_conv_intrinsic_anyall,
+	gfc_conv_intrinsic_count, gfc_conv_intrinsic_btest,
+	gfc_conv_intrinsic_singlebitop): Use 'build_int_cst' instead
+	of converting 'integer_zero_node' or 'integer_one_node'
+	respectively.
+	(gfc_conv_intrinsic_ishftc): Same, but store in local variable to
+	evade re-building.
+	(gfc_conv_intrinsic_strcmp, gfc_conv_intrinsic_rrspacing,
+	gfc_conv_intrinsic_trim, gfc_conv_intrinsic_iargc): Use
+	'build_int_cst' instead of converting 'integer_zero_node' or
+	'integer_one_node' respectively.
+
+	* trans-intrinsic.c (gfc_conv_intrinsic_index,
+	gfc_conv_intrinsic_scan, gfc_conv_intrinsic_verify): Remove
+	'gfc'-prefix from local variable, remove dead code, use correct
+	type when inserting argument.
+
+	* trans-intrinsic.c, trans-types.c: Update copyright years.
+
+2005-01-16  Steven G. Kargl  <kargls@comcast.net>
+
+	PR 19168
+	* resolve.c (check_case_overlap): Typo in comment.
+	(validate_case_label_expr):  Fix up kinds of case values
+	(resolve_select): Properly handle kind mismatches.
+
+2005-01-16  Paul Brook  <paul@codesourcery.com>
+
+	PR fortran/17675
+	* trans-common.c (translate_common): Remove duplicate function call.
+	(finish_equivalences): Preserve alignment when biasing offsets.
+
+2005-01-15  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de
+
+	* primary.c (check_digit): Call 'ISXDIGIT' instead of assuming
+	ASCII-like character encoding.
+
+2005-01-14  Steven G. Kargl  <kargls@comcast.net>
+
+	* resolve.c (compare_case): Cleanup.
+
+2005-01-14  Steven G. Kargl  <kargls@comcast.net>
+
+	* resolve.c (compare_case): Give arguments correct type.
+
+2005-01-13  Kazu Hirata  <kazu@cs.umass.edu>
+
+	* iresolve.c, trans-common.c, trans-types.c: Fix comment
+	typos.
+
+2005-01-09  Paul Brook  <paul@codesourcery.com>
+
+	PR fortran/17675
+	* trans-common.c (current_common, current_offset): Remove.
+	(create_common): Add head argument.
+	(align_segment): New function.
+	(apply_segment_offset): New function.
+	(translate_common): Merge code from new_segment.  Handle alignment.
+	(new_segment): Remove.
+	(finish_equivalences): Ensure proper alignment.
+
+2005-01-08  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* trans-const.c: Don't include unused math.h.
+
+	* trans-intrinsic.c (gfc_get_intrinsic_lib_fndecl,
+	gfc_conv_intrinsic_bound, gfc_conv_intrinsic_minmaxloc,
+	gfc_conv_intrinsic_ishft, gfc_conv_intrinsic_len): Remove
+	trailing whitespace.
+	(prepare_arg_info): Fix formatting, indenting and remove trailing
+	whitespace.
+	(gfc_conv_intrinsic_spacing, gfc_conv_intrinsic_trim): Remove
+	trailing whitespace.
+
+	* arith.c (arctangent2, gfc_arith_init_1, gfc_arith_done_1,
+	gfc_constant_result, gfc_range_check, gfc_arith_power,
+	eval_type_intrinsic0, eval_intrinsic_f2, gfc_real2real,
+	gfc_real2complex, gfc_complex2int, gfc_complex2real,
+	gfc_complex2complex): Fix whitespace issues.
+	* check.c (must_be, type_check, numeric_check, int_or_real_check,
+	logical_array_check, array_check, scalar_check, nonoptional_check,
+	variable_check, dim_check, check_a_kind, gfc_check_a_ikind,
+	gfc_check_a_xkind, gfc_check_abs, gfc_check_all_any,
+	gfc_check_allocated, gfc_check_a_p, gfc_check_besn,
+	gfc_check_btest, gfc_check_char, gfc_check_cmplx, gfc_check_count,
+	gfc_check_cshift, gfc_check_dcmplx, gfc_check_dble,
+	gfc_check_digits, gfc_check_dot_product, gfc_check_eoshift,
+	gfc_check_fnum, gfc_check_g77_math1, gfc_check_huge, gfc_check_i,
+	gfc_check_iand, gfc_check_ibclr, gfc_check_ibits, gfc_check_ibset,
+	gfc_check_idnint, gfc_check_ieor, gfc_check_index, gfc_check_int,
+	gfc_check_ior, gfc_check_ishft, gfc_check_ishftc, gfc_check_kind,
+	gfc_check_lbound, gfc_check_logical, min_max_args,
+	gfc_check_min_max_integer, gfc_check_min_max_real,
+	gfc_check_min_max_double, gfc_check_matmul,
+	gfc_check_minval_maxval, gfc_check_merge, gfc_check_nearest,
+	gfc_check_pack, gfc_check_precision, gfc_check_radix,
+	gfc_check_range, gfc_check_real, gfc_check_repeat,
+	gfc_check_scale, gfc_check_scan, gfc_check_selected_real_kind,
+	gfc_check_set_exponent): Fix formatting issues.
+	(gfc_check_size, gfc_check_sign): Alphabetize function order,
+	remove whitespace-only line.
+	(gfc_check_fstat, gfc_check_fstat_sub, gfc_check_stat,
+	gfc_check_stat_sub, gfc_check_transfer, gfc_check_transpose,
+	gfc_check_ubound, gfc_check_unpack, gfc_check_verify, gfc_check_x,
+	gfc_check_cpu_time, gfc_check_date_and_time, gfc_check_mvbits,
+	gfc_check_random_number, gfc_check_random_seed,
+	gfc_check_second_sub, gfc_check_system_clock,
+	gfc_check_getcwd_sub, gfc_check_exit, gfc_check_flush,
+	gfc_check_umask, gfc_check_umask_sub, gfc_check_unlink,
+	gfc_check_unlink_sub): Fix formatting issues.
+
+2005-01-08  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* gfortran.h: Remove outdated comment.  Don't include stdio.h
+	explicitly.
+
+2005-01-06  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* gfortranspec.c (lang_specific_driver): Change year to 2005 in
+	output of 'gfortran --version'.
+
+2005-01-03  Steven G. Kargl  <kargls@comcast.net>
+
+	* arith.c: Add system.h; remove string.h
+	* decl.c: Ditto
+	* matchexp.c: Ditto
+	* parse.c: Ditto
+	* resolve.c: Ditto
+	* st.c: Ditto
+	* check.c: Remove stdlib.h and stdarg.h
+	* error.c: Remove stdlib.h, stdarg.h, stdio.h, string.h
+	* expr.c: Add system.h; remove stdarg.h, stdio.h, and string.h
+	* f95-lang.c: Add system.h; remove stdio.h
+	* interface.c: Add system.h; remove stdlib.h and string.h
+	* intrinsic.c: Remove stdarg.h, stdio.h, and string.h
+	* io.c: Remove string.h
+	* simplify.c: Ditto
+	* match.c: Remove stdarg.h and string.h
+	* misc.c: Update copyright; add system.h; remove stdlib.h,
+	string.h, and sys/stat.h
+	* module.c: Add system.h; remove string.h, stdio.h, errno.h,
+	unistd.h, and time.h
+	* option.c: Remove string.h and stdlib.h
+	* primary.c: Ditto
+	* scanner.c: Update copyright; add system.h; remove stdlib.h,
+	stdio.h, string.h, and strings.h
+	* symbol.c: Add system.h; remove stdlib.h, stdio.h, and string.h
+	* trans-array.c: Remove stdio.h and gmp.h
+	* trans-const.c: Ditto
+	* trans-expr.c: Ditto
+	* trans-io.c: Ditto
+	* trans-stmt.c: Ditto
+	* trans.c: Ditto
+	* trans-intrinsic.c: Remove stdio.h and string.h
+
+
+Copyright (C) 2005 Free Software Foundation, Inc.
+
+Copying and distribution of this file, with or without modification,
+are permitted in any medium without royalty provided the copyright
+notice and this notice are preserved.
diff --git a/gcc-4.9/gcc/fortran/ChangeLog-2006 b/gcc-4.9/gcc/fortran/ChangeLog-2006
new file mode 100644
index 000000000..4e83f38fe
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/ChangeLog-2006
@@ -0,0 +1,4545 @@
+2006-12-31  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/27900
+	* resolve.c (resolve_actual_arglist): If all else fails and a
+	procedure actual argument has no type, see if a specific
+	intrinsic matches.
+
+	PR fortran/24325
+	* resolve.c (resolve_function): If the function reference is
+	FL_VARIABLE this is an error.
+
+2006-12-31  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/23060
+	* intrinsic.c (compare_actual_formal ): Distinguish argument
+	list functions from keywords.
+	* intrinsic.c (sort_actual): If formal is NULL, the presence of
+	an argument list function actual is an error.
+	* trans-expr.c (conv_arglist_function) : New function to
+	implement argument list functions %VAL, %REF and %LOC.
+	(gfc_conv_function_call): Call it.
+	* resolve.c (resolve_actual_arglist): Add arg ptype and check
+	argument list functions.
+	(resolve_function, resolve_call): Set value of ptype before
+	calls to resolve_actual_arglist.
+	* primary.c (match_arg_list_function): New function.
+	(gfc_match_actual_arglist): Call it before trying for a
+	keyword argument.
+
+2006-12-28  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30034
+	* resolve.c (resolve_formal_arglist): Exclude the test for
+	pointers and procedures for subroutine arguments as well as
+	functions.
+
+	PR fortran/30237
+	* intrinsic.c (remove_nullargs): Do not pass up arguments with
+	a label. If the actual has a label and the formal has a type
+	then emit an error.
+
+2006-12-27  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/30014
+	*io.c (resolve_tag): Don't issue error for tag_size type not being
+	default integer size for -std=F2003.  Add similar check for
+	tag_iolength.
+	*ioparm.def: Change size and iolength parameters to ioint pointer, which
+	corresponds to GFC_IO_INT on the library side.
+
+2006-12-27  Gerald Pfeifer  <gerald@pfeifer.com>
+
+	* interface.c (compare_actual_formal): Remove unused variable
+	gsym.
+
+2006-12-27  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/20896
+	* interface.c (check_sym_interfaces): Try to resolve interface
+	reference as a global symbol, if it is not a nodule procedure.
+	(compare_actual_formal): Remove call to gfc_find_symbol; if
+	the expression is already a variable it is locally declared
+	and this has precedence.
+	gfortran.h : Add prototype for resolve_global_procedure.
+	resolve.c (resolve_global_procedure): Remove static attribute
+	from function declaration.
+	(resolve_fl_procedure): Remove symtree declaration and the
+	redundant check for an ambiguous procedure.
+
+	PR fortran/25135
+	* module.c (load_generic_interfaces): If the symbol is present
+	and is not generic it is ambiguous.
+
+2006-12-22  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/25818
+	* trans-array.c (gfc_trans_g77_array): If the variable is
+	optional or not always present, make the statement conditional
+	on presence of the argument.
+	* gfortran.h : Add symbol_attribute not_always_present.
+	* resolve.c (check_argument_lists): New function to check if
+	arguments are not present in all entries.
+
+	PR fortran/30084
+	* module.c (mio_component_ref): Move treatment of unique name
+	variables, during output, to fix_mio_expr.
+	(fix_mio_expr): New function that fixes defective expressions
+	before they are written to the module file.
+	(mio_expr): Call the new function.
+	(resolve_entries): Call check_argument_lists.
+
+2006-12-21  Roger Sayle  <roger@eyesopen.com>
+
+	* trans-array.c (gfc_trans_create_temp_array): When the size is known
+	at compile-time, avoid an unnecessary conditional assignment.
+	(gfc_array_init_size): Likewise.
+
+2006-12-22  Kazu Hirata  <kazu@codesourcery.com>
+
+	* interface.c: Fix a comment typo.
+
+2006-12-21  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30273
+	* dependency.c (gfc_check_dependency): There is no dependency
+	with EXPR_NULL so always return 0.
+
+2006-12-21  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30202
+	* trans-array.c (gfc_conv_function_call): Use parmse.expr for
+	the nullifying of intent(out) arguments rather than the backend
+	declaration.
+
+2006-12-20  Tobias Schlüter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/25392
+	* trans-stmt.c (gfc_trans_return): Fix comment formatting.
+	* trans-types.c (gfc_sym_type): Don't return early for functions.
+	Remove special handling for -ff2c.
+	(gfc_get_function_type): Add special handling for -ff2c.
+	* trans-decl.c (gfc_create_function_decl): Fix comment formatting.
+	(gfc_get_fake_result_decl): Make sure we get the right type for
+	functions.
+	(gfc_generate_function_code): Convert type of result variable to
+	type of function.
+
+2006-12-20  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30190
+	* trans-array.c (gfc_conv_array_ref): Remove gfc_evaluate_now
+	from the -fbounds-check branch.
+
+2006-12-20  Roger Sayle  <roger@eyesopen.com>
+
+	* trans-expr.c (is_zero_initializer_p): Determine whether a given
+	constant expression is a zero initializer.
+	(gfc_trans_zero_assign): New function to attempt to optimize
+	"a(:) = 0.0" as a call to __builtin_memset (a, 0, sizeof(a));
+	(gfc_trans_assignment): Special case array assignments to a
+	zero initializer constant, using gfc_trans_zero_assign.
+
+2006-12-20  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29992
+	* interface.c (check_sym_interfaces): Module procedures in a
+	generic must be use associated or contained in the module.
+	* decl.c (gfc_match_modproc): Set attribute mod_proc.
+	* gfortran.h (symbol_attribute): Add mod_proc atribute.
+
+	PR fortran/30081
+	* resolve.c (resolve_generic_f, resolve_generic_s): Use
+	gfc_intrinsic_name to find out if the function is intrinsic
+	because it does not have to be a generic intrinsic to be
+	overloaded.
+
+2006-12-19  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/39238
+	* trans-intrinsic.c: Check for associated(NULL,NULL). 
+
+2006-12-19  Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/30236
+	* interface.c (compare_interfaces): Handle NULL symbols.
+	(count_types_test): Count NULL symbols, which correspond to
+	alternate returns.
+
+	(check_interface1): Change final argument from int to bool
+	in the function and all references.
+
+2006-12-18  Roger Sayle  <roger@eyesopen.com>
+
+	* trans-array.c (gfc_conv_array_index_offset): Avoid multiplying
+	index by one, or adding zero to it.
+
+2006-12-17  Roger Sayle  <roger@eyesopen.com>
+
+	PR fortran/30207
+	* dependency.c (gfc_full_array_ref_p): New function to test whether
+	the given array ref specifies the entire array.
+	(gfc_dep_resolver): Use gfc_full_array_ref_p to analyze AR_FULL
+	array refs against AR_SECTION array refs, and vice versa.
+	* dependency.h (gfc_full_array_ref_p): Prototype here.
+	* trans-array.c (gfc_conv_expr_descriptor): Use gfc_full_array_ref_p.
+
+2006-12-16  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* gfortran.texi: Added TeX support for document parts;
+	rearranged existing text into "About GNU Fortran",
+	"Invoking GNU Fortran", and "Language Reference" parts.
+
+2006-12-15  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/30200
+	* trans-io.c (build_dt): Move post block for format_expr to end.
+
+2006-12-14  Richard Guenther  <rguenther@suse.de>
+	    Diego Novillo  <dnovillo@redhat.com>
+
+	* Make-lang.in (fortran/options.o): Add $(PARAMS_H) dependency.
+	* options.c (params.h): Include.
+	(gfc_post_options): Set MAX_ALIASED_VOPS to 50.
+
+2006-12-13  Richard Guenther  <rguenther@suse.de>
+
+	PR fortran/30115
+	* trans-array.c (gfc_array_allocate): Adjust for changed
+	library interface.
+	(gfc_array_deallocate): Likewise.
+	(gfc_trans_dealloc_allocated): Likewise.
+	* trans-stmt.c (gfc_trans_allocate): Likewise.
+	(gfc_trans_deallocate): Likewise.
+	* trans-decl.c (gfc_build_builtin_function_decls): Adjust
+	function declarations to match the library changes.  Mark
+	allocation functions with DECL_IS_MALLOC.
+
+2006-12-12  Tobias Schlüter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* trans-expr.c (gfc_conv_substring): Check for empty substring.
+
+2006-12-11  Jan Hubicka  <jh@suse.cz>
+
+	* f95-lang.c (gfc_expand_function): Update for renamed varpool
+	functions.
+
+2006-12-10  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.texi: Update Fortran 2003 section.
+
+2006-12-10  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/23994
+	* interface.c (compare_actual_formal): PROTECTED is incompatible
+	  with intent(out).
+	* symbol.c (check_conflict): Check for PROTECTED conflicts.
+	  (gfc_add_protected): New function.
+	  (gfc_copy_attr): Copy PROTECTED attribute.
+	* decl.c (match_attr_spec): Add PROTECTED support.
+	  (gfc_match_protected): New function.
+	* dump-parse-tree.c (gfc_show_attr): Add PROTECTED support.
+	* gfortran.h (gfc_symbol): Add protected flag.
+	  Add gfc_add_protected prototype.
+	* expr.c (gfc_check_pointer_assign): Add PROTECTED support.
+	* module.c (ab_attribute, attr_bits, mio_symbol_attribute,
+	  mio_symbol_attribute): Add PROTECTED support.
+	* resolve.c (resolve_equivalence): Add PROTECTED support.
+	* match.c (gfc_match_assignment,gfc_match_pointer_assignment):
+	  Check PROTECTED attribute.
+	* match.h: Add gfc_match_protected prototype.
+	* parse.c (decode_statement): Match PROTECTED statement.
+	* primary.c (match_variable): Add PROTECTED support.
+
+2006-12-09  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29975
+	PR fortran/30068
+	PR fortran/30096
+	* interface.c (compare_type_rank_if): Reject invalid generic
+	interfaces.
+	(check_interface1): Give a warning for nonreferred to ambiguous
+	interfaces.
+	(check_sym_interfaces): Check whether an ambiguous interface is
+	referred to.  Do not check host associated interfaces since these
+	cannot be ambiguous with the local versions.
+	(check_uop_interface, gfc_check_interfaces): Update call to
+	check_interface1.
+	* symbol.c (gfc_get_sym_tree, gfc_get_sym_tree): Allow adding
+	unambiguous procedures to generic interfaces.
+	* gfortran.h (symbol_attribute): Added use_only and
+	ambiguous_interfaces.
+	* module.c (load_need): Set the use_only flag, if needed.
+	* resolve.c (resolve_fl_procedure): Warn for nonreferred
+	interfaces.
+	* expr.c (find_array_section): Fix initializer array contructor.
+
+2006-12-09  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29464
+	* module.c (load_generic_interfaces): Add symbols for all the
+	local names of an interface.  Share the interface amongst the
+	symbols.
+	* gfortran.h : Add generic_copy to symbol_attribute.
+	* symbol.c (free_symbol): Only free interface if generic_copy
+	is not set.
+
+2006-12-09  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29941
+	* resolve.c (resolve_function): Add LEN to the functions not
+	checked for assumed size actual args.
+
+2006-12-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/27546
+	* trans-decl.c (gfc_create_module_variable): Allow imported
+	symbols in interface bodies in modules.
+
+2006-12-06  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/29711
+	* error.c (error_print): Fix handling of printf-style position
+	specifiers of the form "%3$d".
+
+2006-12-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30003
+	* trans-array.c (gfc_trans_create_temp_array): Set the section
+	ends to zero.
+	(gfc_conv_array_transpose): Likewise.
+	(gfc_conv_section_startstride): Declare an expression for end,
+	set it from a the array reference and evaluate it for the info
+	structure. Zero the ends in the ss structure and set end, used
+	in the bounds check, from the info structure.
+	trans.h: Add and end array to the gfc_ss_info structure.
+
+2006-12-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29912
+	* trans-expr.c (gfc_trans_arrayfunc_assign): Return NULL if the
+	lhs and rhs character lengths are not constant and equal for
+	character array valued functions.
+
+2006-12-04  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/29962
+	* expr.c (check_intrinsic_op): Allow noninteger exponents for F2003.
+
+2006-12-04  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29821
+	* resolve.c (resolve_operator): Only return result of
+	gfc_simplify_expr if expression is constant.
+
+2006-12-04  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29916
+	* resolve.c (resolve_symbol): Allow host-associated variables
+	  the specification expression of an array-valued function.
+	* expr.c (check_restricted): Accept host-associated dummy
+	  array indices.
+
+2006-12-03  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29642
+	* trans-expr.c (gfc_conv_variable): A character expression with
+	the VALUE attribute needs an address expression; otherwise all
+	other expressions with this attribute must not be dereferenced.
+	(gfc_conv_function_call): Pass expressions with the VALUE
+	attribute by value, using gfc_conv_expr.
+	* symbol.c (check_conflict): Add strings for INTENT OUT, INOUT
+	and VALUE.  Apply all the constraints associated with the VALUE
+	attribute.
+	(gfc_add_value): New function.
+	(gfc_copy_attr): Call it for VALUE attribute.
+	* decl.c (match_attr_spec): Include the VALUE attribute.
+	(gfc_match_value): New function.
+	* dump-parse-tree.c (gfc_show_attr): Include VALUE.
+	* gfortran.h : Add value to the symbol_attribute structure and
+	add a prototype for gfc_add_value
+	* module.c (mio_internal_string): Include AB_VALUE in enum.
+	(attr_bits): Provide the VALUE string for it.
+	(mio_symbol_attribute): Read or apply the VLUE attribute.
+	* trans-types.c (gfc_sym_type): Variables with the VLAUE
+	attribute are not passed by reference!
+	* resolve.c (was_declared): Add value to those that return 1.
+	(resolve_symbol): Value attribute requires dummy attribute.
+	* match.h : Add prototype for gfc_match_public.
+	* parse.c (decode_statement): Try to match a VALUE statement.
+
+2006-12-01  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR libfortran/29568
+	* gfortran.h (gfc_option_t):  Add max_subrecord_length.
+	(top level): Define MAX_SUBRECORD_LENGTH.
+	* lang.opt:  Add option -fmax-subrecord-length=.
+	* trans-decl.c:  Add new function set_max_subrecord_length.
+	(gfc_generate_function_code): If we are within the main
+	program and max_subrecord_length has been set, call
+	set_max_subrecord_length.
+	* options.c (gfc_init_options):  Add defaults for
+	max_subrecord_lenght, convert and record_marker.
+	(gfc_handle_option):  Add handling for
+	-fmax_subrecord_length.
+	* invoke.texi:  Document the new default for
+	-frecord-marker=<n>.
+
+2006-11-28  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29976
+	* trans-expr.c (gfc_conv_missing_dummy): Remove build_int_const
+	and replace with cast to type of se->expr of integer_zero_node.
+
+2006-11-28  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/20880
+	* resolve.c (resolve_fl_procedure): Error if procedure is
+	ambiguous modified to require attr.referenced.
+
+2006-11-26  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/29892
+	* trans-intrinsic.c (gfc_conv_intrinsic_bound): Use a locus in
+	the call to gfc_trans_runtime_check.
+	* trans-array.c (gfc_trans_array_bound_check): Try harder to find
+	the variable or function name for the runtime error message.
+	(gfc_trans_dummy_array_bias): Use a locus in the call to
+	gfc_trans_runtime_check
+
+2006-11-26  Andrew Pinski  <pinskia@gmail.com>
+
+	* trans-decl.c (gfc_build_intrinsic_function_decls): Mark the
+	pow functions as constant functions.
+
+2006-11-25  Andrew Pinski  <pinskia@gmail.com>
+
+	PR fortran/29982
+	* trans-expr.c (gfc_conv_expr_reference): Strip off NOP_EXPRs.
+
+2006-11-25  Andrew Pinski  <pinskia@gmail.com>
+
+	PR fortran/29951
+	* trans-intrinsic.c (gfc_conv_intrinsic_transfer): Change to
+	call memcpy instead of creating a VIEW_CONVERT_EXRP.
+
+2006-11-25  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/29711
+	* error.c (error_print): Handle printf-style position specifiers,
+	of the form "%3$d".
+
+2006-11-24  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/20880
+	* parse.c (parse_interface): Error if procedure name is that of
+	encompassing scope.
+	* resolve.c (resolve_fl_procedure): Error if procedure is
+	ambiguous.
+
+	PR fortran/29387
+	* interface.c (compare_actual_formal): Add missing condition
+	that 'where' be present for error that asserts that actual
+	arguments be definable.
+
+2006-11-24  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* resolve.c (resolve_actual_arglist): Remove the special case for
+	CHAR.
+	* intrinsic.c (add_functions): Remove the special case for CHAR.
+
+2006-11-22  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/29441
+	* intrinsic.c (gfc_intrinsic_func_interface): Always check if
+	intrinsic is allowed in initialization expression.
+
+2006-11-22  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/25087
+	* resolve.c (resolve_fl_procedure): Add an error if an external
+	automatic character length function does not have an explicit
+	interface.
+
+2006-11-22  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29652
+	* interface.c (check_interface1): Use a local value, instead of
+	the dummy, as the inner iterator over interface symbols.
+
+2006-11-21  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29820
+	* trans-array.c (gfc_get_derived_type): Once done, spread the
+	backend_decl to all identical derived types in all sibling
+	namespaces.
+
+2006-11-20  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/27546
+	* primary.c (gfc_match_rvalue): Added IMPORT support.
+
+2006-11-20  Tobias Burnus  <burnus@net-b.de>
+
+	* symbol.c (check_conflict): Add conflict between VOLATILE
+	  attribute and program name.
+
+2006-11-20  Bernhard Fischer  <aldot@gcc.gnu.org>
+
+	PR fortran/24783
+	* resolve.c (resolve_variable): Get the implicit type from the
+	symbols namespace rather than the default namespace. Fix whitespace.
+	(resolve_formal_arglist, resolve_equivalence): Fix typo.
+
+2006-11-19  Erik Edelmann  <eedelman@gcc.gnu.org>
+
+	* resolve.c (resolve_ref): Check for ALLOCATABLEs to the right of
+	  nonzero rank part references too.
+
+2006-11-19  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* module.c (gfc_use_module): Uncomment the ISO_FORTRAN_ENV code.
+	Check that intrinsic and non-intrinsic modules don't conflict.
+	(use_iso_fortran_env_module): New function.
+	(create_int_parameter): New function.
+	* trans-types.c (gfc_init_kinds): Choose values for
+	gfc_numeric_storage_size and gfc_character_storage_size.
+	(gfc_numeric_storage_size, gfc_character_storage_size): New variables.
+	* resolve.c (resolve_symbol): Do no check intrinsic modules
+	against the list of intrinsic symbols.
+	* iso-fortran-env.def: New file.
+	* gfortran.h (gfc_numeric_storage_size,
+	gfc_character_storage_size): Add prototypes.
+
+2006-11-18  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/24285
+	* io.c (check_format): Allow dollars everywhere in format, and
+	issue a warning.
+
+2006-11-17  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* gfortran.h (gfc_add_intrinsic_modules_path,
+	gfc_open_intrinsic_module): New prototypes.
+	(gfc_add_include_path, gfc_open_included_file): Update prototypes.
+	* lang.opt: Add -fintrinsic-modules-path option.
+	* module.c (gfc_match_use): Match the Fortran 2003 form of
+	USE statement.
+	(gfc_use_module): Also handle intrinsic modules. 
+	* scanner.c (gfc_directorylist): Add use_for_modules for field.
+	(intrinsic_modules_dirs): New static variable.
+	(add_path_to_list, gfc_add_intrinsic_modules_path): New functions.
+	(gfc_add_include_path): Use the new add_path_to_list helper
+	function.
+	(gfc_release_include_path): Free memory for intrinsic_modules_dirs.
+	(open_included_file, gfc_open_intrinsic_module): New functions.
+	(gfc_open_included_file): Use the new open_included_file
+	helper function.
+	* lang-specs.h: Use the new -fintrinsic-modules-path option.
+	* parse.c (decode_statement): Do not match the required space
+	after USE here.
+	* options.c (gfc_handle_option): Handle the new option. Use new
+	prototype for gfc_add_include_path.
+	(gfc_post_options): Use new prototype for gfc_add_include_path.
+
+2006-11-16  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/29391
+	PR fortran/29489
+	* simplify.c (simplify_bound): Fix the simplification of
+	LBOUND/UBOUND intrinsics.
+	* trans-intrinsic.c (simplify_bound): Fix the logic, and
+	remove an erroneous assert.
+
+2006-11-16  Francois-Xavier Coudert  <fxcoudert@gcc.gnu,org>
+
+	* trans-decl.c (gfc_get_symbol_decl): Fix formatting.
+
+2006-11-15  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* data.c: Remove trailing periods from error messages.
+	* decl.c: Likewise.
+	* expr.c: Likewise.
+	* io.c: Likewise.
+	* match.c: Likewise.
+	* module.c: Likewise.
+	* options.c: Likewise.
+	* resolve.c: Likewise.
+	* symbol.c: Likewise.
+	* trans-io.c: Likewise.
+
+2006-11-15  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* lang.opt: Rearrange entries back into ASCII order.
+
+2006-11-15  Tobias Burnus  <burnus@net-b.de>
+
+	* parse.c (parse_contained): Fix indention
+	  of one line.
+
+2006-11-15  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/27546
+	* decl.c (gfc_match_import,variable_decl):
+	  Add IMPORT support.
+	  (gfc_match_kind_spec): Fix typo in gfc_error.
+	* gfortran.h (gfc_namespace, gfc_statement):
+	  Add IMPORT support.
+	* parse.c (decode_statement,gfc_ascii_statement,
+	  verify_st_order): Add IMPORT support.
+	* match.h: Add gfc_match_import.
+	* gfortran.texi: Add IMPORT to the supported
+	  Fortran 2003 features.
+
+2006-11-15  Tobias Burnus  <burnus@net-b.de>
+	    Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/27588
+	* trans-expr.c (gfc_conv_substring): Add bounds checking.
+	  (gfc_conv_variable, gfc_conv_substring_expr): Pass more
+	  arguments to gfc_conv_substring.
+
+2006-11-15  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/29806
+	* parse.c (parse_contained): Check for empty contains statement.
+
+2006-11-15  Bud Davis <bdavis9659@sbcglobal.net>
+
+	PR fortran/28974
+	* gfortran.h (gfc_expr): Add element which holds a splay-tree
+	for the exclusive purpose of quick access to a constructor by
+	offset.
+	* data.c (find_con_by_offset): Use the splay tree for the search.
+	(gfc_assign_data_value): Use the splay tree.
+	(gfc_assign_data_value_range): ditto.
+	* expr.c (gfc_get_expr): Initialize new element to null.
+	(gfc_free_expr): Delete splay tree when deleting gfc_expr.
+
+2006-11-14  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	PR fortran/29702
+	* error.c (show_loci): Move column-offset calculation to
+	show_locus.
+	(show_locus): Remove blank lines before "Included in"
+	lines, clean up code, calculate column-offsets, print
+	column number is error-header lines as appropriate.
+	(error_integer): (new function) Print integer to error
+	buffer.
+	(error_print): Use error_integer, avoid possible buffer
+	overflows from buggy error formats.
+
+2006-11-14  Brooks Moses  <brooks.moses@codesourcery.com>
+ 
+ 	* gfortran.h (GFC_MAX_LINE): Remove constant definition.
+ 	(gfc_option_t): Clarify comments.
+ 	* options.c: Set default line length limits to actual default
+ 	values, rather than flag values.
+ 	* scanner.c: Eliminate checking and handling of the
+ 	fixed/free_line_length flag values.
+
+2006-11-14  Brooks Moses  <brooks.moses@codesourcery.com>
+ 
+ 	* lang.opt: Remove -fno-backend option.
+ 	* gfortran.h (gfc_option_t): Remove flag_no_backend.
+ 	* options.c (gfc_init_options): Remove flag_no_backend.
+ 	(gfc_handle_option): Remove -fno-backend option handler.
+ 	* parse.c (gfc_parse_file): Remove references to
+ 	gfc_option.flag_no_backend.
+
+2006-11-14  Tobias Burnus  <burnus@net-b.de>
+
+	* match.c (gfc_match_namelist): Add missing space to
+	  error message.
+
+2006-11-14  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/29657
+	* symbol.c (check_conflict): Add further conflicts.
+
+2006-11-13  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/29759
+	* fortran/scanner.c (skip_free_comments): Clear openmp_flag
+	before returning true.
+
+2006-11-12  Andrew Pinski  <andrew_pinski@playstation.sony.com>
+
+	PR fortran/26994
+	* trans-expr.c (gfc_conv_expr_reference): Set TREE_STATIC on the
+	new CONST_DECL.
+
+2006-11-11  Tobias Schlüter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* array.c: Add 2006 to copyright years.
+	* data.c: Same.
+	* interface.c: Same.
+	* misc.c: Same.
+	* trans-io.c: Same.
+
+2006-11-11  Richard Guenther  <rguenther@suse.de>
+
+	* trans-intrinsic.c (enum rounding_mode): New enum.
+	(build_fix_expr, gfc_conv_intrinsic_aint, gfc_conv_intrinsic_mod,
+	gfc_conv_intrinsic_function): Use it instead of FIX_CEIL_EXPR,
+	FIX_FLOOR_EXPR, FIX_ROUND_EXPR and FIX_TRUNC_EXPR.
+
+2006-11-10  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* lang.opt (-fmodule-private): Remove option.
+	* gfortran.h (gfc_option_t): Remove module_access_private flag.
+	* options.c (gfc_init_options): Remove initialization for it.
+	(gfc_handle_option): Remove handling for -fmodule-private.
+	* module.c (gfc_check_access): Add comments, remove check for
+	gfc_option.flag_module_access_private.
+
+2006-11-10 Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/29758
+	* check.c (gfc_check_reshape): Check that there are enough
+	elements in the source array as to be able to fill an array
+	defined by shape, when pad is absent.
+
+2006-11-10 Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/29315
+	* trans-expr.c (is_aliased_array): Treat correctly the case where the
+	component is itself and array or array reference.
+
+2006-11-09  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* check.c (same_type_check): Typo fix in comment.
+
+2006-11-09 Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/29431
+	* trans-array.c    (get_array_ctor_strlen): If we fall through to
+	default, use a constant character length if it is available.
+
+2006-11-09 Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/29744
+	* trans-types.c (gfc_get_derived_type): Ensure that the
+	proc_name namespace is not the same as the owner namespace and
+	that identical derived types in the same namespace share the
+	same backend_decl.
+
+2006-11-09 Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/29699
+	* trans-array.c (structure_alloc_comps): Detect pointers to
+	arrays and use indirect reference to declaration.
+	* resolve.c (resolve_fl_variable): Tidy up condition.
+	(resolve_symbol): The same and only add initialization code if
+	the symbol is referenced.
+	* trans-decl.c (gfc_trans_deferred_vars): Call gfc_trans_
+	deferred_array before gfc_trans_auto_array_allocation.
+
+	PR fortran/21370
+	* symbol.c (check_done): Remove.
+	(gfc_add_attribute): Remove reference to check_done and remove
+	the argument attr_intent.
+	(gfc_add_allocatable, gfc_add_dimension, gfc_add_external,
+	gfc_add_intrinsic, gfc_add_optional, gfc_add_pointer,
+	gfc_add_cray_pointer, gfc_add_cray_pointee, gfc_add_result,
+	gfc_add_target, gfc_add_in_common, gfc_add_elemental,
+	gfc_add_pure, gfc_add_recursive, gfc_add_procedure,
+	gfc_add_type): Remove references to check_done.
+	* decl.c (attr_decl1): Eliminate third argument in call to
+	gfc_add_attribute.
+	* gfortran.h : Change prototype for gfc_add_attribute.
+
+2006-11-08  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* invoke.texi: Added documentation for -fmax-errors option.
+
+2006-11-08  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* lang.opt: Add -fmax-errors= option.
+	* gfortran.h (gfc_option_t): Add max_errors element.
+	* options.c (gfc_init_options): Set max_errors default value
+	to 25.
+	(gfc_handle_options): Assign -fmax_errors value to
+	gfc_option.max_errors.
+	* error.c (gfc_increment_error_count): New function, which
+	also checks whether the error count exceeds max_errors.
+	(gfc_warning): Use it.
+	(gfc_warning_now): Use it.
+	(gfc_notify_std): Use it.
+	(gfc_error): Use it.
+	(gfc_error_now): Use it.
+	(gfc_error_check): Use it.
+
+2006-11-08  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* lang.opt: Remove non-working -qkind= option.
+	* gfortran.h (gfc_option_t): Remove q_kind member.
+	* options.c (gfc_init_options): Remove q_kind initialization.
+	(gfc_handle_option): Remove -qkind= option handling.
+	* primary.c: (match_real_constant): Remove 'Q' exponent.
+
+2006-11-08  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.texi: Add volatile and internal-file
+	  namelist to Fortran 2003 status.
+	* intrinsic.texi: Correct CHMOD entry.
+
+2006-11-07  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29539
+	PR fortran/29634
+	* decl.c (variable_decl): Add test for presence of proc_name.
+	* error.c (gfc_error_flag_test): New function.
+	* gfortran.h : Prototype for gfc_error_flag_test.
+
+2006-11-07  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/29601
+	* symbol.c (check_conflict, gfc_add_volatile): Add volatile support.
+	* decl.c (match_attr_spec, gfc_match_volatile): Add volatile support.
+	* gfortran.h (symbol_attribute): Add volatile_ to struct.
+	* resolve.c (was_declared): Add volatile support.
+	* trans-decl.c (gfc_finish_var_decl): Add volatile support.
+	* match.h: Declare gfc_match_volatile.
+	* parse.c (decode_statement): Recognize volatile.
+	* modules.c (ab_attribute, attr_bits, mio_symbol_attribute):
+	  Add volatile support.
+	* dump-parse-tree.c (gfc_show_attr): Add volatile support.
+
+2006-11-06  Tobias Burnus  <burnus@net-b.de>
+
+	* decl.c (match_attr_spec, gfc_match_enum): Unify gfc_notify_std
+	  message for GFC_STD_F2003.
+	* array.c (gfc_match_array_constructor): Unify gfc_notify_std
+	  message for GFC_STD_F2003.
+	* io.c (check_io_constraints): Unify gfc_notify_std message for
+	  GFC_STD_F2003.
+	* resolve.c (resolve_actual_arglist): Unify gfc_notify_std message
+	  for GFC_STD_F2003.
+
+2006-11-06  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* intrinsic.texi: Added documentation for FTELL, GETLOG, and
+	HOSTNM intrinsics.
+
+2006-11-06  Erik Edelmann  <eedelman@gcc.gnu.org>
+
+	PR fortran/29630
+	PR fortran/29679
+	* expr.c (find_array_section): Support vector subscripts.  Don't
+	  add sizes for dimen_type == DIMEN_ELEMENT to the shape array.
+
+2006-11-05  Bernhard Fischer  <aldot@gcc.gnu.org>
+
+	PR fortran/21061
+	* error.c (gfc_warning): If warnings_are_errors then treat
+	warnings as errors with respect to the exit code.
+	(gfc_notify_std): Ditto.
+	(gfc_warning_now): Ditto.
+
+2006-11-05  Francois-Xavier Coudert  <fxcoudert@gcc.gnu,org>
+	    Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/24518
+	* trans-intrinsic.c (gfc_conv_intrinsic_mod): Use built_in fmod
+	for both MOD and MODULO, if it is available.
+
+	PR fortran/29565
+	* trans-expr.c (gfc_conv_aliased_arg): For an INTENT(OUT), save
+	the declarations from the unused loops by merging the block
+	scope for each; this ensures that the temporary is declared.
+
+2006-11-04  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* error.c (show_locus): Add trailing colon in error messages.
+	(error_print): Avoid leading space in error lines.
+
+2006-11-04  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/29713
+	* expr.c (gfc_simplify_expr): Correct memory allocation.
+
+2006-11-02  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* error.c (show_locus): Remove "In file" from error messages.
+
+2006-10-31  Geoffrey Keating  <geoffk@apple.com>
+
+	* trans-decl.c (gfc_generate_constructors): Update for removal
+	of get_file_function_name.
+
+2006-11-01  Bernhard Fischer  <aldot@gcc.gnu.org>
+
+	PR fortran/29537
+	* trans-common.c (gfc_trans_common): If the blank common is
+	in a procedure or program without a name then proc_name is null, so
+	use the locus of the common.
+	(gfc_sym_mangled_common_id): Fix whitespace.
+	* match.c (gfc_match_common): Emit warning about blank common in
+	block data.
+
+2006-10-31  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/29067
+	* decl.c (gfc_set_constant_character_len): NULL-terminate the
+	character constant string.
+	* data.c (create_character_intializer): Likewise.
+	* expr.c (gfc_simplify_expr): NULL-terminate the substring
+	character constant.
+	* primary.c (match_hollerith_constant): NULL-terminate the
+	character constant string.
+
+2006-10-31  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29387
+	* trans-intrinsic.c (gfc_conv_intrinsic_len): Rearrange to have
+	a specific case for EXPR_VARIABLE and, in default, build an ss
+	to call gfc_conv_expr_descriptor for array expressions..
+
+	PR fortran/29490
+	* trans-expr.c (gfc_set_interface_mapping_bounds): In the case
+	that GFC_TYPE_ARRAY_LBOUND is not available, use descriptor
+	values for it and GFC_TYPE_ARRAY_UBOUND.
+
+	PR fortran/29641
+	* trans-types.c (gfc_get_derived_type): If the derived type
+	namespace has neither a parent nor a proc_name, set NULL for
+	the search namespace.
+
+2006-10-30  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/29452
+	* io.c (check_io_constraints): Fix keyword string comparison.
+
+2006-10-30  Andrew Pinski  <pinskia@gmail.com>
+
+	PR fortran/29410
+	* trans-intrinsic.c (gfc_conv_intrinsic_array_transfer):
+	Change over to create VIEW_CONVERT_EXPR instead of using an
+	ADDR_EXPR, a cast and then an indirect reference
+
+2006-10-29  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* trans-intrinsic.c (gfc_conv_intrinsic_loc): Make LOC return a
+	signed integer node.
+
+2006-10-29  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/17741
+	* decl.c (get_proc_name): Bump current namespace refs count.
+
+2006-10-29  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/29629
+	* trans-openmp.c (gfc_trans_omp_array_reduction): Set attr.flavor
+	of init_val_sym and outer_sym to FL_VARIABLE.
+
+2006-10-29  Kazu Hirata  <kazu@codesourcery.com>
+
+	* intrinsic.texi: Fix a typo.
+
+2006-10-27  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* gfortran.h: Remove GFC_MPFR_TOO_OLD.
+	* arith.c (arctangent2): Remove function
+	(gfc_check_real_range): Remove subnormal kludge.
+	* arith.h: Remove arctangent2 prototype.
+	* simplify.c: (gfc_simplify_atan2): Remove use of arctangent2.
+	(gfc_simplify_exponent, gfc_simplify_log, gfc_simplify_nearest,
+	gfc_simplify_rrspacing, gfc_simplify_spacing): Remove mpfr kludges.
+
+2006-10-28  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/28224
+	* io.c (check_io_constraints): Allow namelists
+	  for internal files for Fortran 2003.
+
+2006-10-27  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/27954
+	* decl.c (gfc_free_data_all): New function to free all data structures
+	after errors in DATA statements and declarations.
+	(top_var_list): Use new function.(top_val_list): Use new function.
+	(gfc_match_data_decl): Use new function.
+	* misc.c (gfc_typename): Fixed incorrect function name in error text. 
+
+2006-10-24  Erik Edelmann  <eedelman@gcc.gnu.org>
+
+	PR fortran/29393
+	* expr.c (simplify_parameter_variable): Keep rank of original
+	expression.
+
+2006-10-23 Rafael Ávila de Espíndola  <rafael.espindola@gmail.com>
+
+	* Make-lang.in (f951$(exeext)): Depend on and link with attribs.o.
+	* trans.h (builtin_function): Rename to	gfc_builtin_function.
+	Change the signature.
+	* 95-lang.c (LANG_HOOKS_BUILTIN_FUNCTION): Define as
+	gfc_builtin_function.
+	(builtin_function): Rename to gfc_builtin_function. Move common
+	code to builtin_function.
+	(gfc_define_builtin): Replace calls to builtin_function with
+	gfc_define_builtin.
+
+2006-10-22  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/26025
+	* lang.opt: Add -fexternal-blas and -fblas-matmul-limit options.
+	* options.c (gfc_init_options): Initialize new flags.
+	(gfc_handle_option): Handle new flags.
+	* gfortran.h (gfc_option): Add flag_external_blas and
+	blas_matmul_limit flags.
+	* trans-expr.c (gfc_conv_function_call): Use new argument
+	append_args, appending it at the end of the argument list
+	built for a function call.
+	* trans-stmt.c (gfc_trans_call): Use NULL_TREE for the new
+	append_args argument to gfc_trans_call.
+	* trans.h (gfc_conv_function_call): Update prototype.
+	* trans-decl.c (gfc_build_intrinsic_function_decls): Add
+	prototypes for BLAS ?gemm routines.
+	* trans-intrinsic.c (gfc_conv_intrinsic_funcall): Generate the
+	extra arguments given to the library matmul function, and give
+	them to gfc_conv_function_call.
+	* invoke.texi: Add documentation for -fexternal-blas and
+	-fblas-matmul-limit.
+
+2006-10-21  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
+
+	* Make-lang.in (F95_LIBS): Delete.
+	* f951$(exeext): Use $(LIBS) instead of $(F95_LIBS).
+	* config-lang.in (need_gmp): Delete.
+
+2006-10-19  Brooks Moses  <bmoses@stanford.edu>
+
+	* invoke.texi: Fixed "denormal" typo.
+
+2006-10-19  Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/29216
+	PR fortran/29314
+	* gfortran.h : Add EXEC_INIT_ASSIGN.
+	* dump-parse-tree.c (gfc_show_code_node): The same.
+	* trans-openmp.c (gfc_trans_omp_array_reduction): Set new
+	argument for gfc_trans_assignment to false.
+	* trans-stmt.c (gfc_trans_forall_1): The same.
+	* trans-expr.c (gfc_conv_function_call, gfc_trans_assign,
+	gfc_trans_arrayfunc_assign, gfc_trans_assignment): The
+	same. In the latter function, use the new flag to stop
+	the checking of the lhs for deallocation.
+	(gfc_trans_init_assign): New function.
+	* trans-stmt.h : Add prototype for gfc_trans_init_assign.
+	* trans.c (gfc_trans_code): Implement EXEC_INIT_ASSIGN.
+	* trans.h : Add new boolean argument to the prototype of
+	gfc_trans_assignment.
+	* resolve.c (resolve_allocate_exp): Replace EXEC_ASSIGN by
+	EXEC_INIT_ASSIGN.
+	(resolve_code): EXEC_INIT_ASSIGN does not need resolution.
+	(apply_default_init): New function.
+	(resolve_symbol): Call it for derived types that become
+	defined but which do not already have an initialization
+	expression..
+	* st.c (gfc_free_statement): Include EXEC_INIT_ASSIGN.
+
+2006-10-16  Tobias Burnus  <burnus@net-b.de>
+
+	* primary.c: Revert 'significand'-to-'significant' comment change.
+	* invoke.texi (Warning Options): Minor cleanup for
+	  -Wimplicit-interface.
+
+2006-10-17  Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/29451
+	* trans-array.c (gfc_trans_array_bounds): Test for and set
+	negative stride of a non-constant bound array to zero.
+
+	PR fortran/29392
+	* data.c (create_character_intializer): Copy and simplify
+	the expressions for the start and end of a sub-string
+	reference.
+
+2006-10-16  Kaz Kojima  <kkojima@rr.iij4u.or.jp>
+
+	* io.c (gfc_match_close): Ensure that status is terminated by
+	a NULL element.
+
+2006-10-16  Tobias Burnus  <burnus@net-b.de>
+
+	* trans-stmt.c: Fix a typo
+	* invoke.texi: Fix typos
+	* resolve.c: Fix a comment typo
+	* trans-decl.c: Fix a comment typo
+	* primary.c: Fix a comment typo
+
+2006-10-15  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/29403
+	* io.c (match_io):  Check for a default-char-expr for PRINT format.
+
+2006-10-15  Bernhard Fischer  <aldot@gcc.gnu.org>
+
+	PR fortran/24767
+	* lang.opt (Wunused-labels): Remove.
+	* options.c: Remove references to gfc_option.warn_unused_labels.
+	* gfortran.h: Remove variable warn_unused_labels.               
+	* resolve.c (warn_unused_fortran_label) : Use warn_unused_label
+	instead of gfc_option.warn_unused_labels.
+	* invoke.texi: Remove documentation of -Wunused-labels.
+
+2006-10-14  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.texi: Add link to GFortran apps
+	* intrinsic.texi: Updated documentation of ACCESS and CHMOD
+
+2006-10-14  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/19261
+	* scanner.c (load_line): Add checks for illegal use of '&' and issue
+	warnings.  Issue errors with -pedantic.
+
+2006-10-14 Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/29371
+	* trans-expr.c (gfc_trans_pointer_assignment): Add the expression
+	for the assignment of null to the data field to se->pre, rather
+	than block.	
+
+2006-10-14  Kazu Hirata  <kazu@codesourcery.com>
+
+	* intrinsic.texi: Fix typos.
+	* trans-array.c: Fix a comment typo.
+
+2006-10-13  Brooks Moses  <bmoses@stanford.edu>
+
+	* intrinsic.texi (STAT): Reverted a format in example code to
+	octal; noted this in accompanying string.
+
+2006-10-13 Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/29373
+	* decl.c (get_proc_name, gfc_match_function_decl): Add
+	attr.implicit_type to conditions that throw error for
+	existing explicit interface and that allow new type-
+	spec to be applied.
+
+	PR fortran/29407
+	* resolve.c (resolve_fl_namelist): Do not check for
+	namelist/procedure conflict, if the symbol corresponds
+	to a good local variable declaration.
+
+	PR fortran/27701
+	* decl.c (get_proc_name): Replace the detection of a declared
+	procedure by the presence of a formal argument list by the
+	attributes of the symbol and the presence of an explicit
+	interface.
+
+	PR fortran/29232
+	* resolve.c (resolve_fl_variable): See if the host association
+	of a derived type is blocked by the presence of another type I
+	object in the current namespace.
+
+	PR fortran/29364
+	* resolve.c (resolve_fl_derived): Check for the presence of
+	the derived type for a derived type component.
+
+	PR fortran/24398
+	* module.c (gfc_use_module): Check that the first words in a
+	module file are 'GFORTRAN module'.
+
+	PR fortran/29422
+	* resolve.c (resolve_transfer): Test functions for suitability
+	for IO, as well as variables.
+
+	PR fortran/29428
+	* trans-expr.c (gfc_trans_scalar_assign): Remove nullify of
+	rhs expression.
+
+2006-10-13  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/29391
+	* trans-intrinsic.c (gfc_conv_intrinsic_bound): Generate correct
+	code for LBOUND and UBOUND intrinsics.
+
+2006-10-13  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/21435
+	* io.c (compare_to_allowed_values): New function.
+	(gfc_match_open): Add checks for constant values of specifiers.
+	(gfc_match_close): Add checks for constant values of the STATUS
+	specifier.
+
+2006-10-12  Brooks Moses  <bmoses@stanford.edu>
+
+	* intrinsic.texi (STAT): Fixed a format typo in sample code.
+
+2006-10-12  Brooks Moses  <bmoses@stanford.edu>
+
+	* intrinsic.texi (STAT): Shortened lines in sample code.
+
+2006-10-11  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* gfortran.h (gfc_show_actual_arglist, gfc_show_array_ref,
+	gfc_show_array_spec, gfc_show_attr, gfc_show_code,
+	gfc_show_components, gfc_show_constructor, gfc_show_equiv,
+	gfc_show_expr, gfc_show_namelist, gfc_show_ref, gfc_show_symbol,
+	gfc_show_typespec): Add prototypes.
+	* dump-parse-tree.c (gfc_show_actual_arglist, gfc_show_array_ref,
+	gfc_show_array_spec, gfc_show_attr, gfc_show_code,
+	gfc_show_components, gfc_show_constructor, gfc_show_equiv,
+	gfc_show_expr, gfc_show_namelist, gfc_show_ref, gfc_show_symbol,
+	gfc_show_typespec): Remove 'static' from declaration.
+
+2006-10-10  Brooks Moses  <bmoses@stanford.edu>
+
+	* invoke.texi, gfortran.texi: Corrected erronous dashes.
+
+2006-10-10  Brooks Moses  <bmoses@stanford.edu>
+
+	* Make-lang.in: Added "fortran.pdf", "gfortran.pdf" target
+	support.
+
+2006-10-10  Daniel Franke  <franke.daniel@gmail.com>
+
+	* intrinsic.texi: added documentation for FSTAT, GETARG,GET_COMMAND,
+	GET_COMMAND_ARGUMENT, GETENV, GET_ENVIRONMENT_VARIABLE, IAND, IARGC,
+	LSTAT and STAT, removed the reference to PR19292 from ACCESS, CHMOD,
+	GMTIME, LSHIFT, LTIME, RSHIFT.
+
+2006-10-10  Brooks Moses  <bmoses@stanford.edu>
+
+	* gfortran.texi (Standards): Update to current status.
+
+2006-10-09  Brooks Moses  <bmoses@stanford.edu>
+
+	* Make-lang.in: Added intrinsic.texi to GFORTRAN_TEXI
+	dependences.
+
+2006-10-09  Brooks Moses  <bmoses@stanford.edu>
+
+	* intrinsic.texi (MOVE_ALLOC): changed "Options" to "Standards".
+
+2006-10-09  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* gfortran.h: Define GFC_MPFR_TOO_OLD via mpfr version info.
+	* arith.c (arctangent, gfc_check_real_range): Use it.	
+	* simplify.c (gfc_simplify_atan2, gfc_simplify_exponent,
+	gfc_simplify_log, gfc_simplify_nearest): Use it.
+
+	PR fortran/15441
+	PR fortran/29312
+	* iresolve.c (gfc_resolve_rrspacing): Give rrspacing library
+	routine hidden precision argument.
+	(gfc_resolve_spacing): Give spacing library routine hidden
+	precision, emin - 1, and tiny(x) arguments.
+	* simplify.c (gfc_simplify_nearest): Remove explicit subnormalization.
+	(gfc_simplify_rrspacing): Implement formula from Fortran 95 standard.
+	(gfc_simplify_spacing): Implement formula from Fortran 2003 standard.
+	* trans-intrinsic.c (gfc_intrinsic_map_t) Declare rrspacing and
+	spacing via LIBF_FUNCTION
+	(prepare_arg_info, call_builtin_clz, gfc_conv_intrinsic_spacing,
+	gfc_conv_intrinsic_rrspacing): Remove functions.
+	(gfc_conv_intrinsic_function): Remove calls to
+	gfc_conv_intrinsic_spacing and gfc_conv_intrinsic_rrspacing.
+	* f95-lang.c (gfc_init_builtin_functions): Remove __builtin_clz,
+	__builtin_clzl and __builtin_clzll
+
+2006-10-09  Richard Henderson  <rth@redhat.com>
+
+	Revert emutls patch.
+
+2006-10-09  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* intrinsic.c (add_sym_0s, add_sym_1s, add_sym_2s, add_sym_3s,
+	add_sym_4s, add_sym_5s, add_functions): Use macro ACTUAL_NO,
+	ACTUAL_YES, NOT_ELEMENTAL and ELEMENTAL instead of constants
+	0 and 1 as second and third arguments to add_sym* functions.
+
+2006-10-08  Erik Edelmann <edelmann@gcc.gnu.org>
+	    Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/20541
+	* interface.c (gfc_compare_derived_types): Add comparison of
+	the allocatable field.
+	* intrinsic.c (add_subroutines): Add MOVE_ALLOC.
+	* trans-expr.c (gfc_conv_aliased_arg, gfc_trans_subarray_assign,
+	gfc_trans_subcomponent_assign, gfc_conv_string_parameter,
+	gfc_trans_scalar_assign): Add extra arguments l_is_temp
+	and r_is_var to references to latter function.
+	(gfc_conv_function_call): Add enum for types of argument and
+	an associated variable parm_kind. Deallocate components of
+	INTENT(OUT) and non-variable arrays.
+	(gfc_trans_subcomponent_assign): Add block to assign arrays
+	to allocatable components.
+	(gfc_trans_scalar_assign): Add block to handle assignments of
+	derived types with allocatable components, using the above new
+	arguments to control allocation/deallocation of memory and the
+	copying of allocated arrays.
+	* trans-array.c (gfc_array_allocate): Remove old identification 
+	of pointer and replace with that of an allocatable array. Add
+	nullify of structures with allocatable components. 
+	(gfc_conv_array_initializer): Treat EXPR_NULL.
+	(gfc_conv_array_parameter): Deallocate allocatable components
+	of non-variable structures.
+	(gfc_trans_dealloc_allocated): Use second argument of library
+	deallocate to inhibit, without error, freeing NULL pointers.
+	(get_full_array_size): New function to return the size of a
+	full array.
+	(gfc_duplicate_allocatable): New function to allocate and copy
+	allocated data.
+	(structure_alloc_comps): New recursive function to deallocate,
+	nullify or copy allocatable components.
+	(gfc_nullify_alloc_comp, gfc_deallocate_alloc_comp,
+	gfc_copy_alloc_comp): New interface functions to call previous.
+	(gfc_trans_deferred_array): Add the code to nullify allocatable
+	components, when entering scope, and to deallocate them on
+	leaving. Do not call gfc_trans_static_array_pointer and return
+	for structures with allocatable components and default
+	initializers.
+	* symbol.c (gfc_set_component_attr): Set allocatable field.
+	(gfc_get_component_attr): Set the allocatable attribute.
+	* intrinsic.h : Prototype for gfc_check_move_alloc.
+	* decl.c (build_struct): Apply TR15581 constraints for
+	allocatable components.
+	(variable_decl): Default initializer is always NULL for
+	allocatable components.
+	(match_attr_spec): Allow, or not, allocatable components,
+	according to the standard in force.
+	* trans-array.h : Prototypes for gfc_nullify_alloc_comp,
+	gfc_deallocate_alloc_comp, gfc_copy_alloc_comp and
+	gfc_duplicate_allocatable.
+	* gfortran.texi : Add mention of TR15581 extensions.
+	* gfortran.h : Add attribute alloc_comp, add
+	gfc_components field allocatable and add the prototype
+	for gfc_expr_to_initialize.
+	* trans-stmt.c (generate_loop_for_temp_to_lhs,
+	generate_loop_for_rhs_to_temp, gfc_trans_where_assign,
+	gfc_trans_where_3): Add extra arguments to calls to
+	gfc_trans_scalar_assign and set appropriately.
+	(gfc_trans_allocate): Nullify allocatable components.
+	(gfc_trans_deallocate): Deallocate to ultimate allocatable
+	components but stop at ultimate pointer components.
+	* module.c (mio_symbol_attribute, mio_symbol_attribute,
+	mio_component): Add module support for allocatable
+	components.
+	* trans-types.c (gfc_get_derived_type): Treat allocatable
+	components.
+	* trans.h : Add two boolean arguments to
+	gfc_trans_scalar_assign.
+	* resolve.c (resolve_structure_cons): Check conformance of
+	constructor element and the component.
+	(resolve_allocate_expr): Add expression to nullify the
+	constructor expression for allocatable components.
+	(resolve_transfer): Inhibit I/O of derived types with
+	allocatable components.
+	(resolve_fl_derived): Skip check of bounds of allocatable
+	components.
+	* trans-decl.c (gfc_get_symbol_decl): Add derived types
+	with allocatable components to deferred variable.
+	(gfc_trans_deferred_vars): Make calls for derived types
+	with allocatable components to gfc_trans_deferred_array.
+	(gfc_generate_function_code): Nullify allocatable
+	component function result on entry.
+	* parse.c (parse_derived): Set symbol attr.allocatable if
+	allocatable components are present.
+	* check.c (gfc_check_allocated): Enforce attr.allocatable
+	for intrinsic arguments.
+	(gfc_check_move_alloc): Check arguments of move_alloc.
+	* primary.c (gfc_variable_attr): Set allocatable attribute.
+	* intrinsic.texi : Add index entry and section for
+	for move_alloc.
+
+2006-10-08  Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/29115
+	* resolve.c (resolve_structure_cons): It is an error if the
+	pointer component elements of a derived type constructor are
+	not pointer or target.
+
+
+	PR fortran/29211
+	* trans-stmt.c (generate_loop_for_temp_to_lhs,
+	generate_loop_for_rhs_to_temp): Provide a string length for
+	the temporary by copying that of the other side of the scalar
+	assignment.
+
+2006-10-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/28585
+	* intrinsic.c (add_functions): Add new_line Fortran 2003 intrinsic.
+	* intrinsic.h: Add gfc_simplify_new_line and gfc_check_new_line
+	prototypes.
+	* check.c (gfc_check_new_line): New function.
+	* simplify.c (gfc_simplify_new_line): New function.
+	* intrinsic.texi: Document new_line intrinsic.
+
+2006-10-07  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/16580
+	PR fortran/29288
+	* gcc/fortran/intrinsic.c (add_sym): Define the actual_ok when a
+	gfc_intrinsic_sym structure is filled.
+	(gfc_intrinsic_actual_ok): New function.
+	(add_sym_0s, add_sym_1s, add_sym_2s, add_sym_3s, add_sym_4s,
+	add_sym_5s): Intrinsic subroutines are not allowed as actual
+	arguments, so we remove argument actual_ok.
+	(add_functions): Correct the values for actual_ok of all intrinsics.
+	Add comments for gfc_check_access_func and gfc_resolve_index_func.
+	(add_subroutines): Remove the actual_ok argument, which was never used.
+	* gcc/fortran/intrinsic.h (gfc_intrinsic_actual_ok): New prototype.
+	* gcc/fortran/gfortran.h (gfc_resolve_index_func): New prototype.
+	* gcc/fortran/resolve.c (resolve_actual_arglist): Check whether
+	an intrinsic used as an argument list is allowed there.
+	* gcc/fortran/iresolve.c (gfc_resolve_index_func): New function.
+	(gfc_resolve_len): Change intrinsic function name to agree with
+	libgfortran.
+	* gcc/fortran/trans-decl.c (gfc_get_extern_function_decl): Add
+	new case, because some specific intrinsics take 3 arguments.
+	* gcc/fortran/intrinsic.texi: DIMAG is a GNU extension.
+
+2006-10-06  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/28415
+	* trans-decl.c (gfc_finish_var_decl): With -fno-automatic, don't
+	make artificial variables or pointer to variable automatic array
+	TREE_STATIC.
+
+	* scanner.c (skip_free_comments): Return bool instead of void.
+	(gfc_next_char_literal): Don't return ' ' if & is missing after
+	!$omp or !$.  Use skip_{free,fixed}_comments directly instead
+	of gfc_skip_comments.
+
+2006-10-04  Brooks Moses  <bmoses@stanford.edu>
+
+	* gfortran.texi: (Current Status): update and rewrite to reflect
+	actual status more accurately.
+
+2006-10-04  Brooks Moses  <bmoses@stanford.edu>
+
+	* gfortran.texi: Consistently refer to the compiler as "GNU
+	Fortran".
+	* intrinsic.texi: Ditto.
+	* invoke.texi: Ditto.
+
+2006-10-04  Richard Henderson  <rth@redhat.com>
+	    Jakub Jelinek  <jakub@redhat.com>
+
+	* f95-lang.c (gfc_init_builtin_functions): Add __emutls_get_address
+	and __emutls_register_common.
+	* openmp.c (gfc_match_omp_threadprivate): Don't error if !have_tls.
+	* trans-common.c (build_common_decl): Don't check have_tls.
+	* trans-decl.c (gfc_finish_var_decl): Likewise.
+	* types.def (BT_WORD, BT_FN_PTR_PTR): New.
+	(BT_FN_VOID_PTR_WORD_WORD_PTR): New.
+
+2006-10-04  Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/29343
+	* resolve.c (resolve_allocate_expr): Exclude derived types from
+	search for dependences between allocated variables and the
+	specification expressions for other allocations in the same
+	statement.
+
+2006-10-04  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29098
+	* resolve.c (resolve_structure_cons): Do not return FAILURE if
+	component expression is NULL.
+
+2006-10-03  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/20779
+	PR fortran/20891
+	* resolve.c (find_sym_in_expr): New function that returns true
+	if a symbol is found in an expression.
+	(resolve_allocate_expr): Check whether the STAT variable is
+	itself allocated in the same statement.  Use the call above to
+	check whether any of the allocated arrays are used in array
+	specifications in the same statement.
+
+2006-10-03  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* arith.c (gfc_check_real_range):  Use correct exponent range for
+	subnormal numbers.
+
+2006-10-03  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29284
+	PR fortran/29321
+	PR fortran/29322
+	* trans-expr.c (gfc_conv_function_call): Check the expression
+	and the formal symbol are present when testing the actual
+	argument.
+
+	PR fortran/25091
+	PR fortran/25092
+	* resolve.c (resolve_entries): It is an error if the entries
+	of an array-valued function do not have the same shape.
+
+2006-10-03  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR middle-end/27478
+	* trans-decl.c (gfc_get_fake_result_decl): Mark var as
+	TREE_ADDRESSABLE.
+
+2006-10-02  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/19262
+	* gfortran.h (gfc_option_t): Add max_continue_fixed and
+	max_continue_free.
+	* options.c (gfc_init_options): Initialize fixed form and free form
+	consecutive continuation line limits.
+	* scanner.c (gfc_scanner_init_1): Initialize continue_line
+	and continue_count. (gfc_next_char_literal): Count the number of
+	continuation lines in the current statement and warn if limit
+	is exceeded.
+
+2006-10-02  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/19260
+	* scanner.c (gfc_next_char_literal): Add check for missing '&'
+	and warn if in_string, otherwise return ' '.
+
+2006-10-02  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/29210
+	* primary.c (match_sym_complex_part): Named constants as real or
+	imaginary part of complex a named constant are only allowed in
+	Fortran 2003.
+
+2006-10-01  Brooks Moses  <bmoses@stanford.edu>
+
+	* gfortran.texi: Corrected references to MALLOC intrinsic.
+	* invoke.texi: Minor cleanup and clarification to the Dialect
+	Options section.
+
+2006-09-30  Brooks Moses  <bmoses@stanford.edu>
+
+	* invoke.texi:  Add mention of BOZ constants and integer
+	overflow to -fno-range-check.
+	* gfortran.texi:  Add mention of -fno-range-check to
+	section on BOZ contants.
+
+2006-09-30  Bernhard Fischer  <aldot@gcc.gnu.org>
+
+	* resolve.c: Fix commentary typo.  Fix whitespace.
+
+2006-09-28  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	fortran/29147
+	* arith.c (gfc_check_integer_range): Disable range checking via
+	-fno-range-check.
+
+2006-09-28  Steven G. Kargl <kargl@gcc.gnu.org>
+
+	* arith.c: Change conditional test for inclusion of arctangent().
+	(gfc_check_real_range): Change conditional test for use of
+	mpfr_subnormalize.
+	* simplify.c (gfc_simplify_atan2): Fix conditional for use of
+	mpfr_atan2() instead of arctangent().
+	(gfc_simplify_exponent): Fix conditional for use of mpfr_get_exp().
+ 	(gfc_simplify_log): Fix conditional for use of mpfr_atan2() instead
+	 of arctangent().
+	(gfc_simplify_nearest): Fix conditional for use of mpfr_nextafter(). 
+
+2006-09-27  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* arith.c: Conditionally include arctangent2().
+	(gfc_check_real_range): Use mpfr_subnormalize in preference to local
+	hack.
+	* trans-intrinsic.c (gfc_get_intrinsic_lib_fndecl): Append
+	l for long double functions.
+	* simplify.c: Wrap Copyright to new line.
+	(gfc_simplify_atan2): Use mpfr_atan2 in preference to arctangent2().
+	(gfc_simplify_log): Ditto.
+
+
+	PR fortran/28276
+	* simplify.c (gfc_simplify_exponent): Use mpfr_get_exp in
+	preference to broken local hack.
+
+	PR fortran/27021
+	* simplify.c (gfc_simplify_nearest): Use mpfr_nexttoward and
+	mpfr_subnormalize to handle numbers near zero in preference to broken
+	 local hack.
+
+2006-09-26  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/29097
+	* scanner.c (include_line): Handle conditional include.
+
+2006-09-25  Tobias Schlüter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/21203
+	* error.c (show_loci): No need to risk an ICE to output a
+	slightly nicer error message.
+
+2006-09-19 Paul Thomas <pault@gcc.gnu.org>
+	   Steven Bosscher  <steven@gcc.gnu.org>
+
+	PR fortran/29101
+	* trans-stmt.c (gfc_trans_character_select): Store the label
+	from select_string and then clean up any temporaries from the
+	conversion of the select expression, before branching to the
+	selected case.
+
+2006-09-18 Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/28526
+	* primary.c (match_variable): If the compiler is in a module
+	specification block, an interface block or a contains section,
+	reset host_flag to force the changed symbols mechanism.
+
+	PR fortran/29101
+	* trans-stmt.c (gfc_trans_character_select): Add the post block
+	for the expression to the main block, after the call to
+	select_string and the last label.
+
+2006-09-18  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29060
+	* iresolve.c (resolve_spread): Build shape for result if the
+	source shape is available and dim and ncopies are constants.
+
+2006-09-18  Tobias Schlüter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/28817
+	PR fortran/21918
+	* trans-decl.c (generate_local_decl): Change from 'warning' to
+	'gfc_warning' to have line numbers correctly reported.
+
+2006-09-15  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29051
+	* decl.c (match_old_style_init): Set the 'where' field of the
+	gfc_data structure 'newdata'.
+
+	* match.c (match_case_eos): Add a comprehensible error message.
+
+2006-09-13  Wolfgang Gellerich  <gellerich@de.ibm.com>
+
+	* trans-expr.c (gfc_add_interface_mapping): For characters, dereference
+	pointer if necessary and then perform the cast.
+
+2006-09-11  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* intrinsic.c: Update Copyright date.
+	* intrinsic.h: Ditto.
+
+2006-09-11  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/28890
+	* trans-expr.c (gfc_conv_function_call): Obtain the string length
+	of a dummy character(*) function from the symbol if it is not
+	already translated.  For a call to a character(*) function, use
+	the passed, hidden string length argument, which is available
+	from the backend_decl of the formal argument.
+	* resolve.c (resolve_function): It is an error if a function call
+	to a character(*) function is other than a dummy procedure or
+	an intrinsic.
+
+2006-09-10  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/28959
+	* trans-types.c (gfc_get_derived_type): Use the parent namespace of
+	the procedure if the type's own namespace does not have a parent.
+
+2006-09-10  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/28923
+	* expr.c (find_array_section): Only use the array lower and upper
+	bounds for the start and end of the sections, where the expr is
+	NULL.
+
+2006-09-10  Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/28914
+	* trans-array.c (gfc_trans_array_constructor_value): Create a temporary
+	loop variable to hold the current loop variable in case it is modified
+	by the array constructor.
+
+2006-09-07  Steven G. Kargl  <kargls@comcast.net>
+
+	* gfortran.h (gfc_integer_info): Eliminate max_int.
+	* arith.c (gfc_arith_init_1): Remove initialization of max_int.
+	(gfc_arith_done_1): Remove clearing of max_int.
+	(gfc_check_integer_range): Fix range chekcing of overflow.
+	* simplify.c (gfc_simplify_not): Construct mask that was max_int.
+
+2006-09-05  Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/28908
+	* gfortran.h : Restore the gfc_dt_list structure and reference
+	to it in gfc_namespace.
+	* resolve.c (resolve_fl_derived): Restore the building of the
+	list of derived types for the current namespace. Modify the
+	restored code so that a check is made to see if the symbol is
+	already in the list.
+	(resolve_fntype): Make sure that the specification block
+	version of the derived type is used for a module function that
+	returns that type. 
+	* symbol.c (gfc_free_dt_list): Restore.
+	(gfc_free_namespace): Restore call to previous.
+	* trans-types.c (copy_dt_decls_ifequal): Restore.
+	(gfc_get_derived_type): Restore all the paraphenalia for
+	association of derived types, including calls to previous.
+	Modify the restored code such that all derived types are built
+	if their symbols are found in the parent namespace; not just
+	non-module types.  Add backend_decls to like derived types in
+	sibling namespaces, as well as that of the derived type.
+
+2006-08-30  Kazu Hirata  <kazu@codesourcery.com>
+
+	* match.c: Fix a comment typo.
+
+2006-08-30  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/28885
+	* trans-expr.c (gfc_conv_aliased_arg): Ensure that the temp
+	declaration is retained for INTENT(OUT) arguments.
+
+	PR fortran/28873
+	PR fortran/20067
+	* resolve.c (resolve_generic_f): Make error message more
+	comprehensible.
+	(resolve_generic_s): Restructure search for specific procedures
+	to be similar to resolve_generic_f and change to similar error
+	message.  Ensure that symbol reference is refreshed, in case
+	the search produces a NULL.
+	(resolve_specific_s): Restructure search, as above and as
+	resolve_specific_f. Ensure that symbol reference is refreshed,
+	in case the search produces a NULL.
+
+	PR fortran/25077
+	PR fortran/25102
+	* interface.c (check_operator_interface): Throw error if the
+	interface assignment tries to change intrinsic type assigments
+	or has less than two arguments.  Also, it is an error if an
+	interface operator contains an alternate return.
+
+	PR fortran/24866
+	* parse.c (gfc_fixup_sibling_symbols): Do not modify the symbol
+	if it is a dummy in the contained namespace.
+
+2006-08-29  Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/28866
+	* match.c: Wrap copyright.
+	(gfc_match_assignment):  Return MATCH_NO for failed lvalue.  Remove
+	gotos.  Move error handling of FL_PARAMETER to ...
+	* gfc_match_if: Deal with MATCH_NO from above.
+	* primary.c: Wrap copyright.
+	(match_variable): ... here.  Improve error messages.
+
+2006-08-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/28788
+	* symbol.c (gfc_use_derived): Never eliminate the symbol,
+	following reassociation of use associated derived types.
+
+2006-08-26  Steven G. Kargl  <kargls@comcast.net>
+
+	* arith.h: Update Copyright dates.  Fix whitespace.
+	* arith.c: Update Copyright dates.  Fix whitespace.  Fix comments.
+	(gfc_arith_done_1): Clean up pedantic_min_int and subnormal.
+
+2006-08-26  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.texi: Note variable initialization causes SAVE attribute.
+	* intrinsic.texi: Clarify support for KIND=16 and KIND=10.
+	Mention -std=f2003.  Cross reference INQUIRE from ACCESS intrinsic.
+	Add missing ) in ACOS.
+
+2006-08-26  Daniel Franke  <franke.daniel@gmail.com>
+
+	* intrinsic.texi: Update Copyright date.  Added documentation
+	for ACOSH, AND, ASINH, ATANH, CHDIR, FGET, FGETC, FPUT, FPUTC,
+	GETCWD, OR and XOR intrinsics, removed inadvertently introduced
+	doc-stubs for EQV and NEQV, corrected some typographical errors.
+
+2006-08-24  Daniel Franke  <franke.daniel@gmail.com>,
+	    Brooks Moses  <bmoses@stanford.edu>
+
+	* intrinsic.texi: Added doc-stubs for undocumented intrinsics,
+	added a "See Also" section, renamed the "Options" section to
+	"Standard", improved the index, and made numerous minor
+	typo corrections and grammatical fixes.
+
+2006-08-24  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/28788
+	* symbol.c (shift_types): Shift the derived type references in
+	formal namespaces.
+	(gfc_use_derived): Return if the derived type symbol is already
+	in another namspace.  Add searches for the derived type in
+	sibling namespaces.
+
+	PR fortran/28771
+	* decl.c (add_init_expr_to_sym): Restore the original but
+	restricted to parameter arrays to fix a regression.
+
+2006-08-23  Steven G. Kargl  <kargls@comcast.net>
+
+	* gfortran.texi:  Fix last commit where a "no" was deleted and
+	a grammatical error was introduced.
+
+2006-08-23  Steven G. Kargl  <kargls@comcast.net>
+
+	* gfortran.texi:  Spell check.  Add a few contributors to
+	Chapter 9.  Expand the description of BOZ constant handling.
+
+2006-08-20  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	PR fortran/25828
+	* gfortran.texi: Mention STREAM I/O among supported F2003
+	features.
+
+2006-08-20  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/28601
+	PR fortran/28630
+	* gfortran.h : Eliminate gfc_dt_list structure and reference
+	to it in gfc_namespace.
+	* resolve.c (resolve_fl_derived): Remove the building of the
+	list of derived types for the current namespace.
+	* symbol.c (find_renamed_type): New function to find renamed
+	derived types by symbol name rather than symtree name.
+	(gfc_use_derived): Search parent namespace for identical
+	derived type and use it, even if local version is complete,
+	except in interface bodies. Ensure that renamed derived types
+	are found by call to find_renamed_type. Recurse for derived
+	type components.
+	(gfc_free_dt_list): Remove.
+	(gfc_free_namespace): Remove call to previous.
+	* trans-types.c (copy_dt_decls_ifequal): Remove.
+	(gfc_get_derived_type): Remove all the paraphenalia for
+	association of derived types, including calls to previous.
+	* match.c (gfc_match_allocate): Call gfc_use_derived to
+	associate any derived types that are being allocated.
+
+	PR fortran/20886
+	* resolve.c (resolve_actual_arglist): The passing of
+	a generic procedure name as an actual argument is an
+	error.
+
+	PR fortran/28735
+	* resolve.c (resolve_variable): Check for a symtree before
+	resolving references.
+
+	PR fortran/28762
+	* primary.c (match_variable): Return MATCH_NO if the symbol
+	is that of the program.
+
+	PR fortran/28425
+	* trans-expr.c (gfc_trans_subcomponent_assign): Translate
+	derived type component expressions other than another derived
+	type constructor.
+
+	PR fortran/28496
+	* expr.c (find_array_section): Correct errors in
+	the handling of a missing start value for the
+	index triplet in an array reference.
+
+	PR fortran/18111
+	* trans-decl.c (gfc_build_dummy_array_decl): Before resetting
+	reference to backend_decl, set it DECL_ARTIFICIAL.
+	(gfc_get_symbol_decl): Likewise for original dummy decl, when
+	a copy is made of an array.
+	(create_function_arglist): Likewise for the _entry paramter
+	in entry_masters.
+	(build_entry_thunks): Likewise for dummies in entry thunks.
+
+	PR fortran/28600
+	* trans-decl.c (gfc_get_symbol_decl): Ensure that the
+	DECL_CONTEXT of the length of a character dummy is the
+	same as that of the symbol declaration.
+
+	PR fortran/28771
+	* decl.c (add_init_expr_to_sym): Remove setting of charlen for
+	an initializer of an assumed charlen variable.
+
+	PR fortran/28660
+	* trans-decl.c (generate_expr_decls): New function.
+	(generate_dependency_declarations): New function.
+	(generate_local_decl): Call previous if not either a dummy or
+	a declaration in an entry master.
+
+2006-08-19  Erik Edelmann  <eedelman@gcc.gnu.org>
+
+	PR fortran/25217
+	* resolve.c (resolve_fl_variable): Set a default initializer for
+	derived types with INTENT(OUT) even if 'flag' is true.
+	* trans-expr.c (gfc_conv_function_call): Insert code to
+	reinitialize INTENT(OUT) arguments of derived type with default
+	initializers.
+
+2006-08-15  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/25828
+	* gfortran.h: Add new pointer for stream position to st_inquire.
+	Rename gfc_large_io_int_kind to gfc_intio_kind.
+	* trans-types.c (gfc_init_kinds): use gfc_intio_kind.
+	* io.c: Add new IO tag for file position going in and another for out.
+	(match_dt_element): Match new tag_spos.
+	(gfc_resolve_dt): Resolve new tag_spos.
+	(gfc_free_inquire): Free inquire->strm_pos.
+	(match_inquire_element): Match new tag_strm_out.
+	(gfc_resolve_inquire): Resolve new tag_strm_out.
+	* trans-io.c: Rename IOPARM_type_large_io_int to IOPARM_type_intio.
+	(gfc_build_st_parameter): Same.
+	(gfc_build_io_library_fndecls) Same. and add build pointer type pintio.
+	(gfc_trans_inquire): Translate strm_pos for inquire.
+	* ioparm.def: Reorder flags to accomodate addition of new inquire
+	flag for strm_pos_out and add it in.
+
+2006-08-06  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/28590
+	* parse.c (parse_derived): Remove the test for sequence type
+	components of a sequence type.
+	* resolve.c (resolve_fl_derived): Put the test here so that
+	pointer components are tested.
+
+2006-08-05  Steven G. Kargl <kargls@comcast.nt>
+
+	PR fortran/28548
+	* resolve.c(resolve_elemental_actual): Add flags.h to use -pedantic
+	and exclude conversion functions in conditional.  Change gfc_error
+	to gfc_warning.
+	(warn_unused_label) Rename to ...
+	(warn_unused_fortran_label) avoid warn_unused_label in flags.h.
+
+2006-07-30  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* intrinsic.c (add_functions): Add ACCESS, CHMOD, RSHIFT, LSHIFT.
+	(add_subroutines): Add LTIME, GMTIME and CHMOD.
+	* intrinsic.h (gfc_check_access_func, gfc_check_chmod,
+	gfc_check_chmod_sub, gfc_check_ltime_gmtime, gfc_simplify_rshift,
+	gfc_simplify_lshift, gfc_resolve_access, gfc_resolve_chmod,
+	gfc_resolve_rshift, gfc_resolve_lshift, gfc_resolve_chmod_sub,
+	gfc_resolve_gmtime, gfc_resolve_ltime): Add prototypes.
+	* gfortran.h (gfc_generic_isym_id): Add GFC_ISYM_ACCESS,
+	GFC_ISYM_CHMOD, GFC_ISYM_LSHIFT, GFC_ISYM_RSHIFT.
+	* iresolve.c (gfc_resolve_access, gfc_resolve_chmod,
+	gfc_resolve_rshift, gfc_resolve_lshift, gfc_resolve_chmod_sub,
+	gfc_resolve_gmtime, gfc_resolve_ltime): New functions.
+	* check.c (gfc_check_access_func, gfc_check_chmod,
+	gfc_check_chmod_sub, gfc_check_ltime_gmtime): New functions.
+	* trans-intrinsic.c (gfc_conv_intrinsic_rlshift): New function.
+	(gfc_conv_intrinsic_function): Add cases for the new GFC_ISYM_*.
+
+2006-07-28  Volker Reichelt  <reichelt@igpm.rwth-aachen.de>
+
+	* Make-lang.in: Use $(HEADER_H) instead of header.h in dependencies.
+
+2006-07-26  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* intrinsic.c (add_functions): Add INT2, SHORT, INT8, LONG,
+	LSTAT, MCLOCK and MCLOCK8 intrinsic functions.
+	(add_subroutines): Add LSTAT intrinsic subroutine.
+	* gfortran.h (gfc_generic_isym_id): Add GFC_ISYM_INT2,
+	GFC_ISYM_INT8, GFC_ISYM_LONG, GFC_ISYM_LSTAT, GFC_ISYM_MCLOCK
+	and GFC_ISYM_MCLOCK8.
+	* iresolve.c (gfc_resolve_int2, gfc_resolve_int8,
+	gfc_resolve_long, gfc_resolve_lstat, gfc_resolve_mclock,
+	gfc_resolve_mclock8, gfc_resolve_lstat_sub): New functions.
+	* check.c (gfc_check_intconv): New function.
+	* trans-intrinsic.c (gfc_conv_intrinsic_function): Add cases for
+	the added GFC_ISYM_*.
+	* simplify.c (gfc_simplify_intconv, gfc_simplify_int2,
+	gfc_simplify_int8, gfc_simplify_long): New functions.
+	* intrinsic.h (gfc_check_intconv, gfc_simplify_int2,
+	gfc_simplify_int8, gfc_simplify_long, gfc_resolve_int2,
+	gfc_resolve_int8, gfc_resolve_long, gfc_resolve_lstat,
+	gfc_resolve_mclock, gfc_resolve_mclock8, gfc_resolve_lstat_sub):
+	Add prototypes.
+
+2006-07-24  Erik Edelmann  <eedelman@gcc.gnu.org>
+
+	PR fortran/28416
+	* trans-array.c (gfc_conv_array_parameter): Give special treatment for
+	ALLOCATABLEs if they are themselves dummy variables.
+
+2006-07-23  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/25289
+	* gfortran.h: Declare gfc_large_io_int_kind.
+	* trans-types.c (gfc_init_kinds): Set gfc_large_io_int_kind
+	to size 8 or 4.
+	* trans-io.c (enum iofield_type): Add large_io_int type.
+	(gfc_build_st_parameter): Same.
+	(gfc_build_io_library_fndecls): Same.
+	* ioparm_def: Use large_io_int to define rec.
+
+2006-07-22  Steven Bosscher  <steven@gcc.gnu.org> 
+
+	PR fortran/28439
+	* trans-stmt.c (gfc_trans_arithmetic_if): Evaluate the condition once.
+
+2006-07-16  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/28390
+	* trans-openmp.c (gfc_trans_omp_do): Look for LASTPRIVATE in
+	code->exp.omp_clauses rather than in the 3rd function argument.
+
+2006-07-16  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/28384
+	* trans-common.c (translate_common): If common_segment is NULL
+	emit error that common block does not exist.
+
+	PR fortran/20844
+	* io.c (check_io_constraints): It is an error if an ADVANCE
+	specifier appears without an explicit format.
+
+	PR fortran/28201
+	* resolve.c (resolve_generic_s): For a use_associated function,
+	do not search for an alternative symbol in the parent name
+	space.
+
+	PR fortran/20893
+	* resolve.c (resolve_elemental_actual): New function t combine
+	all the checks of elemental procedure actual arguments. In
+	addition, check of array valued optional args(this PR) has
+	been added.
+	(resolve_function, resolve_call): Remove parts that treated
+	elemental procedure actual arguments and call the above.
+
+2006-07-14  Steven G. Kargl  <kargls@comcast.net>
+
+	* trans-expr.c (gfc_trans_string_copy): Evaluate the string lengths
+
+006-07-13  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/28353
+	* trans-expr.c (gfc_conv_aliased_arg): Missing formal arg means
+	that intent is INOUT (fixes regression).
+
+	PR fortran/25097
+	* check.c (check_present): The only permitted reference is a
+	full array reference.
+
+	PR fortran/20903
+	* decl.c (variable_decl): Add error if a derived type is not
+	from the current namespace if the namespace is an interface
+	body.
+
+2006-07-12  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/28163
+	* trans-expr.c (gfc_trans_string_copy): Generate inline code
+	to perform string copying instead of calling a library function.
+	* trans-decl.c (gfc_build_intrinsic_function_decls): Don't build
+	decl for copy_string.
+	* trans.h (gfor_fndecl_copy_string): Remove prototype.
+
+2006-07-11  Feng Wang  <fengwang@nudt.edu.cn>
+
+	PR fortran/28213
+	* trans-io.c (transfer_expr): Deal with Hollerith constants used in
+	I/O list.
+
+2006-07-07  Kazu Hirata  <kazu@codesourcery.com>
+
+	* intrinsic.texi: Fix typos.
+
+2006-07-07  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/28237
+	PR fortran/23420
+	* io.c (resolve_tag): Any integer that is not an assigned
+	variable is an error.
+
+2006-07-06  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/28129
+	* trans-array.c (gfc_trans_array_bound_check): Add a locus
+	argument, and use it in the error messages.
+	(gfc_conv_array_index_offset): Donc perform bounds checking on
+	the last dimension of assumed-size arrays.
+
+2006-07-06  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/27874
+	* trans-stmt.c (compute_inner_temp_size): Don't perform bounds
+	checking when calculating the bounds of scalarization.
+
+2006-07-05  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/20892
+	* interface.c (gfc_match_interface): Don't allow dummy procedures
+	to have a generic interface.
+
+2006-07-04  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/28174
+	* trans-array.c (gfc_conv_expr_descriptor): When building temp,
+	ensure that the substring reference uses a new charlen.
+	* trans-expr.c (gfc_conv_aliased_arg): Add the formal intent to
+	the argument list, lift the treatment of missing string lengths
+	from the above and implement the use of the intent.
+	(gfc_conv_function_call): Add the extra argument to the call to
+	the above.
+
+	PR fortran/28167
+	* trans-array.c (get_array_ctor_var_strlen): Treat a constant
+	substring reference.
+	* array.c (gfc_resolve_character_array_constructor): Remove 
+	static attribute and add the gfc_ prefix, make use of element
+	charlens for the expression and pick up constant string lengths
+	for expressions that are not themselves constant.
+	* gfortran.h : resolve_character_array_constructor prototype
+	added.
+	* resolve.c (gfc_resolve_expr): Call resolve_character_array_
+	constructor again after expanding the constructor, to ensure
+	that the character length is passed to the expression.
+
+2006-07-04  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+	    Daniel Franke  <franke.daniel@gmail.com>
+
+	* intrinsic.c (add_subroutines): Add ITIME and IDATE.
+	* intrinsic.h (gfc_check_itime_idate,gfc_resolve_idate,
+	fc_resolve_itime): New protos.
+	* iresolve.c (gfc_resolve_itime, gfc_resolve_idate): New functions.
+	* check.c (gfc_check_itime_idate): New function.
+	* intrinsic.texi: Document the new intrinsics.
+
+2006-07-03  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* intrinsics/date_and_time.c (itime0,idate0,itime_i4,itime_i8,
+	idate_i4,idate_i8): New functions.
+
+
+2006-07-03  Asher Langton  <langton2@llnl.gov>
+
+	* decl.c (match_old_style_init): Add data attribute to symbol.
+
+2006-07-03  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* iresolve.c (gfc_resolve_cpu_time, gfc_resolve_random_number):
+	Remove ATTRIBUTE_UNUSED for used argument.
+
+2006-07-03  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* intrinsic.texi: Document new intrinsics.
+
+2006-07-01  Tobias Schlüter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/19259
+	* parse.c (next_free): Error out on line starting with semicolon.
+	(next_fixed): Fix formatting.  Error out on line starting with
+	semicolon.
+
+2006-06-30  Kazu Hirata  <kazu@codesourcery.com>
+
+	* check.c: Fix a comment typo.
+
+2006-06-25  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/25056
+	* interface.c (compare_actual_formal): Signal an error if the formal
+	argument is a pure procedure and the actual is not pure.
+
+	PR fortran/27554
+	* resolve.c (resolve_actual_arglist): If the type of procedure
+	passed as an actual argument is not already declared, see if it is
+	an intrinsic.
+
+	PR fortran/25073
+	* resolve.c (resolve_select): Use bits 1 and 2 of a new int to
+	keep track of  the appearance of constant logical case expressions.
+	Signal an error is either value appears more than once.
+
+	PR fortran/20874
+	* resolve.c (resolve_fl_procedure): Signal an error if an elemental
+	function is not scalar valued.
+
+	PR fortran/20867
+	* match.c (recursive_stmt_fcn): Perform implicit typing of variables.
+
+	PR fortran/22038
+	* match.c (match_forall_iterator): Mark new variables as
+	FL_UNKNOWN if the match fails.
+
+	PR fortran/28119
+	* match.c (gfc_match_forall): Remove extraneous call to
+	gfc_match_eos.
+
+	PR fortran/25072
+	* resolve.c (resolve_code, resolve_function): Rework
+	forall_flag scheme so that it is set and has a value of
+	2, when the code->expr (ie. the forall mask) is resolved.
+	This is used to change "block" to "mask" in the non-PURE
+	error message.
+
+2006-06-24  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/28081
+	* resolve.c (resolve_substring): Don't issue out-of-bounds
+	error messages when the range has zero size.
+
+2006-06-24  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/23862
+	* lang-specs.h (f95-cpp-input): Pass -ffree-form to f951 unless
+	-ffixed-form is explicitly specified.
+
+2006-06-24  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/28118
+	* trans-array.c (gfc_conv_expr_descriptor): When building temp,
+	use the substring reference to calculate the length if the
+	expression does not have a charlen.
+
+2006-06-24  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/28094
+	* trans-intrinsic.c (gfc_conv_intrinsic_mod): Support cases where
+	there is no integer kind equal to the resulting real kind.
+	* intrinsic.c (add_functions): MODULO is not allowed as an actual
+	argument.
+
+2006-06-23  Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/27981
+	* match.c (gfc_match_if):  Handle errors in assignment in simple if.
+
+2006-06-22  Asher Langton  <langton2@llnl.gov>
+
+	PR fortran/24748
+	* primary.c (gfc_match_rvalue): Don't call match_substring for
+	implicit non-character types.
+
+2006-06-22  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR libfortran/26769
+	* iresolve.c (gfc_resolve_reshape): Call reshape_r4 and
+	reshape_r8 instead of reshape_4 and reshape_8.
+	(gfc_resolve_transpose): Likewise for transpose.
+
+2006-06-21  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* trans-expr.c (gfc_conv_missing_dummy, gfc_conv_unary_op,
+	gfc_conv_cst_int_power, gfc_conv_string_tmp,
+	gfc_conv_function_call): Replace calls to convert on constant
+	integer nodes by build_int_cst.
+	* trans-stmt.c (gfc_trans_do): Likewise.
+	* trans-io.c (set_internal_unit, transfer_namelist_element):
+	Likewise.
+	* trans-decl.c (build_entry_thunks): Likewise.
+
+2006-06-20  Steven G. Kargl  <kargls@comcast.net>
+
+	* simplify.c (gfc_simplify_rrspacing): Initialize and clear mpfr_t
+	variable.
+
+2006-06-20  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/25049
+	PR fortran/25050
+	* check.c (non_init_transformational): New function.
+	(find_substring_ref): New function to signal use of disallowed
+	transformational intrinsic in an initialization expression.
+	(gfc_check_all_any): Call previous if initialization expr.
+	(gfc_check_count): The same.
+	(gfc_check_cshift): The same.
+	(gfc_check_dot_product): The same.
+	(gfc_check_eoshift): The same.
+	(gfc_check_minloc_maxloc): The same.
+	(gfc_check_minval_maxval): The same.
+	(gfc_check_gfc_check_product_sum): The same.
+	(gfc_check_pack): The same.
+	(gfc_check_spread): The same.
+	(gfc_check_transpose): The same.
+	(gfc_check_unpack): The same.
+
+	PR fortran/18769
+	*intrinsic.c (add_functions): Add gfc_simplify_transfer.
+	*intrinsic.h : Add prototype for gfc_simplify_transfer.
+	*simplify.c (gfc_simplify_transfer) : New function to act as
+	placeholder for eventual implementation.  Emit error for now.
+
+	PR fortran/16206
+	* expr.c (find_array_element): Eliminate condition on length of
+	offset. Add bounds checking. Rearrange exit. Return try and
+	put gfc_constructor result as an argument.
+	(find_array_section): New function.
+	(find_substring_ref): New function.
+	(simplify_const_ref): Add calls to previous.
+	(simplify_parameter_variable): Return on NULL expr.
+	(gfc_simplify_expr): Only call gfc_expand_constructor for full
+	arrays.
+
+	PR fortran/20876
+	* match.c (gfc_match_forall): Add missing locus to gfc_code.
+
+2006-06-18  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/26801
+	* trans-intrinsic.c (gfc_conv_associated): Use pre and post blocks
+	of the scalarization expression.
+
+2006-06-18  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/19310
+	PR fortran/19904
+	* arith.c (gfc_range_check): Return ARITH_OK if -fno-range-check. Add
+	return of ARITH_NAN, ARITH_UNDERFLOW, and ARITH_OVERFLOW.
+	(gfc_arith_divide): If -fno-range-check allow mpfr to divide by zero.
+	* gfortran.h (gfc_option_t): Add new flag.
+	* invoke.texi: Document new flag.
+	* lang.opt: Add option -frange-check.
+	* options.c (gfc_init_options): Initialize new flag.
+	(gfc_handle_options): Set flag if invoked.
+	* simplify.c (range_check): Add error messages for
+	overflow, underflow, and other errors.
+	* trans-const.c (gfc_conv_mpfr_to_tree): Build NaN and Inf from mpfr
+	result.
+
+2006-06-17  Karl Berry  <karl@gnu.org>
+
+	* gfortran.texi (@dircategory): Use "Software development"
+	instead of "Programming", following the Free Software Directory.
+
+2006-06-16  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/27965
+	* trans-array.c (gfc_conv_ss_startstride): Correct the runtime
+	conditions for bounds-checking. Check for nonzero stride.
+	Don't check the last dimension of assumed-size arrays. Fix the
+	dimension displayed in the error message.
+
+2006-06-15  Thomas Koenig <Thomas.Koenig@online.de>
+
+	* trans-array.h (gfc_trans_create_temp_array):  Add bool
+	argument.
+	* trans-arrray.c (gfc_trans_create_temp_array): Add extra
+	argument "function" to show if we are translating a function.
+	If we are translating a function, perform checks whether
+	the size along any argument is negative.  In that case,
+	allocate size 0.
+	(gfc_trans_allocate_storage):  Add function argument (as
+	false) to gfc_trans_create_temp_array call.
+	* trans-expr.c (gfc_conv_function_call):  Add function
+	argument (as true) to gfc_trans_create_temp_array call.
+	* trans-stmt.c (gfc_conv_elemental_dependencies): Add
+	function argument (as false) to gfc_trans_create_temp_array
+	call.
+	* trans-intrinsic.c:  Likewise.
+
+2006-06-10  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/24558
+	PR fortran/20877
+	PR fortran/25047
+	* decl.c (get_proc_name): Add new argument to flag that a
+	module function entry is being treated. If true, correct
+	error condition, add symtree to module namespace and add
+	a module procedure.
+	(gfc_match_function_decl, gfc_match_entry,
+	gfc_match_subroutine): Use the new argument in calls to
+	get_proc_name.
+	* resolve.c (resolve_entries): ENTRY symbol reference to
+	to master entry namespace if a module function.
+	* trans-decl.c (gfc_create_module_variable): Return if
+	the symbol is an entry.
+	* trans-exp.c (gfc_conv_variable): Check that parent_decl
+	is not NULL.
+
+2006-06-09  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/27916
+	* trans-openmp.c (gfc_omp_clause_default_ctor): New function.
+	* trans.h (gfc_omp_clause_default_ctor): New prototype.
+	* f95-lang.c (LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR): Define.
+
+2006-06-08  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/27958
+	* trans-expr.c (gfc_conv_substring): If the substring start is
+	greater than its end, the length of the substring is zero, and
+	not negative.
+	(gfc_trans_string_copy): Don't generate a call to
+	_gfortran_copy_string when destination length is zero.
+
+2006-06-08  Asher Langton  <langton2@llnl.gov>
+	
+	PR fortran/27786
+	* trans-array.c (gfc_conv_array_ref): Eliminate bounds checking
+	for assumed-size Cray pointees.
+
+2006-06-08  Steven G. Kargl  <kargls@comcat.net>
+
+	* intrinsic.c (add_subroutine):  Make make_noreturn() conditional on
+	the appropriate symbol name.
+	
+2006-06-07  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/23091
+	* resolve.c (resolve_fl_variable): Error if an automatic
+	object has the SAVE attribute.
+
+	PR fortran/24168
+	* expr.c (simplify_intrinsic_op): Transfer the rank and
+	the locus to the simplified expression.
+
+	PR fortran/25090
+	PR fortran/25058
+	* gfortran.h : Add int entry_id to gfc_symbol.
+	* resolve.c : Add static variables current_entry_id and
+	specification_expr.
+	(resolve_variable): During code resolution, check if a
+	reference to a dummy variable in an executable expression
+	is preceded by its appearance as a parameter in an entry.
+	Likewise check its specification expressions.
+	(resolve_code): Update current_entry_id on EXEC_ENTRY.
+	(resolve_charlen, resolve_fl_variable): Set and reset
+	specifiaction_expr.
+	(is_non_constant_shape_array): Do not return on detection
+	of a variable but continue to resolve all the expressions.
+	(resolve_codes): set current_entry_id to an out of range
+	value.
+
+2006-06-06  Mike Stump  <mrs@apple.com>
+
+	* Make-lang.in: Rename to htmldir to build_htmldir to avoid
+	installing during build.
+
+2006-06-06  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/27897
+	* match.c (gfc_match_common):  Fix code typo.  Remove
+	sym->name, since sym is NULL, and replace with name.
+
+2006-06-05  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR libfortran/27895
+	* resolve.c (compute_last_value_for_triplet): New function.
+	(check_dimension): Correctly handle zero-sized array sections.
+	Add checking on last element of array sections.
+
+2006-06-05  Steven G. Kargl  <kargls@comcast.net>
+
+	* data.c (gfc_assign_data_value):  Fix comment typo.  Remove
+	a spurious return.
+
+2006-06-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/14067
+	* data.c (create_character_intializer): Add warning message
+	for truncated string.
+
+	PR fortran/16943
+	* symbol.c : Include flags.h.
+	(gfc_add_type): If a procedure and types are the same do not
+	throw an error unless standard is less than gnu or pedantic.
+
+	PR fortran/20839
+	* parse.c (parse_do_block): Error if named block do construct
+	does not have a named enddo.
+
+	PR fortran/27655
+	* check.c (gfc_check_associated): Pick up EXPR_NULL for pointer
+	as well as target and put error return at end of function.
+
+2006-06-03  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* trans.c (gfc_msg_bounds, gfc_msg_fault, gfc_msg_wrong_return):
+	Add strings for common runtime error messages.
+	(gfc_trans_runtime_check): Add a locus argument, use a string
+	and not a string tree for the message.
+	* trans.h (gfc_trans_runtime_check): Change prototype accordingly.
+	(gfc_msg_bounds, gfc_msg_fault, gfc_msg_wrong_return): Add proto.
+	* trans-const.c (gfc_strconst_bounds, gfc_strconst_fault,
+	gfc_strconst_wrong_return, gfc_strconst_current_filename): Remove.
+	(gfc_init_constants): Likewise.
+	* trans-const.h: Likewise.
+	* trans-decl.c (gfc_build_builtin_function_decls): Call to
+	_gfortran_runtime_error has only one argument, the message string.
+	* trans-array.h (gfc_conv_array_ref): Add a symbol argument and a
+	locus.
+	* trans-array.c (gfc_trans_array_bound_check): Build precise
+	error messages.
+	(gfc_conv_array_ref): Use the new symbol argument and the locus
+	to build more precise error messages.
+	(gfc_conv_ss_startstride): More precise error messages.
+	* trans-expr.c (gfc_conv_variable): Give symbol reference and
+	locus to gfc_conv_array_ref.
+	(gfc_conv_function_call): Use the new prototype for
+	gfc_trans_runtime_check.
+	* trans-stmt.c (gfc_trans_goto): Build more precise error message.
+	* trans-io.c (set_string): Likewise.
+	* trans-intrinsic.c (gfc_conv_intrinsic_bound): Use new prototype
+	for gfc_trans_runtime_check.
+
+2006-06-01  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR fortran/27715
+	* arith.c:  Cast the characters from the strings to unsigned
+	char to avoid values less than 0 for extended ASCII.
+
+2006-06-01  Per Bothner  <bothner@bothner.com>
+
+	* data.c (gfc_assign_data_value): Handle USE_MAPPED_LOCATION.
+	* scanner.c (gfc_gobble_whitespace): Likewise.
+
+2006-06-01  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/25098
+	PR fortran/25147
+	* interface.c (compare_parameter): Return 1 if the actual arg
+	is external and the formal is a procedure.
+	(compare_actual_formal): If the actual argument is a variable
+	and the formal a procedure, this an error.  If a gsymbol exists
+	for a procedure of the same name, this is not yet resolved and
+	the error is cleared.
+
+	* trans-intrinsic.c (gfc_conv_associated): Make provision for
+	zero array length or zero string length contingent on presence
+	of target, for consistency with standard.
+
+2006-05-30  Asher Langton  <langton2@llnl.gov>
+
+	* symbol.c (check_conflict): Allow external, function, and
+	subroutine attributes with Cray pointees.
+	* trans-expr.c (gfc_conv_function_val): Translate Cray pointees
+	that point to procedures.
+	* gfortran.texi: Document new feature.
+
+2006-05-29  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/27634
+	* io.c (check_format): Add error for missing period in format
+	specifier unless -std=legacy.
+	* gfortran.texi: Add description of expanded namelist read and
+	missing period in format extensions.
+
+2006-05-29  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/19777
+	* trans-array.c (gfc_conv_array_ref): Perform out-of-bounds
+	checking for assumed-size arrrays for all but the last dimension.
+
+2006-05-29  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* invoke.texi: Change -fpackderived into -fpack-derived.
+
+2006-05-29  Kazu Hirata  <kazu@codesourcery.com>
+
+	* options.c, primary.c, resolve.c, trans-common.c: Fix typos
+	in error messages.
+
+2006-05-28  Kazu Hirata  <kazu@codesourcery.com>
+
+	* check.c, expr.c, resolve.c, trans-common.c,
+	trans-intrinsic.c, trans-stmt.c, trans-types.c: Fix comment typos.
+
+2006-05-27  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/19777
+	* trans-array.c (gfc_conv_array_ref): Don't perform out-of-bounds
+	checking for assumed-size arrrays.
+
+2006-05-27  Paul Thomas  <pault@gcc.gnu.org>
+
+	* trans-intrinsic.c (gfc_conv_associated): If pointer in first
+	arguments has zero array length of zero string length, return
+	false.
+
+2006-05-26  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/27524
+	* trans-array.c (gfc_trans_dummy_array_bias): Don't use stride as
+	a temporary variable when -fbounds-check is enabled, since its
+	value will be needed later.
+
+2006-05-26  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR fortran/23151
+	* io.c (match_io):  print (1,*) is an error.
+
+2006-05-26  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/27709
+	* resolve.c (find_array_spec): Add gfc_symbol, derived, and
+	use to track repeated component references.
+
+	PR fortran/27155
+	PR fortran/27449
+	* trans-intrinsic.c (gfc_conv_intrinsic_array_transfer): Use
+	se->string_length throughout and use memcpy to populate the
+	expression returned to the scalarizer.
+	(gfc_size_in_bytes): New function.
+
+2006-05-21  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/27613
+	* primary.c (gfc_match_rvalue): Test if symbol represents a
+	direct recursive function reference.  Error if array valued,
+	go to function0 otherwise.
+
+2006-05-21  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/25746
+	* interface.c (gfc_extend_assign): Use new EXEC_ASSIGN_CALL.
+	* gfortran.h : Put EXEC_ASSIGN_CALL in enum.
+	* trans-stmt.c (gfc_conv_elemental_dependencies): New function.
+	(gfc_trans_call): Call it.  Add new boolian argument to flag
+	need for dependency checking. Assert intent OUT and IN for arg1
+	and arg2.
+	(gfc_trans_forall_1): Use new code EXEC_ASSIGN_CALL.
+	trans-stmt.h : Modify prototype of gfc_trans_call.
+	trans.c (gfc_trans_code): Add call for EXEC_ASSIGN_CALL.
+	st.c (gfc_free_statement): Free actual for EXEC_ASSIGN_CALL.
+	* dependency.c (gfc_check_fncall_dependency): Don't check other
+	against itself.
+
+	PR fortran/25090
+	* resolve.c : Remove resolving_index_expr.
+	(entry_parameter): Remove.
+	(gfc_resolve_expr, resolve_charlen, resolve_fl_variable): Lift
+	calls to entry_parameter and references to resolving_index_expr.
+
+	PR fortran/27584
+	* check.c (gfc_check_associated): Replace NULL assert with an
+	error message, since it is possible to generate bad code that
+	has us fall through to here..
+
+	PR fortran/19015
+	* iresolve.c (maxloc, minloc): If DIM is not present, pass the
+	rank of ARRAY as the shape of the result.  Otherwise, pass the
+	shape of ARRAY, less the dimension DIM.
+	(maxval, minval): The same, when DIM is present, otherwise no
+	change.
+
+2006-05-19  H.J. Lu  <hongjiu.lu@intel.com>
+
+	PR fortran/27662
+	* trans-array.c (gfc_conv_expr_descriptor): Don't zero the
+	first stride to indicate a temporary.
+	* trans-expr.c (gfc_conv_function_call): Likewise.
+
+2006-05-18  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+	    Feng Wang  <fengwang@nudt.edu.cn>
+
+	PR fortran/27552
+	* dump-parse-tree.c (gfc_show_expr): Deal with Hollerith constants.
+	* data.c (create_character_intializer): Set from_H flag if character is
+	initialized by Hollerith constant.
+
+2006-05-17  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/26551
+	* resolve.c (resolve_call, resolve_function): Issue an error
+	if a function or subroutine call is recursive but the function or
+	subroutine wasn't declared as such.
+
+2006-05-07  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/26551
+	* gfortran.dg/recursive_check_1.f: New test.
+
+
+2006-05-17  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/27320
+	* dump-parse-tree.c (gfc_show_code_node): Try harder to find the
+	called procedure name.
+
+2006-05-17  Jakub Jelinek  <jakub@redhat.com>
+
+	PR middle-end/27415
+	* trans-openmp.c (gfc_trans_omp_parallel_do,
+	gfc_trans_omp_parallel_sections, gfc_trans_omp_parallel_workshare): Set
+	OMP_PARALLEL_COMBINED flag.
+
+2006-05-16  H.J. Lu  <hongjiu.lu@intel.com>
+
+	PR driver/26885
+	* Make-lang.in (GFORTRAN_D_OBJS): Replace gcc.o with
+	$(GCC_OBJS).
+
+2006-05-15  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/25090
+	* resolve.c: Static resolving_index_expr initialized.
+	(entry_parameter): New function to emit errors for variables
+	that are not entry parameters.
+	(gfc_resolve_expr): Call entry_parameter, when resolving
+	variables, if the namespace has entries and resolving_index_expr
+	is set.
+	(resolve_charlen): Set resolving_index_expr before the call to
+	resolve_index_expr and reset it afterwards.
+	(resolve_fl_variable): The same before and after the call to
+	is_non_constant_shape_array, which ultimately makes a call to
+	gfc_resolve_expr.
+
+	PR fortran/25082
+	* resolve.c (resolve_code): Add error condition that the return
+	expression must be scalar.
+
+	PR fortran/27411
+	* matchexp.c (gfc_get_parentheses): New function.
+	(match_primary): Remove inline code and call above.
+	* gfortran.h: Provide prototype for gfc_get_parentheses.
+	* resolve.c (resolve_array_ref): Call the above, when start is a
+	derived type variable array reference.
+
+2006-05-15  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/27446
+	* trans-openmp.c (gfc_trans_omp_array_reduction): Ensure
+	OMP_CLAUSE_REDUCTION_{INIT,MERGE} are set to BIND_EXPR.
+
+2006-05-14  H.J. Lu  <hongjiu.lu@intel.com>
+
+	* Make-lang.in (fortran/options.o): Depend on $(TARGET_H).
+
+2006-05-11  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/27553
+	* parse.c (next_free): Return instead of calling decode_statement
+	upon error.
+
+2006-05-10  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR fortran/27470
+	* trans-array.c(gfc_array_allocate):  If ref->next exists
+	that is if there is a statement like ALLOCATE(foo%bar(2)),
+	F95 rules require that bar should be a pointer.
+
+2006-05-10  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/20460
+	* resolve.c (gfc_resolve_index): Make REAL array indices a
+	GFC_STD_LEGACY feature.
+
+2006-05-10  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/24549
+	* parse.c (reject_statement): Clear gfc_new_block.
+
+2006-05-09  Steven G. Kargl  <kargls@comcast.net>
+
+	* invoke.texi: Missed file in previous commit.  Update
+	 description of -fall-intrinsics
+
+2006-05-07  Steven Boscher  <steven@gcc.gnu.org>
+
+	PR fortran/27378
+	* parse.c (next_statement): Add check to avoid an ICE when
+	gfc_current_locus.lb is not set.
+
+2006-05-07  Tobias Schlüter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/27457
+	* match.c (match_case_eos): Error out on garbage following
+	CASE(...).
+
+2006-05-07  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/24813
+	* trans-array.c (get_array_ctor_strlen): Remove static attribute.
+	* trans.h: Add prototype for get_array_ctor_strlen.
+	* trans-intrinsic.c (gfc_conv_intrinsic_len): Switch on EXPR_ARRAY
+	and call get_array_ctor_strlen.
+
+2006-05-05  Steven G. Kargl  <kargls@comcast.net>
+
+	* invoke.texi: Update description of -fall-intrinsics
+	* options.c (gfc_post_options): Disable -Wnonstd-intrinsics if
+	-fall-intrinsics is used.
+	(gfc_handle_option): Permit -Wno-nonstd-intrinsics.
+
+2006-05-04  Tobias Schlüter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* simplify.c (ascii_table): Fix wrong entry.
+
+2006-05-02  Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/26896
+	* lang.opt: Fix -Wtab description
+
+	PR fortran/20248  
+	* lang.opt: New flag -fall-intrinsics.
+	* invoke.texi:  Document option.
+	* gfortran.h (options_t):  New member flag_all_intrinsics.
+	* options.c (gfc_init_options, gfc_handle_option): Set new option.
+	sort nearby misplaced options.
+	* intrinsic.c (add_sym, make_generic, make_alias):  Use it.
+
+2006-05-02 Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/27269
+	* module.c: Add static flag in_load_equiv.
+	(mio_expr_ref): Return if no symtree and in_load_equiv.
+	(load_equiv): If any of the equivalence members have no symtree, free
+	the equivalence and the associated expressions.
+
+	PR fortran/27324
+	* trans-common.c (gfc_trans_common): Invert the order of calls to
+	finish equivalences and gfc_commit_symbols.
+
+2006-04-29  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/25681
+	* simplify.c (simplify_len): Character variables with constant
+	length can be simplified.
+
+2006-04-29  H.J. Lu  <hongjiu.lu@intel.com>
+
+	PR fortran/27351
+	* trans-array.c (gfc_conv_array_transpose): Move gcc_assert
+	before gfc_conv_expr_descriptor.
+
+2006-04-23  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/25099
+	* resolve.c (resolve_call): Check conformity of elemental
+	subroutine actual arguments.
+
+2006-04-22  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/26769
+	* iresolve.c (gfc_resolve_reshape): Use reshape_r16 for real(16).
+	(gfc_resolve_transpose): Use transpose_r16 for real(16).
+
+2006-04-21 Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/27122
+	* resolve.c (resolve_function): Remove general restriction on auto
+	character length function interfaces.
+	(gfc_resolve_uops): Check restrictions on defined operator
+	procedures.
+	(resolve_types): Call the check for defined operators.
+
+	PR fortran/27113
+	* trans-array.c (gfc_trans_array_constructor_subarray): Remove
+	redundant gfc_todo_error.
+	(get_array_ctor_var_strlen): Remove typo in enum.
+
+2006-04-18  Bernhard Fischer  <aldot@gcc.gnu.org>
+
+	* parse.c (next_free): Use consistent error string between
+	free-form and fixed-form for illegal statement label of zero.
+	(next_fixed): Use consistent warning string between free-form
+	and fixed-form for statement labels for empty statements.
+
+2006-04-18  Steve Ellcey  <sje@cup.hp.com>
+
+	* trans-io.c (gfc_build_io_library_fndecls): Align pad.
+
+2006-04-16  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR fortran/26017
+	* trans-array.c(gfc_array_init_size):  Introduce or_expr
+	which is true if the size along any dimension
+	is negative.  Create a temporary variable with base
+	name size.  If or_expr is true, set the temporary to 0,
+	to the normal size otherwise.
+
+2006-04-16  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/26822
+	* intrinsic.c (add_functions): Mark LOGICAL as elemental.
+
+	PR fortran/26787
+	* expr.c (gfc_check_assign): Extend scope of error to include
+	assignments to a procedure in the main program or, from a
+	module or internal procedure that is not that represented by
+	the lhs symbol. Use VARIABLE rather than l-value in message.
+
+	PR fortran/27096
+	* trans-array.c (gfc_trans_deferred_array): If the backend_decl
+	is not a descriptor, dereference and then test and use the type.
+
+	PR fortran/25597
+	* trans-decl.c (gfc_trans_deferred_vars): Check if an array
+	result, is also automatic character length.  If so, process
+	the character length.
+
+	PR fortran/18003
+	PR fortran/25669
+	PR fortran/26834
+	* trans_intrinsic.c (gfc_walk_intrinsic_bound): Set
+	data.info.dimen for bound intrinsics.
+	* trans_array.c (gfc_conv_ss_startstride): Pick out LBOUND and
+	UBOUND intrinsics and supply their shape information to the ss
+	and the loop.
+
+	PR fortran/27124
+	* trans_expr.c (gfc_trans_function_call):  Add a new block, post,
+	in to which all the argument post blocks are put.  Add this block
+	to se->pre after a byref call or to se->post, otherwise.
+
+2006-04-14  Roger Sayle  <roger@eyesopen.com>
+
+	* trans-io.c (set_string): Use fold_build2 and build_int_cst instead
+	of build2 and convert to construct "x < 0" rather than "x <= -1".
+
+2006-04-13  Richard Henderson  <rth@redhat.com>
+
+	* trans-openmp.c (gfc_trans_omp_sections): Adjust for changed
+	number of operands to OMP_SECTIONS.
+
+2006-04-08  Kazu Hirata  <kazu@codesourcery.com>
+
+	* gfortran.texi: Fix typos.  Follow spelling conventions.
+	* resolve.c, trans-expr.c, trans-stmt.c: Fix comment typos.
+	Follow spelling conventions.
+
+2006-04-05  Roger Sayle  <roger@eyesopen.com>
+
+	* dependency.c (get_no_elements): Delete function.
+	(get_deps): Delete function.
+	(transform_sections): Delete function.
+	(gfc_check_section_vs_section): Significant rewrite.
+
+2006-04-04  H.J. Lu  <hongjiu.lu@intel.com>
+
+	PR fortran/25619
+	* trans-array.c (gfc_conv_expr_descriptor): Only dereference
+	character pointer when copying temporary.
+
+	PR fortran/23634
+	* trans-array.c (gfc_conv_expr_descriptor): Properly copy
+	temporary character with non constant size.
+
+2006-04-03  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/26891
+	* trans.h: Prototype for gfc_conv_missing_dummy.
+	* trans-expr (gfc_conv_missing_dummy): New function
+	(gfc_conv_function_call): Call it and tidy up some of the code.
+	* trans-intrinsic (gfc_conv_intrinsic_function_args): The same.
+
+	PR fortran/26976
+	* array.c (gfc_array_dimen_size): If available, return shape[dimen].
+	* resolve.c (resolve_function): If available, use the argument
+	shape for the function expression.
+	* iresolve.c (gfc_resolve_transfer): Set shape[0] = size.
+
+2006-04-02  Erik Edelmann  <eedelman@gcc.gnu.org>
+
+	* trans-array.c (gfc_trans_dealloc_allocated): Take a
+	tree representation of the array to be deallocated as argument
+	instead of its gfc_symbol.
+	(gfc_trans_deferred_array): Update call to
+	gfc_trans_dealloc_allocated.
+	* trans-array.h (gfc_trans_dealloc_allocated): Update
+	prototype.
+	* trans-expr.c (gfc_conv_function_call): Update call to
+	gfc_trans_dealloc_allocated, get indirect reference to dummy
+	arguments.
+
+2006-04-01  Roger Sayle  <roger@eyesopen.com>
+
+	PR fortran/25270
+	* trans-array.c (gfc_trans_allocate_array_storage): In array index
+	calculations use gfc_index_zero_node and gfc_index_one_node instead
+	of integer_zero_node and integer_one_node respectively.
+	(gfc_conv_array_transpose): Likewise.
+	(gfc_conv_ss_startstride): Likewise.
+	(gfc_trans_dummy_array_bias): Likewise.
+
+2006-04-01  Roger Sayle  <roger@eyesopen.com>
+
+	* dependency.c (gfc_is_inside_range): Delete.
+	(gfc_check_element_vs_section): Significant rewrite.
+
+2006-04-01  Roger Sayle  <roger@eyesopen.com>
+
+	* dependency.c (gfc_dep_compare_expr): Strip parentheses and unary
+	plus operators when comparing expressions.  Handle comparisons of
+	the form "X+C vs. X", "X vs. X+C", "X-C vs. X" and "X vs. X-C" where
+	C is an integer constant.  Handle comparisons of the form "P+Q vs.
+	R+S" and "P-Q vs. R-S".  Handle comparisons of integral extensions
+	specially (increasing functions) so extend(A) > extend(B), when A>B.
+	(gfc_check_element_vs_element): Move test later, so that we ignore
+	the fact that "A < B" or "A > B" when A or B contains a forall index.
+
+2006-03-31  Asher Langton  <langton2@llnl.gov>
+
+	PR fortran/25358
+	* expr.c (gfc_check_assign): Allow cray pointee to be assumes-size.
+	
+2006-03-30  Paul Thomas <paulthomas2@wanadoo.fr>
+	    Bud Davis  <bdavis9659@sbcglobal.net>
+
+	PR 21130
+	* module.c (load_needed): Traverse entire tree before returning.
+
+2006-03-30  Roger Sayle  <roger@eyesopen.com>
+
+	PR middle-end/22375
+	* trans.c (gfc_trans_runtime_check): Promote the arguments of
+	__builtin_expect to the correct types, and the result back to
+	boolean_type_node.
+
+2006-03-29  Carlos O'Donell  <carlos@codesourcery.com>
+
+	* Make-lang.in: Rename docdir to gcc_docdir.
+
+2006-03-28  Steven G. Kargl  <kargls@comcast.net>
+
+	* intrinsic.texi: s/floor/float in previous commit.
+
+2006-03-28 Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/26779
+	* resolve.c (resolve_fl_procedure): Do not check the access of
+	derived types for internal procedures.
+
+2006-03-27  Jakub Jelinek  <jakub@redhat.com>
+
+	* io.c (check_io_constraints): Don't look at
+	dt->advance->value.charater.string, unless it is a CHARACTER
+	constant.
+
+	* f95-lang.c (gfc_get_alias_set): New function.
+	(LANG_HOOKS_GET_ALIAS_SET): Define.
+
+2006-03-25  Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/26816
+	* intrinsic.c (add_functions): Allow FLOAT to accept all integer kinds.
+	* intrinsic.texi: Document FLOAT.
+
+2006-03-25  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR fortran/26769
+	* iresolve.c (gfc_resolve_reshape):  Remove doubling of
+	kind for complex. For real(kind=10), call reshape_r10.
+	(gfc_resolve_transpose):  For real(kind=10), call
+	transpose_r10.
+
+2006-03-25  Roger Sayle  <roger@eyesopen.com>
+
+	* dependency.c (gfc_check_dependency): Improve handling of pointers;
+	Two variables of different types can't have a dependency, and two
+	variables with the same symbol are equal, even if pointers.
+
+2006-03-24  Roger Sayle  <roger@eyesopen.com>
+
+	* gfortran.h (gfc_symbol): Add a new "forall_index" bit field.
+	* match.c (match_forall_iterator): Set forall_index field on
+	the iteration variable's symbol.
+	* dependency.c (contains_forall_index_p): New function to
+	traverse a gfc_expr to check whether it contains a variable
+	with forall_index set in it's symbol.
+	(gfc_check_element_vs_element): Return GFC_DEP_EQUAL for scalar
+	constant expressions that don't variables used as FORALL indices.
+
+2006-03-22  Volker Reichelt  <reichelt@igpm.rwth-aachen.de>
+
+	PR driver/22600
+	* error.c (gfc_fatal_error): Return ICE_EXIT_CODE instead of 4.
+
+2006-03-22  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR fortran/19303
+	* gfortran.h (gfc_option_t):  Add record_marker.
+	* lang.opt:  Add -frecord-marker=4 and -frecord-marker=8.
+	* trans-decl.c:  Add gfor_fndecl_set_record_marker.
+	(gfc_build_builtin_function_decls): Set
+	gfor_fndecl_set_record_marker.
+	(gfc_generate_function_code):  If we are in the main program
+	and -frecord-marker was provided, call set_record_marker.
+	* options.c (gfc_handle_option):  Add handling for
+	-frecord-marker=4 and -frecord-marker=8.
+	* invoke.texi:  Document -frecord-marker.
+
+2006-03-22  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/17298
+	* trans-intrinsic.c (gfc_conv_intrinsic_array_transfer): New
+	function to implement array valued TRANSFER intrinsic.
+	(gfc_conv_intrinsic_function): Call the new function if TRANSFER
+	and non-null se->ss.
+	(gfc_walk_intrinsic_function): Treat TRANSFER as one of the
+	special cases by calling gfc_walk_intrinsic_libfunc directly.
+
+2006-03-21  Toon Moene  <toon@moene.indiv.nluug.nl>
+
+	* options.c (gfc_init_options): Initialize
+	flag_argument_noalias to 3.
+
+2006-03-20  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR fortran/20935
+	* iresolve.c (gfc_resolve_maxloc):   If mask is scalar,
+	prefix the function name with an "s".  If the mask is scalar
+	or if its kind is smaller than gfc_default_logical_kind,
+	coerce it to default kind.
+	(gfc_resolve_maxval):  Likewise.
+	(gfc_resolve_minloc):  Likewise.
+	(gfc_resolve_minval):  Likewise.
+	(gfc_resolve_product):  Likewise.
+	(gfc_resolve_sum):  Likewise.
+
+2006-03-19  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/26741
+	*expr.c (external_spec_function): Permit elemental functions.
+
+	PR fortran/26716
+	*interface.c (compare_actual_formal): Detect call for procedure
+	usage and require rank checking, in this case, for assumed shape
+	and deferred shape arrays.
+	(gfc_procedure_use): Revert to pre-PR25070 call to
+	compare_actual_formal that does not require rank checking..
+
+2006-03-16  Roger Sayle  <roger@eyesopen.com>
+
+	* gfortran.h (gfc_equiv_info): Add length field.
+	* trans-common.c (copy_equiv_list_to_ns): Set the length field.
+	* dependency.c (gfc_are_equivalenced_arrays): Use both the offset
+	and length fields to determine whether the two equivalenced symbols
+	overlap in memory.
+
+2006-03-14  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/19101
+	* gfortran.h: Add warn_ampersand.
+	* invoke.texi: Add documentation for new option.
+	* lang.opt: Add Wampersand.
+	* options.c (gfc_init_options): Initialize warn_ampersand.
+	(gfc_post_options): Set the warn if pedantic.
+	(set_Wall): Set warn_ampersand.
+	(gfc_handle_option: Add Wampersand for itself, -std=f95, and -std=f2003.
+	* scanner.c (gfc_next_char_literal): Add test for missing '&' in
+	continued character constant and give warning if missing.
+
+2006-03-14  Steven G. Kargl  <kargls@comcast.net>
+
+	PR 18537
+	* gfortran.h: Wrap Copyright line.
+	(gfc_option_t): add warn_tabs member.
+	* lang.opt: Update Coyright year.  Add the Wtabs.
+	* invoke.texi: Document -Wtabs.
+	* scanner.c (gfc_gobble_whitespace): Use warn_tabs.  Add linenum to
+	suppress multiple warnings.
+	(load_line): Use warn_tabs.  Add linenum, current_line, seen_comment
+	to suppress multiple warnings.
+	* options.c (gfc_init_options): Initialize warn_tabs.
+	(set_Wall): set warn_tabs for -Wall.
+	(gfc_post_options): Adjust flag_tabs depending on -pedantic.
+	(gfc_handle_option):  Process command-line option -W[no-]tabs
+
+2006-03-13  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/25378
+	* trans-intrinsic.c (gfc_conv_intrinsic_minmaxloc): Set the initial position to zero and
+	modify the condition for updating it, to implement the F2003 requirement for all(mask)
+	is false.
+
+2006-03-13  Jakub Jelinek  <jakub@redhat.com>
+
+	* trans-openmp.c (gfc_trans_omp_variable): Handle references
+	to parent result.
+	* trans-expr.c (gfc_conv_variable): Remove useless setting
+	of parent_flag, formatting.
+
+	* trans-decl.c (gfc_get_fake_result_decl): Re-add setting of
+	GFC_DECL_RESULT flag.
+
+2006-03-11  Roger Sayle  <roger@eyesopen.com>
+
+	* dependency.c (gfc_dep_compare_expr) <EXPR_OP>: Allow unary and
+	binary operators to compare equal if their operands are equal.
+	<EXPR_FUNCTION>: Allow "constant" intrinsic conversion functions
+	to compare equal, if their operands are equal.
+
+2006-03-11  Erik Edelmann  <eedelman@gcc.gnu.org>
+
+	* symbol.c (check_conflict): Allow allocatable function results,
+	except for elemental functions.
+	* trans-array.c (gfc_trans_allocate_temp_array): Rename to ...
+	(gfc_trans_create_temp_array): ... this, and add new argument
+	callee_alloc.
+	(gfc_trans_array_constructor, gfc_conv_loop_setup): Update call
+	to gfc_trans_allocate_temp_array.
+	* trans-array.h (gfc_trans_allocate_temp_array): Update prototype.
+	* trans-expr.c (gfc_conv_function_call): Use new arg of
+	gfc_trans_create_temp_array avoid pre-allocation of temporary
+	result variables of pointer AND allocatable functions.
+	(gfc_trans_arrayfunc_assign): Return NULL for allocatable
+	functions.
+	* resolve.c (resolve_symbol): Copy value of 'allocatable' attribute
+	from sym->result to sym.
+
+2006-03-09  Erik Edelmann  <eedelman@gcc.gnu.org>
+
+	* trans-expr.c (gfc_add_interface_mapping): Copy 'allocatable'
+	attribute from sym to new_sym.  Call build_fold_indirect_ref()
+	for allocatable arguments.
+
+2006-03-09 Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/26257
+	* trans-array.c (gfc_conv_expr_descriptor): Exclude calculation of
+	the offset and data when se->data_not_needed is set.
+	* trans.h: Include the data_not_need bit in gfc_se.
+	* trans-intrinsic.c (gfc_conv_intrinsic_size): Set it for SIZE.
+
+2006-03-06  Paul Thomas  <pault@gcc.gnu.org>
+	    Erik Edelmann  <eedelman@gcc.gnu.org>
+
+	* trans-array.c (gfc_trans_dealloc_allocated): New function.
+	(gfc_trans_deferred_array): Use it, instead of inline code.
+	* trans-array.h: Prototype for gfc_trans_dealloc_allocated().
+	* trans-expr.c (gfc_conv_function_call): Deallocate allocated
+	ALLOCATABLE, INTENT(OUT) arguments upon procedure entry.
+
+2006-03-06  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/26107
+	* resolve.c (resolve_function): Add name after test for pureness.
+
+	PR fortran/19546
+	* trans-expr.c (gfc_conv_variable): Detect reference to parent result,
+	store current_function_decl, replace with parent, whilst calls are
+	made to gfc_get_fake_result_decl, and restore afterwards. Signal this
+	to gfc_get_fake_result_decl with a new argument, parent_flag.
+	* trans-stmt.c (gfc_trans_return): gfc_get_fake_result_decl 2nd arg
+	is set to zero.
+	* trans.h: Add parent_flag to gfc_get_fake_result_decl prototype.
+	* trans-decl.c (gfc_get_fake_result_decl): On parent_flag, being set,
+	add decl to parent function. Replace refs to current_fake_result_decl
+	with refs to this_result_decl.
+	(gfc_generate_function_code): Null parent_fake_result_decl before the
+	translation of code for contained procedures. Set parent_flag to zero
+	in call to gfc_get_fake_result_decl.
+	* trans-intrinsic.c (gfc_conv_intrinsic_len): The same.
+
+2006-03-05  Steven G. Kargl  <kargls@comcast.net>
+
+	* simplify.c (gfc_simplify_verify):  Fix return when SET=''.
+
+2006-03-05  Erik Edelmann  <eedelman@gcc.gnu.org>
+
+	PR fortran/16136
+	* symbol.c (conf_std): New macro.
+	(check_conflict): Use it to allow ALLOCATABLE dummy
+	arguments for F2003.
+	* trans-expr.c (gfc_conv_function_call): Pass the
+	address of the array descriptor when dummy argument is
+	ALLOCATABLE.
+	* interface.c (compare_allocatable): New function.
+	(compare_actual_formal): Use it.
+	* resolve.c (resolve_deallocate_expr,
+	resolve_allocate_expr): Check that INTENT(IN) variables
+	aren't (de)allocated.
+	* gfortran.texi (Fortran 2003 status): List ALLOCATABLE
+	dummy arguments as supported.
+
+2006-03-03  Roger Sayle  <roger@eyesopen.com>
+
+	* dependency.c (gfc_check_element_vs_element): Revert last change.
+
+2006-03-03  Roger Sayle  <roger@eyesopen.com>
+
+	* dependency.c (gfc_check_element_vs_element): Consider two
+	unordered scalar subscripts as (potentially) equal.
+
+2006-03-03  Roger Sayle  <roger@eyesopen.com>
+
+	* dependency.c (gfc_check_dependency): Call gfc_dep_resolver to
+	check whether two array references have a dependency.
+	(gfc_check_element_vs_element): Assume lref and rref must be
+	REF_ARRAYs.  If gfc_dep_compare_expr returns -2, assume these
+	references could potentially overlap.
+	(gfc_dep_resolver): Whitespace and comment tweaks.  Assume a
+	dependency if the references have different depths.  Rewrite
+	final term to clarrify we only have a dependency for overlaps.
+
+2006-03-03  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR fortran/25031
+	* trans-array.h:  Adjust gfc_array_allocate prototype.
+	* trans-array.c (gfc_array_allocate):  Change type of
+	gfc_array_allocatate to bool.  Function returns true if
+	it operates on an array.  Change second argument to gfc_expr.
+	Find last reference in chain.
+	If the function operates on an allocatable array, emit call to
+	allocate_array() or allocate64_array().
+	* trans-stmt.c (gfc_trans_allocate):  Code to follow to last
+	reference has been moved to gfc_array_allocate.
+	* trans.h:  Add declaration for gfor_fndecl_allocate_array and
+	gfor_fndecl_allocate64_array.
+	(gfc_build_builtin_function_decls):  Add gfor_fndecl_allocate_array
+	and gfor_fndecl_allocate64_array.
+
+2006-03-01  Roger Sayle  <roger@eyesopen.com>
+
+	* trans-stmt.c (generate_loop_for_temp_to_lhs): Add an additional
+	INVERT argument to invert the sense of the WHEREMASK argument.
+	Remove unneeded code to AND together a list of masks.
+	(generate_loop_for_rhs_to_temp): Likewise.
+	(gfc_trans_assign_need_temp): Likewise.
+	(gfc_trans_forall_1): Likewise.
+	(gfc_evaluate_where_mask): Likewise, add a new INVERT argument
+	to specify the sense of the MASK argument.
+	(gfc_trans_where_assign): Likewise.
+	(gfc_trans_where_2): Likewise.  Restructure code that decides
+	whether we need to allocate zero, one or two temporary masks.
+	If this is a top-level WHERE (i.e. the incoming MASK is NULL),
+	we only need to allocate at most one temporary mask, and can
+	invert it's sense to provide the complementary pending execution
+	mask.  Only calculate the size of the required temporary arrays
+	if we need any.
+	(gfc_trans_where): Update call to gfc_trans_where_2.
+
+2006-03-01  Paul Thomas  <pault@gcc.gnu.org>
+
+	* iresolve.c (gfc_resolve_dot_product):  Remove any difference in
+	treatment of logical types.
+	* trans-intrinsic.c (gfc_conv_intrinsic_dot_product):  New function. 
+
+	PR fortran/26393
+	* trans-decl.c (gfc_get_symbol_decl): Extend condition that symbols
+	must be referenced to include unreferenced symbols in an interface
+	body. 
+
+	PR fortran/20938
+	* trans-array.c (gfc_conv_resolve_dependencies): Add call to
+	gfc_are_equivalenced_arrays.
+	* symbol.c (gfc_free_equiv_infos, gfc_free_equiv_lists): New
+	functions. (gfc_free_namespace): Call them.
+	* trans-common.c (copy_equiv_list_to_ns): New function.
+	(add_equivalences): Call it.
+	* gfortran.h: Add equiv_lists to gfc_namespace and define
+	gfc_equiv_list and gfc_equiv_info.
+	* dependency.c (gfc_are_equivalenced_arrays): New function.
+	(gfc_check_dependency): Call it.
+	* dependency.h: Prototype for gfc_are_equivalenced_arrays.
+
+2006-03-01  Roger Sayle  <roger@eyesopen.com>
+
+	* dependency.c (gfc_is_same_range): Compare the stride, lower and
+	upper bounds when testing array reference ranges for equality.
+	(gfc_check_dependency): Fix indentation whitespace.
+	(gfc_check_element_vs_element): Likewise.
+	(gfc_dep_resolver): Likewise.
+
+2006-02-28  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	* trans-intrinsic.c (gfc_conv_intrinsic_minmaxloc):
+	If the mask expression exists and has rank 0, enclose the
+	generated loop in an "if (mask)".  Put the default
+	initialization into the else branch.
+
+2006-02-25  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR fortran/23092
+	* trans-intrinsic.c (gfc_conv_intrinsic_arith):  If the
+	mask expression exists and has rank 0, enclose the generated
+	loop in an "if (mask)".
+	* (gfc_conv_intrinsic_minmaxloc):  Likewise.
+
+2006-02-24  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/26409
+	* resolve.c (resolve_contained_functions, resolve_types,
+	gfc_resolve): Revert patch of 2006-02-19.
+
+2006-02-24  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/24519
+	* dependency.c (gfc_is_same_range): Correct typo.
+	(gfc_check_section_vs_section): Call gfc_is_same_range.
+
+	PR fortran/25395
+	* trans-common.c (add_equivalences): Add a new flag that is set when
+	an equivalence is seen that prevents more from being reset until the
+	start of a new traversal of the list, thus ensuring completion of
+	all the equivalences.
+
+2006-02-23  Erik Edelmann  <eedelman@gcc.gnu.org>
+
+	* module.c (read_module): Remove redundant code lines.
+
+2006-02-20 Rafael Ávila de Espíndola <rafael.espindola@gmail.com>
+	* Make-lang.in (FORTRAN): Remove
+	(.PHONY): Remove F95 and f95. Add fortran
+
+2006-02-20  Roger Sayle  <roger@eyesopen.com>
+
+	* trans-stmt.c (gfc_trans_where_2): Avoid updating unused current
+	execution mask for empty WHERE/ELSEWHERE clauses.  Don't allocate
+	temporary mask arrays if they won't be used.
+
+2006-02-20  Roger Sayle  <roger@eyesopen.com>
+
+	* trans-stmt.c (gfc_trans_where_assign): Remove code to handle
+	traversing a linked list of MASKs.  The MASK is now always a
+	single element requiring no ANDing during the assignment.
+
+2006-02-19  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	* gfortran.texi:  Document environment variables which
+	influence runtime behavior.
+
+2006-02-19  H.J. Lu  <hongjiu.lu@intel.com>
+
+	* resolve.c (resolve_contained_functions): Call resolve_entries
+	first.
+	(resolve_types): Remove calls to resolve_entries and
+	resolve_contained_functions.
+	(gfc_resolve): Call resolve_contained_functions.
+
+2006-02-19  Erik Edelmann  <eedelman@gcc.gnu.org>
+
+	PR fortran/26201
+	* intrinsic.c (gfc_convert_type_warn): Call
+	gfc_intrinsic_symbol() on the newly created symbol.
+
+2006-02-19  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/25054
+	* resolve.c (is_non_constant_shape_array): New function.
+	(resolve_fl_variable): Remove code for the new function and call it.
+	(resolve_fl_namelist): New function.  Add test for namelist array
+	with non-constant shape, using is_non_constant_shape_array.
+	(resolve_symbol): Remove code for resolve_fl_namelist and call it.
+
+	PR fortran/25089
+	* match.c (match_namelist): Increment the refs field of an accepted
+	namelist object symbol.
+	* resolve.c (resolve_fl_namelist): Test namelist objects for a conflict
+	with contained or module procedures.
+
+2006-02-18  Roger Sayle  <roger@eyesopen.com>
+
+	* trans-stmt.c (struct temporary_list): Delete.
+	(gfc_trans_where_2): Major reorganization.  Remove no longer needed
+	TEMP argument.  Allocate and deallocate the control mask and
+	pending control mask locally.
+	(gfc_trans_forall_1): Delete TEMP local variable, and update
+	call to gfc_trans_where_2.  No need to deallocate arrays after.
+	(gfc_evaluate_where_mask): Major reorganization.  Change return
+	type to void.  Pass in parent execution mask, MASK, and two
+	already allocated mask arrays CMASK and PMASK.  On return
+	CMASK := MASK & COND, PMASK := MASK & !COND.  MASK, CMASK and
+	CMASK may all be NULL, or refer to the same temporary arrays.
+	(gfc_trans_where): Update call to gfc_trans_where_2.  We no
+	longer need a TEMP variable or to deallocate temporary arrays
+	allocated by gfc_trans_where_2.
+
+2006-02-18   Danny Smith  <dannysmith@users.sourceforeg.net>
+
+	* gfortran.h (gfc_add_attribute): Change uint to unsigned int.
+	* symbol.c (gfc_add_attribute): Likewise for definition.
+	* resolve.c (resolve_global_procedure): Likewise for variable 'type'.
+
+2006-02-17  Richard Sandiford  <richard@codesourcery.com>
+
+	* trans-common.c: Include rtl.h earlier.
+	* trans-decl.c: Likewise.
+
+2006-02-16  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/26224
+	* parse.c (parse_omp_do, parse_omp_structured_block): Call
+	gfc_commit_symbols and gfc_warning_check.
+
+	* openmp.c (resolve_omp_clauses): Add a dummy case label to workaround
+	PR middle-end/26316.
+
+2006-02-16  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/24557
+	* trans-expr.c (gfc_add_interface_mapping): Use the actual argument
+	for character(*) arrays, rather than casting to the type and kind
+	parameters of the formal argument.
+
+2006-02-15  Toon Moene  <toon@moene.indiv.nluug.nl>
+
+	PR fortran/26054
+	* options.c: Do not warn for Fortran 2003 features by default.
+
+2006-02-15  Tobias Schlüter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* check.c: Update copyright years.
+	
+	* check.c (gfc_check_minloc_maxloc, check_reduction): Don't call
+	dim_range_check on not-present optional dim argument.
+
+2006-02-15  Jakub Jelinek  <jakub@redhat.com>
+
+	PR libgomp/25938
+	PR libgomp/25984
+	* Make-lang.in (install-finclude-dir): New goal.
+	(fortran.install-common): Depend on install-finclude-dir.
+	* lang-specs.h: If not -nostdinc, add -I finclude.
+
+2006-02-14  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR fortran/25045
+	* check.c (dim_check):  Perform all checks if dim is optional.
+	(gfc_check_minloc_maxloc):  Use dim_check and dim_rank_check
+	to check dim argument.
+	(check_reduction):  Likewise.
+
+2006-02-14  Tobias Schlüter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/26277
+	* io.c (match_ltag): Mark label as referenced.
+
+2006-02-14  Jakub Jelinek  <jakub@redhat.com>
+	    Richard Henderson  <rth@redhat.com>
+	    Diego Novillo  <dnovillo@redhat.com>
+
+	* invoke.texi: Document -fopenmp.
+	* gfortran.texi (Extensions): Document OpenMP.
+
+	Backport from gomp-20050608-branch
+	* trans-openmp.c: Call build_omp_clause instead of
+	make_node when creating OMP_CLAUSE_* trees.
+	(gfc_trans_omp_reduction_list): Remove argument 'code'.
+	Adjust all callers.
+
+	* trans.h (build4_v): Define.
+	* trans-openmp.c: Call build4_v to create OMP_PARALLEL nodes.
+	Call build3_v to create OMP_SECTIONS nodes.
+
+	PR fortran/25162
+	* openmp.c (gfc_match_omp_variable_list): Call gfc_set_sym_referenced
+	on all symbols added to the variable list.
+
+	* openmp.c (gfc_match_omp_clauses): Fix check for non-INTRINSIC
+	procedure symbol in REDUCTION.
+
+	* trans-openmp.c (gfc_trans_omp_array_reduction): Use gfc_add
+	for MINUS_EXPR OMP_CLAUSE_REDUCTION_CODE.
+
+	* trans-openmp.c (gfc_trans_omp_do): Add PBLOCK argument.  If PBLOCK
+	is non-NULL, evaluate INIT/COND/INCR and chunk size expressions in
+	that statement block.
+	(gfc_trans_omp_parallel_do): Pass non-NULL PBLOCK to gfc_trans_omp_do
+	for non-ordered non-static combined loops.
+	(gfc_trans_omp_directive): Pass NULL PBLOCK to gfc_trans_omp_do.
+
+	* openmp.c: Include target.h and toplev.h.
+	(gfc_match_omp_threadprivate): Emit diagnostic if target does
+	not support TLS.
+	* Make-lang.in (fortran/openmp.o): Add dependencies on
+	target.h and toplev.h.
+
+	* trans-decl.c (gfc_get_fake_result_decl): Set GFC_DECL_RESULT.
+	* trans-openmp.c (gfc_omp_privatize_by_reference): Make
+	DECL_ARTIFICIAL vars predetermined shared except GFC_DECL_RESULT.
+	(gfc_omp_disregard_value_expr): Handle GFC_DECL_RESULT.
+	(gfc_trans_omp_variable): New function.
+	(gfc_trans_omp_variable_list, gfc_trans_omp_reduction_list): Use it.
+	* trans.h (GFC_DECL_RESULT): Define.
+
+	* trans-openmp.c (gfc_omp_firstprivatize_type_sizes): New function.
+	* f95-lang.c (LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES): Define.
+	* trans.h (gfc_omp_firstprivatize_type_sizes): New prototype.
+
+	* trans-openmp.c (gfc_omp_privatize_by_reference): Return
+	true if a pointer has GFC_DECL_SAVED_DESCRIPTOR set.
+	(gfc_trans_omp_array_reduction, gfc_trans_omp_reduction_list): New
+	functions.
+	(gfc_trans_omp_clauses): Add WHERE argument.  Call
+	gfc_trans_omp_reduction_list rather than gfc_trans_omp_variable_list
+	for reductions.
+	(gfc_trans_omp_do, gfc_trans_omp_parallel, gfc_trans_omp_parallel_do,
+	gfc_trans_omp_parallel_sections, gfc_trans_omp_parallel_workshare,
+	gfc_trans_omp_sections, gfc_trans_omp_single): Adjust
+	gfc_trans_omp_clauses callers.
+
+	* openmp.c (omp_current_do_code): New var.
+	(gfc_resolve_omp_do_blocks): New function.
+	(gfc_resolve_omp_parallel_blocks): Call it.
+	(gfc_resolve_do_iterator): Add CODE argument.  Don't propagate
+	predetermination if argument is !$omp do or !$omp parallel do
+	iteration variable.
+	* resolve.c (resolve_code): Call gfc_resolve_omp_do_blocks
+	for EXEC_OMP_DO.  Adjust gfc_resolve_do_iterator caller.
+	* fortran.h (gfc_resolve_omp_do_blocks): New prototype.
+	(gfc_resolve_do_iterator): Add CODE argument.
+
+	* trans.h (gfc_omp_predetermined_sharing,
+	gfc_omp_disregard_value_expr, gfc_omp_private_debug_clause): New
+	prototypes.
+	(GFC_DECL_COMMON_OR_EQUIV, GFC_DECL_CRAY_POINTEE): Define.
+	* trans-openmp.c (gfc_omp_predetermined_sharing,
+	gfc_omp_disregard_value_expr, gfc_omp_private_debug_clause): New
+	functions.
+	* trans-common.c (build_equiv_decl, build_common_decl,
+	create_common): Set GFC_DECL_COMMON_OR_EQUIV flag on the decls.
+	* trans-decl.c (gfc_finish_cray_pointee): Set GFC_DECL_CRAY_POINTEE
+	on the decl.
+	* f95-lang.c (LANG_HOOKS_OMP_PREDETERMINED_SHARING,
+	LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR,
+	LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE): Define.
+
+	* openmp.c (resolve_omp_clauses): Remove extraneous comma.
+
+	* symbol.c (check_conflict): Add conflict between cray_pointee and
+	threadprivate.
+	* openmp.c (gfc_match_omp_threadprivate): Fail if
+	gfc_add_threadprivate returned FAILURE.
+	(resolve_omp_clauses): Diagnose Cray pointees in SHARED,
+	{,FIRST,LAST}PRIVATE and REDUCTION clauses and Cray pointers in
+	{FIRST,LAST}PRIVATE and REDUCTION clauses.
+
+	* resolve.c (omp_workshare_flag): New variable.
+	(resolve_function): Diagnose use of non-ELEMENTAL user defined
+	function in WORKSHARE construct.
+	(resolve_code): Cleanup forall_save use.  Make sure omp_workshare_flag
+	is set to correct value in different contexts.
+
+	* openmp.c (resolve_omp_clauses): Replace %s with '%s' when printing
+	variable name.
+	(resolve_omp_atomic): Likewise.
+
+	PR fortran/24493
+	* scanner.c (skip_free_comments): Set at_bol at the beginning of the
+	loop, not before it.
+	(skip_fixed_comments): Handle ! comments in the middle of line here
+	as well.
+	(gfc_skip_comments): Use skip_fixed_comments for FIXED_FORM even if
+	not at BOL.
+	(gfc_next_char_literal): Fix expected canonicalized *$omp string.
+
+	* trans-openmp.c (gfc_trans_omp_do): Use make_node and explicit
+	initialization to build OMP_FOR instead of build.
+
+	* trans-decl.c (gfc_gimplify_function): Invoke
+	diagnose_omp_structured_block_errors.
+
+	* trans-openmp.c (gfc_trans_omp_master): Use OMP_MASTER.
+	(gfc_trans_omp_ordered): Use OMP_ORDERED.
+
+	* gfortran.h (gfc_resolve_do_iterator, gfc_resolve_blocks,
+	gfc_resolve_omp_parallel_blocks): New prototypes.
+	* resolve.c (resolve_blocks): Renamed to...
+	(gfc_resolve_blocks): ... this.  Remove static.
+	(gfc_resolve_forall): Adjust caller.
+	(resolve_code): Only call gfc_resolve_blocks if code->block != 0
+	and not for EXEC_OMP_PARALLEL* directives.  Call
+	gfc_resolve_omp_parallel_blocks for EXEC_OMP_PARALLEL* directives.
+	Call gfc_resolve_do_iterator if resolved successfully EXEC_DO
+	iterator.
+	* openmp.c: Include pointer-set.h.
+	(omp_current_ctx): New variable.
+	(gfc_resolve_omp_parallel_blocks, gfc_resolve_do_iterator): New
+	functions.
+	* Make-lang.in (fortran/openmp.o): Depend on pointer-set.h.
+
+	* openmp.c (gfc_match_omp_clauses): For max/min/iand/ior/ieor,
+	look up symbol if it exists, use its name instead and, if it is not
+	INTRINSIC, issue diagnostics.
+
+	* parse.c (parse_omp_do): Handle implied end do properly.
+	(parse_executable): If parse_omp_do returned ST_IMPLIED_ENDDO,
+	return it instead of continuing.
+
+	* trans-openmp.c (gfc_trans_omp_critical): Update for changed
+	operand numbering.
+	(gfc_trans_omp_do, gfc_trans_omp_parallel, gfc_trans_omp_parallel_do,
+	gfc_trans_omp_parallel_sections, gfc_trans_omp_parallel_workshare,
+	gfc_trans_omp_sections, gfc_trans_omp_single): Likewise.
+
+	* trans.h (gfc_omp_privatize_by_reference): New prototype.
+	* f95-lang.c (LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE): Redefine
+	to gfc_omp_privatize_by_reference.
+	* trans-openmp.c (gfc_omp_privatize_by_reference): New function.
+
+	* trans-stmt.h (gfc_trans_omp_directive): Add comment.
+
+	* openmp.c (gfc_match_omp_variable_list): Add ALLOW_COMMON argument.
+	Disallow COMMON matching if it is set.
+	(gfc_match_omp_clauses, gfc_match_omp_flush): Adjust all callers.
+	(resolve_omp_clauses): Show locus in error messages.  Check that
+	variable types in reduction clauses are appropriate for reduction
+	operators.
+
+	* resolve.c (resolve_symbol): Don't error if a threadprivate module
+	variable isn't SAVEd.
+
+	* trans-openmp.c (gfc_trans_omp_do): Put count into BLOCK, not BODY.
+	Fix typo in condition.  Fix DOVAR initialization.
+
+	* openmp.c (gfc_match_omp_clauses): Match min/iand/ior/ieor
+	rather than .min. etc.
+
+	* trans-openmpc.c (omp_not_yet): Remove.
+	(gfc_trans_omp_parallel_do): Keep listprivate clause on parallel.
+	Force creation of BIND_EXPR around the workshare construct.
+	(gfc_trans_omp_parallel_sections): Likewise.
+	(gfc_trans_omp_parallel_workshare): Likewise.
+
+	* types.def (BT_I16, BT_FN_I16_VPTR_I16,
+	BT_FN_BOOL_VPTR_I16_I16, BT_FN_I16_VPTR_I16_I16): Add.
+
+	* trans-openmp.c (gfc_trans_omp_clauses): Create OMP_CLAUSE_DEFAULT.
+	(gfc_trans_omp_code): New function.
+	(gfc_trans_omp_do): Use it, remove omp_not_yet uses.
+	(gfc_trans_omp_parallel, gfc_trans_omp_single): Likewise.
+	(gfc_trans_omp_sections): Likewise.  Only treat empty last section
+	specially if lastprivate clause is present.
+	* f95-lang.c (gfc_init_builtin_functions): Create BUILT_IN_TRAP
+	builtin.
+
+	* trans-openmp.c (gfc_trans_omp_variable_list): Update for
+	OMP_CLAUSE_DECL name change.
+	(gfc_trans_omp_do): Likewise.
+
+	* trans-openmp.c (gfc_trans_omp_clauses): Create OMP_CLAUSE_REDUCTION
+	clauses.
+	(gfc_trans_omp_atomic): Build OMP_ATOMIC instead of expanding
+	sync builtins directly.
+	(gfc_trans_omp_single): Build OMP_SINGLE statement.
+
+	* trans-openmp.c (gfc_trans_add_clause): New.
+	(gfc_trans_omp_variable_list): Take a tree code and build the clause
+	node here.  Link it to the head of a list.
+	(gfc_trans_omp_clauses): Update to match.
+	(gfc_trans_omp_do): Use gfc_trans_add_clause.
+
+	* trans-openmp.c (gfc_trans_omp_clauses): Change second argument to
+	gfc_omp_clauses *.  Use gfc_evaluate_now instead of creating
+	temporaries by hand.
+	(gfc_trans_omp_atomic, gfc_trans_omp_critical): Use buildN_v macros.
+	(gfc_trans_omp_do): New function.
+	(gfc_trans_omp_master): Dont' check for gfc_trans_code returning NULL.
+	(gfc_trans_omp_parallel): Adjust gfc_trans_omp_clauses caller.
+	Use buildN_v macros.
+	(gfc_trans_omp_parallel_do, gfc_trans_omp_parallel_sections,
+	gfc_trans_omp_parallel_workshare, gfc_trans_omp_sections,
+	gfc_trans_omp_single, gfc_trans_omp_workshare): New functions.
+	(gfc_trans_omp_directive): Use them.
+	* parse.c (parse_omp_do): Allow new_st.op == EXEC_NOP.
+	* openmp.c (resolve_omp_clauses): Check for list items present
+	in multiple clauses.
+	(resolve_omp_do): Check that iteration variable is not THREADPRIVATE
+	and is not present in any clause variable lists other than PRIVATE
+	or LASTPRIVATE.
+
+	* gfortran.h (symbol_attribute): Add threadprivate bit.
+	(gfc_common_head): Add threadprivate member, change use_assoc
+	and saved into char to save space.
+	(gfc_add_threadprivate): New prototype.
+	* symbol.c (check_conflict): Handle threadprivate.
+	(gfc_add_threadprivate): New function.
+	(gfc_copy_attr): Copy threadprivate.
+	* trans-openmp.c (gfc_trans_omp_clauses): Avoid creating a temporary
+	if IF or NUM_THREADS is constant.  Create OMP_CLAUSE_SCHEDULE and
+	OMP_CLAUSE_ORDERED.
+	* resolve.c (resolve_symbol): Complain if a THREADPRIVATE symbol
+	outside a module and not in COMMON has is not SAVEd.
+	(resolve_equivalence): Ensure THREADPRIVATE objects don't get
+	EQUIVALENCEd.
+	* trans-common.c: Include target.h and rtl.h.
+	(build_common_decl): Set DECL_TLS_MODEL if THREADPRIVATE.
+	* trans-decl.c: Include rtl.h.
+	(gfc_finish_var_decl): Set DECL_TLS_MODEL if THREADPRIVATE.
+	* dump-parse-tree.c (gfc_show_attr): Handle THREADPRIVATE.
+	* Make-lang.in (fortran/trans-decl.o): Depend on $(RTL_H).
+	(fortran/trans-common.o): Depend on $(RTL_H) and $(TARGET_H).
+	* openmp.c (gfc_match_omp_variable_list): Ensure COMMON block
+	is from current namespace.
+	(gfc_match_omp_threadprivate): Rewrite.
+	(resolve_omp_clauses): Check some clause restrictions.
+	* module.c (ab_attribute): Add AB_THREADPRIVATE.
+	(attr_bits): Add THREADPRIVATE.
+	(mio_symbol_attribute, mio_symbol_attribute): Handle threadprivate.
+	(load_commons, write_common, write_blank_common): Adjust for type
+	change of saved, store/load threadprivate bit from the integer
+	as well.
+
+	* types.def (BT_FN_UINT_UINT): New.
+	(BT_FN_VOID_UINT_UINT): Remove.
+
+	* trans-openmp.c (gfc_trans_omp_clauses, gfc_trans_omp_barrier,
+	gfc_trans_omp_critical, gfc_trans_omp_flush, gfc_trans_omp_master,
+	gfc_trans_omp_ordered, gfc_trans_omp_parallel): New functions.
+	(gfc_trans_omp_directive): Use them.
+
+	* openmp.c (expr_references_sym): Add SE argument, don't look
+	into SE tree.
+	(is_conversion): New function.
+	(resolve_omp_atomic): Adjust expr_references_sym callers.  Handle
+	promoted expressions.
+	* trans-openmp.c (gfc_trans_omp_atomic): New function.
+	(gfc_trans_omp_directive): Call it.
+
+	* f95-lang.c (builtin_type_for_size): New function.
+	(gfc_init_builtin_functions): Initialize synchronization and
+	OpenMP builtins.
+	* types.def: New file.
+	* Make-lang.in (f95-lang.o): Depend on $(BUILTINS_DEF) and
+	fortran/types.def.
+
+	* trans-openmp.c: Rename GOMP_* tree codes into OMP_*.
+
+	* dump-parse-tree.c (show_symtree): Don't crash if ns->proc_name
+	is NULL.
+
+	* dump-parse-tree.c (gfc_show_namelist, gfc_show_omp_node): New
+	functions.
+	(gfc_show_code_node): Call gfc_show_omp_node for EXEC_OMP_* nodes.
+
+	* parse.c (parse_omp_do): Call pop_state before next_statement.
+	* openmp.c (expr_references_sym, resolve_omp_atomic, resolve_omp_do):
+	New functions.
+	(gfc_resolve_omp_directive): Call them.
+	* match.c (match_exit_cycle): Issue error if EXIT or CYCLE statement
+	leaves an OpenMP structured block or if EXIT terminates !$omp do
+	loop.
+
+	* Make-lang.in (F95_PARSER_OBJS): Add fortran/openmp.o.
+	(F95_OBJS): Add fortran/trans-openmp.o.
+	(fortran/trans-openmp.o): Depend on $(GFORTRAN_TRANS_DEPS).
+	* lang.opt: Add -fopenmp option.
+	* options.c (gfc_init_options): Initialize it.
+	(gfc_handle_option): Handle it.
+	* gfortran.h (ST_OMP_ATOMIC, ST_OMP_BARRIER, ST_OMP_CRITICAL,
+	ST_OMP_END_CRITICAL, ST_OMP_END_DO, ST_OMP_END_MASTER,
+	ST_OMP_END_ORDERED, ST_OMP_END_PARALLEL, ST_OMP_END_PARALLEL_DO,
+	ST_OMP_END_PARALLEL_SECTIONS, ST_OMP_END_PARALLEL_WORKSHARE,
+	ST_OMP_END_SECTIONS, ST_OMP_END_SINGLE, ST_OMP_END_WORKSHARE,
+	ST_OMP_DO, ST_OMP_FLUSH, ST_OMP_MASTER, ST_OMP_ORDERED,
+	ST_OMP_PARALLEL, ST_OMP_PARALLEL_DO, ST_OMP_PARALLEL_SECTIONS,
+	ST_OMP_PARALLEL_WORKSHARE, ST_OMP_SECTIONS, ST_OMP_SECTION,
+	ST_OMP_SINGLE, ST_OMP_THREADPRIVATE, ST_OMP_WORKSHARE): New
+	statement codes.
+	(OMP_LIST_PRIVATE, OMP_LIST_FIRSTPRIVATE, OMP_LIST_LASTPRIVATE,
+	OMP_LIST_COPYPRIVATE, OMP_LIST_SHARED, OMP_LIST_COPYIN,
+	OMP_LIST_PLUS, OMP_LIST_REDUCTION_FIRST, OMP_LIST_MULT,
+	OMP_LIST_SUB, OMP_LIST_AND, OMP_LIST_OR, OMP_LIST_EQV,
+	OMP_LIST_NEQV, OMP_LIST_MAX, OMP_LIST_MIN, OMP_LIST_IAND,
+	OMP_LIST_IOR, OMP_LIST_IEOR, OMP_LIST_REDUCTION_LAST, OMP_LIST_NUM):
+	New OpenMP variable list types.
+	(gfc_omp_clauses): New typedef.
+	(gfc_get_omp_clauses): Define.
+	(EXEC_OMP_CRITICAL, EXEC_OMP_DO, EXEC_OMP_FLUSH, EXEC_OMP_MASTER,
+	EXEC_OMP_ORDERED, EXEC_OMP_PARALLEL, EXEC_OMP_PARALLEL_DO,
+	EXEC_OMP_PARALLEL_SECTIONS, EXEC_OMP_PARALLEL_WORKSHARE,
+	EXEC_OMP_SECTIONS, EXEC_OMP_SINGLE, EXEC_OMP_WORKSHARE,
+	EXEC_OMP_ATOMIC, EXEC_OMP_BARRIER, EXEC_OMP_END_NOWAIT,
+	EXEC_OMP_END_SINGLE): New OpenMP gfc_exec_op codes.
+	(struct gfc_code): Add omp_clauses, omp_name, omp_namelist
+	and omp_bool fields to ext union.
+	(flag_openmp): Declare.
+	(gfc_free_omp_clauses, gfc_resolve_omp_directive): New prototypes.
+	* scanner.c (openmp_flag, openmp_locus): New variables.
+	(skip_free_comments, skip_fixed_comments, gfc_next_char_literal):
+	Handle OpenMP directive lines and conditional compilation magic
+	comments.
+	* parse.h (COMP_OMP_STRUCTURED_BLOCK): New compile state.
+	* parse.c (decode_omp_directive, parse_omp_do, parse_omp_atomic,
+	parse_omp_structured_block): New functions.
+	(next_free, next_fixed): Parse OpenMP directives.
+	(case_executable, case_exec_markers, case_decl): Add ST_OMP_*
+	codes.
+	(gfc_ascii_statement): Handle ST_OMP_* codes.
+	(parse_executable): Rearrange the loop slightly, so that
+	parse_omp_do can return next_statement.
+	* match.h (gfc_match_omp_eos, gfc_match_omp_atomic,
+	gfc_match_omp_barrier, gfc_match_omp_critical, gfc_match_omp_do,
+	gfc_match_omp_flush, gfc_match_omp_master, gfc_match_omp_ordered,
+	gfc_match_omp_parallel, gfc_match_omp_parallel_do,
+	gfc_match_omp_parallel_sections, gfc_match_omp_parallel_workshare,
+	gfc_match_omp_sections, gfc_match_omp_single,
+	gfc_match_omp_threadprivate, gfc_match_omp_workshare,
+	gfc_match_omp_end_nowait, gfc_match_omp_end_single): New prototypes.
+	* resolve.c (resolve_blocks): Ignore EXEC_OMP_* block directives.
+	(resolve_code): Call gfc_resolve_omp_directive on EXEC_OMP_*
+	directives.
+	* trans.c (gfc_trans_code): Call gfc_trans_omp_directive for
+	EXEC_OMP_* directives.
+	* st.c (gfc_free_statement): Handle EXEC_OMP_* statement freeing.
+	* trans-stmt.h (gfc_trans_omp_directive): New prototype.
+	* openmp.c: New file.
+	* trans-openmp.c: New file.
+
+2006-02-13  Andrew Pinski  <pinskia@physics.uc.edu>
+	    Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/26246
+	* trans-decl.c (gfc_get_symbol_decl, gfc_get_fake_result_decl): Use
+	gfc_add_decl_to_function rather than gfc_finish_var_decl on length.
+
+2006-02-13  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/26074
+	PR fortran/25103
+	* resolve.c (resolve_symbol): Extend the requirement that module
+	arrays have constant bounds to those in the main program.  At the
+	same time simplify the array bounds, to avoiding trapping parameter
+	array references, and exclude automatic character length from main
+	and modules. Rearrange resolve_symbol and resolve_derived to put as
+	each flavor together, as much as is possible and move all specific
+	code for flavors FL_VARIABLE, FL_PROCEDURE and FL_PARAMETER into new
+	functions.
+	(resolve_fl_var_and_proc, resolve_fl_variable, resolve_fl_procedure):
+	New functions to do work of resolve_symbol.
+	(resolve_index_expr): New function that is called from resolved_symbol
+	and is extracted from resolve_charlen.
+	(resolve_charlen): Call this new function.
+	(resolve_fl_derived): Renamed resolve_derived to be consistent with
+	the naming of the new functions for the other flavours.  Change the
+	charlen checking so that the style is consistent with other similar
+	checks. Add the generation of the gfc_dt_list, removed from resolve_
+	symbol.
+
+	PR fortran/20861
+	* resolve.c (resolve_actual_arglist): Prevent internal procedures
+	from being dummy arguments.
+
+	PR fortran/20871
+	* resolve.c (resolve_actual_arglist): Prevent pure but non-intrinsic
+	procedures from being dummy arguments.
+
+	PR fortran/25083
+	* resolve.c (check_data_variable): Add test that data variable is in
+	COMMON.
+
+	PR fortran/25088
+	* resolve.c (resolve_call): Add test that the subroutine does not
+	have a type.
+
+2006-02-12  Erik Edelmann  <eedelman@gcc.gnu.org>
+
+	PR fortran/25806
+	* trans-array.c (gfc_trans_allocate_array_storage): New argument
+	dealloc; free the temporary only if dealloc is true.
+	(gfc_trans_allocate_temp_array): New argument bool dealloc, to be
+	passed onwards to gfc_trans_allocate_array_storage.
+	(gfc_trans_array_constructor, gfc_conv_loop_setup): Update call to
+	gfc_trans_allocate_temp_array.
+	* trans-array.h (gfc_trans_allocate_temp_array): Update function
+	prototype.
+	* trans-expr.c (gfc_conv_function_call): Set new argument 'dealloc'
+	to gfc_trans_allocate_temp_array to false in case of functions
+	returning pointers.
+	(gfc_trans_arrayfunc_assign): Return NULL for functions returning
+	pointers.
+
+2006-02-10  Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/20858
+	*decl.c (variable_decl): Improve error message.  Remove initialization
+	typespec.  Wrap long line.
+	*expr.c (gfc_check_pointer_assign): Permit checking of type, kind type,
+	and rank.
+	*simplify.c (gfc_simplify_null): Ensure type, kind type, and rank
+	are set.
+
+
+2006-02-10  Tobias Schlüter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/14771
+	* arith.c (eval_intrinsic): Accept INTRINSIC_PARENTHESES.
+	* expr.c (check_intrinsic_op): Likewise.
+	* module.c (mio_expr): Likewise.
+
+2006-02-09  Tobias Schlüter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* dump-parse-tree.c: Update copyright years.
+	* matchexp.c: Likewise.
+	* module.c: Likewise.
+
+	PR fortran/14771
+	* gfortran.h (gfc_intrinsic_op): Add INTRINSIC_PARENTHESES.
+	* dump-parse-tree (gfc_show_expr): Handle INTRINSIC_PARENTHESES.
+	* expr.c (simplify_intrinsic_op): Treat INTRINSIC_PARENTHESES as
+	if it were INTRINSIC_UPLUS.
+	* resolve.c (resolve_operator): Handle INTRINSIC_PARENTHESES.
+	* match.c (intrinsic_operators): Add INTRINSIC_PARENTHESES.
+	* matchexp.c (match_primary): Record parentheses surrounding
+	numeric expressions.
+	* module.c (intrinsics): Add INTRINSIC_PARENTHESES for module
+	dumping.
+	* trans-expr.c (gfc_conv_expr_op): Handle INTRINSIC_PARENTHESES.
+
+2006-02-09  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/26038
+	* trans-stmt.c (gfc_trans_allocate): Provide assumed character length
+	scalar with missing backend_decl for the hidden dummy charlen.
+
+	PR fortran/25059
+	* interface.c (gfc_extend_assign): Remove detection of non-PURE
+	subroutine in assignment interface, with gfc_error, and put it in
+	* resolve.c (resolve_code).
+
+	PR fortran/25070
+	* interface.c (gfc_procedure_use): Flag rank checking for non-
+	elemental, contained or interface procedures in call to
+	(compare_actual_formal), where ranks are checked for assumed
+	shape arrays..
+
+2006-02-08  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR libfortran/25425
+	* trans-decl.c (gfc_generate_function_code): Add new argument,
+	pedantic, to set_std call.
+
+2006-02-06  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR libfortran/23815
+	* gfortran.texi: Document the GFORTRAN_CONVERT_UNIT environment
+	variable.
+	* invoke.texi:  Mention the "Runtime" chapter.
+	Document the -fconvert= option.
+	* gfortran.h:  Add options_convert.
+	* lang.opt:  Add fconvert=little-endian, fconvert=big-endian,
+	fconvert=native and fconvert=swap.
+	* trans-decl.c (top level):  Add gfor_fndecl_set_convert.
+	(gfc_build_builtin_function_decls):  Set gfor_fndecl_set_convert.
+	(gfc_generate_function_code):  If -fconvert was specified,
+	and this is the main program, add a call to set_convert().
+	* options.c:  Handle the -fconvert options.
+
+2006-02-06  Roger Sayle  <roger@eyesopen.com>
+
+	* trans-stmt.c (gfc_evaluate_where_mask): Allow the NMASK argument
+	to be NULL to indicate that the not mask isn't required.
+	(gfc_trans_where_2): Remove PMASK argument.  Avoid calculating the
+	pending mask for the last clause of a WHERE chain.  Update recursive
+	call.
+	(gfc_trans_forall_1): Update call to gfc_trans_where_2.
+	(gfc_trans_where): Likewise.
+
+2006-02-06  Jakub Jelinek  <jakub@redhat.com>
+
+	Backport from gomp-20050608-branch
+	* trans-decl.c (create_function_arglist): Handle dummy functions.
+
+	* trans-decl.c (gfc_get_symbol_decl): Revert explicit setting of
+	TYPE_SIZE_UNIT.
+	(gfc_trans_vla_type_sizes): Also "gimplify"
+	GFC_TYPE_ARRAY_DATAPTR_TYPE for GFC_DESCRIPTOR_TYPE_P types.
+	* trans-array.c (gfc_trans_deferred_array): Call
+	gfc_trans_vla_type_sizes.
+
+	* trans-decl.c (saved_function_decls, saved_parent_function_decls):
+	Remove unnecessary initialization.
+	(create_function_arglist): Make sure __result has complete type.
+	(gfc_get_fake_result_decl): Change current_fake_result_decl into
+	a tree chain.  For entry master, create a separate variable
+	for each result name.  For BT_CHARACTER results, call
+	gfc_finish_var_decl on length even if it has been already created,
+	but not pushdecl'ed.
+	(gfc_trans_vla_type_sizes): For function/entry result, adjust
+	result value type, not the FUNCTION_TYPE.
+	(gfc_generate_function_code): Adjust for current_fake_result_decl
+	changes.
+	(gfc_trans_deferred_vars): Likewise.  Call gfc_trans_vla_type_sizes
+	even on result if it is assumed-length character.
+
+	* trans-decl.c (gfc_trans_dummy_character): Add SYM argument.
+	Call gfc_trans_vla_type_sizes.
+	(gfc_trans_auto_character_variable): Call gfc_trans_vla_type_sizes.
+	(gfc_trans_vla_one_sizepos, gfc_trans_vla_type_sizes_1,
+	gfc_trans_vla_type_sizes): New functions.
+	(gfc_trans_deferred_vars): Adjust gfc_trans_dummy_character
+	callers.  Call gfc_trans_vla_type_sizes on assumed-length
+	character parameters.
+	* trans-array.c (gfc_trans_array_bounds,
+	gfc_trans_auto_array_allocation, gfc_trans_dummy_array_bias): Call
+	gfc_trans_vla_type_sizes.
+	* trans.h (gfc_trans_vla_type_sizes): New prototype.
+
+	* trans-decl.c (gfc_build_qualified_array): For non-assumed-size
+	arrays without constant size, create also an index var for
+	GFC_TYPE_ARRAY_SIZE (type).  If the type is incomplete, complete
+	it as 0..size-1.
+	(gfc_create_string_length): Don't call gfc_defer_symbol_init
+	if just creating DECL_ARGUMENTS.
+	(gfc_get_symbol_decl): Call gfc_finish_var_decl and
+	gfc_defer_symbol_init even if ts.cl->backend_decl is already
+	set to a VAR_DECL that doesn't have DECL_CONTEXT yet.
+	(create_function_arglist): Rework, so that hidden length
+	arguments for CHARACTER parameters are created together with
+	the parameters.  Resolve ts.cl->backend_decl for CHARACTER
+	parameters.  If the argument is a non-constant length array
+	or CHARACTER, ensure PARM_DECL has different type than
+	its DECL_ARG_TYPE.
+	(generate_local_decl): Call gfc_get_symbol_decl even
+	for non-referenced non-constant length CHARACTER parameters
+	after optionally issuing warnings.
+	* trans-array.c (gfc_trans_array_bounds): Set last stride
+	to GFC_TYPE_ARRAY_SIZE (type) to initialize it as well.
+	(gfc_trans_dummy_array_bias): Initialize GFC_TYPE_ARRAY_SIZE (type)
+	variable as well.
+
+	* trans-expr.c (gfc_conv_expr_val): Fix comment typo.
+
+	* trans-stmt.c (gfc_trans_simple_do): Fix comment.
+
+2006-02-04  Roger Sayle  <roger@eyesopen.com>
+
+	* dependency.c (gfc_check_dependency): Remove unused vars and nvars
+	arguments.  Replace with an "identical" argument.  A full array
+	reference to the same symbol is a dependency if identical is true.
+	* dependency.h (gfc_check_dependency): Update prototype.
+	* trans-array.h (gfc_check_dependency): Delete duplicate prototype.
+	* trans-stmt.c: #include dependency.h for gfc_check_dependency.
+	(gfc_trans_forall_1): Update calls to gfc_check_dependency.
+	(gfc_trans_where_2): Likewise.  Remove unneeded variables.
+	(gfc_trans_where_3): New function for simple non-dependent WHEREs.
+	(gfc_trans_where): Call gfc_trans_where_3 to translate simple
+	F90-style WHERE statements without internal dependencies.
+	* Make-lang.in (trans-stmt.o): Depend upon dependency.h.
+
+2006-02-05  H.J. Lu  <hongjiu.lu@intel.com>
+
+	PR fortran/26041
+	PR fortran/26064
+	* resolve.c (resolve_types): New function.
+	(resolve_codes): Likewise.
+	(gfc_resolve): Use them.
+
+2006-02-05  Roger Sayle  <roger@eyesopen.com>
+
+	* trans-stmt.c (gfc_evaluate_where_mask): Use LOGICAL*1 for WHERE
+	masks instead of LOGICAL*4.
+
+2006-02-05  Jakub Jelinek  <jakub@redhat.com>
+
+	* resolve.c (resolve_symbol): Initialize constructor_expr to NULL.
+
+2006-02-04  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR fortran/25075
+	check.c (identical_dimen_shape):  New function.
+	(check_dot_product):  Use identical_dimen_shape() to check sizes
+	for dot_product.
+	(gfc_check_matmul):  Likewise.
+	(gfc_check_merge):  Check conformance between tsource and fsource
+	and between tsource and mask.
+	(gfc_check_pack):  Check conformance between array and mask.
+
+2006-02-03  Steven G. Kargl  <kargls@comcast>
+	    Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/20845
+	* resolve.c (resolve_symbol): Default initialization of derived type
+	component reguires the SAVE attribute.
+
+2006-02-02  Steven G. Kargl  <kargls@comcast>
+
+	PR fortran/24958
+	match.c (gfc_match_nullify):  Free the list from head not tail.
+
+	PR fortran/25072
+	* match.c (match_forall_header): Fix internal error caused by bogus
+	gfc_epxr pointers.
+
+
+2006-01-31  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR fortran/26039
+	expr.c (gfc_check_conformance):  Reorder error message
+	to avoid plural.
+	check.c(gfc_check_minloc_maxloc):  Call gfc_check_conformance
+	for checking arguments array and mask.
+	(check_reduction):  Likewise.
+
+2006-01-30  Erik Edelmann  <eedelman@gcc.gnu.org>
+
+	PR fortran/24266
+	* trans-io.c (set_internal_unit): Check the rank of the
+	expression node itself instead of its symbol.
+
+2006-01-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/18578
+	PR fortran/18579
+	PR fortran/20857
+	PR fortran/20885
+	* interface.c (compare_actual_formal): Error for INTENT(OUT or INOUT)
+	if actual argument is not a variable.
+
+2006-01-28  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/17911
+	* expr.c (gfc_check_assign, gfc_check_pointer_assign): Emit error if
+	the lvalue is a use associated procedure.
+
+	PR fortran/20895
+	PR fortran/25030
+	* expr.c (gfc_check_pointer_assign): Emit error if lvalue and rvalue
+	character lengths are not the same.  Use gfc_dep_compare_expr for the
+	comparison.
+	* gfortran.h: Add prototype for gfc_dep_compare_expr.
+	* dependency.h: Remove prototype for gfc_dep_compare_expr.
+
+2006-01-27  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/25964
+	* resolve.c (resolve_function): Add GFC_ISYM_LOC to the list of
+	generic_ids exempted from assumed size checking.
+
+2006-01-27  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/25324
+	* Make-lang.in (fortran/scanner.o): Depend on toplev.h.
+	* lang.opt (fpreprocessed): New option.
+	* scanner.c: Include toplev.h.
+	(gfc_src_file, gfc_src_preprocessor_lines): New variables.
+	(preprocessor_line): Unescape filename if there were any
+	backslashes.
+	(load_file): If initial and gfc_src_file is not NULL,
+	use it rather than opening the file.  If gfc_src_preprocessor_lines
+	has non-NULL elements, pass it to preprocessor_line.
+	(unescape_filename, gfc_read_orig_filename): New functions.
+	* gfortran.h (gfc_option_t): Add flag_preprocessed.
+	(gfc_read_orig_filename): New prototype.
+	* options.c (gfc_init_options): Clear flag_preprocessed.
+	(gfc_post_options): If flag_preprocessed, call
+	gfc_read_orig_filename.
+	(gfc_handle_option): Handle OPT_fpreprocessed.
+	* lang-specs.h: Pass -fpreprocessed to f951 if preprocessing
+	sources.
+
+2006-01-27  Erik Edelmann  <eedelman@gcc.gnu.org>
+
+	* symbol.c (free_old_symbol): Fix confusing comment, and add code
+	  to free old_symbol->formal.
+
+2006-01-26  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/25964
+	* resolve.c (resolve_function): Exclude statement functions from
+	global reference checking.
+
+	PR fortran/25084
+	PR fortran/20852
+	PR fortran/25085
+	PR fortran/25086
+	* resolve.c (resolve_function): Declare a gfc_symbol to replace the
+	references through the symtree to the symbol associated with the
+	function expresion. Give error on reference to an assumed character
+	length function is defined in an interface or an external function
+	that is not a dummy argument.
+	(resolve_symbol): Give error if an assumed character length function
+	is array-valued, pointer-valued, pure or recursive. Emit warning
+	that character(*) value functions are obsolescent in F95.
+
+	PR fortran/25416
+	* trans-expr.c (gfc_conv_function_call): The above patch to resolve.c
+	prevents any assumed character length function call from getting here
+	except intrinsics such as SPREAD. In this case, ensure that no
+	segfault occurs from referencing non-existent charlen->length->
+	expr_type and provide a backend_decl for the charlen from the charlen
+	of the first actual argument.
+
+	Cure temp name confusion.
+	* trans-expr.c (gfc_get_interface_mapping_array): Change name of
+	temporary from "parm" to "ifm" to avoid clash with temp coming from
+	trans-array.c.
+
+2006-01-25  Erik Edelmann  <eedelman@gcc.gnu.org>
+
+	PR fortran/25716
+	* symbol.c (free_old_symbol): New function.
+	(gfc_commit_symbols): Use it.
+	(gfc_commit_symbol): New function.
+	(gfc_use_derived): Use it.
+	* gfortran.h: Add prototype for gfc_commit_symbol.
+	* intrinsic.c (gfc_find_function): Search in 'conversion'
+	if not found in 'functions'.
+	(gfc_convert_type_warn): Add a symtree to the new
+	expression node, and commit the new symtree->n.sym.
+	* resolve.c (gfc_resolve_index): Make sure typespec is
+	properly initialized.
+
+2006-01-23  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/25901
+	* decl.c (get_proc_name): Replace subroutine and function attributes
+	in "already defined" test by the formal arglist pointer being non-NULL.
+
+	Fix regression in testing of admissability of attributes.
+	* symbol.c (gfc_add_attribute): If the current_attr has non-zero
+	intent, do not do the check for a dummy being used.
+	* decl.c (attr_decl1): Add current_attr.intent as the third argument
+	in the call to gfc_add_attribute.
+	* gfortran.h: Add the third argument to the prototype for
+	gfc_add_attribute.
+
+2006-01-21  Joseph S. Myers  <joseph@codesourcery.com>
+
+	* gfortranspec.c (lang_specific_driver): Update copyright notice
+	date.
+
+2006-01-21  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/25124
+	PR fortran/25625
+	* decl.c (get_proc_name): If there is an existing
+	symbol in the encompassing namespace, call errors
+	if it is a procedure of the same name or the kind
+	field is set, indicating a type declaration.
+
+	PR fortran/20881
+	PR fortran/23308
+	PR fortran/25538
+	PR fortran/25710
+	* decl.c (add_global_entry): New function to check
+	for existing global symbol with this name and to
+	create new one if none exists.
+	(gfc_match_entry): Call add_global_entry before
+	matching argument lists for subroutine and function
+	entries.
+	* gfortran.h: Prototype for existing function,
+	global_used.
+	* resolve.c (resolve_global_procedure): New function
+	to check global symbols for procedures.
+	(resolve_call, resolve_function): Calls to this
+	new function for non-contained and non-module
+	procedures.
+	* match.c (match_common): Add check for existing
+	global symbol, creat one if none exists and emit
+	error if there is a clash.
+	* parse.c (global_used): Remove static and use the
+	gsymbol name rather than the new_block name, so that
+	the function can be called from resolve.c.
+	(parse_block_data, parse_module, add_global_procedure):
+	Improve checks for existing gsymbols.  Emit error if
+	already defined or if references were to another type.
+	Set defined flag.
+
+	PR fortran/PR24276
+	* trans-expr.c (gfc_conv_aliased_arg): New function called by 
+	gfc_conv_function_call that coverts an expression for an aliased
+	component reference to a derived type array into a temporary array
+	of the same type as the component.  The temporary is passed as an
+	actual argument for the procedure call and is copied back to the
+	derived type after the call.
+	(is_aliased_array): New function that detects an array reference
+	that is followed by a component reference.
+	(gfc_conv_function_call): Detect an aliased actual argument with
+	is_aliased_array and convert it to a temporary and back again
+	using gfc_conv_aliased_arg.
+
+2006-01-19  Tobias Schlüter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* gfortranspec.c: Update copyright years.
+	* trans.c: Likewise.
+	* trans-array.c: Likewise.
+	* trans-array.h: Likewise.
+	* trans-decl.c: Likewise.
+	* trans-stmt.c: Likewise.
+	* trans-stmt.h: Likewise.
+	* trans-types.c: Likewise.
+
+2006-01-18  Tobias Schlüter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/18540
+	PR fortran/18937
+	* gfortran.h (BBT_HEADER): Move definition up.
+	(gfc_st_label): Add BBT_HEADER, remove 'prev' and 'next'.
+	* io.c (format_asterisk): Adapt initializer.
+	* resolve.c (resolve_branch): Allow FORTRAN 66 cross-block GOTOs
+	as extension.
+	(warn_unused_label): Take gfc_st_label label as argument, adapt to
+	new data structure.
+	(gfc_resolve): Adapt call to warn_unused_label.
+	* symbol.c (compare_st_labels): New function.
+	(gfc_free_st_label, free_st_labels, gfc_get_st_label): Convert to
+	using balanced binary tree.
+	* decl.c (match_char_length, gfc_match_old_kind_spec): Do away
+	with 'cnt'.
+	(warn_unused_label): Adapt to binary tree.
+	* match.c (gfc_match_small_literal_int): Only set cnt if non-NULL.
+	* primary.c (match_kind_param): Do away with cnt.
+
+2006-01-18  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/20869
+	PR fortran/20875
+	PR fortran/25024
+	* symbol.c (check_conflict): Add pointer valued elemental
+	functions and internal procedures with the external attribute
+	to the list of conflicts.
+	(gfc_add_attribute): New catch-all function to perform the
+	checking of symbol attributes for attribute declaration
+	statements.
+	* decl.c (attr_decl1): Call gfc_add_attribute for each of -
+	(gfc_match_external, gfc_match_intent, gfc_match_intrinsic,
+	gfc_match_pointer, gfc_match_dimension, gfc_match_target):
+	Remove spurious calls to checks in symbol.c.  Set the
+	attribute directly and use the call to attr_decl() for
+	checking.
+	* gfortran.h:  Add prototype for gfc_add_attribute.
+
+	PR fortran/25785
+	* resolve.c (resolve_function): Exclude PRESENT from assumed size
+	argument checking. Replace strcmp's with comparisons with generic
+	codes.
+
+2006-01-16  Rafael Ávila de Espíndola  <rafael.espindola@gmail.com>
+
+	* gfortranspec.c (lang_specific_spec_functions): Remove.
+
+2006-01-16  Richard Guenther  <rguenther@suse.de>
+
+	* trans-stmt.c (gfc_trans_if_1): Use fold_buildN and build_int_cst.
+	(gfc_trans_arithmetic_if): Likewise.
+	(gfc_trans_simple_do): Likewise.
+	(gfc_trans_do): Likewise.
+	(gfc_trans_do_while): Likewise.
+	(gfc_trans_logical_select): Likewise.
+	(gfc_trans_forall_loop): Likewise.
+	(generate_loop_for_temp_to_lhs): Likewise.
+	(generate_loop_for_rhs_to_temp): Likewise.
+	(gfc_trans_allocate): Likewise.
+	* trans.c (gfc_add_expr_to_block): Do not fold expr again.
+
+2006-01-16  Richard Guenther  <rguenther@suse.de>
+
+	* trans-expr.c (gfc_conv_function_call): Use fold_build2.
+	* trans-stmt.c (gfc_trans_goto): Likewise.  Use build_int_cst.
+	* trans.c (gfc_trans_runtime_check): Don't fold the condition
+	again.
+
+2006-01-13  Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/25756
+	* symbol.c (gfc_free_st_label): Give variable meaningful name. Remove
+	unneeded parenthesis. Fix-up the head of the list (2 lines gleaned
+	from g95).
+
+2006-01-13  Diego Novillo  <dnovillo@redhat.com>
+
+	* trans.c (gfc_add_expr_to_block): Do not fold tcc_statement
+	nodes.
+
+2006-01-11  Tobias Schlüter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* parse.c (next_fixed): Remove superfluous string concatenation.
+
+2006-01-11  Bernhard Fischer  <rep.nop@aon.at>
+
+	PR fortran/25486
+	* scanner.c (load_line): use maxlen to determine the line-length used
+	for padding lines in fixed form.
+
+2006-01-11  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/25730
+	* trans-types.c (copy_dt_decls_ifequal): Copy backend decl for
+	character lengths.
+
+2006-01-09  Andrew Pinski  <pinskia@physics.uc.edu>
+
+	fortran/24936
+	* trans-stmt.c (gfc_trans_pointer_assign_need_temp): Use fold_convert
+	to avoid type mismatch.
+
+2006-01-09  Andrew Pinski  <pinskia@physics.uc.edu>
+
+	PR fortran/21977
+	* trans-decl.c (gfc_generate_function_code): Move the NULLing of
+	current_fake_result_decl down to below generate_local_vars.
+
+2006-01-09  Feng Wang  <fengwang@nudt.edu.cn>
+
+	PR fortran/12456
+	* trans-expr.c (gfc_to_single_character): New function that converts
+	string to single character if its length is 1.
+	(gfc_build_compare_string):New function that compare string and handle
+	single character specially.
+	(gfc_conv_expr_op): Use gfc_build_compare_string.
+	(gfc_trans_string_copy): Use gfc_to_single_character.
+	* trans-intrinsic.c (gfc_conv_intrinsic_strcmp): Use
+	gfc_build_compare_string.
+	* trans.h (gfc_build_compare_string): Add prototype.
+
+2006-01-09  Feng Wang  <fengwang@nudt.edu.cn>
+
+	* simplify.c (gfc_simplify_char): Use UCHAR_MAX instead of literal
+	constant.
+	(gfc_simplify_ichar): Get the result from unsinged char and in the
+	range 0 to UCHAR_MAX instead of CHAR_MIN to CHAR_MAX.
+
+2006-01-08  Erik Edelmann  <eedelman@gcc.gnu.org>
+
+	PR fortran/25093
+	* resolve.c (resolve_fntype): Check that PUBLIC functions
+	aren't of PRIVATE type.
+
+2006-01-07  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* decl.c (gfc_match_function_decl): Correctly error out in case of
+	omitted function argument list.
+
+2006-01-07  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/22146
+	* trans-array.c (gfc_reverse_ss): Remove static attribute.
+	(gfc_walk_elemental_function_args): Replace gfc_expr * argument for
+	the function call with the corresponding gfc_actual_arglist*.  Change
+	code accordingly.
+	(gfc_walk_function_expr): Call to gfc_walk_elemental_function_args
+	now requires the actual argument list instead of the expression for
+	the function call.
+	* trans-array.h: Modify the prototype for gfc_walk_elemental_function_args
+	and provide a prototype for gfc_reverse_ss.
+	* trans-stmt.h (gfc_trans_call): Add the scalarization code for the case
+	where an elemental subroutine has array valued actual arguments.
+
+	PR fortran/25029
+	PR fortran/21256
+	PR fortran/20868
+	PR fortran/20870
+	* resolve.c (check_assumed_size_reference): New function to check for upper
+	bound in assumed size array references.
+	(resolve_assumed_size_actual): New function to do a very restricted scan
+	of actual argument expressions of those procedures for which incomplete
+	assumed size array references are not allowed.
+	(resolve_function, resolve_call): Switch off assumed size checking of
+	actual arguments, except for elemental procedures and intrinsic
+	inquiry functions, in some circumstances.
+	(resolve_variable): Call check_assumed_size_reference.
+
+2006-01-05  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/24268
+	* io.c (next_char_not_space): New function that returns the next
+	character that is not white space.
+	(format_lex): Use the new function to skip whitespace within
+	a format string.
+
+2006-01-05  Erik Edelmann  <eedelman@gcc.gnu.org>
+
+	PR fortran/23675
+	* expr.c (gfc_expr_set_symbols_referenced): New function.
+	* gfortran.h: Add a function prototype for it.
+	* resolve.c (resolve_function): Use it for
+	use associated character functions lengths.
+	* expr.c, gfortran.h, resolve.c: Updated copyright years.
+
+2006-01-03  Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/25101
+	* resolve.c (resolve_forall_iterators):  Check for scalar variables;
+	Check stride is nonzero.
+
+2006-01-02  Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/24640
+	* parse.c (next_free): Check for whitespace after the label.
+	* match.c (gfc_match_small_literal_int): Initialize cnt variable.
+
+2006-01-01  Steven G. Kargl  <kargls@comcast.net>
+
+	* ChangeLog: Split previous years into ...
+	* ChangeLog-2002: here.
+	* ChangeLog-2003: here.
+	* ChangeLog-2004: here.
+	* ChangeLog-2005: here.
+
+
+Copyright (C) 2006 Free Software Foundation, Inc.
+
+Copying and distribution of this file, with or without modification,
+are permitted in any medium without royalty provided the copyright
+notice and this notice are preserved.
diff --git a/gcc-4.9/gcc/fortran/ChangeLog-2007 b/gcc-4.9/gcc/fortran/ChangeLog-2007
new file mode 100644
index 000000000..421dc886e
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/ChangeLog-2007
@@ -0,0 +1,5776 @@
+2007-12-31  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34558
+	* interface.c (gfc_compare_types): Prevent linked lists from
+	putting this function into an endless recursive loop.
+
+2007-12-26  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/34532
+	* gfortran.texi: Fixed section about implicit conversion of
+	logical and integer variables.
+
+2007-12-25  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34514
+	* decl.c (attr_decl1): Reject specifying the DIMENSION for
+	already initialized variable.
+	(do_parm): Reject PARAMETER for already initialized variable.
+
+2007-12-25  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/34533
+	* intrinsic.h (gfc_check_etime): Renamed to ...
+	(gfc_check_dtime_etime): ... this.
+	(gfc_check_etime_sub): Renamed to ...
+	(gfc_check_dtime_etime_sub): ... this.
+	(gfc_resolve_dtime_sub): New prototype.
+	* check.c (gfc_check_etime): Renamed to ...
+	(gfc_check_dtime_etime): ... this.
+	(gfc_check_etime_sub): Renamed to ...
+	(gfc_check_dtime_etime_sub): ... this.
+	* iresolve.c (gfc_resolve_dtime_sub): New implementation.
+	* intrinsic.c (add_functions): Removed alias from ETIME to DTIME,
+	added stand-alone intrinsic DTIME.
+	(add_subroutines): Adjusted check and resolve function names for
+	DTIME and ETIME.
+	* trans-intrinsic.c (gfc_conv_intrinsic_function): Added DTIME
+	to known functions in switch.
+	* intrinsic.texi (DTIME): Added paragraph about thread-safety,
+	fixed return value section.
+	(CPU_TIME): Clarified intent and added implementation notes.
+
+2007-12-23  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34421
+	* resolve.c (resolve_entries): Add standard error for functions
+	returning characters with different length.
+
+2007-12-23  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/34536 
+	* matchexp.c (match_ext_mult_operand): Print warning for unary 
+	operators following arithmetic ones by default.
+	(match_ext_add_operand): Likewise.
+
+2007-12-22  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/34559
+	* simplify.c (gfc_simplify_repeat): Added safeguard for empty
+	string literals.
+
+2007-12-22  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/34549
+	* check.c (gfc_check_cshift):  Add check that shift is
+	type INTEGER.
+
+2007-12-21  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/34540
+	* iresolve.c (gfc_resolve_cshift): Take optional dim path
+	only if the argument is an optional itself.
+	* iresolve.c (gfc_resolve_eoshift): Same.
+
+2007-12-21  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34438
+	* trans-decl.c (gfc_finish_var_decl): Do not mark derived types
+	with default initializers as TREE_STATIC unless they are in the
+	main program scope.
+	(gfc_get_symbol_decl): Pass derived types with a default
+	initializer to gfc_defer_symbol_init.
+	(init_default_dt): Apply default initializer to a derived type.
+	(init_intent_out_dt): Call init_default_dt.
+	(gfc_trans_deferred_vars): Ditto.
+
+	* module.c (read_module): Check sym->module is there before
+	using it in a string comparison.
+
+2007-12-20  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34482
+	* gfortran.texi (BOZ): Document behavior for complex
+	numbers.
+	* target-memory.h (gfc_convert_boz): Update prototype.
+	* target-memory.c (gfc_convert_boz): Add error check
+	and convert BOZ to smallest possible bit size.
+	* resolve.c (resolve_ordinary_assign): Check return value.
+	* expr.c (gfc_check_assign): Ditto.
+	* simplify.c (simplify_cmplx, gfc_simplify_dble,
+	gfc_simplify_float, gfc_simplify_real): Ditto.
+
+2007-12-19  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/34325
+	* match.h: New function declaration.
+	* match.c (gfc_match_parens): New function to look for mismatched
+	parenthesis. (gfc_match_if): Use new function to catch missing '('.
+
+2007-12-19  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/34495
+	* expr.c (check_init_expr): Check whether variables with flavor
+	FL_PARAMETER do have a value assigned. Added error messages where
+	appropriate.
+	* simplify.c (gfc_simplify_transfer): Added check if the MOLD
+	argument is a constant if working with initialization
+	expressions.
+
+2007-12-17  Tobias Burnus  <burnus@net-b.de>
+
+	* intrinsic.c (add_functions): Undo change; mark float and
+	sngl as STD_F77.
+	* intrinsic.texi (FLOAT, SNGL): Change standard to F77 and later.
+	* gfortran.texi (BOZ): Make note about FLOAT etc. clearer.
+
+2007-12-16  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34495
+	* intrinsic.c (add_functions): Mark float and sngl as STD_GNU.
+	(gfc_intrinsic_func_interface): Reject REAL, DBLE and CMPLX
+	in initialization expressions for -std=f95.
+
+2007-12-16  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/34305
+	* resolve.c (compare_bound):  If either of the types of
+	the arguments isn't INTEGER, return CMP_UNKNOWN.
+
+2007-12-16  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34246
+	* trans-types.c (gfc_init_types): Change build_type_variant
+	to build_qualified_type.
+	(gfc_sym_type): Return gfc_character1_type_node for
+	character-returning bind(C) functions.
+	* trans-expr.c (gfc_conv_function_call): Do not set
+	se->string_length for character-returning bind(c) functions.
+	(gfc_trans_string_copy,gfc_trans_scalar_assign):
+	Support also single characters.
+
+2007-12-16  Bernhard Fischer  <aldot@gcc.gnu.org>
+
+	* errors.c (gfc_notify_std): As originally stated but improperly
+	changed, disregard warnings_are_errors for deciding which buffer
+	to use for warnings.
+
+2007-12-16  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31213
+	PR fortran/33888
+	PR fortran/33998
+	* trans-array.c (gfc_trans_array_constructor_value): If the
+	iterator variable does not have a backend_decl, use a local
+	temporary.
+	(get_elemental_fcn_charlen): New function to map the character
+	length of an elemental function onto its actual arglist.
+	(gfc_conv_expr_descriptor): Call the above so that the size of
+	the temporary can be evaluated.
+	* trans-expr.c : Include arith.h and change prototype of
+	gfc_apply_interface_mapping_to_expr to return void.  Change all
+	references to gfc_apply_interface_mapping_to_expr accordingly.
+	(gfc_free_interface_mapping): Free the 'expr' field.
+	(gfc_add_interface_mapping): Add an argument for the actual
+	argument expression. This is copied to the 'expr' field of the
+	mapping.  Only stabilize the backend_decl if the se is present.
+	Copy the character length expression and only add it's backend
+	declaration if se is present.  Return without working on the
+	backend declaration for the new symbol if se is not present.
+	(gfc_map_intrinsic_function) : To simplify intrinsics 'len',
+	'size', 'ubound' and 'lbound' and then to map the result.
+	(gfc_map_fcn_formal_to_actual): Performs the formal to actual
+	mapping for the case of a function found in a specification
+	expression in the interface being mapped.
+	(gfc_apply_interface_mapping_to_ref): Remove seen_result and
+	all its references. Remove the inline simplification of LEN
+	and call gfc_map_intrinsic_function instead.  Change the
+	order of mapping of the actual arguments and simplifying
+	intrinsic functions.  Finally, if a function maps to an
+	actual argument, call gfc_map_fcn_formal_to_actual.
+	(gfc_conv_function_call): Add 'e' to the call to
+	gfc_add_interface_mapping.
+	* dump-parse-tree.c (gfc_show_symbol_n): New function for
+	diagnostic purposes.
+	* gfortran.h : Add prototype for gfc_show_symbol_n.
+	* trans.h : Add 'expr' field to gfc_add_interface_mapping.
+	Add 'expr' to prototype for gfc_show_symbol_n.
+	* resolve.c (resolve_generic_f0): Set specific function as
+	referenced.
+
+2007-12-14  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34438
+	* resolve.c (resolve_symbol): Do not emit public-variable-
+	of-private-derived-type error for non-module variables.
+
+2007-12-14  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34398
+	* expr.c (gfc_check_assign): Add range checks for assignments of BOZs.
+	* resolve.c (resolve_ordinary_assign): Ditto.
+	* arith.c (gfc_range_check): Fix return value for complex numbers.
+
+2007-12-14  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/34324
+	* module.c (parse_atom): Fixed parsing of modules files whose
+	lines are terminated by CRLF.
+
+2007-12-13  Anton Korobeynikov  <asl@math.spbu.ru>
+
+	* trans-decl.c (gfc_build_builtin_function_decls): Correct decl
+	construction for select_string() and internal_unpack()
+
+2007-12-13  Duncan Sands  <baldrick@free.fr>
+	    Anton Korobeynikov  <asl@math.spbu.ru>
+
+	* trans-expr.c (gfc_conv_structure): Make sure record constructors
+	for static variables are marked constant.
+
+2007-12-12  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34254
+	* decl.c (match_char_kind): Support use-associated/imported
+	kind parameters.
+	(gfc_match_kind_spec): Support als BT_CHARACTER, when
+	re-scanning kind spec.
+
+2007-12-11  Aldy Hernandez  <aldyh@redhat.com>
+
+	* decl.c (add_global_entry): Make type unsigned.
+
+2007-12-11  Bernhard Fischer  <aldot@gcc.gnu.org>
+
+	* decl.c (match_prefix): Make seen_type a boolean.
+	(add_global_entry): Cache type distinction.
+	* trans-decl.c: Whitespace cleanup.
+
+2007-12-10  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34425
+	* interface.c (get_expr_storage_size): Use signed integer when
+	obtaining the bounds.
+
+2007-12-09  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/22244
+	* trans.h (struct array_descr_info): Forward declaration.
+	(gfc_get_array_descr_info): New prototype.
+	(enum gfc_array_kind): New type.
+	(struct lang_type): Add akind field.
+	(GFC_TYPE_ARRAY_AKIND): Define.
+	* trans-types.c: Include dwarf2out.h.
+	(gfc_build_array_type): Add akind argument.  Adjust
+	gfc_get_array_type_bounds call.
+	(gfc_get_nodesc_array_type): Include proper debug info even for
+	assumed-size arrays.
+	(gfc_get_array_type_bounds): Add akind argument, set
+	GFC_TYPE_ARRAY_AKIND to it.
+	(gfc_sym_type, gfc_get_derived_type): Adjust gfc_build_array_type
+	callers.
+	(gfc_get_array_descr_info): New function.
+	* trans-array.c (gfc_trans_create_temp_array,
+	gfc_conv_expr_descriptor): Adjust gfc_get_array_type_bounds
+	callers.
+	* trans-stmt.c (gfc_trans_pointer_assign_need_temp): Likewise.
+	* trans-types.h (gfc_get_array_type_bounds): Adjust prototype.
+	* Make-lang.in (fortran/trans-types.o): Depend on dwarf2out.h.
+	* f95-lang.c (LANG_HOOKS_GET_ARRAY_DESCR_INFO): Define.
+
+2007-12-09  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/32129
+	* dump-parse-tree.c (gfc_show_expr_n): New function for
+	debugging.
+	* gfortran.h : Add prototype for gfc_show_expr_n.
+	* expr.c (simplify_constructor): Copy the constructor
+	expression and try to simplify that.  If success, replace the
+	original.  Otherwise discard the copy, keep going through
+	the structure and return success.
+
+	PR fortran/31487
+	* decl.c (build_struct): Pad out default initializers with
+	spaces to the component character length.
+
+2007-12-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34342
+	PR fortran/34345
+	PR fortran/18026
+	PR fortran/29471
+	* gfortran.texi (BOZ literal constants): Improve documentation
+	and adapt for BOZ changes.
+	* Make-lang.ini (resolve.o): Add target-memory.h dependency.
+	* gfortran.h (gfc_expr): Add is_boz flag.
+	* expr.c: Include target-memory.h.
+	(gfc_check_assign): Support transferring BOZ for real/cmlx.
+	* resolve.c: Include target-memory.h
+	(resolve_ordinary_assign): Support transferring BOZ for real/cmlx.
+	* target-memory.c (gfc_convert_boz): New function.
+	* target-memory.c (gfc_convert_boz): Add prototype.
+	* primary.c (match_boz_constant): Set is_boz, enable F95 error
+	also without -pedantic, and allow for Fortran 2003 BOZ.
+	(match_real_constant): Fix comment.
+	* simplify.c (simplify_cmplx,gfc_simplify_dble,gfc_simplify_float,
+	gfc_simplify_real): Support Fortran 2003 BOZ.
+
+2007-12-08  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/34359
+	* gfortran.h (gfc_file): Remove sibling and down fields.
+	* scanner.c (file_changes, file_changes_cur, file_changes_count,
+	file_changes_allocated): New variables.
+	(add_file_change, report_file_change): New functions.
+	(change_file): Remove.
+	(gfc_start_source_files, gfc_end_source_files): Call
+	report_file_change instead of change_file.
+	(gfc_advance_line): Call report_file_change instead of change_file,
+	call it even if lb->file == lb->next->file.
+	(get_file): Revert last changes.
+	(preprocessor_line): Call add_file_change when entering or leaving
+	a file.
+	(load_file): Likewise.  Set file_change[...].lb for all newly added
+	file changes.
+
+2007-12-06  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34333
+	* primary.c (match_boz_constant): Add gfc_notify_std diagnostics.
+
+2007-12-06  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34335
+	* module.c (find_symbol): Do not return symtrees with unique
+	names, which shows that they are private.
+
+2007-12-05  Jakub Jelinek  <jakub@redhat.com>
+
+	PR debug/33739
+	* gfortran.h (gfc_file): Remove included_by field, add sibling and
+	down.
+	(gfc_start_source_files, gfc_end_source_files): New prototypes.
+	* parse.c (gfc_parse_file): Call gfc_start_source_files and
+	gfc_end_source_files instead of calling the debugging hooks directly.
+	* error.c (show_locus): Use up field instead of included_by.
+	* scanner.c (change_file, gfc_start_source_files,
+	gfc_end_source_files): New functions.
+	(gfc_advance_line): Call change_file instead of calling debug hooks
+	directly.
+	(get_file): Set up rather than included_by.  Initialize down and
+	sibling.
+	(preprocessor_line, load_file): Don't set up field here.
+
+2007-12-05  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34333
+	* arith.h (gfc_compare_expr): Add operator argument, needed
+	for compare_real.
+	* arith.c (gfc_arith_init_1): Use mpfr_min instead of mpfr_cmp/set
+	to account for NaN.
+	(compare_real): New function, as mpfr_cmp but takes NaN into account.
+	(gfc_compare_expr): Use compare_real.
+	(compare_complex): Take NaN into account.
+	(gfc_arith_eq,gfc_arith_ne,gfc_arith_gt,gfc_arith_ge,gfc_arith_lt,
+	gfc_arith_le): Pass operator to gfc_compare_expr.
+	* resolve.c (compare_cases,resolve_select): Pass operator
+	to gfc_compare_expr.
+	* simplify.c (simplify_min_max): Take NaN into account.
+
+2007-12-04  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34318
+	* module.c (mio_gmp_real): Properly write NaN and Infinity.
+
+2007-12-02  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34186
+	* symbol.c (generate_isocbinding_symbol): Fix setting string length.
+
+2007-11-30  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34133
+	* match.h: Add bool allow_binding_name to gfc_match_bind_c.
+	* decl.c (match_attr_spec,gfc_match_bind_c_stmt,gfc_match_entry):
+	Adjust accordingly.
+	(gfc_match_bind_c): Add allow_binding_name argument, reject
+	binding name for dummy arguments.
+	(gfc_match_suffix,gfc_match_subroutine): Make use of
+	allow_binding_name.
+
+2007-11-30  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34186
+	* symbol.c (generate_isocbinding_symbol): Set string length.
+	* dump-parse-tree.c (gfc_show_attr): Show BIND(C) attribute.
+	* misc.c (gfc_basic_typename): Handle BT_VOID.
+
+2007-11-29  Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/34230
+	* fortran/arith.c (gfc_check_real_range): Set intermediate values
+	to +-Inf and 0 when -fno-range-check is in effect.
+	* fortran/invoke.texi: Improve -fno-range-check description.
+
+	PR fortran/34203
+	* fortran/invoke.texi: Document the C escaped characters activated
+	by -fbackslash.
+
+2007-11-29  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34248
+	* trans-decl.c (generate_dependency_declarations): Check
+	for NULL pointers before accessing the string length.
+
+2007-11-29  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34262
+	* intrinsic.c (gfc_get_intrinsic_sub_symbol): Add comment.
+	(gfc_intrinsic_sub_interface): Copy elemental state if needed.
+	* iresolve.c (gfc_resolve_mvbits): Mark procedure as elemental.
+
+2007-11-28  Jakub Jelinek  <jakub@redhat.com>
+
+	* trans-expr.c (gfc_trans_string_copy): Convert both dest and
+	src to void *.
+
+	PR fortran/34247
+	* trans-openmp.c (gfc_omp_privatize_by_reference): For REFERENCE_TYPE
+	pass by reference only PARM_DECLs or non-artificial decls.
+
+2007-11-27  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/32928
+	* decl.c (match_data_constant): Use gfc_match_init_expr to match the
+	array spec and set the initializer expression.
+
+2007-11-27  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/34227
+	* match.c (gfc_match_common): Add additional check for BLOCK DATA.
+
+2007-11-27  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29389
+	*resolve.c (resolve_ordinary_assign): Use find_sym_in_expr to
+	test if a temporary should be written for a vector subscript
+	on the lhs.
+
+	PR fortran/33850
+	* restore.c (pure_stmt_function): Add prototype and new
+	function. Calls impure_stmt_fcn.
+	(pure_function): Call it.
+	(impure_stmt_fcn): New function.
+
+	* expr.c (gfc_traverse_expr): Call *func for all expression
+	types, not just variables. Add traversal of character lengths,
+	iterators and component character lengths and arrayspecs.
+	(expr_set_symbols_referenced): Return false if not a variable.
+	* trans-stmt.c (forall_replace, forall_restore): Ditto.
+	* resolve.c (forall_index): Ditto.
+	(sym_in_expr): New function.
+	(find_sym_in_expr): Rewrite to traverse expression calling
+	sym_in_expr.
+	*trans-decl.c (expr_decls): New function.
+	(generate_expr_decls): Rewrite to traverse expression calling
+	expr_decls.
+	*match.c (check_stmt_fcn): New function.
+	(recursive_stmt_fcn): Rewrite to traverse expression calling
+	check_stmt_fcn.
+
+2007-11-27  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/33541
+	*interface.c (compare_actual_formal): Exclude assumed size
+	arrays from the possibility of scalar to array mapping.
+	* decl.c (get_proc_name): Fix whitespace problem.
+
+	PR fortran/34231
+	* gfortran.h : Add 'use_rename' bit to symbol_attribute.
+	* module.c : Add 'renamed' field to pointer_info.u.rsym.
+	(load_generic_interfaces): Add 'renamed' that is set after the
+	number_use_names is called.  This is used to set the attribute
+	use_rename, which, in its turn identifies those symbols that
+	have not been renamed.
+	(load_needed): If pointer_info.u.rsym->renamed is set, then
+	set the use_rename attribute of the symbol.
+	(read_module): Correct an erroneous use of use_flag. Use the
+	renamed flag and the use_rename attribute to determine which
+	symbols are not renamed.
+
+2007-11-26  Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/34203
+	* options.c:  Change default behavior of backslash processing.
+	* invoke.texi: Update documentation.
+
+2007-11-25  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/33152
+	* decl.c (add_init_expr_to_sym): Remove error message.
+	* resolve.c (check_data_variable): Add new check for a data variable
+	that has an array spec, but no ref and issue an error.
+	* match.c (gfc_match_common): Remove error message.
+
+2007-11-25  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34079
+	* trans-types.c (gfc_return_by_reference,
+	gfc_get_function_type): Do not return result of
+	character-returning bind(C) functions as argument.
+	* trans-expr.c (gfc_conv_function_call): Ditto.
+
+2007-11-25  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/34175
+	* gfortran.texi: Document default forms assumed for various file
+	extensions.
+
+2007-11-25  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/33499
+	* decl.c (get_proc_name): If ENTRY statement occurs before type
+	specification, set the symbol untyped and ensure that it is in
+	the procedure namespace.
+
+2007-11-24  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/33541
+	* module.c (find_symtree_for_symbol): Move to new location.
+	(find_symbol): New function.
+	(load_generic_interfaces): Rework completely so that symtrees
+	have the local name and symbols have the use name.  Renamed
+	generic interfaces exclude the use of the interface without an
+	ONLY clause (11.3.2).
+	(read_module): Implement 11.3.2 in the same way as for generic
+	interfaces.
+
+2007-11-23 Christopher D. Rickett <crickett@lanl.gov>
+
+	* trans-common.c (build_common_decl): Fix the alignment for
+	BIND(C) common blocks.
+
+2007-11-23  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/34209
+	* iresolve.c (gfc_resolve_nearest): If sign variable kind does not match
+	kind of input variable, convert it to match.
+
+	PR fortran/33317
+	* trans.h: Modify prototype for gfc_conv_missing_dummy.
+	* trans-expr.c (gfc_conv_missing_dummy): Modify to pass an integer kind
+	parameter in.  Set the type of the dummy to the kind given.
+	(gfc_conv_function_call): Pass representation.length to
+	gfc_conv_missing_dummy.
+	* iresolve.c (gfc_resolve_cshift): Determine the correct kind to use and
+	if appropriate set representation.length to this kind value.
+	(gfc_resolve_eoshift): Likewise.
+	* check.c (gfc_check_cshift): Enable dim_check to allow DIM as an
+	optional argument. (gfc_check_eoshift): Likewise.
+	* trans_intrinsic.c (gfc_conv_intrinsic_function_args): Update call to
+	gfc_conv_missing_dummy.
+
+2007-11-23  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34187
+	* module.c (load_needed): Ensure binding_label is not lost.
+
+	* decl.c (set_binding_label,gfc_match_bind_c): Replace
+	strncpy by strcpy.
+
+2007-11-23  Tobias Burnus  <burnus@net-b.de>
+	    Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/34192
+	* simplify.c (gfc_simplify_nearest): Fix NEAREST for
+	subnormal numbers.
+
+2007-11-23  Aldy Hernandez  <aldyh@redhat.com>
+
+	* trans-expr.c (gfc_trans_string_copy): Use "void *" when building a
+	memset.
+		
+2007-11-22  Tobias Burnus  <burnus@net-b.de>
+
+	* primary.c (gfc_match_structure_constructor): Allow
+	constructor for types without components.
+
+2007-11-22  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34079
+	* trans-expr.c (gfc_conv_function_call): Do not append
+	string length arguments when calling bind(c) procedures.
+	* trans-decl.c (create_function_arglist): Do not append
+	string length arguments when declaring bind(c) procedures.
+
+2007-11-21  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/34083
+	* resolve.c (resolve_structure_cons): Also check for zero rank.
+
+2007-11-19  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/33317
+	* trans-expr.c (gfc_conv_missing_dummy): Revert.
+	* iresolve.c (gfc_resolve_cshift): Revert.
+	(gfc_resolve_eoshift): Likewise.
+	* check.c (gfc_check_cshift): Revert.
+	(gfc_check_eoshift): Likewise.
+
+2007-11-19  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34079
+	* decl.c (gfc_match_entry): Support BIND(C).
+	(gfc_match_subroutine): Fix comment typo.
+
+2007-11-18  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/33317
+	* trans-expr.c (gfc_conv_missing_dummy): Set the type of the dummy
+	argument to default integer if flagged to do so. Fix typo in comment.
+	* resolve.c (gfc_resolve_dim_arg): Whitespace cleanup.
+	* iresolve.c (gfc_resolve_cshift): Do not convert type, mark attribute
+	for converting the DIM type appropriately in trans-expr.c.
+	(gfc_resolve_eoshift): Likewise.
+	* check.c (dim_check): Remove pre-existing dead code.
+	(gfc_check_cshift): Enable dim_check to allow DIM as an optional.
+	(gfc_check_eoshift): Likewise.
+	* trans_intrinsic.c (gfc_conv_intrinsic_function_args): Fix whitespace.
+
+2007-11-18  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31608
+	* trans-array.c (gfc_conv_expr_descriptor): Remove exception
+	for indirect references in the call to gfc_trans_scalar_assign.
+	* trans-expr.c (gfc_conv_string_parameter): Instead of asserting
+	that the expression is not an indirect reference, cast it to a
+	pointer type of the length given by se->string_length.
+
+2007-11-18  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34137
+	* primary.c (match_variable): Reject non-result entry symbols.
+	* resolve.c (resolve_contained_fntype): Do not check entry master
+	functions.
+
+2007-11-17  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* trans-types.c (gfc_init_types): Use wider buffer.
+
+2007-11-17  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* trans-types.c (gfc_init_types): Use Fortran-90-style type
+	names, with kinds.
+
+2007-11-17  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34133
+	* decl.c (gfc_match_suffix,gfc_match_subroutine): Disallow
+	bind(c) attribute for internal procedures.
+
+2007-11-17  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/25252
+	* interface.c (gfc_current_interface_head,
+	gfc_set_current_interface_head): New functions.
+	* decl.c (gfc_match_modproc): Move check for syntax error earlier.
+	On syntax error, restore previous state of the interface.
+	* gfortran.h (gfc_current_interface_head,
+	gfc_set_current_interface_head): New prototypes.
+
+2007-11-17  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/30285
+	* module.c (struct written_common, written_commons): New structure.
+	(compare_written_commons, free_written_common, write_common_0):
+	New functions.
+	(write_common): Call recursive function write_common_0.
+
+2007-11-17  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/34108
+	* io.c (check_format_string): Only check character expressions.
+	(match_dt_format): Return MATCH_ERROR if that is what
+	gfc_match_st_label said.
+
+2007-11-16  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/33957
+	* expr.c (check_inquiry): Don't call gfc_error now.
+
+2007-11-16  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/33739
+	PR fortran/34084
+	* scanner.c (start_source_file, end_source_file,
+	exit_remaining_files, gfc_advance_line): Revert rev. 130016.
+
+2007-11-16  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34008
+	* trans-stmt.c (gfc_conv_elemental_dependencies): Add check for
+	INTENT_INOUT as well as INTENT_OUT.
+	(gfc_trans_call): Remove redundant gcc_asserts in dependency
+	check.
+
+2007-11-16  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/33986
+	* trans-array.c (gfc_conv_array_parameter ): Allow allocatable
+	function results.
+
+2007-11-15  Tobias Burnus  <burnus@net-b.de>
+ 
+	PR fortran/33917
+	* decl.c (match_procedure_decl): Pre-resolve interface.
+	* resolve.c (resolve_symbol): Reject interfaces later
+	declared in procedure statements.
+
+2007-11-13  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/33162
+	* decl.c (match_procedure_decl): Remove TODO and allow intrinsics in
+	PROCEDURE declarations.  Set attr.untyped to allow the interface to be
+	resolved later where the symbol type will be set.
+	* interface.c (compare_intr_interfaces): Remove static from pointer
+	declarations.  Add type and kind checks for dummy function arguments.
+	(compare_actual_formal_intr): New function to compare an actual
+	argument with an intrinsic function. (gfc_procedures_use): Add check for
+	interface that points to an intrinsic function, use the new function.
+	* resolve.c (resolve_specific_f0): Resolve the intrinsic interface.
+	(resolve_specific_s0): Ditto.
+
+2007-11-13  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34080
+	* iresolve.c (gfc_resolve_transfer): Do not try to convert
+	to a constant MOLD expression, if it is an assumed size
+	dummy.
+
+2007-11-10  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* trans-common.c: Remove prototype for gfc_get_common.
+
+2007-11-10  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/33592
+	* trans.c (gfc_call_realloc): Fix the logic and rename variables.
+
+2007-11-08  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/33739
+	* scanner.c (start_source_file, end_source_file,
+	exit_remaining_files): New functions.
+	(gfc_advance_line): Use the new functions.
+
+2007-11-08  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/34028
+	* trans-intrinsic.c (gfc_conv_intrinsic_ishft): Use correct type.
+
+2007-11-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/33917
+	* interface.c (check_sym_interfaces): Disallow PROCEDURE-declared
+	procedures for MODULE PROCEDURE.
+	* decl.c (match_procedure_in_interface): Do not mark as procedure.
+
+2007-11-03  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/33881
+	* trans-array.c (gfc_conv_array_parameter): Evaluate
+	se->string_length instead of the expr->ts.cl->backend_decl.
+
+2007-11-03  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* gfortran.h: Shorten comment.
+	* trans-types.c (gfc_get_function_type): Allow argument to have
+	flavor FL_PROGRAM.
+	* trans-decl.c (gfc_sym_mangled_function_id): Mangle main program
+	name into MAIN__.
+	(build_function_decl): Fix comment.
+	* parse.c (main_program_symbol): Give the main program its proper
+	name, if any. Set its flavor to FL_PROGRAM.
+	(gfc_parse_file): Likewise.
+
+2007-11-02  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* intrinsic.texi (ALLOCATED): Fix typo.
+
+2007-10-31  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/33941
+	* modules.c (intrinsics): Use only alphabetic names for
+	intrinsic operators.
+
+2007-10-31  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/33162
+	* interface.c (compare_intr_interfaces): New function to check intrinsic
+	function arguments against formal arguments. (compare_interfaces): Fix
+	logic in comparison of function and subroutine attributes.
+	(compare_parameter): Use new function for intrinsic as argument.
+	* resolve.c (resolve_actual_arglist): Allow an intrinsic without
+	function attribute to be checked further.  Set function attribute if
+	intrinsic symbol is found, return FAILURE if not.
+
+2007-10-31  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/33897
+	* decl.c (gfc_match_entry): Do not make ENTRY name
+	global for contained procedures.
+	* parse.c (gfc_fixup_sibling_symbols): Fix code for
+	determining whether a procedure is external.
+
+2007-10-30  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/33596
+	* trans-intrinsic.c (gfc_conv_intrinsic_isnan): Strip NOP_EXPR
+	from the result of build_call_expr.
+
+2007-10-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31217
+	PR fortran/33811
+	PR fortran/33686
+
+	* trans-array.c (gfc_conv_loop_setup): Send a complete type to
+	gfc_trans_create_temp_array if the temporary is character.
+	* trans-stmt.c (gfc_trans_assign_need_temp): Do likewise for
+	allocate_temp_for_forall_nest.
+	(forall_replace): New function.
+	(forall_replace_symtree): New function.
+	(forall_restore): New function.
+	(forall_restore_symtree): New function.
+	(forall_make_variable_temp): New function.
+	(check_forall_dependencies): New function.
+	(cleanup_forall_symtrees): New function.
+	gfc_trans_forall_1): Add and initialize pre and post blocks.
+	Call check_forall_dependencies to check for all dependencies
+	and either trigger second forall block to copy temporary or
+	copy lval, outside the forall construct and replace all
+	dependent references. After assignment clean-up and coalesce
+	the blocks at the end of the function.
+	* gfortran.h : Add prototypes for gfc_traverse_expr and
+	find_forall_index.
+	expr.c (gfc_traverse_expr): New function to traverse expression
+	and visit all subexpressions, under control of a logical flag,
+	a symbol and an integer pointer. The slave function is caller
+	defined and is only called on EXPR_VARIABLE.
+	(expr_set_symbols_referenced): Called by above to set symbols
+	referenced.
+	(gfc_expr_set_symbols_referenced): Rework of this function to
+	use two new functions above.
+	* resolve.c (find_forall_index): Rework with gfc_traverse_expr,
+	using forall_index.
+	(forall_index): New function used by previous.
+	* dependency.c (gfc_check_dependency): Use gfc_dep_resolver for
+	all references, not just REF_ARRAY.
+	(gfc_dep_resolver): Correct the logic for substrings so that
+	overlapping arrays are handled correctly.
+
+2007-10-28  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	PR fortran/32147
+	* module.c (write_symbol): Fix whitespace.
+	(write_symbol0): Walk symtree from left-to-right instead
+	breadth-first.
+	(write_symbol1): Similarly change walk of pointer info tree.
+	(write_module): Insert linebreak.
+	* symbol.c (gfc_traverse_symtree): Change to left-to-right order.
+	(traverse_ns): Likewise.
+
+2007-10-27 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+	PR fortran/31306
+	* decl.c (char_len_param_value): Add check for conflicting attributes of
+	function argument.
+
+2007-10-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/33862
+	* lang-specs.h: Support .ftn and .FTN extension, use CPP for .FOR.
+	* options.c (form_from_filename): Support .ftn extension.
+	* gfortran.texi: Document support of .for and .ftn file extension.
+
+2007-10-26  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/33162
+	* intrinsic.h: Add prototypes for four new functions, gfc_check_datan2,
+	gfc_check_dprod, gfc_check_fn_d, and gfc_check_x_yd.
+	* intrinsic.c (add_functions): Add double precision checks for dabs,
+	dacos, dacosh, dasin, dasinh, datan, datanh, datan2, dbesj0, dbesj1,
+	dbesy0, dbesy1, dcos, dcosh, ddim, derf, derfc, dexp, dgamma,
+	dlgama, dlog, dlog10, dmod, dsign, dsin, dsinh, dsqrt, dtan, and dtanh.
+	Add real check dprod.
+	* check.c (gfc_check_datan2): New function to check for double precision
+	argumants. (gfc_check_dprod, gfc_check_fn_d, and gfc_check_x_yd): Ditto.
+
+2007-10-26  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	* invoke.texi: Fix typo in -fmax-errors=.
+
+2007-10-26  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/29784
+	* gfortran.texi: Document that there is no logical/integer
+	conversion performed during I/O operations.
+
+2007-10-22  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/33849
+	* resolve.c (resolve_actual_arglist): Fix error message text.
+
+2007-10-22  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/31244
+	* gfortran.h (gfc_data_value): Change repeat from unsigned int
+	to mpz_t.
+	* decl.c(top_val_list): Remove msg variable.  Use mpz_t for
+	repeat count.
+	* resolve.c (values):  Change left from unsigned int to mpz_t.
+	(next_data_value): Change for mpz_t.
+	(check_data_variable): Change ??? to FIXME in a comment.  Use
+	"mpz_t left".
+	(resolve_data ): Use "mpz_t left".
+
+2007-10-21  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/33749
+	* resolve.c (resolve_ordinary_assign): New function that takes
+	the code to resolve an assignment from resolve_code. In
+	addition, it makes a temporary of any vector index, on the
+	lhs, using gfc_get_parentheses.
+	(resolve_code): On EXEC_ASSIGN call the new function.
+
+2007-10-20  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/33818
+	* resolve.c (resolve_variable): Check that symbol is in the same
+	namespace as the entry function.
+
+2007-10-20  Paul Thomas  <pault@gcc.gnu.org>
+	    FX Coudert <fxcoudert@gcc.gnu.org>
+
+	PR fortran/31608
+	* trans-array.c (gfc_conv_expr_descriptor): For all except
+	indirect references, use gfc_trans_scalar_assign instead of
+	gfc_add_modify_expr.
+	* iresolve.c (check_charlen_present): Separate creation of cl
+	if necessary and add code to treat an EXPR_ARRAY.
+	(gfc_resolve_char_achar): New function.
+	(gfc_resolve_achar, gfc_resolve_char): Call it.
+	(gfc_resolve_transfer): If the MOLD expression does not have a
+	character length expression, get it from a constant length.
+
+2007-10-19  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/33544
+	* simplify.c (gfc_simplify_transfer): Only warn for short transfer when
+	-Wsurprising is given.
+	* invoke.texi: Document revised behavior.
+
+2007-10-18  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/33795
+	* gfortran.texi: Document GFORTRAN_UNBUFFERED_PRECONNECTED
+	environment variable.  Delete mention of environment variable
+	GFORTRAN_UNBUFFERED_n.
+
+2007-10-18  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/33233
+	* resolve.c (check_host_association): Check singly contained
+	namespaces and start search for symbol in current namespace.
+
+2007-10-18  Paul Thomas  <pault@gcc.gnu.org>
+	    Dominique d'Humières  <dominiq@lps.ens.fr>
+
+	PR fortran/33733
+	* simplify.c (gfc_simplify_transfer): Return null if the source
+	expression is EXPR_FUNCTION.
+
+2007-10-17 Christopher D. Rickett <crickett@lanl.gov>
+
+	PR fortran/33760
+	* symbol.c (gen_special_c_interop_ptr): Remove code to create
+	constructor for c_null_ptr and c_null_funptr with value of 0.
+	* expr.c (check_init_expr): Prevent check on constructors for
+	iso_c_binding derived types.
+	* resolve.c (resolve_structure_cons): Verify that the user isn't
+	trying to invoke a structure constructor for one of the
+	iso_c_binding derived types.
+
+2007-10-15 Christopher D. Rickett <crickett@lanl.gov>
+
+	PR fortran/32600
+	* trans-expr.c (gfc_conv_function_call): Generate code to inline
+	c_associated.
+	* symbol.c (get_iso_c_sym): Preserve from_intmod and intmod_sym_id
+	attributes in the resolved symbol.
+	* resolve.c (gfc_iso_c_sub_interface): Remove dead code.
+
+2007-10-15  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/33055
+	* trans-io.c (create_dummy_iostat): New function to create a unique
+	dummy variable expression to use with IOSTAT.
+	(gfc_trans_inquire): Use the new function to pass unit number error info
+	to run-time library if a regular IOSTAT variable was not given.
+
+2007-10-14  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/33745
+	* trans-array.c (gfc_conv_ss_startstride): Fix dimension check.
+	(gfc_trans_array_bound_check, gfc_conv_array_ref,
+	gfc_conv_ss_startstride): Simplify error message.
+	* resolve.c (check_dimension): Fix dimension-type switch;
+	improve error message.
+
+2007-10-13  Tobias Schlüter  <tobi@gcc.gnu.org>
+	    Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/33254
+	PR fortran/33727
+	* trans-array.c (get_array_ctor_var_strlen): Check upper bound for
+	constness instead of lower bound.
+	(get_array_ctor_strlen): Add bounds-checking code.
+
+2007-10-12  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/33542
+	* resolve.c (resolve_actual_arglist): If the actual argument is
+	ambiguous, then there is an error.
+
+2007-10-12  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/33664
+	* expr.c (gfc_specification_expr): If a function is not
+	external, intrinsic or pure is an error.  Set the symbol pure
+	to prevent repeat errors.
+
+2007-10-10  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/33636
+	* expr.c (find_array_section): Check for constructor constantness.
+
+2007-10-08  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	PR fortran/33689
+	* resolve.c (gfc_resolve_expr): Fix indentation.
+	(resolve_fl_variable_derived): Rename argument.
+	(resolve_fl_variable): Fix case in message.  Clarify logic.
+	Correctly simplify array bounds.
+
+2007-10-07  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR libfortran/33683
+	* mathbuiltins.def (GAMMA):  Change function name to
+	"tgamma" instad of "gamma".
+
+2007-10-07  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	PR fortran/20851
+	* expr.c (check_inquiry): Typo fix in error message.
+	(check_init_expr): Same * 3.
+	(check_restricted): Verify that no dummy arguments appear in
+	restricted expressions in ELEMENTAL procedures.
+	* resolve.c (resolve_fl_variable): Exchange order of checks to
+	avoid side-effect.
+
+2007-10-06  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/33609
+	* simplify.c (range_check): Return gfc_bad_expr if incoming expression 
+	is NULL.
+
+2007-10-06  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	* simplify.c (gfc_simplify_size): Fix typo.
+
+2007-10-06  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	PR fortran/25076
+	* resolve.c (gfc_find_forall_index): Move towards top,
+	renaming to ...
+	(find_forall_index): ... this.  Add check for NULL expr.
+	(resolve_forall_iterators): Verify additional constraint.
+	(resolve_forall): Remove checks obsoleted by new code in
+	resolve_forall_iterators.
+
+2007-10-05  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* gfortran.h (gfc_get_data_variable, gfc_get_data_value,
+	gfc_get_data): Move to decl.c.
+	(global_used): Rename into gfc_global_used.
+	(gfc_formalize_init_value, gfc_get_section_index,
+	gfc_assign_data_value, gfc_assign_data_value_range,
+	gfc_advance_section): Move to data.h.
+	(gfc_set_in_match_data): Remove.
+	* decl.c (gfc_get_data_variable, gfc_get_data_value,
+	gfc_get_data): Move here.
+	(gfc_set_in_match_data): Rename into set_in_match_data.
+	(gfc_match_data): Likewise.
+	(add_global_entry): Rename global_used into gfc_global_used.
+	* data.c: Include data.h.
+	* trans.h (gfc_todo_error): Remove.
+	* trans-array.c (gfc_trans_array_constructor,
+	gfc_conv_ss_startstride, gfc_conv_loop_setup): Change
+	gfc_todo_error into assertions.
+	* resolve.c (resolve_global_procedure): Rename global_used into
+	gfc_global_used.
+	* parse.c (gfc_global_used, parse_module, add_global_procedure,
+	add_global_program): Likewise.
+	* trans-intrinsic.c (gfc_walk_intrinsic_function): Rename
+	global_used into gfc_global_used.
+	* Make-lang.in: Add dependencies on fortran/data.h.
+	* data.h: New file.
+
+2007-10-04  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/33529
+	* decl.c (match_char_kind): New function.
+	(match_char_spec): Use match_char_kind.
+
+2007-10-04  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/33502
+	* scanner.c (gfc_advance_line): Call debug_hooks->end_source_file
+	and debug_hooks->start_source_file when appropriate, and set
+	dbg_emitted.
+	(gfc_define_undef_line): New function.
+	(load_file): Don't error out on #define and #undef lines.
+	* parse.c (next_statement): Call gfc_define_undef_line.
+	(gfc_parse_file): Call debug_hooks->start_source_file and
+	debug_hooks->end_source_file for the main source file if
+	required.
+	* gfortran.h (gfc_linebuf): Add dbg_emitted field.
+	(gfc_define_undef_line): New prototype.
+
+2007-10-04  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	PR fortran/33626
+	* resolve.c (resolve_operator): Always copy the type for
+	expressions in parentheses.
+
+2007-10-04  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/33646
+	PR fortran/33542
+	* interface.c (check_interface1): Revert patch of 10-02.
+
+2007-10-03  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/26682
+	* trans-decl.c (build_function_decl): Set "externally_visible"
+	attribute on the MAIN program decl.
+
+2007-10-03  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	PR fortran/33198
+	* resolve.c (has_default_initializer): Move to top.  Make bool.
+	(resolve_common_blocks): Simplify logic.  Add case for derived
+	type initialization.
+	(resolve_fl_variable_derived): Split out from ...
+	(resolve_fl_variable): ... here, while adapting to new h_d_i
+	interface.
+
+2007-10-03  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/26682
+	* options.c (gfc_post_options): Issue an error when
+	-fwhole-program is used.
+
+2007-10-02  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/33542
+	* interface.c (check_interface1): Specific procedures are
+	always ambiguous if they have the same name.
+
+2007-10-02  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/33566
+	* primary.c (gfc_match_rvalue): Make all expressions with array
+	references to structure parameters into variable expressions.
+
+2007-10-02  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/33554
+	* trans-decl.c (init_intent_out_dt): New function.
+	(gfc_trans_deferred_vars): Remove the code for default
+	initialization of INTENT(OUT) derived types and put it
+	in the new function.  Call it earlier than before, so
+	that array offsets and lower bounds are available.
+
+2007-10-02  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/33550
+	* decl.c (get_proc_name): Return rc if rc is non-zero; ie. if
+	the name is a reference to an ambiguous symbol.
+
+2007-10-02  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31154
+	PR fortran/31229
+	PR fortran/33334
+	* decl.c : Declare gfc_function_kind_locs and
+	gfc_function_type_locus.
+	(gfc_match_kind_spec): Add second argument kind_expr_only.
+	Store locus before trying to match the expression. If the
+	current state corresponds to a function declaration and there
+	is no match to the expression, read to the parenthesis, return
+	kind = -1, dump the expression and return.
+	(gfc_match_type_spec): Renamed from match_type_spec and all
+	references changed.  If an interface or an external function,
+	store the locus, set kind = -1 and return.  Otherwise, if kind
+	is already = -1, use gfc_find_symbol to try to find a use
+	associated or imported type.
+	match.h : Prototype for gfc_match_type_spec.
+	* parse.c (match_deferred_characteristics): New function.
+	(parse_spec): If in a function, statement is USE or IMPORT
+	or DERIVED_DECL and the function kind=-1, call
+	match_deferred_characteristics.  If kind=-1 at the end of the
+	specification expressions, this is an error.
+	* parse.h : Declare external gfc_function_kind_locs and
+	gfc_function_type_locus.
+
+2007-09-27  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
+
+	* module.c (mio_expr): Avoid -Wcast-qual warning.
+
+2007-09-27  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	* arith.c (reduce_binary_aa): Fix capitalization.
+	* check.c (gfc_check_dot_product): Likewise.
+	(gfc_check_matmul): Likewise.
+	* expr.c (gfc_check_conformance): Likewise.
+	(gfc_check_assign): Likewise.
+	(gfc_default_initializer): Simplify logic.
+	* trans.c (gfc_msg_bounds): Make const.
+	(gfc_msg_fault): Likewise.
+	(gfc_msg_wrong_return): Likewise.
+	* trans.h: Add const to corresponding extern declarations.
+
+2007-09-27  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/33568
+	* trans-intrinsic.c (gfc_conv_intrinsic_aint): Allow for the 
+	possibility of the optional KIND argument by making arg
+	an array, counting the number of arguments and using arg[0].
+
+2007-09-26  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/30780
+	* invoke.texi: Add note to -ffpe-trap option. Fix typos.
+
+2007-09-23  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	PR fortran/33269
+	* io.c (check_format_string): Move NULL and constant checks into
+	this function.
+	(check_io_constraints): Call gfc_simplify_expr() before calling
+	check_format_string().  Remove NULL and constant checks.
+
+2007-09-24  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/33538
+	* scanner.c, parse.c, gfortran.h: Revert revision 128671.
+
+2007-09-23  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/33528
+	* scanner.c (preprocessor_line): Call linemap_add when exiting
+	a file.
+	(gfc_new_file): Adjust debug code for USE_MAPPED_LOCATION.
+
+2007-09-22  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/33522
+	* trans-types.c (gfc_get_desc_dim_type): Mark artificial
+	variables with TREE_NO_WARNING.
+	(gfc_get_array_descriptor_base): Likewise.
+
+2007-09-22  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/33337
+	PR fortran/33376
+	* trans-decl.c (gfc_create_module_variable): Output
+	derived type parameters.
+	* arith.c (gfc_parentheses): Return the argument if
+	it is a constant expression.
+	* primary.c (gfc_match_rvalue): Remove the clearing of
+	the module name and the use_assoc attribute for derived
+	type parameter expressions.
+
+2007-09-22  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/33502
+	* scanner.c (gfc_advance_line): Call debug_hooks->start_source_file
+	and debug_hooks->end_source_file when entering and exiting
+	included files.
+	(gfc_define_undef_line): New function.
+	(load_file): Ignore #define and #undef preprocessor lines
+	while reading source files.
+	* parse.c (next_statement): Handle #define and #undef
+	preprocessor lines.
+	(gfc_parse_file): Call debug_hooks->start_source_file and
+	debug_hooks->end_source_file for the main source file if
+	requested by the debug format.
+	* gfortran.h (gfc_define_undef_line): Add prototype.
+
+2007-09-22  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/33445
+	* scanner.c (skip_free_comments): Warn if !$OMP& is used
+	if no OpenMP directive is to be continued.
+
+2007-09-21  Paul Thomas  <pault@gcc.gnu.org>
+
+	*trans-expr.c (gfc_trans_pointer_assignment): Convert array
+	descriptor for subref pointer assignements, rather than using
+	the loop info version.
+
+2007-09-21  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/33037
+	* simplify.c (gfc_simplify_transfer): Warn if source size
+	is smaller than result size.
+
+2007-09-20  Asher Langton  <langton2@llnl.gov>
+
+	PR fortran/20441
+	* gfortran.h : Add init_local_* enums and init_flag_* flags to
+	gfc_option_t.
+	* lang.opt: Add -finit-local-zero, -finit-real, -finit-integer,
+	-finit-character, and -finit-logical flags.
+	* invoke.texi: Document new options.
+	* resolve.c (build_init_assign): New function.
+	(apply_init_assign): Move part of function into build_init_assign.
+	(build_default_init_expr): Build local initializer (-finit-*).
+	(apply_default_init_local): Apply local initializer (-finit-*).
+	(resolve_fl_variable): Try to add local initializer (-finit-*).
+	* options.c (gfc_init_options, gfc_handle_option,
+	gfc_post_options): Handle -finit-local-zero, -finit-real,
+	-finit-integer, -finit-character, and -finit-logical flags.
+
+2007-09-20  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/33221
+	* gfortran.h (symbol_attribute): Add zero_comp field.
+	* symbol.c (gfc_use_derived): Handle case of emtpy derived types.
+	* decl.c (gfc_match_data_decl): Likewise.
+	(gfc_match_derived_decl): Likewise.
+	* module.c (ab_attribute, attr_bits): Add AB_ZERO_COMP member.
+	(mio_symbol_attribute): Write and read AB_ZERO_COMP.
+	* resolve.c (resolve_symbol): Handle case of emtpy derived types.
+	* parse.c (parse_derived): Likewise.
+
+2007-09-20  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/33288
+	* arith.c (reduce_unary, reduce_binary_ac, reduce_binary_ca,
+	reduce_binary_aa): Call ourselves recursively if an element of
+	the constructor is itself a constant array.
+
+2007-09-20  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	* io.c (resolve_tag_format): New function using code split out
+	and simplified from ...
+	(resolve_tag): ... this function.  Simplify logic.  Unify
+	IOSTAT, IOLENGTH and SIZE handling.
+
+2007-09-20  Christopher D. Rickett  <crickett@lanl.gov>
+
+	PR fortran/33497
+	* resolve.c (gfc_iso_c_func_interface): Use information from
+	subcomponent if applicable.
+
+2007-09-20  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/33325
+	* intrinsic.text: Add documentation of the intrinsic modules.
+	* gfortran.texi: Link to intrinsic-modules section and to
+	the GOMP manual.
+
+2007-09-18  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/31119
+	* trans-array.c (gfc_conv_ss_startstride): Only perform bounds
+	checking for optional args when they are present.
+
+2007-09-18  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/33231
+	* resolve.c (resolve_elemental_actual): Check for conformance
+	of intent out/inout dummies.
+
+2007-09-17  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/33106
+	* resolve.c (resolve_symbol): Reject public variable of
+	private derived-types for Fortran 95.
+
+2007-09-17  Tobias Burnus  <burnus@net-b.de>
+
+	* resolve.c (resolve_fl_procedure): Allow private dummies
+	for Fortran 2003.
+
+2007-09-17  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* trans-types.c (gfc_get_desc_dim_type): Do not to try
+	emit debug info.
+	(gfc_get_array_descriptor_base): Likewise.
+	(gfc_get_mixed_entry_union): Likewise
+	(gfc_get_derived_type): Set decl location for fields and
+	derived type itself.
+
+2007-09-16  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29396
+	PR fortran/29606
+	PR fortran/30625
+	PR fortran/30871
+	* trans.h : Add extra argument to gfc_build_array_ref. Rename
+	gfc_conv_aliased_arg to gfc_conv_subref_array_arg.  Move
+	prototype of is_aliased_array to gfortran.h and rename it
+	gfc_is_subref_array.  Add field span to lang_decl, add a new
+	decl lang specific flag accessed by GFC_DECL_SUBREF_ARRAY_P
+	and a new type flag GFC_DECL_SUBREF_ARRAY_P.
+	* trans.c (gfc_build_array_ref): Add the new argument, decl.
+	If this is a subreference array pointer, use the lang_decl
+	field 'span' to calculate the offset in bytes and use pointer
+	arithmetic to address the element.
+	* trans-array.c (gfc_conv_scalarized_array_ref,
+	gfc_conv_array_ref): Add the backend declaration as the third
+	field, if it is likely to be a subreference array pointer.
+	(gfc_conv_descriptor_dimension, gfc_trans_array_ctor_element,
+	gfc_trans_array_constructor_element, structure_alloc_comps,
+	gfc_conv_array_index_offset): For all other references to
+	gfc_build_array_ref, set the third argument to NULL.
+	(gfc_get_dataptr_offset): New function.
+	(gfc_conv_expr_descriptor): If the rhs of a pointer assignment
+	is a subreference array, then calculate the offset to the
+	subreference of the first element and set the descriptor data
+	pointer to this, using gfc_get_dataptr_offset.
+	trans-expr.c (gfc_get_expr_charlen): Use the expression for the
+	character length for a character subreference.
+	(gfc_conv_substring, gfc_conv_subref_array_arg): Add NULL for
+	third argument in call to gfc_build_array_ref.
+	(gfc_conv_aliased_arg): Rename to gfc_conv_subref_array_arg.
+	(is_aliased_array): Remove.
+	(gfc_conv_function_call): Change reference to is_aliased_array
+	to gfc_is_subref_array and reference to gfc_conv_aliased_arg to
+	gfc_conv_subref_array_arg.
+	(gfc_trans_pointer_assignment): Add the array element length to
+	the lang_decl 'span' field.
+	* gfortran.h : Add subref_array_pointer to symbol_attribute and
+	add the prototype for gfc_is_subref_array.
+	* trans-stmt.c : Add NULL for third argument in all references
+	to gfc_build_array_ref.
+	* expr.c (gfc_is_subref_array): Renamed is_aliased_array.
+	If this is a subreference array pointer, return true.
+	(gfc_check_pointer_assign): If the rhs is a subreference array,
+	set the lhs subreference_array_pointer attribute.
+	* trans-decl.c (gfc_get_symbol_decl): Allocate the lang_decl
+	field if the symbol is a subreference array pointer and set an
+	initial value of zero for the 'span' field.
+	* trans-io.c (set_internal_unit): Refer to is_subref_array and
+	gfc_conv_subref_array_arg.
+	(nml_get_addr_expr): Add NULL third argument to
+	gfc_build_array_ref. 
+	(gfc_trans_transfer): Use the scalarizer for a subreference
+	array.
+
+2007-09-13  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	* iresolve.c (resolve_mask_arg): If a mask is an array
+	expression, convert it to kind=1.
+
+2007-09-13  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/33343
+	* expr.c (gfc_check_conformance): Print ranks in the error message.
+	* resolve.c (resolve_elemental_actual): Check also conformance of
+	the actual arguments for elemental functions.
+
+2007-09-13  Tobias Burnus  <burnus@net-b.de>
+
+	* symbol.c (gfc_add_elemental,gfc_add_pure,gfc_add_recursive):
+	Allow prefixes only to be specified once.
+
+2007-09-13  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/33412
+	* symbol.c (check_conflict): Add conflict of ELEMENTAL with Bind(C).
+
+2007-09-12  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/33297
+	* check.c (scalar_check): Move up in the file.
+	(kind_check): Call scalar_check.
+	(dim_check): If optional, do not call nonoptional_check; use
+	bool for optional.
+	(gfc_check_all_any,gfc_check_count,gfc_check_cshift,gfc_check_eoshift,
+	gfc_check_lbound,gfc_check_minloc_maxloc,check_reduction,
+	gfc_check_spread,gfc_check_ubound): Use true/false instead of 0/1
+	for dim_check; honor changed meaning of optional.
+	(gfc_check_int): Replace checks by kind_check.
+	(gfc_check_size): Replace checks by dim_check.
+
+2007-09-12  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/33284
+	PR fortran/33310
+	* symbol.c (check_conflict): Add conflict between INTRINSIC and ENTRY
+	and between BIND(C) and PARAMETER.
+
+2007-09-12  Tobias Burnus  <burnus@net-b.de>
+
+	* trans-expr.c (gfc_conv_initializer): Fix expr == NULL check.
+
+2007-09-12  Jan Hubicka  <jh@suse.cz>
+
+	* f95-lang.c (LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION): Kill.
+
+2007-09-12  Christopher D. Rickett  <crickett@lanl.gov>
+
+	PR fortran/33395
+	* trans-expr.c (gfc_conv_initializer): Remove unnecessary test for
+	intmod_sym_id and use derived symbol to set new kind of C_NULL_PTR
+	and C_NULL_FUNPTR expressions.
+
+2007-09-11  Christopher D. Rickett  <crickett@lanl.gov>
+
+	PR fortran/33040
+	* trans-expr.c (gfc_trans_structure_assign): Convert component
+	C_NULL_PTR and C_NULL_FUNPTR component initializers to (void *).
+	* trans-types.c (gfc_get_derived_type): Create a backend_decl for
+	the c_address field of C_PTR and C_FUNPTR and ensure initializer
+	is of proper type/kind for (void *).
+
+2007-09-11  Jan Hubicka <jh@suse.cz>
+
+	* f95-lang.c (gfc_expand_function): Kill.
+	(LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION): Kill.
+
+2007-09-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/31547
+	* gfortran.texi: Document when CPP is called.
+
+	* intrinsic.texi (IOR): Fix typos.
+
+2007-09-10  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/33370
+	* trans-expr.c (copyable_array_p):  Add tests that expression
+	is a variable, that it has no subreferences and that it is a
+	full array.
+	(gfc_trans_assignment): Change conditions to suit modifications
+	to copyable_array_p.
+
+2007-09-06  Tom Tromey  <tromey@redhat.com>
+
+	* scanner.c (get_file): Update.
+	(load_file): Update.
+	(gfc_next_char_literal): Use gfc_linebuf_linenum.
+	* f95-lang.c (gfc_init): Update.
+	* gfortran.h (gfc_linebuf_linenum): New macro.
+
+2007-09-05  Sandra Loosemore  <sandra@codesourcery.com>
+
+	* trans-decl.c (build_entry_thunks): Use set_cfun.
+	(gfc_generate_function_code): Likewise.
+
+2007-09-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31564
+	* primary.c (gfc_match_rvalue): Make expressions that refer
+	to derived type parameters that have array references into
+	variable expressions.  Remove references to use association
+	from the symbol.
+
+	PR fortran/33241
+	* decl.c (add_init_expr_to_sym): Provide assumed character
+	length parameters with the length of the initialization
+	expression, if a constant, or that of the first element of
+	an array.
+
+2007-09-04  Janus Weil  <jaydub66@gmail.com>
+	    Paul Thomas  <pault@gcc.gnu.org>
+
+	* decl.c (match_procedure_decl,match_procedure_in_interface,
+	gfc_match_procedure): Handle PROCEDURE statements.
+	* gfortran.h (struct gfc_symbol): New member "gfc_symbol *interface".
+	(enum gfc_statement): New element "ST_PROCEDURE".
+	(strcut symbol_attribute): New member "unsigned procedure".
+	* interface.c (check_interface0): Extended error checking.
+	* match.h: Add gfc_match_procedure prototype.
+	* parse.c (decode_statement,next_statement,gfc_ascii_statement,
+	parse_derived,parse_interface): Implement PROCEDURE statements.
+	* resolve.c (resolve_symbol): Ditto.
+	* symbol.c (check_conflict): Ditto.
+	(gfc_add_proc): New function for setting the procedure attribute.
+	(copy_formal_args): New function for copying formal argument lists.
+
+2007-09-03  Daniel Jacobowitz  <dan@codesourcery.com>
+
+	* Make-lang.in (gfortranspec.o): Remove SHLIB_MULTILIB.
+
+2007-09-03  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
+
+	* gfortranspec.c (lang_specific_driver): Use CONST_CAST2.
+	* options.c (gfc_post_options): Supply a TYPE for CONST_CAST.
+	* parse.c (parse_omp_structured_block): Likewise,
+	* st.c (gfc_free_statement): Likewise,
+
+2007-09-03  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/31675
+	* libgfortran.h: New file.
+	* iso-fortran-env.def: Use macros in the new header instead of
+	hardcoded integer constants.
+	* Make-lang.in (F95_PARSER_OBJS, GFORTRAN_TRANS_DEPS): Add
+	fortran/libgfortran.h.
+	* gfortran.h (GFC_STD_*, GFC_FPE_*, options_convert,
+	ioerror_codes): Remove.
+	* trans.c (ERROR_ALLOCATION): Remove.
+	(gfc_call_malloc, gfc_allocate_with_status,
+	gfc_allocate_array_with_status): Use LIBERROR_ALLOCATION.
+	* trans-types.h (GFC_DTYPE_*): Remove.
+	* trans-decl.c (gfc_generate_function_code): Use
+	GFC_CONVERT_NATIVE instead of CONVERT_NATIVE.
+	* trans-io.c (set_parameter_value, set_parameter_ref): Use
+	LIBERROR_* macros instead of IOERROR_ macros.
+	* trans-intrinsic.c (gfc_conv_intrinsic_function): Use
+	LIBERROR_END and LIBERROR_EOR instead of hardcoded constants.
+	* options.c (gfc_init_options): Use GFC_CONVERT_NATIVE instead of
+	CONVERT_NATIVE.
+	(gfc_handle_option): Use GFC_CONVERT_* macros instead of CONVERT_*.
+
+2007-09-02  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* invoke.texi: Fix the -frange-checking option entry.
+
+2007-09-02  Roger Sayle  <roger@eyesopen.com>
+
+	* decl.c (match_string_p): New helper function to explicitly match
+	a string of characters.
+	(match_attr_spec): Remove no longer needed DECL_COLON from decl_types.
+	Delete decls array and peek_char.  Rewrite decl attribute parser to
+	avoid calling gfc_match_strings.
+	* match.c (gfc_match_strings): Delete unused function.
+	* match.h (gfc_match_strings): Delete prototype.
+
+2007-09-02  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	* dump-parse-tree.c (show_char_const): New function.
+	(gfc_show_expr): Use it.
+	* expr.c (find_substring_ref): Rework to not keep characters
+	dangling beyond end of string.
+
+2007-09-02  H.J. Lu  <hongjiu.lu@intel.com>
+
+	PR fortran/33276
+	* array.c (expand_iterator): Initialize frame.prev.
+
+2007-08-31  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/33232
+	* io.c (match_io): Also diagnose extra comma for READ.
+
+2007-08-31  Joseph Myers  <joseph@codesourcery.com>
+
+	* intrinsic.texi (LGAMMA): Remove empty @cindex line.
+
+2007-08-31  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31879
+	PR fortran/31197
+	PR fortran/31258
+	PR fortran/32703
+	* gfortran.h : Add prototype for gfc_resolve_substring_charlen.
+	* resolve.c (gfc_resolve_substring_charlen): New function.
+	(resolve_ref): Call gfc_resolve_substring_charlen.
+	(gfc_resolve_character_operator): New function.
+	(gfc_resolve_expr): Call the new functions in cases where the
+	character length is missing.
+	* iresolve.c (cshift, eoshift, merge, pack, reshape, spread,
+	transpose, unpack): Call gfc_resolve_substring_charlen for
+	source expressions that are character and have a reference.
+	* trans.h (gfc_trans_init_string_length) Change name to
+	gfc_conv_string_length; modify references in trans-expr.c,
+	trans-array.c and trans-decl.c.
+	* trans-expr.c (gfc_trans_string_length): Handle case of no
+	backend_decl.
+	(gfc_conv_aliased_arg): Remove code for treating substrings
+	and replace with call to gfc_trans_string_length.
+	* trans-array.c (gfc_conv_expr_descriptor): Remove code for
+	treating strings and call gfc_trans_string_length instead.
+
+2007-08-30  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/33228
+	* interface.c (check_interface0): Improve error for external procs.
+	(check_sym_interfaces): Fix checking of module procedures.
+
+2007-08-29  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/32989
+	* iresolve.c (gfc_resolve_getarg): Handle non-default integer
+	kinds.
+	* check.c (gfc_check_getarg): New function
+	* intrinsic.h: Add prototype for gfc_check_getarg.
+	* intrinsic.c (add_subroutines): Add reference to gfc_check_getarg.
+	* intrinsic.texi (GETARG): Adjust documentation.
+
+2007-08-29  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+	    Tobias Burnus  <burnus@gcc.gnu.org>
+
+	PR fortran/33105
+	* intrinsic.c (add_functions): Add IS_IOSTAT_END and
+	IS_IOSTAT_EOR intrinsics.
+	* gfortran.h (gfc_isym_id): Add GFC_ISYM_IS_IOSTAT_END and
+	GFC_ISYM_IS_IOSTAT_EOR.
+	* trans-intrinsic.c (gfc_conv_has_intvalue): New function.
+	(gfc_conv_intrinsic_function): Call gfc_conv_has_intvalue for
+	GFC_ISYM_IS_IOSTAT_END and GFC_ISYM_IS_IOSTAT_EOR.
+	* intrinsic.texi: Add IS_IOSTAT_END and IS_IOSTAT_EOR.
+
+2007-08-28  Christopher D. Rickett  <crickett@lanl.gov>
+
+	PR fortran/33215
+	* decl.c (build_sym): Pass number of identifiers on line to
+	set_binding_label.
+	(set_binding_label): Verify that only one identifier given if
+	NAME= specified, even if the given binding label has zero length.
+	(gfc_match_bind_c): Remove declaration for has_name_equals because
+	it hides the static global one that is needed.
+
+2007-08-29  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* trans-array.c (gfc_grow_array): Use gfc_call_realloc.
+	(gfc_array_allocate): Use gfc_allocate_with_status and
+	gfc_allocate_array_with_status.
+	(gfc_array_deallocate): Use gfc_deallocate_with_status.
+	(gfc_trans_dealloc_allocated): Use gfc_deallocate_with_status.
+	* trans-stmt.c (gfc_trans_allocate): Use gfc_allocate_with_status.
+	(gfc_trans_deallocate): Use gfc_deallocate_with_status.
+	* trans.c (gfc_allocate_with_status, gfc_allocate_array_with_status,
+	gfc_deallocate_with_status, gfc_call_realloc): New functions.
+	* trans.h (gfc_allocate_with_status, gfc_allocate_array_with_status,
+	gfc_deallocate_with_status, gfc_call_realloc): New prototypes.
+	(gfor_fndecl_internal_realloc, gfor_fndecl_allocate,
+	gfor_fndecl_allocate_array, gfor_fndecl_deallocate): Remove.
+	* f95-lang.c (gfc_init_builtin_functions): Create decl for
+	BUILT_IN_REALLOC.
+	* trans-decl.c (gfor_fndecl_internal_realloc,
+	gfor_fndecl_allocate, gfor_fndecl_allocate_array,
+	gfor_fndecl_deallocate): Remove function decls.
+	(gfc_build_builtin_function_decls): Likewise.
+
+2007-08-28  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/33055
+	Revert previous patch.
+
+2007-08-28  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/22244
+	* Make-lang.in (fortran/trans-types.o): Depend on $(FLAGS_H).
+	* trans-types.c: Include flags.h.
+	(gfc_get_nodesc_array_type): Add TYPE_DECL TYPE_NAME with
+	correct bounds and dimensions for packed arrays.
+
+2007-08-27  Tobias Burnus  <burnus@net-b.de>
+
+	* simplify.c (gfc_simplify_lgamma): Fix mpfr_lgamma call.
+
+2007-08-26  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/33055
+	* trans-io.c (create_dummy_iostat): New function to create a unique
+	dummy variable expression to use with IOSTAT.
+	(gfc_trans_inquire): Use the new function to pass unit number error info
+	to run-time library if a regular IOSTAT variable was not given.
+
+2007-08-26  H.J. Lu  <hongjiu.lu@intel.com>
+
+	* gfortran.h (gfc_isym_id): Add GFC_ISYM_GAMMA and
+	GFC_ISYM_LGAMMA.
+
+2007-08-26  Asher Langton  <langton2@llnl.gov>
+	    Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.h (gfc_option_t): Add flag_recursive.
+	* lang.opt: Add -frecursive option and update -fopenmp.
+	* invoke.texi (-frecursive): Document new option.
+	(-fopenmp,-fno-automatic,-fmax-stack-var-size): Update.
+	* options.c (gfc_init_options, gfc_post_options,
+	gfc_handle_option): Add -frecursive and modify -fopenmp.
+	(gfc_post_options): Add warning for conflicting flags.
+
+2007-08-26  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/31298
+	* module.c (mio_symbol_ref,mio_interface_rest):  Return pointer_info.
+	(load_operator_interfaces): Support multible loading of an operator.
+
+2007-08-26  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/32985
+	* match.c (gfc_match_common): Remove SEQUENCE diagnostics.
+	* resolve.c (resolve_common_blocks): Add SEQUENCE diagnostics;
+	fix walking through the tree.
+
+2007-08-26  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/32980
+	* intrinsic.h (gfc_simplify_gamma,gfc_simplify_lgamma,
+	gfc_resolve_gamma,gfc_resolve_lgamma): New function declations.
+	* mathbuiltins.def: Define GAMMA and LGAMMA.
+	* intrinsic.c (add_functions): Add GAMMA, DGAMMA, LGAMMA, ALGAMA
+	and DLGAMA.
+	* simplify.c (gfc_simplify_gamma,gfc_simplify_lgamma): New functions.
+	* iresolve.c (gfc_resolve_gamma,gfc_resolve_lgamma): New functions.
+	* intrinsic.texi: Add documentation for GAMMA and LGAMMA.
+
+2007-08-26  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/33188
+	* parse.c (parse_derived): Support empty derived type
+	definitions for Fortran 2003.
+
+2007-08-25  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
+
+	* trans-openmp.c (gfc_omp_privatize_by_reference): Constify.
+	* trans.h (gfc_omp_privatize_by_reference): Likewise.
+
+2007-08-24  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/33178
+	* intrinsic.c (gfc_intrinsic_func_interface): Fix initialization
+	expression check.
+
+2007-08-24  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/32972
+	* iresolve.c:  Don't convert array masks.
+
+2007-08-24  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/33139
+	* trans-array.c (gfc_conv_expr_descriptor): Copy bounds for
+	whole-array pointer assignments.
+
+2007-08-23  Jakub Jelinek  <jakub@redhat.com>
+
+	* decl.c (variable_decl): Don't share charlen structs if
+	length == NULL.
+	* trans-decl.c (create_function_arglist): Assert
+	f->sym->ts.cl->backend_decl is NULL instead of unsharing
+	charlen struct here.
+
+2007-08-23  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/33095
+	* trans-intrinsic.c (gfc_conv_intrinsic_minmax): Remove
+	runtime error checking.
+
+2007-08-22  Roger Sayle  <roger@eyesopen.com>
+	    Tobias Schlüter <tobias.schlueter@physik.uni-muenchen.de>
+
+	* match.c (intrinsic_operators): Delete.
+	(gfc_match_intrinsic_op): Rewrite matcher to avoid calling
+	gfc_match_strings.
+
+2007-08-22  Christopher D. Rickett  <crickett@lanl.gov>
+
+	PR fortran/33020
+	* resolve.c (gfc_iso_c_sub_interface): Remove setting of type and
+	kind for optional SHAPE parameter of C_F_POINTER.
+
+2007-08-22  Janus Weil  <jaydub66@gmail.com>
+
+	* decl.c (match_attr_spec): Pass on errors from gfc_match_bind_c.
+	(gfc_match_bind_c): Bugfix in check for NAME= with abstract interfaces.
+	(gfc_match_mopdproc): Bugfix to reject module procedures in
+	abstract interfaces.
+
+2007-08-22  Kai Tietz  <kai.tietz@onevision.com>
+
+	* f95-lang.c: (gfc_init_decl_processing): Choose sizetype by using
+	Pmode.
+
+2007-08-21  Paul Brook  <paul@codesourcery.com>
+	    Nathan Sidwell  <nathan@codesourcery.com>
+	    Mark Mitchell  <mark@codesourcery.com>
+	    Joseph Myers  <joseph@codesourcery.com>
+
+	* gfortranspec.c (lang_specific_driver): Use pkgversion_string.
+	* Make-lang.in (gfortran.pod): Define BUGURL.
+	* invoke.texi: Use BUGURL for bug-reporting instructions.
+
+2007-08-19  Roger Sayle  <roger@eyesopen.com>
+
+	* match.c (intrinsic_operators): Make static.
+	(gfc_op2string): New function for converting a gfc_intrinsic_op to
+	to a "const char*", replacing the macro of the same name.
+	* gfortran.h (intrinsic_operators): Delete prototype.
+	(gfc_op2string): Replace macro with function prototype.
+
+2007-08-18  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.h (gfc_is_intrinsic_typename): Add declaration.
+	* symbol.c (gfc_is_intrinsic_typename): New function.
+	* parse.c (decode_statement): Check for space in ABSTRACT INTERFACE.
+	(parse_interface): Use gfc_is_intrinsic_typename.
+	* decl.c (gfc_match_derived_decl): Ditto.
+	* module.c (gfc_match_use): Use gcc_unreachable() for
+	INTERFACE_ABSTRACT in switch().
+
+2007-08-18  Roger Sayle  <roger@eyesopen.com>
+
+	* primary.c (match_logical_constant_string): New function to match
+	a ".true." or a ".false.".
+	(match_logical_constant): Use it instead of gfc_match_strings.
+
+2007-08-18  Paul Thomas  <pault@gcc.gnu.org>
+	    Janus Weil  <jaydub66@gmail.com>
+
+	* interface.c (gfc_match_interface,gfc_match_abstract_interface,
+	gfc_match_end_interface,gfc_add_interface): Add abstract interface.
+	* dump-parse-tree.c (gfc_show_attr): Ditto.
+	* gfortran.h (interface_type,symbol_attribute): Ditto.
+	* module.c (gfc_match_use,ab_attribute,attr_bits,
+	mio_symbol_attribute): Ditto.
+	* resolve.c (resolve_function): Ditto.
+	* match.h: Ditto.
+	* parse.c (decode_statement): Ditto.
+	(parse_interface): Ditto, check for C1203 (name of abstract interface
+	cannot be the same as an intrinsic type).
+	* decl.c (gfc_match_bind_c): Check for NAME= with abstract interfaces.
+	(access_attr_decl): Handle Abstract interfaces.
+
+2007-08-18  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/32881
+	* expr.c (gfc_check_pointer_assign): If the rhs is the
+	initialization expression for the rhs, there is no error.
+
+2007-08-18  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/32875
+	* trans-array.c	(get_array_ctor_strlen): Set the character
+	length of a zero length array to zero.
+
+2007-08-16  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/33072
+	* module.c (gfc_match_use): Mark user operators as such.
+	(find_use_name_n): Distinguish between operators and other symbols.
+	(find_use_name,number_use_names,mio_namelist,
+	 load_operator_interfaces,load_generic_interfaces,read_module,
+	 write_generic): Update find_use_name_n calls.
+
+2007-08-15  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/29459
+	* trans.c (gfc_create_var_np): Do not emit warnings for
+	anonymous variables.
+
+2007-08-15  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/33066
+	* decl.c (gfc_get_type_attr_spec): Fix whitespace.
+	(gfc_match_derived_decl): Fix logic.
+
+2007-08-14  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/33073
+	* trans-intrinsic.c (build_fixbound_expr): Convert to result type
+	in all cases.
+
+2007-08-14  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/32594
+	* trans-expr.c (gfc_conv_substring_expr): Only call
+	gfc_conv_substring if expr->ref is not NULL.
+	* expr.c (gfc_is_constant_expr): If e->ref is NULL, the substring
+	expression might be a constant.
+	(gfc_simplify_expr): Handle missing start and end, as well as
+	missing ref.
+
+2007-08-13  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/32926
+	* match.c (gfc_match_call): Do not create a new symtree in the
+	case where the existing symbol is external and not referenced.
+
+2007-08-13  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/32827
+	* decl.c (variable_decl): Check for an imported symbol
+	by looking for its symtree and testing for the imported
+	attribute.
+	(gfc_match_import): Remove change of symbol's namespace
+	and set the attribute imported instead.
+	* symbol.c (gfc_get_sym_tree): It is not an error if a
+	symbol is imported.
+	* gfortran.h : Add the 'imported' to symbol_attribute.
+
+2007-08-13  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/32962
+	* trans-array.c (gfc_conv_array_transpose): Set the offset
+	of the destination to zero if the loop is zero based.
+
+2007-08-12  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/29600
+	* intrinsic.c (add_functions): Add optional KIND argument to ACHAR.
+	* iresolve.c (gfc_resolve_achar): Handle the KIND argument.
+	* check.c (gfc_check_achar): Check for the optional KIND argument.
+	* simplify.c (gfc_simplify_achar): Use KIND argument.
+	* intrinsic.h (gfc_check_achar, gfc_simplify_achar,
+	gfc_resolve_achar): Adjust prototypes.
+
+2007-08-12  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/30964
+	PR fortran/33054
+	* trans-expr.c (gfc_conv_function_call): When no formal argument
+	list is available, we still substitute missing optional arguments.
+	* check.c (gfc_check_random_seed): Correct the check on the
+	number of arguments to RANDOM_SEED.
+	* intrinsic.c (add_subroutines): Add a resolution function to
+	RANDOM_SEED.
+	* iresolve.c (gfc_resolve_random_seed): New function.
+	* intrinsic.h (gfc_resolve_random_seed): New prototype.
+
+2007-08-12  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/32860
+	* error.c (error_uinteger): New function.
+	(error_integer): Call error_uinteger.
+	(error_print): Handle %u, %lu, %li and %ld format specifiers.
+	* interface.c (compare_actual_formal): Use the new %lu specifier.
+
+2007-08-12  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/31629
+	* lang.opt (-fmodule-private): New option.
+	* gfortran.h (gfc_option_t): Add flag_module_private member.
+	* invoke.texi (-fmodule-private): Document the new option.
+	* module.c (gfc_check_access): Allow the -fmodule-private option
+	to modify the default behaviour.
+	* options.c (gfc_init_options): Initialize flag_module_private.
+	(gfc_handle_option): Handle -fmodule-private.
+
+2007-08-12  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/29600
+	* intrinsic.c (add_functions): Add KIND arguments to COUNT,
+	IACHAR, ICHAR, INDEX, LBOUND, LEN, LEN_TRIM, SCAN, SIZE, UBOUND
+	and VERIFY.
+	* iresolve.c (gfc_resolve_count): Add kind argument.
+	(gfc_resolve_iachar): New function.
+	(gfc_resolve_ichar): Add kind argument.
+	(gfc_resolve_index_func): Likewise.
+	(gfc_resolve_lbound): Likewise.
+	(gfc_resolve_len): Likewise.
+	(gfc_resolve_len_trim): Likewise.
+	(gfc_resolve_scan): Likewise.
+	(gfc_resolve_size): New function.
+	(gfc_resolve_ubound): Add kind argument.
+	(gfc_resolve_verify): Likewise.
+	* trans-decl.c (gfc_get_extern_function_decl): Allow specific
+	intrinsics to have 4 arguments.
+	* check.c (gfc_check_count): Add kind argument.
+	(gfc_check_ichar_iachar): Likewise.
+	(gfc_check_index): Likewise.
+	(gfc_check_lbound): Likewise.
+	(gfc_check_len_lentrim): New function.
+	(gfc_check_scan): Add kind argument.
+	(gfc_check_size): Likewise.
+	(gfc_check_ubound): Likewise.
+	(gfc_check_verify): Likewise.
+	* intrinsic.texi: Update documentation for COUNT, IACHAR, ICHAR,
+	INDEX, LBOUND, LEN, LEN_TRIM, SCAN, SIZE, UBOUND and VERIFY.
+	* simplify.c (get_kind): Whitespace fix.
+	(int_expr_with_kind): New function.
+	(gfc_simplify_iachar): Add kind argument.
+	(gfc_simplify_iachar): Likewise.
+	(gfc_simplify_ichar): Likewise.
+	(gfc_simplify_index): Likewise.
+	(simplify_bound_dim): Likewise.
+	(simplify_bound): Likewise.
+	(gfc_simplify_lbound): Likewise.
+	(gfc_simplify_len): Likewise.
+	(gfc_simplify_len_trim): Likewise.
+	(gfc_simplify_scan): Likewise.
+	(gfc_simplify_shape): Pass NULL as kind argument to gfc_simplify_size.
+	(gfc_simplify_size): Add kind argument.
+	(gfc_simplify_ubound): Likewise.
+	(gfc_simplify_verify): Likewise.
+	* intrinsic.h: Update prototypes and add new ones.
+	* trans-intrinsic.c (gfc_conv_intrinsic_index): Rename into
+	gfc_conv_intrinsic_index_scan_verify.
+	(gfc_conv_intrinsic_scan, gfc_conv_intrinsic_verify): Remove.
+	(gfc_conv_intrinsic_function): Call
+	gfc_conv_intrinsic_index_scan_verify to translate the INDEX,
+	SCAN and VERIFY intrinsics.
+
+2007-08-11  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/31189
+	* invoke.texi (-fbacktrace): Document the new behaviour.
+
+2007-08-11  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/32937
+	* trans-array.c (gfc_conv_expr_descriptor): Use
+	gfc_conv_const_charlen to generate backend_decl of right type.
+	* trans-expr.c (gfc_conv_expr_op): Use correct return type.
+	(gfc_build_compare_string): Use int type instead of default
+	integer kind for single character comparison.
+	(gfc_conv_aliased_arg): Give backend_decl the right type.
+	* trans-decl.c (gfc_build_intrinsic_function_decls): Make
+	compare_string return an int.
+
+2007-08-11  Ian Lance Taylor  <iant@google.com>
+
+	* f95-lang.c (gfc_get_alias_set): Change return type to
+	alias_set_type.
+
+2007-08-10  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/31270
+	* trans.c (gfc_trans_runtime_check): Reorder arguments and
+	add extra variable arguments. Hand them to the library function.
+	* trans.h (gfc_trans_runtime_check): Update prototype.
+	* trans-array.c (gfc_trans_array_bound_check): Issue more
+	detailled error messages.
+	(gfc_conv_array_ref): Likewise.
+	(gfc_conv_ss_startstride): Likewise.
+	(gfc_trans_dummy_array_bias): Reorder arguments to
+	gfc_trans_runtime_check.
+	* trans-expr.c (gfc_conv_substring): Issue more detailled
+	error messages.
+	(gfc_conv_function_call): Reorder arguments to gfc_trans_runtime_check.
+	* trans-stmt.c (gfc_trans_goto): Likewise.
+	* trans-io.c (set_string): Reorder arguments to
+	gfc_trans_runtime_check and issue a more detailled error message.
+	* trans-decl.c (gfc_build_builtin_function_decls): Make
+	runtime_error and runtime_error_at handle a variable number of
+	arguments.
+	* trans-intrinsic.c (gfc_conv_intrinsic_bound): Reorder arguments
+	to gfc_trans_runtime_check.
+	(gfc_conv_intrinsic_minmax): Likewise.
+	(gfc_conv_intrinsic_repeat): Issue more detailled error messages.
+
+2007-08-10  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
+
+	* gfortranspec.c (lang_specific_driver): Use CONST_CAST.
+	* options.c (gfc_post_options): Likewise.
+	* parse.c (parse_omp_structured_block): Likewise.
+	* st.c (gfc_free_statement): Likewise.
+
+2007-08-10  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/32933
+	* trans-decl.c (gfc_build_builtin_function_decls): Change
+	prototype for associated.
+	* trans-intrinsic.c (gfc_conv_intrinsic_minmax): Convert the
+	result of __builtin_isnan into a boolean.
+	(gfc_conv_intrinsic_strcmp): Cleanup.
+	(gfc_conv_associated): Convert the result of the associated
+	function into a boolean.
+
+2007-08-09  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/32987
+	* io.c (format_token): Add FMT_ERROR.
+	(next_char_not_space): Print error/warning when
+	'\t' are used in format specifications.
+	(format_lex): Propagate error.
+	(check_format): Ditto.
+
+2007-08-09  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/33001
+	* arith.c (arith_error): Point in the error message
+	to -fno-range-check.
+
+2007-08-09  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/32902
+	* intrinsic.texi (SIZEOF): Add mention to C_SIZE_T.
+
+2007-08-06  Christopher D. Rickett  <crickett@lanl.gov>
+
+	PR fortran/32732
+	* trans-expr.c (gfc_conv_scalar_char_value): Convert the tree and
+	actual arg expressions for scalar characters passed by-value to
+	bind(c) routines.
+	(gfc_conv_function_call): Call gfc_conv_scalar_char_value.
+	* trans.h: Add prototype for gfc_conv_scalar_char_value.
+	* trans-decl.c (generate_local_decl): Convert by-value character
+	dummy args of bind(c) procedures using
+	gfc_conv_scalar_char_value.
+
+2007-08-06  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/30947
+	* iresolve.c (gfc_resolve_alarm_sub): Suffix the subroutine name
+	with the kind of the STATUS argument.
+
+2007-08-06  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/30948
+	* intrinsic.c (add_functions): Fix name of argument to CHDIR.
+
+2007-08-06  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/30933
+	* iresolve.c (gfc_resolve_exit): Convert argument to default
+	integer kind.
+
+2007-08-06  Daniel Franke  <franke.daniel@gmail.com>
+
+	* resolve.c (derived_pointer): Removed, replaced callers by access 
+	to appropiate attribute bit.
+	(derived_inaccessable): Shortcut recursion depth.
+	(resolve_fl_namelist): Fixed checks for private components in namelists.
+
+2007-08-06  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/29828
+	* trans.h (gfor_fndecl_string_minmax): New prototype.
+	* trans-decl.c (gfor_fndecl_string_minmax): New variable.
+	(gfc_build_intrinsic_function_decls): Create gfor_fndecl_string_minmax.
+	* check.c (gfc_check_min_max): Allow for character arguments.
+	* trans-intrinsic.c (gfc_conv_intrinsic_minmax_char): New function.
+	(gfc_conv_intrinsic_function): Add special case for MIN and MAX
+	intrinsics with character arguments.
+	* simplify.c (simplify_min_max): Add simplification for character
+	arguments.
+
+2007-08-06  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/31612
+	* invoke.texi: Adjust documentation for option -fsyntax-only.
+
+2007-08-05  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+	    Tobias Burnus  <burnus@gcc.gnu.org>
+
+	PR fortran/32979
+	* intrinsic.h (gfc_check_isnan): Add prototype.
+	* gfortran.h (gfc_isym_id): Add GFC_ISYM_ISNAN.
+	* intrinsic.c (add_functions): Add ISNAN intrinsic.
+	* check.c (gfc_check_isnan): New function.
+	* trans-intrinsic.c (gfc_conv_intrinsic_isnan): New function.
+	(gfc_conv_intrinsic_function): Call gfc_conv_intrinsic_isnan
+	to translate ISNAN.
+	* intrinsic.texi: Document ISNAN.
+
+2007-08-04  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31214
+	* symbol.c (get_unique_symtree): Moved from module.c.
+	* module.c (get_unique_symtree): Moved to symbol.c.
+	* decl.c (get_proc_name): Transfer the typespec from the local
+	symbol to the module symbol, in the case that an entry is also
+	a module procedure.  Ensure the local symbol is cleaned up by
+	pointing to it with a unique symtree.
+
+	* dump_parse_tree (gfc_show_code_node): Add EXEC_ASSIGN_CALL.
+
+2007-08-04  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/32969
+	* iresolve.c (gfc_resolve_rrspacing): Convert argument(s) to
+	expected KIND.
+	(gfc_resolve_scale): Ditto.
+	(gfc_resolve_set_exponent): Ditto.
+	(gfc_resolve_spacing): Ditto.
+ 
+	PR fortran/32968
+	* trans-intrinsic.c (gfc_conv_intrinsic_si_kind,
+	gfc_conv_intrinsic_sr_kind): Convert the argument(s) to the
+	expected KIND, and fold the result to the expected KIND.
+
+2007-08-03  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/31202
+	* f95-lang.c (gfc_init_builtin_functions): Defin builtins for 
+	lround{f,,l} and llround{f,,l}.
+	* trans-intrinsic.c (build_fix_expr): Generate calls to the
+	{l,}round{f,,l} functions.
+
+2007-08-01  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR libfortran/32954
+	* intrinsic.c (resolve_mask_arg):  New function.
+	(gfc_resolve_maxloc):  Use resolve_mask_arg for mask resolution.
+	(gfc_resolve_maxval):  Likewise.
+	(gfc_resolve_minloc):  Likewise.
+	(gfc_resolve_minval):  Likewise.
+	(gfc_resolve_pack):  Likewise.
+	(gfc_resolve_product):  Likewise.
+	(gfc_resolve_sum):  Likewise.
+	(gfc_resolve_unpack):  Likewise.
+
+2007-08-01  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/32936
+	* match.c (gfc_match_allocate): Better check that STAT is
+	a variable.
+
+	* check.c (gfc_check_allocated): Reorder checks to improve
+	error message.
+
+2007-08-01  Nick Clifton  <nickc@redhat.com>
+
+	* arith.c: Change copyright header to refer to version 3 of the
+	GNU General Public License and to point readers at the COPYING3
+	file and the FSF's license web page.
+	* openmp.c, interface.c, intrinsic.c, trans-array.c, trans-expr.c,
+	symbol.c, iso-fortran-env.def, intrinsic.h, decl.c, trans-array.h,
+	matchexp.c, dump-parse-tree.c, trans-common.c, array.c,
+	Make-lang.in, trans-openmp.c, gfortran.h, error.c,
+	iso-c-binding.def, lang.opt, data.c, trans-const.c, trans-stmt.c,
+	expr.c, trans-const.h, trans-stmt.h, module.c, trans.c, scanner.c,
+	trans-types.c, trans.h, gfortranspec.c, trans-types.h,
+	lang-specs.h, io.c, bbt.c, resolve.c, f95-lang.c, st.c,
+	iresolve.c, match.c, trans-decl.c, trans-io.c, target-memory.c,
+	match.h, target-memory.h, parse.c, arith.h, check.c, dependency.c,
+	parse.h, types.def, convert.c, dependency.h, primary.c,
+	trans-intrinsic.c, options.c, misc.c, simplify.c: Likewise.
+
+2007-08-01  Daniel Franke  <franke.daniel@gmail.com>
+
+	* trans-decl.c (generate_local_decl): Emit warning on unused parameter
+	on "-Wall -Wextra" or "-Wunused-parameter" but not on "-Wall", changed
+	messages that start with lower case to upper case.
+	* invoke.texi (-Wparameter-unused): Document differences between gcc
+	and gfortran regarding this option.
+
+2007-08-01  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/32945
+	* expr.c (check_specification_function): Skip check if no symtree 
+	is available.
+
+2007-08-01  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31609
+	* resolve.c (resolve_entries): Entries declared to be module
+	procedures must point to the function namespace.
+
+2007-07-31  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/32938
+	* trans-stmt.c (gfc_trans_return): Convert to correct type.
+
+2007-07-31  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/32942
+	* trans-intrinsic.c (gfc_conv_intrinsic_exponent): Convert to correct
+	type.
+
+2007-07-29  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	* invoke.texi: Document -fsign-zero flag.
+
+2007-07-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31211
+	* trans-expr.c (gfc_conv_expr_reference): Add block for case of
+	scalar pointer functions so that NULL result is correctly
+	handled.
+
+	PR fortran/32682
+	* trans-array.c (gfc_trans_array_constructor): On detecting a
+	multi-dimensional parameter array, set the loop limits.
+
+2007-07-29  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/32906
+	* resolve.c (resolve_fl_parameter): Check for constant shape arrays,
+	adjusted error message.
+
+2007-07-29  Daniel Franke  <franke.daniel@gmail.com>
+
+	* invoke.texi: Removed -w from option summary.
+
+2007-07-29  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/32879
+	* intrinsic.texi (IRAND, RAND, RANDOM_NUMBER): Document algorithm
+	used for random number generator.
+
+2007-07-28  Kazu Hirata  <kazu@codesourcery.com>
+
+	* gfortran.h, interface.c, resolve.c, symbol.c: Fix comment
+	typos.
+	* intrinsic.texi, invoke.texi: Fix typos.
+
+2007-07-28  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/31609
+	* resolve.c (generic_sym): Check for a same symbol and if so, return to
+	avoid infinite recursion.
+
+2007-07-28  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/31818
+	PR fortran/32876
+	PR fortran/32905
+	* gfortran.h (symbol_attribute): Added bits for pointer_comp, 
+	private_comp.
+	* parse.c (parse_derived): Set pointer_comp/private_comp bits if 
+	the derived type ultimately contains pointer components or private 
+	components.
+	* module.c (ab_attribute): New values AB_POINTER_COMP, AB_PRIVATE_COMP.
+	(attr_bits): Added names for new ab_attributes.
+	(mio_symbol_attribute): Save/restore new attribute bits in modules.
+	* match.c (gfc_match_namelist): Removed check for namelist objects
+	of assumed shape.
+	* resolve.c (resolve_fl_namelist): Added check for pointer or
+	private components in nested types. Added check for namelist objects
+	of assumed shape.
+
+2007-07-28  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/32880
+	* trans-expr.c (gfc_trans_scalar_assign): Revert to fixed order
+	for lse and rse pre expressions, for derived types with
+	allocatable components.  Instead, assign the lhs to a temporary
+	and deallocate after the assignment.
+
+2007-07-28  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	PR fortran/32909
+	* trans-stmt.c (gfc_trans_character_select): Replace occurrences
+	of gfc_c_int_type_node with integer_type_node.
+	* trans-decl.c (gfc_build_intrinsic_function_decls): Likewise.
+	(gfc_build_builtin_function_decls): Likewise.
+	(gfc_generate_function_code): Likewise.
+	* trans-io.c (gfc_build_io_library_fndecls): Likewise.
+
+2007-07-27  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	* trans-decl.c (gfc_build_builtin_function_decls): Use existing
+	gfc_array_index_type rather than creating another typenode for
+	gfc_index_integer_kind.
+
+2007-07-27  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	* trans-io.c (gfc_build_io_library_fndecls): Change to use
+	gfc_array_index_type for array descriptor triplets instead of
+	gfc_int4_type_node.
+
+2007-07-26  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/32899
+	* resolve.c (resolve_operator): Add INTRINSIC_EQ_OS comparison.
+
+2007-07-27  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+	    Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/32760
+	* primary.c (match_variable): Do not call gfc_add_flavor if symbol has
+	attribute of ACCESS_PUBLIC or ACCESS_PRIVATE already marked.
+
+2007-07-27  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/32035
+	* trans-stmt.c (gfc_trans_character_select): Replace the
+	mechanism with labels by a SWITCH_EXPR.
+	* trans-decl.c (gfc_build_builtin_function_decls): Change
+	return type for select_string.
+
+2007-07-27  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/32903
+	* trans-decl.c (gfc_trans_deferred_vars): Set intent(out)
+	derived types as referenced, if they have the the default
+	initializer set.
+
+2007-07-25  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
+
+	* gfortran.h (generate_isocbinding_symbol): Constify.
+	* symbol.c (gen_special_c_interop_ptr, gen_cptr_param,
+	generate_isocbinding_symbol): Likewise.
+
+2007-07-24  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31205
+	PR fortran/32842
+	* trans-expr.c (gfc_conv_function_call): Remove the default
+	initialization of intent(out) derived types.
+	* symbol.c (gfc_lval_expr_from_sym): New function.
+	* matchexp.c (gfc_get_parentheses): Return argument, if it is
+	character and posseses a ref.
+	* gfortran.h : Add prototype for gfc_lval_expr_from_sym.
+	* resolve.c (has_default_initializer): Move higher up in file.
+	(resolve_code): On detecting an interface assignment, check
+	if the rhs and the lhs are the same symbol.  If this is so,
+	enclose the rhs in parenetheses to generate a temporary and
+	prevent any possible aliasing.
+	(apply_default_init): Remove code making the lval and call
+	gfc_lval_expr_from_sym instead.
+	(resolve_operator): Give a parentheses expression a type-
+	spec if it has no type.
+	* trans-decl.c (gfc_trans_deferred_vars): Apply the a default
+	initializer, if any, to an intent(out) derived type, using
+	gfc_lval_expr_from_sym and gfc_trans_assignment.  Check if
+	the dummy is present.
+
+2007-07-24  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/32867
+	* expr.c (check_init_expr): Simplify matched functions.
+
+2007-07-24  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/32778
+	* intrinsic.c (add_sym): Do not exclude any symbols, even if not part
+	of the selected standard.
+	(make generic): Likewise.
+	(make alias): Likewise, set standard the alias belongs to.
+	(add_subroutines): Call make_noreturn unconditionally.
+	(check_intrinsic_standard): Change return value to try.
+	(gfc_intrinsic_func_interface): Check return value of above function.
+	(gfc_intrinsic_sub_interface): Likewise.
+
+2007-07-24  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/30814
+	* trans-decl.c (generate_function_code):  Add argument
+	for flag_bounds_check to the array for set_options.
+	* invoke.texi (-fbounds-check): Document new libarary run-time
+	behaviour.
+
+2007-07-23  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/25104
+	PR fortran/31639
+	* expr.c (check_transformational): Reject valid transformational
+	intrinsics to avoid ICE.
+	(check_inquiry): Report error for assumed character lengths for
+	all supported standards.
+	(check_init_expr): Whitespace fix.
+
+2007-07-23  Christopher D. Rickett  <crickett@lanl.gov>
+
+	PR fortran/32797
+	PR fortran/32800
+	* decl.c (verify_bind_c_sym): Use the result symbol for functions
+	with a result clause.  Warn if implicitly typed.  Verify the type
+	and rank of the SHAPE argument, if given.
+	* resolve.c (gfc_iso_c_sub_interface): Use gfc_procedure_use to
+	check the actual args against the formal, sorting them if
+	necessary.
+	* symbol.c (gen_shape_param): Initialize type of SHAPE param to
+	BT_VOID.
+
+2007-07-23  Christopher D. Rickett  <crickett@lanl.gov>
+
+	PR fortran/32732
+	* trans-decl.c (generate_local_decl): Convert the TREE_TYPE for by
+	value character dummy args of BIND(C) procedures.
+	* trans-expr.c (gfc_conv_variable): Do not build address
+	expression for BT_CHARACTER dummy args.
+
+2007-07-23  Christopher D. Rickett  <crickett@lanl.gov>
+	    Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/32600
+	* trans-expr.c (gfc_conv_function_call): Handle c_funloc.
+	* trans-types.c: Add pfunc_type_node.
+	(gfc_init_types,gfc_typenode_for_spec): Use it.
+	* resolve.c (gfc_iso_c_func_interface): Fix whitespace and
+	improve error message.
+
+2007-07-22  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/32710
+	* parse.c (gfc_fixup_sibling_symbols): No replacement of symbols if
+	the current is a namelist.
+
+2007-07-22  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/29962
+	PR fortran/31253
+	PR fortran/31265
+	PR fortran/31639
+	* gfortran.h (gfc_intrinsic_sym): Changed members elemental, pure,
+	generic, specific, actual_ok, noreturn into bits of a bitfield, 
+	added bits for inquiry, transformational, conversion.
+	* check.c (non_init_transformational): Removed, removed all callers.
+	* intrinsic.c (enum class): New.
+	(add_sym*): Replaced argument elemetal by enum class. Changed all
+	callers.
+	(add_functions): Assign appropriate classes to intrinsic functions.
+	(add_subroutines): Assign appropriate classes to intrinsic subroutines.
+	(add_conv): Set conversion attribute.
+	(gfc_init_expr_extensions): Removed, removed all callers.
+	(gfc_intrinsic_func_interface): Reimplemented check for non-standard
+	initializatione expressions.
+	* expr.c (check_specification_function): New.
+	(gfc_is_constant_expr): Added check for specification functions.
+	(check_init_expr_arguments): New.
+	(check_inquiry): Changed return value to MATCH, added checks for
+	inquiry functions defined by F2003.
+	(check_transformational): New.
+	(check_null): New.
+	(check_elemental): New.
+	(check_conversion): New.
+	(check_init_expr): Call new check functions, add more specific error
+	messages.
+
+2007-07-21  Christopher D. Rickett  <crickett@lanl.gov>
+
+	PR fortran/32627
+	* resolve.c (set_name_and_label): Set kind number for character
+	version of c_f_pointer.
+	(gfc_iso_c_sub_interface): Set the kind of the SHAPE formal arg to
+	that of the actual SHAPE arg.
+	* symbol.c (gen_shape_param): Initialize kind for SHAPE arg.
+
+2007-07-21  Christopher D. Rickett  <crickett@lanl.gov>
+
+	PR fortran/32801
+	* symbol.c (generate_isocbinding_symbol): Remove unnecessary
+	conditional.
+
+	PR fortran/32804
+	* resolve.c (gfc_iso_c_func_interface): Reject assumed-shape and
+	deferred-shape arrays as args to C_LOC.  Fix bug in testing
+	character args to C_LOC.
+
+2007-07-21  Lee Millward  <lee.millward@gmail.com>
+
+	PR fortran/32823
+	* trans-intrinsic.c (gfc_conv_intrinsic_int): Evaluate all
+	arguments passed, not just the first one. Adjust code to 
+	refer to "args[0]" instead of "arg" as a result.
+	
+2007-07-19  Christopher D. Rickett  <crickett@lanl.gov>
+
+	PR fortran/32600
+	* trans-expr.c (gfc_conv_function_call): Inline C_LOC.
+
+2007-07-18  Christopher D. Rickett  <crickett@lanl.gov>
+
+	PR fortran/32801
+	* symbol.c (generate_isocbinding_symbol): Fix bug where
+	ISOCBINDING_FUNPTR was generated for C_LOC instead of the needed
+	ISOCBINDING_PTR.
+
+2007-07-17  Janus Weil  <jaydub66@gmail.com> 
+
+	PR fortran/32535
+	* resolve.c (resolve_fl_namelist): Check for namelist private 
+	components in contained subprograms.
+
+2007-07-17  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31320
+	PR fortran/32665
+	* trans-expr.c (gfc_trans_subcomponent_assign): Ensure that
+	renormalization unity base is done independently of existing
+	lbound value.
+	(gfc_trans_scalar_assign): If rhs is not a variable, put
+	lse->pre after rse->pre to ensure that de-allocation of lhs
+	occurs after evaluation of rhs.
+
+2007-07-16  Lee Millward  <lee.millward@gmail.com>
+
+	PR fortran/32222
+	PR fortran/32238
+	PR fortran/32242	
+	* trans-intrinsic.c (gfc_conv_intrinsic_function_args): Adjust
+	to operate on a stack allocated array for the intrinsic arguments
+	instead of creating a TREE_LIST. Add two new parameters for the
+	array and the number of elements. Update all callers to allocate
+	an array of the correct length to pass in. Update comment.
+	(gfc_intrinsic_argument_list_length): New function.
+	(gfc_conv_intrinsic_conversion): Call it.
+	(gfc_conv_intrinsic_mnimax): Likewise.
+	(gfc_conv_intrinsic_merge): Likewise.
+	(gfc_conv_intrinsic_lib_function): Call it. Use new CALL_EXPR
+	constructors.
+	(gfc_conv_intrinsic_cmplx): Likewise.
+	(gfc_conv_intrinsic_ctime): Likewise.
+	(gfc_covn_intrinsic_fdate): Likewise.
+	(gfc_conv_intrinsic_ttynam): Likewise.
+	(gfc_conv_intrinsic_ishftc): Likewise.
+	(gfc_conv_intrinsic_index): Likewise.
+	(gfc_conv_intrinsic_scan): Likewise.
+	(gfc_conv_intrinsic_verify): Likewise.
+	(gfc_conv_intrinsic_trim): Likewise.
+	(gfc_conv_intrinsic_aint): Use new CALL_EXPR constructors.
+	(gfc_conv_intrinsic_exponent): Likewise.
+	(gfc_conv_intrinsic_bound): Likewise.
+	(gfc_conv_intrinsic_abs): Likewise.
+	(gfc_conv_intrinsic_mod): Likewise.
+	(gfc_conv_intrinsic_sign): Likewise.
+	(gfc_conv_intrinsic_len): Likewise.
+	(gfc_conv_intrinsic_adjust): Likewise.
+	(gfc_conv_intrinsic_si_kind): Likewise. 
+	
+2007-07-16  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	PR fortran/32748
+	* trans-decl.c (gfc_build_builtin_function_decls): Remove
+	DECL_IS_MALLOC attribute from internal_realloc, thus reverting
+	part of my 2007-07-03 patch.
+
+2007-07-15  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+	    Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/32611
+	* gfortran.h (gfc_option_t): Add flag_sign_zero field.
+	* lang.opt (-fsign-zero): New option.
+	* trans.h: Rename gfor_fndecl_set_std into gfor_fndecl_set_options.
+	* trans-decl.c (gfc_build_builtin_function_decls): Build the function
+	declaration to pass an array containing the options to be used by the
+	runtime library. (gfc_generate_function_code): Build an array that
+	contains option values to be passed to the runtime library and the call
+	to the function. 
+	* options.c (gfc_init_options): Initialize the flag_sign_zero field.
+	(gfc_handle_option): Handle the -fsign-zero option.
+
+2007-07-15  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/32036
+	* trans-array.c (gfc_conv_array_ref): Only evaluate index once.
+
+2007-07-15  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/32357
+	* iresolve.c (gfc_resolve_mvbits): Convert FROMPOS, LEN and TOPOS
+	to C int.
+
+2007-07-14  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR libfortran/32731
+	* iresolve.c(gfc_resolve_pack):  A scalar mask has
+	to be kind=4, an array mask with kind<4 is converted
+	to gfc_default_logical_kind automatically.
+	(gfc_resolve_unpack):  Convert mask to gfc_default_lotical_kind
+	if it has a kind<4.
+
+2007-07-14  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/32724
+	* parse.c (parse_spec): Emit error on unexpected statement
+	function.
+
+2007-07-13  Daniel Franke  <franke.daniel@gmail.com>
+
+	* invoke.texi: Unified upper- and lower-case in menus.
+	(-w, -W): Removed, documented by gcc.
+	* intrinsic.texi: Unified Class-section entries, added
+	subroutine/function warning where appropiate.
+
+2007-07-12  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/31639
+	* decl.c (gfc_match_suffix): Removed surplus general error that hides
+	a more specific message.
+	* resolve.c (resolve_fl_variable): Reject illegal initializiers only
+	if not already done.
+	(resolve_fl_procedure): Added check for initializers of functions.
+
+2007-07-12  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/32704
+	* invoke.texi (-static-libgfortran): Document new option.
+
+2007-07-12  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/32634
+	PR fortran/32727
+	* module.c (write_generic): Restore patch of 2007-07-10 and use
+	symbol name if there are no use names. 
+
+2007-07-12  Christopher D. Rickett  <crickett@lanl.gov>
+
+	PR fortran/32599
+	* decl.c (verify_c_interop_param): Require character string dummy
+	args to BIND(C) procedures to have length 1.
+	* resolve.c (resolve_fl_procedure): Modify parameter checking for
+	BIND(C) procedures.
+
+	PR fortran/32601
+	* resolve.c (gfc_iso_c_func_interface): Verify that a valid
+	expression is given as an argument to C_LOC and C_ASSOCIATED.
+	* trans-io.c (transfer_expr): Add argument for code block.  Add
+	standards check to determine if an error message should be
+	reported for printing C_PTR or C_FUNPTR.
+	(transfer_array_component): Update arguments to transfer_expr.
+	(gfc_trans_transfer): Ditto.
+
+	* symbol.c (gen_cptr_param): Fix whitespace.
+
+2007-07-12  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/32550
+	* trans.h (GFC_POINTER_TYPE_P): Define.
+	* trans-types.c (gfc_sym_type): Set it for types on attr->sym.pointer.
+	* trans-openmp.c (gfc_omp_privatize_by_reference): Return false
+	if GFC_POINTER_TYPE_P is set on the type.
+
+2007-07-12  Richard Guenther  <rguenther@suse.de>
+
+	* trans-intrinsic.c (gfc_conv_intrinsic_repeat): Convert
+	arguments to gfc_charlen_type_node.
+	* trans-io.c (gfc_convert_array_to_string): Convert type
+	size to gfc_array_index_type.
+
+2007-07-12  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/32634
+	PR fortran/32727
+	* module.c: Reverted Paul's patch from 2007-07-10.
+
+2007-07-11  Richard Guenther  <rguenther@suse.de>
+
+	* trans-array.c (gfc_conv_array_parameter): Use correct
+	types for comparison.
+	* trans-intrinsic.c (gfc_conv_intrinsic_repeat): Use
+	correct types for POINTER_PLUS_EXPR.
+	* trans-stmt.c (gfc_trans_forall_loop): Use correct type
+	for integer one constant.
+
+2007-07-10  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/32157
+	* resolve.c (is_external_proc): New function.  Adds test that
+	the symbol is not an intrinsic procedure.
+	* (resolve_function, resolve_call): Replace logical statements
+	with call to is_external_proc.
+
+	PR fortran/32689
+	* simplify.c (gfc_simplify_transfer): If mold has rank, the
+	result is an array.
+
+	PR fortran/32634
+	* module.c (write_generic): Write the local name of the
+	interface. 
+
+2007-07-09  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/29459
+	* trans-array.c (gfc_trans_array_constructor): Mark offset field
+	with TREE_NO_WARNING.
+	* trans-decl.c (gfc_build_qualified_array): Mark lbound, ubound,
+	stride and size variables with TREE_NO_WARNING.
+
+2007-07-09  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* trans-decl.c (set_tree_decl_type_code): Remove function.
+	(generate_local_decl): Remove reference to set_tree_decl_type_code.
+
+2007-07-09  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/31129
+	* trans-decl.c (generate_local_decl) Emit a warning if an unused
+	parameter is found.
+
+2007-07-08  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/29876
+	* module.c (gfc_match_use): Do not set an non-existant 
+	intrinsic operator if a user-defined operator is found.
+
+2007-07-08  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/24784
+	PR fortran/28004
+	* trans-decl.c (generate_local_decl): Adjusted warning on unused 
+	dummy arguments, tell middle-end not to emit additional warnings.
+
+2007-07-08  Daniel Franke  <franke.daniel@gmail.com>
+	    Tobias Schlüter <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/17711
+	* gfortran.h (gfc_intrinsic_op): Added INTRINSIC_EQ_OS,
+	INTRINSIC_NE_OS, INTRINSIC_GT_OS, INTRINSIC_GE_OS, 
+	INTRINSIC_LT_OS and INTRINSIC_LE_OS.
+	* arith.c (eval_intrinsic, eval_type_intrinsic0): Likewise.
+	* arith.h (gfc_eq, gfc_ne, gfc_gt, gfc_ge, gfc_lt, gfc_le):
+	Added gfc_intrinsic_op as third argument type.
+	* dump-parse-tree.c (gfc_show_expr): Account for new enum values.
+	* expr.c (simplify_intrinsic_op, check_intrinsic_op): Likewise.
+	* interface.c (check_operator_interface): Likewise.
+	(gfc_check_interfaces): Added cross-checks for FORTRAN 77 and 
+	Fortran 90 style operators using new enum values.
+	(gfc_extend_expr): Likewise.
+	(gfc_add_interface): Likewise.
+	* match.c (intrinsic_operators): Distinguish FORTRAN 77 style
+	operators from Fortran 90 style operators using new enum values.
+	* matchexp.c (match_level_4): Account for new enum values.
+	* module.c (mio_expr): Likewise.
+	* resolve.c (resolve_operator): Deal with new enum values, fix
+	inconsistent error messages.
+	* trans-expr.c (gfc_conv_expr_op): Account for new enum values.
+
+2007-07-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/32669
+	* interface.c (get_expr_storage_size): Properly obtain lower bound.
+	(compare_actual_formal): Add space before parenthesis.
+
+2007-07-08  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/25094
+	* resolve.c (resolve_fl_procedure): Added check for PRIVATE types 
+	in PUBLIC interfaces.
+
+2007-07-07  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/32644
+	* decl.c (match_attr_spec): Don't return MATCH_ERROR if comma found and
+	gfc_match_bind_c does not return MATCH_YES.
+
+2007-07-07  Kazu Hirata  <kazu@codesourcery.com>
+
+	* decl.c, gfortran.h, interface.c, module.c, resolve.c,
+	trans-array.c, trans-decl.c: Fix comment typos.  Follow
+	spelling conventions.
+	* intrinsic.texi: Fix typos.  Follow spelling conventions.
+
+2007-05-06  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/32633
+	* symbol.c (save_status): New.
+	* gfortran.h (save_status): Added external declaration.
+	(check_conflict): Check for conflicting explicite SAVE statements
+	only.
+	(gen_special_c_interop_ptr): Use SAVE_EXPLICIT constant.
+	* module.c (ab_attribute, attr_bits): Removed enumerator value 
+	AB_SAVE for save attribute.
+	(mio_symbol_attribute): Import/export the full SAVE status, 
+	removed usage of AB_SAVE.
+	* dump-parse-tree.c (gfc_show_attr): Dump full SAVE status.
+	* decl.c (add_init_expr_to_sym): Set SAVE_IMPLICIT only if not
+	already explicit.
+
+2007-07-05  Daniel Franke  <franke.daniel@gmail.com>
+	    Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/32359
+	* gfortran.h (symbol_attribute): Change save attribute into an enum.
+	* decl.c (add_init_expr_to_sym): Set it to SAVE_IMPLICIT.
+	* symbol.c (gfc_add_save): Check for SAVE_EXPLICIT.
+	* resolve.c (resolve_fl_variable): Check for SAVE_EXPLICIT.
+	(resolve_symbol): Allow OMP threadprivate with
+	initialization SAVEd and save_all variable.
+	* trans-decl.c (gfc_finish_var_decl): Remove obsolete sym->value check.
+
+2007-07-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/32526
+	* match.c (gfc_match_call): Check, in all cases, that a symbol
+	is neither generic nor a subroutine before trying to add it as
+	a subroutine.
+
+	PR fortran/32613
+	* match.c (gfc_match_do): Reset the implied_index attribute.
+
+2007-07-04  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/31198
+	* trans-intrinsic.c (trans-intrinsic.c): Handle optional
+	arguments correctly for MIN and MAX intrinsics.
+
+2007-07-03  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/32545
+	* io.c (check_format): Always call gfc_error for errors.
+	(check_format_string): Change type of this function to try and
+	return the result of check_format.
+	(check_io_constraints): Return MATCH_ERROR if check_format_string
+	returns FAILURE.
+
+2007-07-03  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/32612
+	* decl.c (get_proc_name): Include attr->mod_proc in check for error.
+
+2007-07-03  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/32432
+	* gfortran.h: Change type of gfc_assign_data_value from void to try.
+	* data.c (gfc_assign_data_value): Return FAILURE if error found.
+	* resolve.c (check_data_variable): If gfc_assign_data_value returns
+	failure, break out of loop and return failure.
+
+2007-07-03  Christopher D. Rickett  <crickett@lanl.gov>
+
+	PR fortran/32579
+	* symbol.c (gen_cptr_param): Generate C_PTR and C_FUNPTR if necessary.
+	(build_formal_args): Pass intrinsic module symbol id to
+	gen_cptr_param.
+
+2007-07-03  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/25062
+	* resolve.c (resolve_common_blocks): New check function.
+	(resolve_types): Use it.
+
+2007-07-03  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/30940
+	* interface.c (get_sym_storage_size): New function.
+	(get_sym_storage_size): New function.
+	(compare_actual_formal): Enhance sequence association
+	support and improve checking.
+
+2007-07-03  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	* trans-decl.c (gfc_build_builtin_function_decls): Mark
+	internal_realloc as a malloc function.
+
+2007-07-03  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/20888
+	* resolve.c (resolve_operator): Check for NULL as operand.
+
+2007-07-02  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.texi (Fortran 2003): Add ISO Bind C.
+	* intrinsic.texi (C_ASSOCIATED,C_F_POINTER,C_F_PROCPOINTER,
+	C_FUNLOC,C_LOC): Document new ISO Bind C intrinsics.
+
+2007-07-01  Christopher D. Rickett  <crickett@lanl.gov>
+
+	* interface.c (gfc_compare_derived_types): Special case for comparing
+	derived types across namespaces.
+	(gfc_compare_types): Deal with BT_VOID.
+	(compare_parameter): Use BT_VOID to accept ISO C Binding pointers.
+	* trans-expr.c (gfc_conv_function_call): Remove setting parm_kind
+	to SCALAR
+	(gfc_conv_initializer): Deal with ISO C Binding NULL_PTR and 
+	NULL_FUNPTR.
+	(gfc_conv_expr): Convert expressions for ISO C Binding derived types.
+	* symbol.c (gfc_set_default_type): BIND(C) variables should not be
+	Implicitly declared.
+	(check_conflict): Add BIND(C) and check for conflicts.
+	(gfc_add_explicit_interface): Whitespace.	
+	(gfc_add_is_bind_c): New function.  
+	(gfc_copy_attr): Use it.
+	(gfc_new_symbol): Initialize ISO C Binding objects.
+	(get_iso_c_binding_dt):  New function.
+	(verify_bind_c_derived_type): Ditto.
+	(gen_special_c_interop_ptr): Ditto.
+	(add_formal_arg): Ditto.
+	(gen_cptr_param): Ditto.
+	(gen_fptr_param): Ditto.
+	(gen_shape_param): Ditto.
+	(add_proc_interface): Ditto.
+	(build_formal_args): Ditto.
+	(generate_isocbinding_symbol):  Ditto.
+	(get_iso_c_sym):  Ditto.
+	* decl.c (num_idents_on_line, has_name_equals): New variables.
+	(verify_c_interop_param): New function.
+	(build_sym): Finish binding labels and deal with COMMON blocks.
+	(add_init_expr_to_sym): Check if the initialized expression is
+	an iso_c_binding named constants
+	(variable_decl): Set ISO C Binding type_spec components.
+	(gfc_match_kind_spec): Check match for C interoperable kind.
+	(match_char_spec): Fix comment. Chnage gfc_match_small_int
+	to gfc_match_small_int_expr.  Check for C interoperable kind.
+	(match_type_spec): Clear the current binding label.
+	(match_attr_spec): Add DECL_IS_BIND_C.  If BIND(C) is found, use it
+	to set attributes.
+	(set_binding_label): New function.
+	(set_com_block_bind_c): Ditto.
+	(verify_c_interop): Ditto.
+	(verify_com_block_vars_c_interop): Ditto.
+	(verify_bind_c_sym): Ditto.
+	(set_verify_bind_c_sym): Ditto.
+	(set_verify_bind_c_com_block): Ditto.
+	(get_bind_c_idents): Ditto.
+	(gfc_match_bind_c_stmt): Ditto.
+	(gfc_match_data_decl): Use num_idents_on_line.
+	(match_result): Deal with right paren in BIND(C).
+	(gfc_match_suffix): New function.
+	(gfc_match_function_decl): Use it.  Code is re-arranged to deal with
+	ISO C Binding result clauses.
+	(gfc_match_subroutine):  Deal with BIND(C).
+ 	(gfc_match_bind_c): New function.
+	(gfc_get_type_attr_spec): New function.  Code is re-arranged in and
+	taken from gfc_match_derived_decl.
+	(gfc_match_derived_decl): Add check for BIND(C).
+	* trans-common.c: Forward declare gfc_get_common.
+	(gfc_sym_mangled_common_id): Change arg from 'const char *name' to
+	'gfc_common_head *com'.  Check for ISO C Binding of the common block.
+	(build_common_decl): 'com->name' to 'com in SET_DECL_ASSEMBLER_NAME.
+	* gfortran.h: Add GFC_MAX_BINDING_LABEL_LEN
+	(bt): Add BT_VOID
+	(sym_flavor): Add FL_VOID.
+ 	(iso_fortran_env_symbol, iso_c_binding_symbol, intmod_id): New enum
+	(CInteropKind_t): New struct.
+	(c_interop_kinds_table): Use it.  Declare an array of structs.
+	(symbol_attribute): Add is_bind_c, is_c_interop, and is_iso_c
+	bitfields.
+	(gfc_typespec): Add is_c_interop; is_iso_c, and f90_type members.
+	(gfc_symbol): Add from_intmod, intmod_sym_id, binding_label, and
+	common_block members.
+	(gfc_common_head): Add binding_label and is_bind_c members.
+	(gfc_gsymbol): Add sym_name, mod_name, and binding_label members.
+	Add prototypes for get_c_kind, gfc_validate_c_kind, 
+	gfc_check_any_c_kind, gfc_add_is_bind_c, gfc_add_value,
+	verify_c_interop, verify_c_interop_param, verify_bind_c_sym,
+	verify_bind_c_derived_type, verify_com_block_vars_c_interop,
+	generate_isocbinding_symbol, get_iso_c_sym, gfc_iso_c_sub_interface
+	* iso-c-binding.def: New file. This file contains the definitions
+	of the types provided by the Fortran 2003 ISO_C_BINDING intrinsic
+	module.
+	* trans-const.c (gfc_conv_constant_to_tree): Deal with C_NULL_PTR
+	 or C_NULL_FUNPTR expressions.
+	* expr.c (gfc_copy_expr): Add BT_VOID case.  For BT_CHARACTER, the
+	ISO C Binding requires a minimum string length of 1 for '\0'.  
+	* module.c (intmod_sym): New struct.
+	(pointer_info): Add binding_label member.
+	(write_atom): Set len to 0 for NULL pointers. Check for NULL p and *p.
+	(ab_attribute): Add AB_IS_BIND_C, AB_IS_C_INTEROP and AB_IS_ISO_C.
+	(attr_bits): Add "IS_BIND_C", "IS_C_INTEROP", and "IS_ISO_C".
+	(mio_symbol_attribute): Deal with ISO C Binding attributes.
+	(bt_types): Add "VOID".
+	(mio_typespec): Deal with ISO C Binding components.
+	(mio_namespace_ref): Add intmod variable. 
+	(mio_symbol): Check for symbols from an intrinsic module.
+	(load_commons): Check for BIND(C) common block.
+	(read_module): Read binding_label and use it.
+	(write_common): Add label.  Write BIND(C) info.
+	(write_blank_common): Blank commons are not BIND(C).  Explicitly
+	set is_bind_c=0.
+	(write_symbol): Deal with binding_label.
+	(sort_iso_c_rename_list): New function.
+	(import_iso_c_binding_module): Ditto.
+	(create_int_parameter): Add to args.
+	(use_iso_fortran_env_module): Adjust to deal with iso_c_binding
+	intrinsic module.
+	* trans-types.c (c_interop_kinds_table): new array of structs. 
+	(gfc_validate_c_kind): New function.
+	(gfc_check_any_c_kind): Ditto.
+	(get_real_kind_from_node): Ditto.
+	(get_int_kind_from_node): Ditto.
+	(get_int_kind_from_width): Ditto.
+	(get_int_kind_from_minimal_width): Ditto.
+	(init_c_interop_kinds): Ditto.
+	(gfc_init_kinds): call init_c_interop_kinds.
+	(gfc_typenode_for_spec): Adjust for BT_VOID and ISO C Binding pointers.
+	Adjust handling of BT_DERIVED.
+	(gfc_sym_type): Whitespace.
+	(gfc_get_derived_type):  Account for iso_c_binding derived types
+	* resolve.c (is_scalar_expr_ptr): New function.
+	(gfc_iso_c_func_interface): Ditto.
+	(resolve_function): Use gfc_iso_c_func_interface. 
+	(set_name_and_label): New function.
+	(gfc_iso_c_sub_interface): Ditto.
+	(resolve_specific_s0): Use gfc_iso_c_sub_interface.
+	(resolve_bind_c_comms): New function.
+	(resolve_bind_c_derived_types): Ditto.
+	(gfc_verify_binding_labels): Ditto.
+	(resolve_fl_procedure): Check for ISO C interoperability.
+	(resolve_symbol): Check C interoperability.
+	(resolve_types): Walk the namespace.  Check COMMON blocks.
+	* trans-decl.c (gfc_sym_mangled_identifier):  Prevent the mangling
+	of identifiers that have an assigned binding label.
+	(gfc_sym_mangled_function_id): Use the binding label rather than
+	the mangled name.
+	(gfc_finish_var_decl): Put variables that are BIND(C) into a common
+	segment of the object file, because this is what C would do.
+	(gfc_create_module_variable): Conver to proper types
+	(set_tree_decl_type_code): New function.
+	(generate_local_decl): Check dummy variables and derived types for
+	ISO C Binding attributes.
+	* match.c (gfc_match_small_int_expr): New function.
+	(gfc_match_name_C): Ditto.
+	(match_common_name): Deal with ISO C Binding in COMMON blocks
+	* trans-io.c (transfer_expr):  Deal with C_NULL_PTR or C_NULL_FUNPTR
+	expressions
+	* match.h: Add prototypes for gfc_match_small_int_expr,
+	gfc_match_name_C, match_common_name, set_com_block_bind_c,
+	set_binding_label, set_verify_bind_c_sym,
+	set_verify_bind_c_com_block, get_bind_c_idents,
+	gfc_match_bind_c_stmt, gfc_match_suffix, gfc_match_bind_c,
+	gfc_get_type_attr_spec
+	* parse.c (decode_statement): Use gfc_match_bind_c_stmt
+	(parse_derived): Init *derived_sym = NULL, and gfc_current_block
+	later for valiadation.
+	* primary.c (got_delim): Set ISO C Binding components of ts.
+	(match_logical_constant): Ditto.
+	(match_complex_constant): Ditto.
+	(match_complex_constant): Ditto.
+	(gfc_match_rvalue): Check for existence of at least one arg for
+	C_LOC, C_FUNLOC, and C_ASSOCIATED.
+	* misc.c (gfc_clear_ts): Clear ISO C Bindoing components in ts.
+	(get_c_kind): New function.
+
+2007-07-01  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	PR fortran/32239
+	* trans-expr.c (gfc_conv_power_op): Use builtin_powi for
+	real**int4 powers.
+	* f95-lang.c (gfc_init_builtin_functions): Add builtin_powi to the
+	builtins table.
+
+2007-07-01  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	* trans.h: Remove decls for 64-bit allocation functions.
+	* trans-array.c (gfc_grow_array): Always pick the standard realloc
+	function decl.
+	(gfc_array_allocate): Likewise.
+	* trans-decl.c: Remove trees for 64-bit allocation functions.
+	(gfc_build_builtin_function_decls): Don't build fndecls for 64-bit
+	allocations functions, use index_int_type for normal allocation
+	functions.
+
+2007-06-30  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/20373
+	* intrinsic.c (add_functions): Additional function types.
+	(gfc_convert_type_warn): Remove intrinsic-flag from
+	conversion functions.
+	* resolve.c (resolve_symbol): Added type checks to 
+	explicitly defined intrinsics.
+
+2007-06-30  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/32555
+	* io.c (check_format): Allow zero to precede the
+	P edit descriptor.
+
+2007-06-30  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/32472
+	* simplify.c (gfc_simplify_repeat): Add handling of character
+	literal for first argument.
+
+2007-06-29  Daniel Franke  <franke.daniel@gmail.com>
+
+	* resolve.c (resolve_operator): Added check whether a user
+	defined operator is available.
+
+2007-06-29  Daniel Franke <franke.daniel@gmail.com>
+
+	* openmp.c (resolve_omp_clauses): Adjust error message to
+	better reflect the actual requirement.
+
+2007-06-29  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/32483
+	* io.c (format_lex): Fix FMT_ZERO.
+	(check_format,check_format_string,gfc_match_format,
+	check_io_constraints) Additional checking for READ.
+
+2007-06-28 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+
+	PR other/31400
+	* lang.opt (static-libgfortran): New option.
+	* gfortranspec.c (ADD_ARG_LIBGFORTRAN): New macro.
+	(Option): Add OPTION_static and OPTION_static_libgfortran.
+	(lookup_option): Handle the new -static-libgfortran option.
+	(lang_specific_driver): Check whether -static is passed.
+	Handle the new -static-libgfortran option.
+	* options.c (gfc_handle_option): If -static-libgfortran is
+	passed and isn't supported on this configuration, error out.
+
+2007-06-27  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/32467
+	* openmp.c (resolve_omp_clauses): Emit error on allocatable
+	components in COPYIN, COPYPRIVATE, FIRSTPRIVATE and LASTPRIVATE
+	clauses.
+
+2007-06-25  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/32464
+	* resolve.c (check_host_association): Return if the old symbol
+	is use associated.  Introduce retval to reduce the number of
+	evaluations of the first-order return value.
+
+	PR fortran/31494
+	* match.c (gfc_match_call): If a host associated symbol is not
+	a subroutine, build a new symtree/symbol in the current name
+	space.
+
+2007-06-24  Tobias Burnus  <burnus@net-de>
+
+	PR fortran/32460
+	* interface.c (gfc_compare_derived_types): Add access check.
+	* symbol.c (gfc_find_component): Ditto.
+	(gfc_set_component_attr,gfc_get_component_attr) Copy access state.
+	* dump-parse-tree.c (gfc_show_components): Dump access state.
+	* gfortran.h (struct gfc_component): Add gfc_access.
+	* module.c (mio_component): Add access state.
+	* (gfc_match_structure_constructor): Check for private access state.
+
+2007-06-24  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/32298
+	PR fortran/31726
+	* trans-intrinsic.c (gfc_conv_intrinsic_minmaxloc): Calculate
+	the offset between the loop counter and the position as
+	defined. Add the offset within the loop so that the mask acts
+	correctly.  Do not advance the location on the basis that it
+	is zero.
+
+2007-06-22  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/31473
+	* symbol.c (gfc_copy_attr): Emit errors for duplicate 
+	EXTERNAL/INTRINSIC statements.
+
+2007-06-22  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/32360
+	* expr.c (gfc_check_assign): If the rvalue expression type is NULL_EXPR,
+	check to see if the lvalue has attribute pointer and data.  
+
+2007-06-21  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/31162
+	* resolve.c (gfc_resolve_iterator_expr): Add check for REAL using
+	gfc_notify_standard. (gfc_resolve_iterator): Remove check.
+	(resolve_branch): Change "Obsolete" to "Deleted feature".
+	* io.c (resolve_tag): Ditto.
+	* match.c (gfc_match_pause, gfc_match_assign, gfc_match_goto): Ditto.
+
+2007-06-20  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/32361
+	* match.c (gfc_match_common): If the symbol value expression type is
+	NULL_EXPR, don't error if previously initialized.
+
+2007-06-20  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/25061
+	* decl.c (get_proc_name) Check symbol for generic interface
+	and issue an error.
+
+2007-06-20  Andrew Pinski  <andrew_pinski@playstation.sony.com>
+	Richard Guenther  <rguenther@suse.de>
+
+	PR fortran/32140
+	* trans.c (gfc_build_addr_expr): Use the correct types.
+
+2007-06-19  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/20863
+	PR fortran/20882
+	* resolve.c (resolve_code): Use gfc_impure_variable as a
+	condition for rejecting derived types with pointers, in pure
+	procedures.
+	(gfc_impure_variable): Add test for dummy arguments of pure
+	procedures; any for functions and INTENT_IN for subroutines.
+
+	PR fortran/32236
+	* data.c (gfc_assign_data_value): Change the ICE on an array
+	reference initializer not being an array into an error and
+	clear init to prevent a repetition of the error.
+
+2007-06-17  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	* gfortran.texi: Add documentation for GFORTRAN_UNBUFFERED_n
+	environment variables. Fix documentation for
+	GFORTRAN_UNBUFFERED_ALL environment variable.
+
+2007-06-15  Andrew Pinski  <andrew_pinski@playstation.sony.com>
+
+	* trans-intrinsic.c (gfc_conv_intrinsic_repeat): Use
+	POINTER_PLUS_EXPR instead of PLUS_EXPR for pointer addition.
+	* trans-expr.c (gfc_trans_string_copy): Create
+	POINTER_PLUS_EXPR instead of a PLUS_EXPR
+	for pointer types.
+
+2007-06-14  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/32302
+	* trans-common.c (build_common_decl): If resizing of common
+	decl is needed, update the TREE_TYPE.
+
+2007-06-13  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/32323
+	* interface.c (has_vector_section): New.
+	(compare_actual_formal): Check for array sections with vector subscript.
+
+2007-06-12  Dirk Mueller  <dmueller@suse.de>
+
+	* trans-stmt.c (gfc_trans_call): fix gcc_assert to
+	a comparison, not an assignment.
+
+2007-06-12  Paul Thomas  <pault@gcc.gnu.org>
+
+	* trans-common.c (create_common): Initialize 'field_init'.
+
+2007-06-12  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29786
+	PR fortran/30875
+	* trans-common.c (get_init_field): New function.
+	(create_common): Call get_init_field for overlapping
+	initializers in equivalence blocks.
+	* resolve.c (resolve_equivalence_derived, resolve_equivalence):
+	Remove constraints on initializers in equivalence blocks.
+	* target-memory.c (expr_to_char, gfc_merge_initializers):
+	New functions.
+	(encode_derived): Add the bit offset to the byte offset to get
+	the total offset to the field.
+	* target-memory.h : Add prototype for gfc_merge_initializers.
+
+2007-06-11  Rafael Ávila de Espíndola  <espindola@google.com>
+
+	* trans-types.c (gfc_signed_type): Remove.
+	* trans-types.h (gfc_signed_type): Remove.
+	* f95-lang.c (LANG_HOOKS_SIGNED_TYPE): Remove.
+
+2007-06-08 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+
+	* trans-intrinsic.c: Revert Lee's 2007-06-04 patch.
+
+2007-06-07  Steven G. Kargl  <kargl@gcc.gnu.org>
+	    Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/32223
+	* match.c (gfc_match_special_char): New function.  Match special char.
+	Add handling '\0'.
+	* match.h: Add prototype.
+	* io.c (next_char): Use it.
+	* primary.c (next_string_char): Ditto.
+
+2007-06-06  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* decl.c: Miscellaneous whitespace fixes.
+	* expr.c: Likewise.
+	* gfortran.h: Likewise.
+	* interface.c : Likewise.
+	* io.c: Likewise.
+	* match.c: Likewise.
+	* match.h: Likewise.
+	* module.c: Likewise.
+	* parse.c: Likewise.
+	* resolve.c: Likewise.
+	* symbol.c: Likewise.
+	* trans-array.c: Likewise.
+	* trans-common.c: Likewise.
+	* trans-decl.c: Likewise.
+	* trans-intrinsic.c: Likewise.
+	* trans-io.c: Likewise.
+	* trans-stmt.c: Likewise.
+	* trans-types.c: Likewise.
+
+2007-06-05  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/18923
+	* parse.c (decode_statement): Don't call gfc_undo_symbols on MATCH_ERROR
+	for ST_FUNCTION since it is called in reject_statement.
+	(parse_contained): If error, loop back after reject_statement and try
+	again.  Free the namespace if an error occured.
+
+2007-06-04 Lee Millward <lee.millward@codesourcery.com>
+
+	* trans-intrinsic.c (gfc_conv_intrinsic_function_args): Adjust
+	to operate on a stack allocated array for the intrinsic arguments
+	instead of creating a TREE_LIST. Add two new parameters for the
+	array and the number of elements. Update all callers to allocate
+	an array of the correct length to pass in. Update comment.
+	(gfc_intrinsic_argument_list_length): New function.
+	(gfc_conv_intrinsic_mnimax): Call it.
+	(gfc_conv_intrinsic_merge): Likewise.
+	(gfc_conv_intrinsic_lib_function): Call it. Use new CALL_EXPR
+	constructors.
+	(gfc_conv_intrinsic_cmplx): Likewise.
+	(gfc_conv_intrinsic_ctime): Likewise.
+	(gfc_covn_intrinsic_fdate): Likewise.
+	(gfc_conv_intrinsic_ttynam): Likewise.
+	(gfc_conv_intrinsic_ishftc): Likewise.
+	(gfc_conv_intrinsic_index): Likewise.
+	(gfc_conv_intrinsic_scan): Likewise.
+	(gfc_conv_intrinsic_verify): Likewise.
+	(gfc_conv_intrinsic_trim): Likewise.
+	(gfc_conv_intrinsic_aint): Use new CALL_EXPR constructors.
+	(gfc_conv_intrinsic_exponent): Likewise.
+	(gfc_conv_intrinsic_bound): Likewise.
+	(gfc_conv_intrinsic_abs): Likewise.
+	(gfc_conv_intrinsic_mod): Likewise.
+	(gfc_conv_intrinsic_sign): Likewise.
+	(gfc_conv_intrinsic_len): Likewise.
+	(gfc_conv_intrinsic_adjust): Likewise.
+	(gfc_conv_intrinsic_si_kind): Likewise.
+
+2007-06-04  Steve Ellcey  <sje@cup.hp.com>
+
+	* trans-array.c (gfc_conv_array_parameter): Initialize tmp.
+
+2007-05-31  Richard Guenther  <rguenther@suse.de>
+
+	* trans-expr.c (gfc_conv_expr_op): Use zero constant
+	that matches the lse type.
+	(gfc_trans_string_copy): Use sizetype zero constant.
+	* intrinsic.c (add_functions): The sizeof intrinsic has
+	index type result.
+	* trans-types.c (gfc_get_dtype): Convert size to index
+	type before shifting.
+	* trans-array.c (gfc_trans_array_constructor_value): Use
+	index type for offset computation.
+	* trans-intrinsic.c (gfc_conv_associated): Use correct type
+	for zero constant.
+
+2007-05-31  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/32156
+	* trans-array.c (gfc_trans_array_constructor): Treat the case
+	where the ss expression charlen is missing.
+
+2007-05-31  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/32103
+	* module.c (mio_symtree_ref): If an equivalence group member
+	is not used, give it a hidden symbol and set the pointer_info.
+	(load_equiv): Only free the equivalence if none of the members
+	are used.
+
+2007-05-29  Daniel Franke  <franke.daniel@gmail.com>
+
+	* gfortran.h: Renamed 'enum gfc_generic_isym_id' to 'enum gfc_isym_id',
+	added missing GFC_ISYM_* enumerators, ordered alphabetically.
+	(struct gfc_intrinsic_sym): Renamed 'generic_id' to 'id'.
+	(gfc_find_subroutine): New prototype.
+	* intrinsic.c (add_sym, add_sym_*): Added argument 'id' and changed all callers.
+	(find_subroutine): Renamed to 'gfc_find_subroutine', removed static.  
+	* dependency.c: Changed usage of isym->generic_id to isym->id.  
+	* openmp.c: Likewise.  
+	* resolve.c: Likewise.  
+	* trans-array.c: Likewise.  
+	* trans-expr.c: Likewise.  
+	* trans-intrinsic.c: Likewise.  
+	* trans-openmp.c: Likewise.
+
+2007-05-28  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	* gfortran.h (gfc_generic_isym_id): Add GFC_ISYM_SIZEOF.
+	* intrinsic.c (add_functions): Add stuff for SIZEOF intrinsic.
+	* intrinsic.h (gfc_check_sizeof): Add prototype of ...
+	* check.c (gfc_check_sizeof): .. new function.
+	* trans-intrinsic.c (gfc_conv_intrinsic_sizeof): New function.
+	(gfc_conv_intrinsic_strcmp): Whitespace fix.
+	(gfc_conv_intrinsic_array_transfer): Remove double initialization,
+	use fold_build. where appropriate.
+	(gfc_conv_intrinsic_function): Add case for SIZEOF.
+	* intrinsic.texi: Add documentation for SIZEOF.
+
+2007-05-28  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* trans-array.c (gfc_conv_expr_descriptor): Edit comment.
+
+2007-05-28  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	PR fortran/31972
+	* target-memory.c (gfc_target_expr_size): Add handling
+	for size of BT_HOLLERITH variables.
+	* check.c (gfc_check_transfer): Reject BT_HOLLERITH
+	variables in MOLD argument of TRANSFER.
+
+2007-05-28  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* gfortran.h (gfc_expr): Remove from_H, add "representation"
+	struct.
+	* primary.c (match_hollerith_constant): Store the representation
+ 	of the Hollerith in representation, not in value.character.
+	* arith.c: Add dependency on target-memory.h.
+	(eval_intrinsic): Remove check for from_H.
+	(hollerith2representation): New function.
+	(gfc_hollerith2int): Determine value of the new constant.
+	(gfc_hollerith2real): Likewise.
+	(gfc_hollerith2complex): Likewise.
+	(gfc_hollerith2logical): Likewise.
+	(gfc_hollerith2character): Point both representation.string and
+	value.character.string at the value string.
+	* data.c (create_character_initializer): For BT_HOLLERITH
+	rvalues, get the value from the representation rather than
+	value.character.
+	* expr.c (free_expr0): Update handling of BT_HOLLERITH values
+	and values with representation.string.
+	(gfc_copy_expr): Likewise.
+	* intrinsic.c (do_simplify): Remove special treatement of
+	variables resulting from Hollerith constants.
+	* dump-parse-trees.c (gfc_show_expr): Update handling of
+	Holleriths.
+	* trans-const.c (gfc_conv_constant_to_tree): Replace from_H
+	check with check for representation.string; get Hollerith
+	representation from representation.string, not value.character.
+	* trans-expr.c (is_zero_initializer_p): Replace from_H check
+	with check for representation.string.
+	* trans-stmt.c (gfc_trans_integer_select): Use
+	gfc_conv_mpz_to_tree for case values, so as to avoid picking up
+	the memory representation if the case is given by a transfer
+	expression.
+	* target-memory.c (gfc_target_encode_expr): Use the known memory
+	representation rather than the value, if it exists.
+	(gfc_target_interpret_expr): Store the memory representation of
+	the interpreted expression as well as its value.
+	(interpret_integer): Move to gfc_interpret_integer, make
+	non-static.
+	(interpret_float): Move to gfc_interpret_float, make non-static.
+	(interpret_complex): Move to gfc_interpret_complex, make
+	non-static.
+	(interpret_logical): Move to gfc_interpret_logical, make
+	non-static.
+	(interpret_character): Move to gfc_interpret_character, make
+	non-static.
+	(interpret_derived): Move to gfc_interpret_derived, make
+	non-static.
+	* target-memory.h: Add prototypes for newly-exported
+	gfc_interpret_* functions.
+
+2007-05-27  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/31812
+	* parse.c (next_statement): Warn for truncated lines if source is free
+	form.
+
+2007-05-27 Paul Thomas  <pault@gcc.gnu.org>
+	   Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/32088
+	* symbol.c (gfc_check_function_type): Copy dimensions of
+	  result variable.
+	* resolve.c (resolve_contained_fntype): Improve symbol output in
+	  the error message.
+
+2007-05-26  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/31813
+	* io.c (check_format): Add warning for H specifier in format.
+	
+2007-05-26  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.texi: Document the GFORTRAN_ERROR_DUMPCORE and
+	GFORTRAN_ERROR_BACKTRACE environment variables.
+
+2007-05-26  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31219
+	* trans.h : Add no_function_call bitfield to gfc_se structure.
+	Add stmtblock_t argument to prototype of get_array_ctor_strlen.
+	* trans-array.c (get_array_ctor_all_strlen): New function.
+	(get_array_ctor_strlen): Add new stmtblock_t argument and call
+	new function for character elements that are not constants,
+	arrays or variables.
+	(gfc_conv_array_parameter): Call get_array_ctor_strlen to get
+	good string length.
+	* trans-intrinsic (gfc_conv_intrinsic_len): Add new argument
+	to call of get_array_ctor_strlen.
+
+2007-05-25  Kazu Hirata  <kazu@codesourcery.com>
+
+	* intrinsic.texi: Fix typos.
+
+2007-05-25  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/32047
+	* trans-expr.c (gfc_apply_interface_mapping_to_expr): Change
+	order in logic under EXPR_FUNCTION to handle functions with
+	no arguments.
+
+2007-05-23  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/31716
+	* array.c (spec_dimen_size): Test for correct BT_INTEGER type. 
+
+2007-05-23  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/32046
+	* trans-expr.c (gfc_trans_zero_assign): Convert the result of
+	TYPE_SIZE_UNIT into a signed type.
+	(gfc_trans_array_copy):  Likewise.
+	(gfc_trans_array_constructor_copy): Likewise.
+	* trans-array.c (gfc_trans_create_temp_array): Likewise.
+	(gfc_grow_array): Likewise.
+	(gfc_array_init_size): Likewise.
+	(gfc_duplicate_allocatable): Likewise.
+	* trans-stmt.c (allocate_temp_for_forall_nest_1): Likewise.
+
+2007-05-22  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/18923
+	* resolve.c (resolve_function): Don't call resolve_global_procedure if
+	there is no name. Delete duplicated statement in ELSE clause.
+
+2007-05-22 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+
+	PR fortran/31627
+	* trans-array.c (gfc_trans_array_bound_check): Take extra argument to
+	indicate whether we should check the upper bound in that dimension.
+	(gfc_conv_array_index_offset): Check only the lower bound of the
+	last dimension for assumed-size arrays.
+	(gfc_conv_array_ref): Likewise.
+	(gfc_conv_ss_startstride): Likewise.
+
+2007-05-21  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+	    Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/32002
+	* resolve.c (resolve_actual_arglist): Resolve actual argument after
+	being identified as variable.
+
+2007-05-21  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/32027
+	* trans-stmt.c (gfc_trans_do): Fix the value of loop variable
+	when the loop ends.
+
+2007-05-21  H.J. Lu  <hongjiu.lu@intel.com>
+
+	* trans-stmt.c (gfc_trans_do): Fix a typo in comment.
+
+2007-05-21  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31867
+	PR fortran/31994
+	* trans-array.c (gfc_conv_expr_descriptor): Obtain the stored
+	offset for non-descriptor, source arrays and correct for stride
+	not equal to one before writing to field of output descriptor.
+
+2007-05-20  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/32001
+	* check.c (check_rest): Improved argument conformance check and 
+	fixed error message generation.
+
+2007-05-19  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/30820
+	* Make-lang.in: Remove use of -Wno-error for expr.o, resolve.o,
+	simplify.o and trans-common.o.
+
+2007-05-19  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/31974
+	* trans-array.c (gfc_trans_auto_array_allocation): Avoid
+	multiplication of mismatched types.
+
+2007-05-18  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/24633
+	* symbol.c (gfc_add_flavor): Add the NAME to error message if
+	available.
+
+2007-05-15  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/31919
+	PR fortran/31929
+	PR fortran/31930
+	* intrinsic.c (check_specific): Check elemental intrinsics for
+	rank and shape.
+	(add_functions): Fixed dummy argument names of BESJN and BESYN.
+	Fixed elemental status of MCLOCK and MCLOCK8.
+	* check.c (check_rest): Added check for array conformance.
+	(gfc_check_merge): Removed check for array conformance.
+	(gfc_check_besn): Removed check for scalarity.
+	* intrinsic.texi (CSHIFT, EOSHIFT): Fixed typos.
+	(BESJN, BESYN): Clarified documentation.
+
+2007-05-17  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.texi (GFORTRAN_CONVERT_UNIT): Improve documentation.
+
+2007-05-16  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	PR fortran/18769
+	PR fortran/30881
+	PR fortran/31194
+	PR fortran/31216
+	PR fortran/31427
+	* target-memory.c: New file.
+	* target-memory.h: New file.
+	* simplify.c: Add #include "target-memory.h".
+	(gfc_simplify_transfer): Implement constant-
+	folding for TRANSFER intrinsic.
+	* Make-lang.in: Add dependencies on new target-memory.* files.
+
+2007-05-15  Paul Brook  <paul@codesourcery.com>
+
+	* trans-types.c (gfc_type_for_size): Handle signed TImode.
+
+2007-05-14  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/30723
+	* trans.h (gfor_fndecl_internal_malloc, gfor_fndecl_internal_malloc64,
+	gfor_fndecl_internal_free): Remove prototypes.
+	(gfor_fndecl_os_error, gfc_call_free, gfc_call_malloc): Add prototypes.
+	* trans.c (gfc_call_malloc, gfc_call_free): New functions.
+	* f95-lang.c (gfc_init_builtin_functions): Add __builtin_free
+	and __builtin_malloc builtins.
+	* trans-decl.c (gfor_fndecl_internal_malloc,
+	gfor_fndecl_internal_malloc64, gfor_fndecl_internal_free): Remove.
+	(gfor_fndecl_os_error): Add.
+	(gfc_build_builtin_function_decls): Don't create internal_malloc,
+	internal_malloc64 and internal_free library function declaration.
+	Create os_error library call function declaration.
+	* trans-array.c (gfc_trans_allocate_array_storage,
+	gfc_trans_auto_array_allocation, gfc_trans_dummy_array_bias,
+	gfc_conv_array_parameter, gfc_duplicate_allocatable): Use
+	gfc_call_malloc and gfc_call_free instead of building calls to
+	internal_malloc and internal_free.
+	* trans-expr.c (gfc_conv_string_tmp): Likewise.
+	* trans-stmt.c (gfc_do_allocate, gfc_trans_assign_need_temp,
+	gfc_trans_pointer_assign_need_temp, gfc_trans_forall_1,
+	gfc_trans_where_2: Likewise.
+	* trans-intrinsic.c (gfc_conv_intrinsic_ctime,
+	gfc_conv_intrinsic_fdate, gfc_conv_intrinsic_ttynam,
+	gfc_conv_intrinsic_array_transfer, gfc_conv_intrinsic_trim): Likewise.
+
+2007-05-14  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/31725
+	* trans-expr.c (gfc_conv_substring): Evaluate substring bounds
+	only once.
+
+2007-05-14  Rafael Ávila de Espíndola  <espindola@google.com>
+
+	* f95-lang.c (LANG_HOOKS_UNSIGNED_TYPE): Remove.
+	* trans-intrinsic.c (gfc_conv_intrinsic_ishft): Use unsigned_type_for
+	instead of gfc_unsigned_type.
+	* trans-stmt.c (gfc_trans_do): Use unsigned_type_for instead of
+	gfc_unsigned_type.
+	* trans-types.c (gfc_unsigned_type): Remove.
+	* trans-types.h (gfc_unsigned_type): Remove.
+
+2007-05-12  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30746
+	* resolve.c (check_host_association): New function that detects
+	incorrect host association and corrects it.
+	(gfc_resolve_expr): Call the new function for variables and
+	functions.
+	* match.h : Remove prototype for gfc_match_rvalue.
+	* gfortran.h : Add prototype for gfc_match_rvalue.
+
+2007-05-11 Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/30876
+	* trans-expr.c (gfc_conv_function_call): Reduce indirection for
+	direct assignments of recursive array valued functions.
+	* primary.c (gfc_match_rvalue): Correct error for recursive
+	function calls such that directly recursive calls of scalar
+	function without an explicit result are disallowed.
+
+2007-05-11 Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/30878
+	* resolve.c (resolve_fl_namelist): It is not an error if the
+	namelist element is the result variable of the enclosing
+	function.  Search for the symbol in current and all parent
+	namespaces for a potential conflict.
+	* symbol.c (check_conflict): Remove the conflict between
+	'in_namelist' and 'FL_PROCEDURE' because the symbol info
+	is not available to exclude function result variables.
+	* trans-io.c (nml_get_addr_expr): Use the fake result decl
+	if the symbol is an implicit result variable.
+
+2007-05-11  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31474
+	* decl.c (get_proc_name): If an entry has already been declared
+	as a module procedure, pick up the symbol and the symtree and
+	use them for the entry.
+
+2007-05-08  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31630
+	* resolve.c (resolve_symbol): Remove the flagging mechanism from the
+	formal namespace resolution and instead check that the formal
+	namespace is not the current namespace.
+
+2007-05-08  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31692
+	* trans-array.c (gfc_conv_array_parameter): Convert full array
+	references to the result of the procedure enclusing the call.
+
+2007-05-08  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29397
+	PR fortran/29400
+	* decl.c (add_init_expr_to_sym): Expand a scalar initializer
+	for a parameter array into an array expression with the right
+	shape.
+	* array.c (spec_dimen_size): Remove static attribute.
+	* gfortran.h : Prototype for spec_dimen_size.
+
+2007-05-07  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/31399
+	* trans-stmt.c (gfc_trans_do): Handle large loop counts.
+
+2007-05-07  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/31764
+	* simplify.c (gfc_simplify_new_line): NEW_LINE can be simplified
+	even for non constant arguments.
+
+2007-05-06  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+	    Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/31201
+	* gfortran.h: Add runtime error codes from libgfortran.h. Define
+	MAX_UNIT_NUMBER.
+	* trans.c (gfc_trans_runtime_check): Update the format of runtime error
+	messages to match library runtime errors.  Use call to new library
+	function runtime_error_at().
+	* trans.h: Add prototype for new function gfc_trans_io_runtime_check.
+	Add declaration for library functions runtime_error_at and
+	generate_error.
+	* trans_io.c (gfc_trans_io_runtime_check): New function.
+	(set_parameter_value): Add error checking for UNIT numbers.
+	(set_parameter_ref): Initialize the users variable to zero. 
+	(gfc_trans_open): Move setting of unit number to after setting of common
+	flags so that runtime error trapping can be detected.
+	(gfc_trans_close): Likewise. (build_filepos): Likewise.
+	(gfc_trans_inquire): Likewise. (build_dt): Likewise.
+	* trans-decl.c: Add declarations for runtime_error_at and
+	generate_error. (gfc_build_builtin_function_decls): Build function
+	declarations for runtime_error_at and generate_error.
+
+2007-05-06  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31540
+	* resolve.c (resolve_fl_procedure): Resolve constant character
+	lengths.
+
+2007-05-05  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/31251
+	* decl.c (match_char_spec): Add check for invalid character lengths.
+
+2007-05-04  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* intrinsic.texi (CMPLX): Document result kind.
+	(COMPLEX): Add documentation.
+
+2007-05-04  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/31760
+	* intrinsic.c (add_functions): Replaced calls to gfc_check_g77_math1
+	by gfc_check_fn_r to avoid checks for scalarity.
+	* check.c (gfc_check_besn): Removed check for scalarity.
+	(gfc_check_g77_math1): Removed.
+	* intrinsic.h (gfc_check_g77_math1): Removed.
+
+2007-05-04  Daniel Franke  <franke.daniel@gmail.com>
+
+	* check.c (gfc_check_fseek_sub): Fixed typo.
+
+2007-05-04  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/22359
+	* intrinsic.c (add_subroutines): Added FSEEK.
+	* intrinsic.h (gfc_resolve_fseek_sub, gfc_check_fseek_sub): New.
+	* iresolve.c (gfc_resolve_fseek_sub): New.
+	* check.c (gfc_check_fseek_sub): New.
+	* intrinsic.texi (FSEEK): Updated.
+
+2007-05-04  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/31803
+	* expr.c (gfc_check_pointer_assign): Check for NULL pointer.
+
+2007-05-04  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/31251
+	* simplify.c (gfc_simplify_len): Only simplify integer lengths.
+
+2007-05-04  Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+
+	PR fortran/31781
+	* simplify.c (gfc_simplify_repeat): Don't put function call with
+	side effect in a gcc_assert().
+
+2007-05-04  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/25071
+	* interface.c (compare_actual_formal): Check character length.
+
+2007-05-01  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/31732
+	* dependency.c (gfc_full_array_ref_p):  If the reference is
+	to a single element, check that the array has a single
+	element and that the correct element is referenced.
+
+2007-05-01  Daniel Franke  <franke.daniel@gmail.com>
+
+	* intrinsic.c (add_functions): Fixed ELEMENTAL specifications.
+	(add_subroutines): Replaced magic numbers in function calls by
+	ELEMENTAL and NOT_ELEMENTAL respectively.
+	* intrinsic.texi (MVBITS): Changed class to elemental subroutine.
+	(RANDOM_NUMBER): Changed class to subroutine.
+	(HUGE, TINY): Changed class to inquiry function.
+
+2007-04-30  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* trans-const.c (gfc_conv_mpz_to_tree): Use mpz_get_double_int.
+	(gfc_conv_tree_to_mpz): New function.
+	(gfc_conv_mpfr_to_tree): Use real_from_mpfr.
+	(gfc_conv_tree_to_mpfr): New function.
+	* trans-const.h: (gfc_conv_tree_to_mpz): New prototype.
+	(gfc_conv_tree_to_mpfr): New prototype.
+
+2007-04-30  Daniel Franke  <franke.daniel@gmail.com>
+
+	* intrinsic.texi (IERRNO): Changed class to non-elemental function.
+	(LOG10): Removed COMPLEX as accepted argument type.
+	(NEW_LINE): Changed class from elemental to inquiry function.
+	(SIGN): Removed requirement of scalar arguments.
+	(SNGL): Changed class to elemental function.
+
+2007-04-29  Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+
+	PR fortran/31591
+	* simplify.c (simplify_bound_dim): New function.
+	(simplify_bound): Use the above. Perform simplification of LBOUND
+	and UBOUND when DIM argument is not present.
+
+2007-04-29  Daniel Franke  <franke.daniel@gmail.com>
+
+	* gfortran.texi: Cleaned up keyword index.
+	* invoke.texi: Likewise.
+	* intrinsic.texi: Likewise.
+			
+2007-04-29  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/31645
+	* scanner.c (load_file): Discard the byte order mark if one is
+	found on the first non-preprocessor line of a file.
+
+2007-04-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31711
+	* trans-array.c (gfc_conv_resolve_dependencies): Create a temp
+	whenever a dependency is found.
+
+2007-04-28  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	* options.c (gfc_handle_option): Ensure requested free form line
+	length is not too small.
+
+2007-04-27  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* intrinsic.texi (Transfer): Improve documentation.
+
+2007-04-27  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* gfortran.texi (Option Index): Add @samp as needed.
+
+2007-04-27  Daniel Franke  <franke.daniel@gmail.com>
+
+	* gfortran.texi: Added node and menu entry for an option index.
+	* invoke.texi: Moved command line option related entries of the concept 
+	index to the option index.
+
+2007-04-27  Daniel Franke  <franke.daniel@gmail.com>
+
+	* intrinsic.texi (AND, FPUT, FPUTC, MODULO, OR, SET_EXPONENT,
+	XOR): Fixed examples.
+
+2007-04-27  Daniel Franke  <franke.daniel@gmail.com>
+
+	* intrinsic.texi (PRODUCT, RESHAPE, SPACING, SPREAD, SUM, 
+	SYSTEM_CLOCK, TRANSFER, UNPACK): New.
+	(DATE_AND_TIME, CPU_TIME, RRSPACING): Added cross references.
+
+2007-04-26  Daniel Franke  <franke.daniel@gmail.com>
+
+	* intrinsic.texi (NULL, PACK, PRESENT, REPEAT, SCAN, SHAPE, 
+	SIZE, TRANSPOSE, TRIM, VERIFY): New.
+	(ADJUSTL, ADJUSTR, INDEX): Added cross references.
+	(INT, INT2, INT8, LONG): Enabled section header.
+
+2007-04-25  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	* module.c (module_char): Replace fgetc() with
+	getc(). 
+	(write_char): Replace fputc() with putc().
+	* scanner.c (load_line): Replace fgetc() with getc().
+	(gfc_read_orig_filename): Likewise.
+
+2007-04-25  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/31668
+	* error.c (error_print): Fix %% support.
+	* intrinsic.c (sort_actual): Improve error message.
+	* resolve.c (resolve_actual_arglist): Allow %VAL for
+	interfaces defined in the module declaration part.
+
+2007-04-25  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR libfortran/31299
+	* intrinsic.texi (GETLOG): Update documentation to reflect
+	library changes.
+
+2007-04-24  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/31587
+	* module.c (write_char): Add character to the MD5 buffer.
+	(read_md5_from_module_file): New function.
+	(gfc_dump_module): Compute MD5 for new module file. Call
+	read_md5_from_module_file. Only overwrite old module file
+	if the new MD5 is different.
+
+2007-04-23  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31630
+	* resolve.c (resolve_symbol): Allow resolution of formal
+	namespaces nested within formal namespaces coming from modules.
+
+	PR fortran/31620
+	* trans-expr.c (gfc_trans_assignment): Make the call to
+	gfc_trans_zero_assign conditional on the lhs array ref being
+	the only reference.
+
+2007-04-23  Tobias Burnus  <burnus@net-b.de>
+
+	* primary.c (match_integer_constant): Mention -fno-range-check
+	in the error message.
+
+2007-04-21  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/31495
+	* scanner.c (load_line):  Remove check for comment after ampersand and
+	adjust tracking of ampersand.
+
+2007-04-21  Andrew Pinski  <andrew_pinski@playstation.sony.com>
+
+	* f95-lang.c (lang_tree_node): Use GENERIC_NEXT
+	instead of checking GIMPLE_STMT_P in chain_next.
+
+2007-04-17  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	* trans-types.h (gfc_packed): New enum.
+	(gfc_get_nodesc_array_type): Change prototype to use new enum.
+	* trans-types.c (gfc_get_nodesc_array): Use gfc_packed for
+	argument packed.  Adapt all references to values accordingly.
+	(gfc_sym_type): Use enum values in call to gfc_get_nodesc_array.
+	(gfc_get_derived_type): Likewise.
+	* trans-array.c (gfc_build_constant_array_constructor): Likewise.
+	* trans-expr.c (gfc_get_interface_mapping_charlen): Changed packed
+	argument to type gfc_packed.
+	(gfc_add_interface_mapping): Use enum values in call to
+	gfc_get_interface_mapping.
+	* trans-decl.c (gfc_build_dummy_array_decl): Adapt to use enum
+	values when determining packing.
+
+	* trans-decl.c (gfc_finish_decl): Remove unused second argument
+	'init'.  Simplify code accordingly.  Remove calls to
+	gfc_fatal_error in favor of gcc_assert.
+	(create_function_arglist): Remove second argument from calls to
+	gfc_finish-decl.
+	(gfc_trans_dummy_character): Likewise.
+
+	* arith.h: Update copyright years.
+	* dependency.h: Likewise.
+	* gfortran.h: Likewise.
+	* lang-specs.h: Likewise.
+	* parse.h: Likewise.
+	* symbol.c: Likewise.
+	* trans.h: Likewise.
+	* trans.c: Likewise.
+	* trans-array.c: Likewise.
+	* trans-common.c: Likewise.
+	* trans-const.h: Likewise.
+	* trans-const.c: Likewise.
+	* trans-decl.c: Likewise.
+	* trans-expr.c: Likewise.
+	* trans-io.c: Likewise.
+	* trans-openmp.c: Likewise.
+	* trans-types.h: Likewise.
+	* types.def: Likewise.
+
+2007-04-17  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	PR fortran/31144
+	* decl.c (gfc_sym_mangled_identifier): Use capital letters in name
+	mangling.
+	(gfc_sym_mangled_function_id): Likewise.
+
+2007-04-15  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31204
+	* primary.c (check_for_implicit_index): New function to check
+	that a host associated variable is not an undeclared implied
+	do loop index.
+	(gfc_match_rvalue, match_variable): Use it and reset the
+	implied_index attribute.
+	* gfortran.h : Add the implied_index field to symbol_attribute.
+	* match.c (gfc_match_iterator): Mark the iterator variable
+	with the new attribute.
+	* decl.c (build_sym): Reset the new attribute.
+
+2007-04-15  Kazu Hirata  <kazu@codesourcery.com>
+
+	* gfc-internals.texi: Fix typos.
+	* simplify.c: Fix a comment typo.
+
+2007-04-14  Bernhard Fischer  <aldot@gcc.gnu.org>
+
+	* primary.c: Commentary typo fix; Add question about redundant (?)
+	set.
+
+2007-04-14  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29507
+	PR fortran/31404
+	* expr.c (scalarize_intrinsic_call): New function to
+	scalarize elemental intrinsic functions in initialization
+	expressions.
+	(check_init_expr): Detect elemental intrinsic functions
+	in initalization expressions and call previous.
+
+2007-04-13  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/31559
+	* primary.c (match_variable): External functions
+	are no variables.
+
+2007-04-13  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31550
+	* trans-types.c (copy_dt_decls_ifequal): Do not get pointer
+	derived type components.
+
+2007-04-13  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	PR fortran/18937
+	* resolve.c: Include obstack.h and bitmap.h.  New variable
+	labels_obstack.
+	(code_stack): Add tail and reachable_labels fields.
+	(reachable_labels): New function.
+	(resolve_branch): Rework to use new fields in code_stack.
+	(resolve_code): Call reachable_labels.
+	(resolve_codes): Allocate and free labels_obstack.
+
+2007-04-12  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	PR fortran/31250
+	* decl.c (match_char_spec): Move check for negative CHARACTER
+	length ...
+	* resolve.c (resolve_charlen): ... here.
+	(resolve_types): Resolve CHARACTER lengths earlier.
+
+2007-04-12  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/31234
+	* intrinsic.texi (RANDOM_SEED, RANDOM_NUMBER): New.
+
+2007-04-12  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	PR fortran/31266
+	* primary.c (gfc_variable_attr): Don't copy string length if it
+	doesn't make sense.
+	* resolve.c (resolve_code): Clarify error message.
+
+	PR fortran/31471
+	* decl.c (gfc_match_end): Also check for construct name in END
+	FORALL and END WERE statements.
+	* match.c (match_case_eos): Use uppercase for statement name in
+	error message.
+	(match_elsewhere): Construct name may appear iff construct has a
+	name.
+
+	* trans-types.c: Update copyright years.  Reformat long comment
+	explaining array descriptor format.  Remove obsolete mention of
+	TYPE_SET.
+
+	* arith.c (gfc_arith_uplus): Rename to ...
+	(gfc_arith_identity): ... this.
+	(gfc_parentheses): New function.
+	(gfc_uplus): Adapt to renamed function.
+	* arith.h (gfc_parentheses): Add prototype.
+	* expr.c (gfc_copy_expr): Deal with INTRINSIC_PARENTHESES.
+	(simplifiy_intrinsic_op): Treat INTRINSIC_UPLUS separately from
+	INTRINSIC_PARENTHESES.
+
+2007-04-12  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/31472
+	* decl.c (match_attr_spec): Allow PRIVATE/PUBLIC
+	attribute in type definitions.
+	(gfc_match_private): Allow PRIVATE statement only
+	in specification part of modules.
+	(gfc_match_public): Ditto for PUBLIC.
+	(gfc_match_derived_decl): Allow PRIVATE/PUBLIC attribute only in
+	specificification part of modules.
+
+2007-04-07  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31257
+	* intrinsic.c (add_functions): Add ref. to gfc_resolve_achar.
+	* intrinsic.h : Add prototype for gfc_resolve_achar.
+	* iresolve.c (gfc_resolve_achar): New function.
+
+2007-04-07  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30880
+	* resolve.c (resolve_fl_variable): Set flag to 2 for automatic
+	arrays.  Make condition for automatic array error explicit.
+	If a dummy, no error on an INTENT(OUT) derived type.
+
+2007-04-07  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30872
+	* expr.c (find_array_element): Correct arithmetic for rank > 1.
+
+2007-04-07  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31222
+	* check.c (numeric_check): If an expresson has not got a type,
+	see if it is a symbol for which a default type applies.
+
+2007-04-07  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31214
+	* trans-decl.c (gfc_get_symbol_decl): Allow unreferenced use
+	associated symbols.
+
+2007-04-07  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31293
+	* symbol.c (gfc_check_function_type): New function.
+	* gfortran.h : Add prototype for previous.
+	* parse.c (parse_progunit): Call it after parsing specification
+	statements.
+
+2007-04-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31483
+	* trans-expr.c (gfc_conv_function_call): Give a dummy
+	procedure the correct type if it has alternate returns.
+
+2007-04-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31292
+	* decl.c (gfc_match_modproc): Go up to the top of the namespace
+	tree to find the module namespace for gfc_get_symbol.
+
+2007-04-03  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/31304
+	* fortran/gfortran.h (gfc_charlen_int_kind): New prototype.
+	* fortran/trans-types.c (gfc_charlen_int_kind): New variable.
+	(gfc_init_types): Define gfc_charlen_int_kind. 
+	* fortran/trans.h (gfor_fndecl_string_repeat): Remove prototype.
+	* fortran/trans-decl.c (gfor_fndecl_string_repeat): Delete.
+	(gfc_build_intrinsic_function_decls): Don't set
+	gfor_fndecl_string_repeat.
+	* fortran/trans-intrinsic.c (gfc_conv_intrinsic_repeat): Rewrite
+	so that we don't have to call a library function.
+	* fortran/simplify.c (gfc_simplify_repeat): Perform the necessary
+	checks on the NCOPIES argument, and work with arbitrary size
+	arguments.
+
+2007-03-31  Tobias Burnus  <burnus@net-b.de>
+
+	* intrinsic.c (add_functions): Fix name of dummy argument
+	  for new_line and exit intrinsic.
+
+2007-03-31  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31160
+	* gfortran.texi: Add a section for the %VAL, %REF and %LOC
+	extensions.
+
+2007-03-30  Rafael Ávila de Espíndola  <espindola@google.com>
+
+	* trans-types.c (gfc_signed_or_unsigned_type): Remove.
+	(gfc_unsigned_type): Use get_signed_or_unsigned_type instead of
+	gfc_signed_or_unsigned_type.
+	(gfc_signed_type): Ditto.
+	* trans-types.h (gfc_signed_or_unsigned_type): Remove.
+	* f95-lang.c (LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE): Remove.
+
+2007-03-30  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	* symbol.c (gfc_find_gsymbol): Simplify, don't unconditionally
+	descend into all branches.
+
+2007-03-29  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	* intrinsic.c (conv_name): Let gfc_get_string handle the format.
+	(find_conv): Compare pointers instead of calling strcmp.
+	(find_sym): Likewise, but ensure that the compared pointer is in
+	the global string table.
+
+2007-03-28  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	* gfc-internals.texi: Fix output filename.  Merge type index into
+	concept index.  Start documentation of gfc_code structure.
+
+2007-03-26  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* gfc-internals.texi: New file,
+	* Make-lang.in: Add rules to convert it to dvi, pdf, and info.
+
+2007-03-26  Brooks Moses  <brooks.moses@codesourcery.com>
+ 
+	* error.c (show_locus): Remove always-false test.
+
+2007-03-26  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* lang.opt: Minor edits to descriptions.
+
+2007-03-25  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/30877
+	* fortran/interface.c (check_operator_interface): Implement
+	the standard checks on user operators extending intrinsic operators.
+	* fortran/resolve.c (resolve_operator): If the ranks of operators
+	don't match, don't error out but try the user-defined ones first.
+
+2007-03-24  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/30655
+	* expr.c (check_dimension): Fix logic of comparisons.
+
+2007-03-24  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31215
+	* trans-expr.c (gfc_apply_interface_mapping_to_expr): Return
+	int result that is non-zero if the expression is the function
+	result.  Only the characteristics of the result expression
+	can be used in a procedure interface, so simplify LEN in situ
+	using its character length.
+
+	PR fortran/31209
+	PR fortran/31200
+	* trans-expr.c (gfc_conv_function_call): Do not use
+	gfc_conv_expr_reference for actual pointer function with formal
+	target because a temporary is created that does not transfer
+	the reference correctly.  Do not indirect formal pointer
+	functions since it is the function reference that is needed.
+
+2007-03-24  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* gfortran.h: Edit comments on GFC_STD_*.
+
+2007-03-23  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* invoke.texi: Misc. small typo fixes.
+	(-Wcharacter-truncation): Add.
+	(-Wnonstd-intrinsics): Correct spelling.
+	(-std=): Edit.
+	(-fintrinsic-modules-path): Add.
+
+2007-03-23  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/30834
+	* arith.c (complex_pow): Rewrite to handle large power.
+	(gfc_arith_power): Handle large power in the real and integer
+	cases.
+
+2007-03-22  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/31262
+	* trans-const.c (gfc_conv_mpz_to_tree): Allow integer constants
+	larger than twice the width of a HOST_WIDE_INT.
+
+2007-03-22  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31193
+	* trans-intrinsic.c (gfc_size_in_bytes): Remove function.
+	(gfc_conv_intrinsic_array_transfer): Remove calls to previous.
+	Explicitly extract TREE_TYPEs for source and mold.  Use these
+	to calculate length of source and mold, except for characters,
+	where the se string_length is used.  For mold, the TREE_TYPE is
+	recalculated using gfc_get_character_type_len so that the
+	result is correctly cast for character literals and substrings.
+	Do not use gfc_typenode_for_spec for the final cast.
+
+2007-03-22  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	PR fortran/20897
+	* decl.c (gfc_match_derived_decl): Reliably reject
+	'doubleprecision' and 'doublecomplex' as type names.
+
+2007-03-19  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/31203
+	* trans-expr.c (gfc_trans_init_string_length): Length should
+	never be negative.
+	(gfc_conv_function_call): Likewise.
+
+2007-03-18  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30531
+	PR fortran/31086
+	* symbo.c : Add gfc_derived_types.
+	(gfc_free_dt_list): Free derived type list gfc_derived_types.
+	(gfc_free_namespace): Remove call to gfc_free_dt_list.
+	(gfc_symbol_done_2): Call  gfc_free_dt_list.
+	* gfortran.h : Declare gfc_derived_types to be external. Remove
+	derived types field from gfc_namespace.
+	* resolve.c (resolve_fl_derived): Refer to gfc_derived types
+	rather than namespace derived_types.
+	(resolve_fntype): Remove special treatment for module
+	derived type functions.
+	* trans-types.c (gfc_get_derived_type): Remove search for like
+	derived types.  Finish by copying back end declaration to like
+	derived types in the derived type list gfc_derived_types.
+
+	2007-03-17  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/31120
+	* trans-expr.c (gfc_conv_powi): Make n argument unsigned hwi.
+	(gfc_conv_cst_int_power): Handle integer exponent with care,
+	since it might be too large for us.
+
+2007-03-17  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/31184
+	* invoke.texi: Fix typo.
+
+2007-03-16  Tobias Burnus  <burnus@net-b.de>
+
+	* trans-decl.c (gfc_generate_function_code): Use all arguments of
+	  set_std.
+
+2007-03-15  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* gfortran.h (gfc_option_t): Add flag_backtrace field.
+	* lang.opt: Add -fbacktrace option.
+	* invoke.texi: Document the new option.
+	* trans-decl.c (gfc_build_builtin_function_decls): Add new
+	option to the call to set_std.
+	* options.c (gfc_init_options, gfc_handle_option): Handle the
+	new option.
+
+2007-03-15  Tobias Burnus  <burnus@gcc.gnu.org>
+	    Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30922
+	* decl.c (gfc_match_import): If the parent of the current name-
+	space is null, try looking for an imported symbol in the parent
+	of the proc_name interface.
+	* resolve.c (resolve_fl_variable): Do not check for blocking of
+	host association by a same symbol, if the symbol is in an
+	interface body.
+
+2007-03-15  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30879
+	* decl.c (match_data_constant): Before going on to try to match
+	a name, try to match a structure component.
+
+
+	PR fortran/30870
+	* resolve.c (resolve_actual_arglist): Do not reject a generic
+	actual argument if it has a same name specific interface.
+
+	PR fortran/31163
+	* trans-array.c (parse_interface): Do not nullify allocatable
+	components if the symbol has the saved attribute.
+
+2007-03-14  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* trans-array.c (gfc_trans_auto_array_allocation): Replace
+	fold(convert()) by fold_convert().
+	(gfc_duplicate_allocatable): Likewise.
+	* trans-intrinsic.c (gfc_conv_intrinsic_dot_product): Use
+	build_int_cst instead of converting an integer_zero_node
+	to the final type.
+
+2007-03-14  Jakub Jelinek  <jakub@redhat.com>
+
+	* module.c (mio_typespec): Don't look at ts->cl if not BT_CHARACTER.
+
+2007-03-13  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	PR fortran/30933
+	PR fortran/30948
+	PR fortran/30953
+	* intrinsics.texi (CHDIR): Fix argument names, note
+	that STATUS must be a default integer.
+	(CTIME): Fix argument names, note that RESULT must
+	be a default integer.
+	(EXIT): Note that STATUS must be a default integer.
+
+2007-03-13  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	PR fortran/28068
+	* intrinsic.texi: General whitespace cleanup, remove
+	comment about missing intrinsics.
+	(menu): Add lines for new entries listed below.
+	(ACOSH): Mention specific function DACOSH, correct
+	description phrasing.
+	(ASINH): Mention specific function DASINH, correct
+	description phrasing.
+	(ATANH): Mention specific function DATANH, correct
+	description phrasing.
+	(COS): Add index entry for CCOS.
+	(CPU_TIME): Correct "REAL" to "REAL(*)".
+	(EXP): Add index entry for CEXP.
+	(INT): Correct argument name to "A".
+	(INT2): New entry.
+	(INT8): New entry.
+	(LONG): New entry.
+	(MAX): Add index entries for specific variants.
+	(MCLOCK): New entry.
+	(MCLOCK8): New entry.
+	(SECNDS): Adjust to a more standard form.
+	(SECOND): New entry.
+	(TIME): Add cross-reference to MCLOCK.
+	(TIME8): Add cross-reference to MCLOCK8.
+
+2007-03-11  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30883
+	* parse.c (parse_interface): Use the default types from the
+	formal namespace if a function or its result do not have a type
+	after parsing the specification statements.
+
+2007-03-08  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* intrinsic.texi: (ICHAR) Improve internal I/O note.
+	(ACHAR): Reference it.
+	(CHAR): Reference it.
+	(IACHAR): Reference it.
+
+2007-03-08  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* intrinsic.texi: (LINK) Document function form.
+	(RENAME): Likewise.
+	(SYMLNK): Likewise.
+	(SYSTEM): Likewise.
+	(UNLINK): Likewise.
+
+2007-03-08  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* intrinsic.texi: minor typo fixes, removed prologue.
+	(FSEEK): moved to correct place in alphabetical order.
+
+2007-03-08  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/30947
+	* check.c (gfc_check_alarm_sub): Added check for default integer 
+	kind of status argument.
+	* iresolve.c (gfc_resolve_alarm_sub): Removed conversion of 
+	status argument.
+	* intrinsic.texi (ALARM): Extended documentation.
+
+2007-03-08  Daniel Franke  <franke.daniel@gmail.com>
+
+	* intrinsic.texi (GERROR, ISATTY, TTYNAM): New.
+	(ABORT, FLUSH, FNUM, IRAND, MALLOC, SIGNAL, SRAND): Fixed typo.
+	* intrinsic.c (add_subroutines): Adjusted dummy argument names 
+	of GERROR and TTYNAM.
+
+2007-07-08  Tobias Burnus  <burnus@net-b.de>
+
+	* module.c (gfc_match_use): Support renaming of operators
+	in USE statements.
+	* gfortran.texi (Fortran 2003 Status): Document support of
+	renaming of operators.
+
+2007-07-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/30973
+	* module.c (read_module): Always import module name as symbol.
+	(gfc_match_use): Disallow module name in the only clause of
+	a use statement.
+
+2007-03-08  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31011
+	* expr.c (find_array_section): Correct arithmetic for section
+	size.
+
+2007-03-07  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* iresolve.c (gfc_resolve_ishftc): Correct s_kind value.
+
+2007-03-06  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR documentation/30950
+	* intrinsic.texi (AND, CPU_TIME): Fix dummy argument names.
+	(FREE): Fix call syntax.
+
+2007-03-06  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* intrinsic.texi: Limit column widths to a total of .85.
+
+2007-03-05  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* gfortran.texi (GFortran and G77): Rewrite completely.
+
+2007-03-05  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* match.c (gfc_match_name): Expanded comment.
+
+2007-03-05  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* gfortran.texi (Old-style kind specifications): Document
+	special handling of old-style kind specifiers for COMPLEX.
+	* decl.c (gfc_match_old_kind_spec): Document kind/bytesize
+	assumptions for COMPLEX in comment.
+
+2007-03-05  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	PR 31050
+	* gfortranspec.c (lang_specific_driver): Update program
+	name and copyright date.
+
+2007-03-03  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30882
+	* check.c (dim_rank_check): The shape of subsections of
+	assumed-size arrays is known.
+
+2007-03-02  Paul Thomas  <pault@gcc.gnu.org>
+	    Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/30873
+	* decl.c (gfc_match_entry): Remove erroneous entry result check.
+
+2007-03-01  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* Make-lang.in: Add install-pdf target as copied from
+	automake v1.10 rules.
+
+2007-03-01  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/30865
+	* trans-intrinsic.c (gfc_conv_intrinsic_size): Compare pointers.
+
+2007-02-28  Tobias Burnus  <burnus@net-b.de>
+	    Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30888
+	PR fortran/30887
+	* resolve.c (resolve_actual_arglist): Allow by-value
+	arguments and non-default-kind for %VAL().
+	* trans-expr.c (conv_arglist_function): Allow
+	non-default-kind for %VAL().
+
+2007-02-28  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/30968
+	* primary.c (next_string_char): Correct reading a character
+	after the delimiter.
+	(match_string_constant): Print warning message only once.
+
+2007-02-27  Richard Guenther  <rguenther@suse.de>
+
+	* trans-array.c (structure_alloc_comps): Use correct type
+	for null pointer constant.
+
+2007-02-26  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* gfortran.texi: Standardize title page, remove version number
+	from copyright page.
+
+2007-02-26  Thomas Koenig  <Thomas.Koenig@online.de>
+	    Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30865
+	* trans-intrinsic.c (gfc_conv_intrinsic_size):
+	If dim is an optional argument, check for its
+	presence and call size0 or size1, respectively.
+
+2007-02-23  Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/30660
+	* resolve.c (has_default_initializer): New function.
+	(resolve_fl_variable): Call has_default_initializer to determine if
+	the derived type has a default initializer to its ultimate
+	components.
+
+
+2007-02-22  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	* options.c (set_default_std_flags): New function to consolidate
+	setting the flags.
+	(gfc_init_options): Use new function.
+	(gfc_handle_option): Use new function.
+
+2007-02-22  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* gfortran.texi (Old-style kind specifications): Document
+	special handling of old-style kind specifiers for COMPLEX.
+	* decl.c (gfc_match_old_kind_spec): Documented kind/bytesize
+	assumptions in comment.
+
+2007-02-21  Bernhard Fischer  <aldot@gcc.gnu.org>
+
+	* parse.c (next_free): Gooble spaces after OpenMP sentinel.
+
+2007-02-20  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR fortran/30869
+	* match.c (gfc_match_iterator): Remove conflict between
+	loop variable and pointer.
+
+2007-02-20  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/30522
+	* symbol.c (gfc_add_volatile): Allow to set VOLATILE
+	  attribute for host-associated variables.
+	* gfortran.h (symbol_attribute): Save namespace
+	  where VOLATILE has been set.
+	* trans-decl.c (gfc_finish_var_decl): Move variable
+	  declaration to the top.
+
+2007-02-20  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/30783
+	* resolve.c (resolve_symbol): Add character dummy VALUE check.
+
+2007-02-19  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR libfortran/30533
+	* fortran/iresolve.c (gfc_resolve_maxloc): Remove coercion of
+	argument to default integer.
+	(gfc_resolve_minloc): Likewise.
+
+2007-02-18  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/30681
+	* options.c (gfc_init_options): Relax warning level for obsolescent.
+	* match.c (match_arithmetic_if): Change to obsolescent from deleted.
+	(gfc_match_if): Same.
+
+2007-02-18  Roger Sayle  <roger@eyesopen.com>
+
+	* trans-array.c (gfc_build_constant_array_constructor): When the
+	shape of the constructor is known, use that to construct the
+	gfc_array_spec.
+	(gfc_trans_constant_array_constructor): Initialize the "info"
+	information for all of the dimensions of the array constructor.
+	(constant_array_constructor_loop_size): New function.
+	(gfc_trans_array_constructor): Use it to determine whether a
+	loop is suitable for "constant array constructor" optimization.
+
+	* trans-intrinsic.c (gfc_conv_intrinsic_anyall): Use fold_build2
+	instead of build2, to avoid conditions like "(a != b) != 0".
+
+2007-02-18  Roger Sayle  <roger@eyesopen.com>
+	    Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/30400
+	* match.c (match_forall_iterator): Use gfc_match_expr instead
+	of gfc_match_variable to match the iterator variable.  Return
+	MATCH_NO if not a variable.  Remove the reset of the symbol's
+	flavor in cleanup.
+
+2007-02-16  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/30793
+	* trans-decl.c (gfc_generate_function_code): Do not initialize
+	pointers to derived components.
+
+2007-02-15  Sandra Loosemore  <sandra@codesourcery.com>
+	    Brooks Moses  <brooks.moses@codesourcery.com>
+	    Lee Millward  <lee.millward@codesourcery.com>
+
+	* trans-expr.c (gfc_conv_power_op): Use build_call_expr.
+	(gfc_conv_string_tmp): Likewise.
+	(gfc_conv_concat_op): Likewise.
+	(gfc_build_compare_string): Likewise.
+	(gfc_conv_function_call): Use build_call_list instead of build3.
+
+	* trans-array.c (gfc_trans_allocate_array_storage): Use
+	build_call_expr.
+	(gfc_grow_array): Likewise.
+	(gfc_trans_array_ctor_element): Likewise.
+	(gfc_trans_array_constructor_value): Likewise.
+	(gfc_array_allocate): Likewise.
+	(gfc_array_deallocate): Likewise.
+	(gfc_trans_auto_array_allocation): Likewise.
+	(gfc_trans_dummy_array_bias): Likewise.
+	(gfc_conv_array_parameter): Likewise.
+	(gfc_trans_dealloc_allocated): Likewise.
+	(gfc_duplicate_allocatable): Likewise.
+
+	* trans-openmp.c (gfc_trans_omp_barrier): Use build_call_expr.
+	(gfc_trans_omp_flush): Likewise.
+
+	* trans-stmt.c (gfc_conv_elementel_dependencies): Use build_call_expr.
+	(gfc_trans_pause): Likewise.
+	(gfc_trans_stop): Likewise.
+	(gfc_trans_character_select): Likewise.
+	(gfc_do_allocate): Likewise.
+	(gfc_trans_assign_need_temp): Likewise.
+	(gfc_trans_pointer_assign_need_temp): Likewise.
+	(gfc_trans_forall_1): Likewise.
+	(gfc_trans_where_2): Likewise.
+	(gfc_trans_allocate): Likewise.
+	(gfc_trans_deallocate): Likewise.
+
+	* trans.c (gfc_trans_runtime_check): Use build_call_expr.
+
+	* trans-io.c (gfc_trans_open): Use build_call_expr.
+	(gfc_trans_close): Likewise.
+	(build_filepos): Likewise.
+	(gfc_trans_inquire): Likewise.
+	(NML_FIRST_ARG): Delete.
+	(NML_ADD_ARG): Delete.
+	(transfer_namelist_element): Use build_call_expr.
+	(build_dt): Likewise.
+	(gfc_trans_dt_end): Likewise.
+	(transfer_expr): Likewise.
+	(transfer_array-desc): Likewise.
+
+	* trans-decl.c (gfc_generate_function_code): Use build_call_expr.
+	(gfc_generate_constructors): Likewise.
+
+	* trans-intrinsic.c (gfc_conv_intrinsic_ctime): Use build_call_expr.
+	(gfc_conv_intrinsic_fdate): Likewise.
+	(gfc_conv_intrinsic_ttynam): Likewise.
+	(gfc_conv_intrinsic_array_transfer): Likewise.
+	(gfc_conv_associated): Likewise.
+	(gfc_conv_intrinsic_si_kind): Likewise.
+	(gfc_conv_intrinsic_trim): Likewise.
+	(gfc_conv_intrinsic_repeat: Likewise.
+	(gfc_conv_intrinsic_iargc): Likewise.
+
+2007-02-14  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/30779
+	* scanner.c (gfc_next_char_literal): Add check for end of file after
+	call to advance_line.
+
+2007-02-14  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/30799
+	* primary.c (match_logical_constant): Return MATCH_ERROR on invalid
+	kind.
+
+2007-02-14  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* misc.c (gfc_typename): Fix potential buffer overflow.
+
+2007-02-13  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30554
+	* module.c (read_module): Set pointer_info to referenced if the
+	symbol has no namespace.
+
+2007-02-12  Nick Clifton  <nickc@redhat.com>
+
+	* lang.opt: Add Warning attribute to warning options.
+
+2007-02-11  Daniel Franke  <franke.daniel@gmail.com>
+
+	* intrinsic.texi (HOSTNM): Fix typographical error in syntax.
+	(SLEEP): Added section and documentation.
+
+2007-02-11  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	PR fortran/30478
+	* decl.c (add_init_expr_to_sym): Remove ENUM specific code.
+	(variable_decl): Likewise.  Rewrap comment.
+	(match_attr_spec): Remove ENUM specific code.
+	(gfc_match_enum): Fix typo in error message.
+	(enumerator_decl): New function.
+	(gfc_match_enumerator_def): Use enumerator_decl instead of
+	variable_decl.  Adapt code accordingly.
+
+2007-02-11  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30554
+	* module.c (find_symtree_for_symbol): New function to return
+	a symtree that is not a "unique symtree" given a symbol.
+	(read_module): Do not automatically set pointer_info to
+	referenced because this inhibits the generation of a unique
+	symtree.  Recycle the existing symtree if possible by calling
+	find_symtree_for_symbol.
+
+	PR fortran/30319
+	* decl.c (add_init_expr_to_sym): Make new charlen for an array
+	constructor initializer.
+
+2007-02-10  Richard Henderson  <rth@redhat.com>, Jakub Jelinek  <jakub@redhat.com>
+
+	* f95-lang.c (gfc_init_builtin_functions): Add __emutls_get_address
+	and __emutls_register_common.
+	* openmp.c (gfc_match_omp_threadprivate): Don't error if !have_tls.
+	* trans-common.c (build_common_decl): Don't check have_tls.
+	* trans-decl.c (gfc_finish_var_decl): Likewise.
+	* types.def (BT_WORD, BT_FN_PTR_PTR): New.
+	(BT_FN_VOID_PTR_WORD_WORD_PTR): New.
+
+2007-02-09  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/30512
+	* trans-intrinsic.c (gfc_conv_intrinsic_minmaxloc,
+	  gfc_conv_intrinsic_minmaxval): Use HUGE-1 for most negative integer.
+
+2007-02-09  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/30720
+	* trans-array.c (gfc_trans_create_temp_array): Remove use of the
+	function argument. Always generate code for negative extent.
+	Simplify said code.
+	* trans-array.h (gfc_trans_create_temp_array): Change prototype.
+	* trans-expr.c (gfc_conv_function_call): Remove use of last argument
+	of gfc_trans_create_temp_array.
+	* trans-intrinsic.c (gfc_conv_intrinsic_array_transfer): Likewise.
+	* trans-stmt.c (gfc_conv_elemental_dependencies): Likewise.
+
+2007-02-08  Roger Sayle  <roger@eyesopen.com>
+
+	* trans-stmt.c (gfc_trans_forall_1): Optimize the cases where the
+	mask expression is a compile-time constant (".true." or ".false.").
+
+2007-02-04  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/30611
+	* trans-intrinsic.c (gfc_conv_intrinsic_repeat): Evaluate
+	arguments only once. Generate check that NCOPIES argument is not
+	negative.
+
+2007-02-04  Steven G. Kargl <kargl@gcc.gnu.org>
+
+	PR fortran/30605
+	* fortran/invoke.texi: Update documentation.
+	* fortran/options.c (gfc_post_options): Deal with tabs with -std=f2003
+	and -pedantic.
+
+2007-02-03  Kazu Hirata  <kazu@codesourcery.com>
+
+	* trans-array.c: Fix a comment typo.
+
+2007-02-03  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30514
+	* array.c (match_array_element_spec): If the length of an array is
+	negative, adjust the upper limit to make it zero length.
+
+	PR fortran/30660
+	* resolve.c (pure_function, resolve_function): Initialize name to
+	null to clear up build warnings.
+	(resolve_fl_variable): Look at components explicitly to check for
+	default initializer, rather than using gfc_default_initializer.
+
+2007-02-02  Steven G. Kargl <kargl@gcc.gnu.org>
+
+	PR fortran/30683
+	* resolve.c (resolve_generic_f): Check for non-NULL sym.
+
+2007-02-02  Roger Sayle  <roger@eyesopen.com>
+
+	* trans.c (gfc_build_array_ref): Use STRIP_TYPE_NOPS to eliminate
+	NON_LVALUE_EXPR nodes and useless type conversions.
+
+2007-02-02  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30284
+	PR fortran/30626
+	* trans-expr.c (gfc_conv_aliased_arg): Remove static attribute
+	from function and make sure that substring lengths are
+	translated.
+	(is_aliased_array): Remove static attribute.
+	* trans.c : Add prototypes for gfc_conv_aliased_arg and
+	is_aliased_array.
+	* trans-io.c (set_internal_unit): Add the post block to the
+	arguments of the function.  Use is_aliased_array to check if
+	temporary is needed; if so call gfc_conv_aliased_arg.
+	(build_dt): Pass the post block to set_internal_unit and
+	add to the block after all io activiy is done.
+
+2007-02-01  Roger Sayle  <roger@eyesopen.com>
+
+	* trans-array.c (gfc_conv_expr_descriptor): We don't need to use
+	a temporary array to pass a constant non-character array constructor.
+	Generalize the descriptor generation code to handle scalarizer
+	"info" without an array reference.
+
+2007-02-01  Roger Sayle  <roger@eyesopen.com>
+
+	* dependency.c (gfc_check_dependency) <EXPR_ARRAY>: Implement
+	dependency checking for array constructors.
+
+2007-02-01  Roger Sayle  <roger@eyesopen.com>
+
+	* trans-stmt.c (compute_overall_iter_number): Document function
+	arguments.  Generalize "unconditional forall nest with constant
+	bounds" optimization to eliminate unconditional inner loops with
+	constant bounds.
+
+2007-01-31  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/30520
+	* interface.c (compare_actual_formal): Check conformance between
+	  actual and VOLATILE dummy arguments.
+	* symbol.c (gfc_add_volatile): Allow setting of VOLATILE
+	  multiple times in different scopes.
+	* decl.c (gfc_match_volatile): Search symbol in host association.
+
+2007-01-31  Kazu Hirata  <kazu@codesourcery.com>
+
+	* simplify.c, trans-array.c: Fix comment typos.
+
+2007-01-30  Ralf Wildenhues  <Ralf.Wildenhues@gmx.de>
+
+	* invoke.texi (Code Gen Options): Fix abbreviation typo.
+	* intrinsic.texi (ACCESS, LSHIFT, RSHIFT): Fix typos.
+
+2007-01-30  Steve Ellcey  <sje@cup.hp.com>
+
+	PR fortran/30432
+	* trans-types.c (gfc_get_function_type): Do not add void_type_node
+	to empty arg list.
+	* trans-decl.c (create_function_arglist): Change assert.
+
+2007-01-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30554
+	* module.c (read_module): If a symbol is excluded by an ONLY
+	clause, check to see if there is a symtree already loaded. If
+	so, attach the symtree to the pointer_info.
+
+2007-01-28  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR libfortran/30389
+	* gfortran.h: Remove gfc_simplify_init_1.
+	* arith.h: Remove third argument from gfc_compare_string.
+	* arith.c (gfc_compare_expression): Remove third argument
+	from call to gfc_compare_string.
+	(gfc_compare_string): Remove third argument xcoll_table.
+	Remove use of xcoll_table.
+	* misc.c (gfc_init_1): Remove call to gfc_simplify_init_1.
+	* simplify.c (ascii_table): Remove.
+	(xascii_table): Likewise.
+	(gfc_simplify_achar): ICE if extract_int fails.  Remove use of
+	ascii_table.  Warn if -Wsurprising and value < 0 or > 127.
+	(gfc_simplify_char): ICE if extract_int fails. Error if
+	value < 0 or value > 255.
+	(gfc_simplify_iachar): Remove use of xascii_table.
+	Char values outside of 0..255 are an ICE.
+	(gfc_simplify_lge): Remove use of xascii_table.
+	(gfc_simplify_lgt): Likewise.
+	(gfc_simplify_lle): Likewise.
+	(gfc_simplify_llt): Likewise.
+	(invert_table): Remove.
+	(gfc_simplify_init_1): Remove.
+
+2007-01-27  Roger Sayle  <roger@eyesopen.com>
+
+	* trans-stmt.c (forall_info): Replace the next_nest and outer
+	fields that previously implemented a doubly-linked list with a
+	single prev_nest field (singly-linked list).
+	(gfc_trans_nested_forall_loop): The nested_forall_info argument
+	now denotes the innermost FORALL in the loop nest.
+	(compute_overall_iter_number): Use prev_nest instead of next_nest.
+	(gfc_trans_forall_1): Link/cons the new "info" to the head of the
+	nested_forall_info linked list.  Free the current "info" when done.
+
+2007-01-27  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30407
+	* trans-expr.c (gfc_conv_operator_assign): New function.
+	* trans.h : Add prototype for gfc_conv_operator_assign.
+	* trans-stmt.c (gfc_trans_where_assign): Add a gfc_symbol for
+	a potential operator assignment subroutine.  If it is non-NULL
+	call gfc_conv_operator_assign instead of the first assignment.
+	( gfc_trans_where_2): In the case of an operator assignment,
+	extract the argument expressions from the code for the
+	subroutine call and pass the symbol to gfc_trans_where_assign.
+	resolve.c (resolve_where, gfc_resolve_where_code_in_forall,
+	gfc_resolve_forall_body): Resolve the subroutine call for
+	operator assignments.
+
+2007-01-26  Steven Bosscher  <stevenb.gcc@gmail.com>
+	    Steven G. Kargl <kargl@gcc.gnu.org>
+
+	PR fortran/30278
+	* fortran/io.c (next_char): Deal with backslash escaped characters.
+	Issue warnings in non -std=gnu cases.
+	* fortran/primary.c (next_string_char): Issue warnings in non
+
+2007-01-26  Tobias Burnus  <burnus@net-b.de>
+
+	* lang-specs.h: Add support for .f03 and .F03 extensions.
+	* gfortran.texi: Document .f03 extension.
+	* options.c (form_from_filename): Recognize .f03.
+
+2007-01-25  Manuel Lopez-Ibanez  <manu@gcc.gnu.org>
+
+	PR fortran/30437
+	* lang.opt (Wall): Remove RejectNegative.
+	* options.c (gfc_handle_option): Wall can be disabled.
+	(set_Wall): Add a parameter for disabling Wall.
+	
+2007-01-23  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/30532
+	* scanner.c (load_line): Remove check fot ctrl-z and don't gobble.
+	
+2007-01-23  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30481
+	* match.c (gfc_match_namelist): Add check for assumed size character
+	in namelist and provide error if found.
+
+2007-01-21  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* intrinsic.texi (ACHAR): Added cross-references.
+	(CHAR): Put cross-references in alphabetical order.
+	(IACHAR): Added cross-references.
+	(ICHAR): Added cross-references.
+
+2007-01-20  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* intrinsic.texi: Edited all "Syntax" examples to a consistent form.
+	(MAXVAL): Corrected description of result characteristics.
+	(MINVAL): Same.
+	(UMASK): Added documentation.
+
+2007-01-20  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* openmp.c, matchexp.c, module.c, scanner.c, resolve.c, st.c,
+	parse.c, primary.c, options.c, misc.c, simplify.c: Next installment
+	in the massive whitespace patch.
+
+2007-01-20  Roger Sayle  <roger@eyesopen.com>
+
+	* module.c (mio_array_ref): The dimen_type fields of an array ref
+	are an enumerated type and can't be read/written directly with a
+	call to mio_integer.  Instead loop over and cast each element.
+
+2007-01-20  Roger Sayle  <roger@eyesopen.com>
+
+	* dependency.c (gfc_full_array_ref_p): Check that ref->next is NULL,
+	i.e. that the ARRAY_REF doesn't mention components.
+	* trans-array.c (gfc_constant_array_constructor_p): Export external
+	function renamed from constant_array_constructor_p.
+	(gfc_build_constant_array_constructor): Export.
+	(gfc_trans_array_constructor): Update call to the renamed function
+	constant_array_constructor_p.
+	* trans-array.h (gfc_constant_array_constructor_p): Prototype here.
+	(gfc_build_constant_array_constructor): Likewise.
+	* trans-expr.c (gfc_build_memcpy_call): New helper function split
+	out from gfc_trans_array_copy.
+	(gfc_trans_array_copy): Use gfc_build_memcpy_call.
+	(gfc_trans_array_constructor_copy): New function to optimize
+	assigning an entire array from a constant array constructor.
+	(gfc_trans_assignment): Call gfc_trans_array_constructor_copy
+	when appropriate.
+
+2007-01-20  Roger Sayle  <roger@eyesopen.com>
+
+	* trans-intrinsic.c (gfc_conv_intrinsic_sign): New branchless
+	implementation for the SIGN intrinsic with integral operands.
+	(gfc_conv_intrinsic_minmax): Fix whitespace.
+
+2007-01-20  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* gfortran.h (gfc_options_t): Add flag_allow_leading_underscore.
+	* lang.opt: Add -fallow-leading-underscore.
+	* match.c (gfc_match_name): Allow leading underscore in symbol
+	name if -fallow-leading-underscore is used.
+	* symbol.c (gfc_get_default_type): Add special case for symbol
+	names beginning with an underscore.
+	* trans-decl.c (gfc_get_extern_function_decl,
+	gfc_build_intrinsic_function_decls): Add _gfortran prefix to
+	library symbols selected_int_kind, selected_real_kind and 
+	all specifics.
+	* options.c (gfc_init_options, gfc_handle_option): Handle the
+	new -fallow-leading-underscore option.
+
+2007-01-20  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/30446
+	* options.c (gfc_handle_module_path_options): Path used in -J
+	option is now added to the module search path.
+
+2007-01-20  Richard Guenther  <rguenther@suse.de>
+
+	PR fortran/30223
+	* f95-lang.c (gfc_init_builtin_functions): Provide cbrt and
+	cexpi builtins if we have TARGET_C99_FUNCTIONS.  Provide
+	sincos builtins if the target has sincos.
+
+2007-01-19  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* intrinsic.texi (MATMUL): Corrected a typo.
+	(MAX): Separated @var arguments.
+	(MIN): Separated @var arguments.
+
+2007-01-19  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* intrinsic.texi: general whitespace cleanup.
+	(menu): Added TIME8, removed UNMASK.
+	(AINT): Clarified argument requirement.
+	(ANINT): Clarified argument requirement.
+	(CEILING): Clarified argument requirement.
+	(CHAR): Clarified argument requirement.
+	(CMPLX): Clarified argument requirement.
+	(DCMPLX): Clarified argument requirement.
+	(FGET): Line rewrapping.
+	(FLOOR): Clarified argument requirement.
+	(GMTIME): Added documentation.
+	(IAND): Added cross-reference.
+	(IBCLR): Added cross-reference.
+	(IBSET): Added cross-reference.
+	(IEOR): Added cross-reference.
+	(INT): Collapsed examples, clarified argument requirement.
+	(IOR): Added cross-references.
+	(LEN_TRIM): Corrected result kind.
+	(LINK): Added cross-reference.
+	(LLT): Removed "documentation pending".
+	(LOGICAL): Added documentation.
+	(LSHIFT): Added documentation.
+	(LTIME): Added documentation.
+	(MATMUL): Added documentation.
+	(MAX): Added documentation.
+	(MAXLOC): Added documentation.
+	(MAXVAL): Added documentation.
+	(MERGE): Added documentation.
+	(MIN): Added documentation.
+	(MINLOC): Added documentation.
+	(MINVAL): Added documentation.
+	(MVBITS): Moved to correct place, added documentation.
+	(NOT): Added documentation.
+	(PERROR): Added documentation.
+	(RAN): Moved to correct place, added documentation.
+	(REAL): Clarified argument requirement.
+	(RENAME): Added documentation.
+	(RSHIFT): Clarified argument requirement.
+	(SIGN): Corrected table specification.
+	(SYMLNK): Added documentation.
+	(SYSTEM): Added documentation.
+	(TIME): Added documentation.
+	(TIME8): Added section and documentation.
+	(UNMASK): Removed erroneous section.
+
+2007-01-18  H.J. Lu  <hongjiu.lu@intel.com>
+
+	* trans-stmt.c (compute_overall_iter_number): Fix a typo.
+
+2007-01-18  Roger Sayle  <roger@eyesopen.com>
+
+	* trans-expr.c (copyable_array_p): Consider user derived types without
+	allocatable components to be copyable.
+
+2007-01-18  Roger Sayle  <roger@eyesopen.com>
+
+	* trans-stmt.c (compute_overall_iter_number): Enhance to precompute
+	the number of interations in unconditional FORALL nests with constant
+	bounds.
+
+2007-01-18  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+	    Tobias Burnus  <burnus@net-b.de>
+
+	PR libfortran/29649
+	* gfortran.h (gfc_option_t): Add flag_dump_core.
+	* lang.opt: Add -fdump-core option.
+	* invoke.texi: Document the new options.
+	* trans-decl.c (gfc_build_builtin_function_decls): Add new
+	  options to the call to set_std.
+	* options.c (gfc_init_options, gfc_handle_option): Set the
+	  new options.
+
+2007-01-17  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30476
+	* module.c (load_generic_interfaces): Make the marking of the
+	symbol as ambiguous conditional on the module names being
+	different.
+	(write_generic): Ensure that the generic interface has a
+	non-NULL module field.
+
+2007-01-16  Roger Sayle  <roger@eyesopen.com>
+
+	PR fortran/30404
+	* trans-stmt.c (forall_info): Remove pmask field.
+	(gfc_trans_forall_loop): Remove NVAR argument, instead assume that
+	NVAR covers all the interation variables in the current forall_info.
+	Add an extra OUTER parameter, which specified the loop header in
+	which to place mask index initializations.
+	(gfc_trans_nested_forall_loop): Remove NEST_FLAG argument.
+	Change the semantics of MASK_FLAG to only control the mask in the
+	innermost loop.
+	(compute_overall_iter_number): Optimize the trivial case of a
+	top-level loop having a constant number of iterations.  Update
+	call to gfc_trans_nested_forall_loop.  Calculate the number of
+	times the inner loop will be executed, not to size of the 
+	iteration space.
+	(allocate_temp_for_forall_nest_1): Reuse SIZE as BYTESIZE when
+	sizeof(type) == 1.  Tidy up.
+	(gfc_trans_assign_need_temp): Remove NEST_FLAG argument from calls
+	to gfc_trans_nested_forall_loop.
+	(gfc_trans_pointer_assign_need_temp): Likewise.
+	(gfc_trans_forall_1): Remove unused BYTESIZE, TMPVAR, SIZEVAR and
+	LENVAR local variables.  Split mask allocation into a separate
+	hunk/pass from mask population.  Use allocate_temp_for_forall_nest
+	to allocate the FORALL mask with the correct size.  Update calls
+	to gfc_trans_nested_forall_loop.
+	(gfc_evaluate_where_mask): Update call to
+	gfc_trans_nested_forall_loop.
+	(gfc_trans_where_2): Likewise.
+
+2007-01-15  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/28172
+	* trans-stmt.c (gfc_trans_call): If it does not have one, get
+	a backend_decl for an alternate return.
+
+	PR fortran/29389
+	* resolve.c (pure_function): Statement functions are pure. Note
+	that this will have to recurse to comply fully with F95.
+
+	PR fortran/29712
+	* resolve.c (resolve_function): Only a reference to the final
+	dimension of an assumed size array is an error in an inquiry
+	function.
+
+	PR fortran/30283
+	* resolve.c (resolve_function): Make sure that the function
+	expression has a type.
+
+2007-01-14  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30410
+	* trans-decl.c (gfc_sym_mangled_function_id): Module, external
+	symbols must not have the module name prepended.
+
+2007-01-11  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR libfortran/30415
+	* iresolve.c (gfc_resolve_maxloc): If the rank
+	of the return array is nonzero and we process an
+	integer array smaller than default kind, coerce
+	the array to default integer.
+	* iresolve.c (gfc_resolve_minloc): Likewise.
+
+2007-01-11  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* simplify.c: Update copyright to 2007.
+	* scanner.c: Same.
+
+2007-01-11  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/30430
+	* scanner.c (gfc_release_include_path): Free gfc_option.module_dir
+	only once!
+
+2007-01-09  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* simplify.c (gfc_simplify_ibclr): Fix POS comparison.
+	(gfc_simplify_ibset): Same.
+
+2007-01-09  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	PR 30381
+	PR 30420
+	* simplify.c (convert_mpz_to_unsigned): New function.
+	(convert_mpz_to_signed): New function, largely based on
+	twos_complement().
+	(twos_complement): Removed.
+	(gfc_simplify_ibclr): Add conversions to and from an
+	unsigned representation before bit-twiddling.
+	(gfc_simplify_ibset): Same.
+	(gfc_simplify_ishftc): Add checks for overly large
+	constant arguments, only check the third argument if
+	it's present, carry over high bits into	the result as
+	appropriate, and perform the final conversion back to
+	a signed representation using the correct sign bit.
+	(gfc_simplify_not): Removed unnecessary masking.
+
+2007-01-09  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30408
+	* resolve.c (resolve_code): Use the code->expr character length
+	directly to set length of llen.
+
+2007-01-09  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/30408
+	* lang.opt: Add Wcharacter_truncation option.
+	* options.c (gfc_init_options): Initialize
+	gfc_option.warn_character_truncation to zero.
+	(gfc_handle_option): Add case for OPT_Wcharacter_truncation.
+
+2007-01-08  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* interface.c, intrinsic.c, gfortranspec.c, io.c, f95-lang.c,
+	iresolve.c, match.c: Update Copyright years.  Whitespace.
+
+2007-01-08  Richard Guenther  <rguenther@suse.de>
+
+	* trans-io.c (transfer_array_desc): Use build_int_cst instead
+	of build_int_cstu.
+
+2007-01-08  Roger Sayle  <roger@eyesopen.com>
+
+	* trans-array.c (constant_array_constructor_p): New function to
+	determine whether an array constructor consists only of constant
+	elements, and if so return it's size.
+	(gfc_build_constant_array_constructor): Construct a statically
+	initialized gfortran array for a given EXPR_ARRAY.
+	(gfc_trans_constant_array_constructor): Efficiently scalarize
+	a constant array constructor.
+	(gfc_trans_array_constructor): Tidy up use of CONST_STRING.
+	Special case scalarization of constant array constructors, all of
+	whose elements are specified, using constant_array_constructor_p 
+	and gfc_trans_constant_array_constructor.
+	(gfc_conv_scalarized_array_ref): Check whetger info->offset is zero
+	before adding it to index, to avoid creating a NON_LVALUE_EXPR.
+
+2007-01-08  Kazu Hirata  <kazu@codesourcery.com>
+
+	gfortran.texi: Fix typos.
+
+2007-01-07  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* decl.c, dump-parse-tree.c, error.c, data.c, expr.c, dependency.c,
+	convert.c: Update Copyright dates.  Fix whitespace.
+
+2007-01-07  Bernhard Fischer  <aldot@gcc.gnu.org>
+
+	* data.c (gfc_assign_data_value): Fix whitespace.
+
+2007-01-07  Bernhard Fischer  <aldot@gcc.gnu.org>
+
+	* trans-array.c (gfc_trans_create_temp_array, gfc_array_init_size):
+	Commentary typo fix.
+
+2007-01-07  Bernhard Fischer  <aldot@gcc.gnu.org>
+
+	PR fortran/27698
+	* match.c (gfc_match_name): Print diagnostics for invalid
+	character in names.
+
+2007-01-06  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* array.c: Fix whitespace in comment table.
+
+2007-01-06  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* array.c, bbt.c, check.c: Update copyright years.  Whitespace.
+
+2007-01-06  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* arith.c: Update copyright years.  Whitespace.
+
+2007-01-05  Roger Sayle  <roger@eyesopen.com>
+
+	* trans-expr.c (gfc_trans_assignment_1): New subroutine to scalarize
+	array assignments split out from gfc_trans_assignment.
+	(gfc_trans_array_copy): New function to implement array to array
+	copies via calls to __builtin_memcpy.
+	(copyable_array_p): New helper function to identify an array of
+	simple/POD types, that may be copied/assigned using memcpy.
+	(gfc_trans_assignment): Use gfc_trans_array_copy to handle simple
+	whole array assignments considered suitable by copyable_array_p.
+	Invoke gfc_trans_assignment_1 to perform the fallback scalarization.
+
+2007-01-05  Roger Sayle  <roger@eyesopen.com>
+
+	* trans-array.c (gfc_trans_array_constructor_value): Make the
+	static const "data" array as TREE_READONLY.
+	* trans-stmt.c (gfc_trans_character_select): Likewise.
+
+2007-01-05  Roger Sayle  <roger@eyesopen.com>
+
+	* trans-array.c (gfc_conv_loop_setup): Test whether the loop
+	stride is one, to avoid fold_build2 introducing a useless
+	NON_LVALUE_EXPR node.
+
+2007-01-05  Tobias Burnus  <burnus@net-b.de>
+
+	* symbol.c (check_conflict): Fix error message.
+
+2007-01-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/23232
+	* decl.c (gfc_in_match_data, gfc_set_in_match_data): New
+	functions to signal that a DATA statement is being matched.
+	(gfc_match_data): Call gfc_set_in_match_data on entry and on
+	exit.
+	* gfortran.h : Add prototypes for above.
+	* expr.c (check_init_expr): Avoid check on parameter or
+	variable if gfc_in_match_data is true.
+	(gfc_match_init_expr): Do not call error on non-reduction of
+	expression if gfc_in_match_data is true.
+
+	PR fortran/27996
+	PR fortran/27998
+	* decl.c (gfc_set_constant_character_len): Add boolean arg to
+	flag array constructor resolution.  Warn if string is being
+	truncated.  Standard dependent error if string is padded. Set
+	new arg to false for all three calls to
+	gfc_set_constant_character_len.
+	* match.h : Add boolean arg to prototype for
+	gfc_set_constant_character_len.
+	* gfortran.h : Add warn_character_truncation to gfc_options.
+	* options.c (set_Wall): Set warn_character_truncation if -Wall
+	is set.
+	* resolve.c (resolve_code): Warn if rhs string in character
+	assignment has to be truncated.
+	* array.c (gfc_resolve_character_array_constructor): Set new
+	argument to true for call to gfc_set_constant_character_len.
+
+2007-01-05  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/29624
+	* interface.c (compare_parameter_intent): New function.
+	  (check_intents): Support pointer intents.
+	* symbol.c (check_conflict): Support pointer intents,
+	  better conflict_std message.
+	* expr.c (gfc_check_assign,gfc_check_pointer_assign):
+	  Support pointer intents.
+	* resolve.c (resolve_deallocate_expr,resolve_allocate_expr):
+	  Support pointer intents.
+
+2007-01-03  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	PR 30371
+	* check.c (gfc_check_kill_sub): Add checks for non-scalar
+	arguments.
+
+2007-01-04  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* intrinsic.texi: Minor cleanup, reflowing overlong
+	paragraphs, and correcting whitespace.
+
+2007-01-04  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* intrinsic.texi (LBOUND): Add documentation.
+	(LGE): Add documentation.
+	(LGT): Add documentation.
+	(LINK): Add documentation.
+	(LLE): Add documentation.
+	(LLT): Add documentation.
+	(LNBLNK): Add documentation.
+	(UBOUND): Add documentation.
+	(UNLINK): Add documentation.
+
+2007-01-04  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* intrinsic.texi (IAND): Clarify argument specifications.
+	(IBCLR): Add documentation.
+	(IBITS): Add documentation.
+	(IBSET): Add documentation.
+	(IEOR): Add documentation.
+	(IERRNO): Add documentation.
+	(INDEX): Add documentation.
+	(IOR): Add documentation.
+	(ISHFT): Add documentation.
+	(ISHFTC): Add documentation.
+	(KILL): Add documentation.
+	(LEN_TRIM): Add documentation.
+
+2007-01-04  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	PR 30235
+	* interface.c (compare_actual_formal): check for
+	alternate returns when iterating over non-present
+	arguments.
+
+2007-01-04  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* invoke.texi: Update manpage copyright to include 2007.
+
+2007-01-04  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* gfortran.texi: Update copyright to include 2007.
+	* intrinsic.texi: Update copyright to include 2007.
+	* invoke.texi: Update copyright to include 2007.
+
+2007-01-02  Tobias Burnus  <burnus@net-b.de>
+	    Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/30276
+	* scanner.c (open_included_file): Revert patch.
+	  (gfc_open_included_file): Support absolute pathnames.
+	  (gfc_open_intrinsic_module): Support absolute pathnames.
+
+2007-01-03  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* gfortran.texi (GNU Fortran and GCC): Rewrite
+
+2007-01-03  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* gfortran.texi (Introduction): Lower "Part I:
+	Introduction" to a chapter, renumber Parts II and III to
+	Parts I and II.
+	* intrinsic.texi (Introduction): Rename to "Introduction
+	to Intrinsics" to avoid conflict with the new chapter.
+
+2007-01-03  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* intrinsic.texi (Introduction): Rewrite first paragraph.
+
+2007-01-03  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* invoke.texi (OpenMP): Added index entry.
+	* gfortran.texi (title page): Removed erroneous '*'.
+
+2007-01-03  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* gfortran.texi (GFORTRAN_DEFAULT_RECL): Added units
+	to description.
+	(Extensions): Miscellaneous minor rewriting and copyediting.
+	(BOZ-literal constants): Renamed from Hexadecimal constants.
+	(Hollerith constants support): Added explanation and 
+	suggestions for standard-conforming modern equivalents.
+
+2007-01-03  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* intrinsic.texi: Improvements to index entries; change
+	@findex entries to @cindex entries.
+	* invoke.texi: Standardize and improve index entries.
+	* gfortran.texi: Fix @code in one index entry.
+
+2007-01-03  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* invoke.texi: Change @code-type macros to appropriate
+	variants (@command, @option, etc.)
+	* gfortran.texi: Same.
+
+2007-01-03  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	* intrinsic.texi: Various minor cleanups.
+
+2007-01-02  Steven G. Kargl  <kargls@comcast.net>
+
+	* trans-intrinsic.c (gfc_conv_intrinsic_ibits): Fix call to
+	build_int_cst.
+
+2007-01-02  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/30276
+	* scanner.c (open_included_file): Support full-path filenames.
+
+2007-01-02  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/20896
+	* interface.c (check_sym_interfaces): Remove call to
+	resolve_global_procedure.
+	gfortran.h : Remove prototype for resolve_global_procedure.
+	resolve.c (resolve_global_procedure): Add static attribute
+	to function declaration.
+
+2007-01-01  Steven G. Kargl  <kargls@comcast.net>
+
+	* ChangeLog: Copy to ...
+	* ChangeLog-2006: here.
+
+
+Copyright (C) 2007 Free Software Foundation, Inc.
+
+Copying and distribution of this file, with or without modification,
+are permitted in any medium without royalty provided the copyright
+notice and this notice are preserved.
diff --git a/gcc-4.9/gcc/fortran/ChangeLog-2008 b/gcc-4.9/gcc/fortran/ChangeLog-2008
new file mode 100644
index 000000000..6fe1eea16
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/ChangeLog-2008
@@ -0,0 +1,4142 @@
+2008-12-31  Daniel Franke  <franke.daniel@gmail.com>
+
+	* check.c (dim_rank_check): Fixed checking of dimension argument
+	if array is of type EXPR_ARRAY.
+
+2008-12-22  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/38602
+	* trans-decl.c (init_intent_out_dt): Allow for optional args.
+
+2008-12-21  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/38398
+	* io.c: Add error checks for g0 formatting and provide adjustment of
+	error loci for improved error messages.
+
+2008-12-21  Arjen Markus  <arjen.markus@wldelft.nl>
+	    Daniel Kraft  <d@domob.eu>
+
+	PR fortran/37605
+	* gfortran.texi: Fixed some typos and some minor style improvements.
+	* intrinsic.texi: Some clarifications and typo-fixes.
+	* invoke.texi: Better documenation of the behaviour of the
+	-fdefault-*-8 options and some other fixes.
+
+2008-12-18  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/31822
+	* gfortran.h (gfc_check_same_strlen): Made public.
+	* trans.h (gfc_trans_same_strlen_check): Made public.
+	* check.c (gfc_check_same_strlen): Made public and adapted error
+	message output to be useful not only for intrinsics.
+	(gfc_check_merge): Adapt to gfc_check_same_strlen change.
+	* expr.c (gfc_check_pointer_assign): Use gfc_check_same_strlen for
+	string length compile-time check.
+	* trans-expr.c (gfc_trans_pointer_assignment): Add runtime-check for
+	equal string lengths using gfc_trans_same_strlen_check.
+	* trans-intrinsic.c (gfc_trans_same_strlen_check): Renamed and made
+	public from conv_same_strlen_check.
+	(gfc_conv_intrinsic_merge): Adapted accordingly.
+
+2008-12-17  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/38137
+	* trans-intrinsic.c (conv_same_strlen_check): New method.
+	(gfc_conv_intrinsic_merge): Call it here to actually do the check.
+
+2008-12-15  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/38487
+	* dependency.c (gfc_is_data_pointer): New function.
+	(gfc_check_argument_var_dependency): Disable the warning
+	in the pointer case.
+	(gfc_check_dependency): Use gfc_is_data_pointer.
+
+2008-12-15  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/38113
+	* error.c (show_locus): Start counting columns at 0.
+	* primary.c (match_actual_arg): Eat spaces
+	before copying the current locus.
+	(match_variable): Copy the locus before matching.
+
+2008-12-14  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/35937
+	* trans-expr.c (gfc_finish_interface_mapping): Fold convert the
+	character length to gfc_charlen_type_node.
+
+2008-12-12  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/36355
+	* check.c (gfc_check_matmul): Fixed error message for invalid
+	types to correctly identify the offending argument, added check
+	for mismatching types.
+
+2008-12-11  Richard Guenther  <rguenther@suse.de>
+
+	* Make-lang.in (install-finclude-dir): Use correct mode argument
+	for mkinstalldirs.
+
+2008-12-09  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/36376
+	PR fortran/37468
+	* lang-specs.h: Pass on -i* options to f951 to (probably) report
+	them as unknown. Duplicate gcc.c (cpp_options), but omit
+	-fpch-preprocess on -save-temps.
+
+2008-12-09  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/36457
+	* lang.opt: Added option idirafter.
+	* cpp.h (gfc_cpp_add_include_path_after): New prototype.
+	* cpp.c (gfc_cpp_handle_option): Recognize and handle OPT_dirafter.
+	(gfc_cpp_add_include_path_after): New, adds user-defined search path
+	after any other paths.
+	* invoke.texi (idirafter): New.
+	(no-range-check): Fixed entry in option-index.
+
+2008-12-09  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/37469
+	* expr.c (find_array_element): Simplify array bounds.
+	Assert that both bounds are constant expressions.
+
+2008-12-09  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/35983
+	* trans-expr.c (gfc_trans_subcomponent_assign):
+	Add se's pre and post blocks to current block.
+	(gfc_trans_structure_assign): Remove specific handling
+	of C_NULL_PTR and C_NULL_FUNPTR.
+
+2008-12-06  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/38425
+	* io.c (check_io_constraints): Check constraints on REC=, POS=, and
+	internal unit with POS=. Fix punctuation on a few error messages.
+
+2008-12-06  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/38415
+	* expr.c (gfc_check_pointer_assign): Added a check for abstract
+	interfaces in procedure pointer assignments, removed check involving
+	gfc_compare_interfaces until PR38290 is fixed completely.
+
+2008-12-05  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/38291
+	* io.c (match_dt_element): Use dt->pos in matcher.
+	(gfc_free_dt): Free dt->pos after use.
+	(gfc_resolve_dt): Use dt->pos in resolution of stream position tag.
+
+2008-12-05  Sebastian Pop  <sebastian.pop@amd.com>
+
+	PR bootstrap/38262
+	* Make-lang.in (f951): Add BACKENDLIBS, remove GMPLIBS.
+
+2008-12-02  Jakub Jelinek  <jakub@redhat.com>
+	    Diego Novillo  <dnovillo@google.com>
+
+	* Make-lang.in (install-finclude-dir): Use mkinstalldirs
+	and don't remove the finclude directory beforehand.
+
+2008-12-02  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/36704
+	PR fortran/38290
+	* decl.c (match_result): Result may be a standard variable or a
+	procedure pointer.
+	* expr.c (gfc_check_pointer_assign): Additional checks for procedure
+	pointer assignments.
+	* primary.c (gfc_match_rvalue): Bugfix for procedure pointer
+	assignments.
+	* resolve.c (resolve_function): Check for attr.subroutine.
+	* symbol.c (check_conflict): Addtional checks for RESULT statements.
+	* trans-types.c (gfc_sym_type,gfc_get_function_type): Support procedure
+	pointers as function result.
+
+2008-12-01  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/38252
+	* parse.c (parse_spec): Skip statement order check in case
+	of a CONTAINS statement.
+
+2008-11-30  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/37779
+	* gfortran.h (struct gfc_entry_list): Fixed typo in comment.
+	* resolve.c (is_illegal_recursion): New method.
+	(resolve_procedure_expression): Use new is_illegal_recursion instead of
+	direct check and handle function symbols correctly.
+	(resolve_actual_arglist): Removed useless recursion check.
+	(resolve_function): Use is_illegal_recursion instead of direct check.
+	(resolve_call): Ditto.
+
+2008-11-29  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* trans-array.c (gfc_conv_array_parameter): Guard union access.
+
+2008-11-29  Janus Weil  <janus@gcc.gnu.org>
+	    Mikael Morin <mikael@gcc.gnu.org>
+
+	PR fortran/38289
+	PR fortran/38290
+	* decl.c (match_procedure_decl): Handle whitespaces.
+	* resolve.c (resolve_specific_s0): Bugfix in check for intrinsic
+	interface.
+
+2008-11-25  H.J. Lu  <hongjiu.lu@intel.com>
+
+	* module.c (gfc_dump_module): Report error on unlink only if
+	errno != ENOENT.
+
+2008-11-25  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/36463
+	* expr.c (replace_symbol): Don't replace the symtree
+	if the expresion is an intrinsic function. Don't create
+	non-existent symtrees.  Use symbol's name instead of symtree's,
+	different in case of module procedure dummy arguments.
+
+2008-11-25  Jan Kratochvil  <jan.kratochvil@redhat.com>
+
+	PR fortran/38248
+	* module.c (gfc_dump_module): Check rename/unlink syscalls errors.
+
+2008-11-25  Eric Botcazou  <ebotcazou@adacore.com>
+
+	PR fortran/37319
+	* parse.c (match_deferred_characteristics): Make sure 'name' is
+	initialized before reading it.
+
+2008-11-24  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/37803
+	* arith.c (gfc_check_real_range): Add mpfr_check_range.
+	* simplify.c (gfc_simplify_nearest): Add mpfr_check_range.
+
+2008-11-24  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/38184
+	* simplify.c (is_constant_array_expr): Return true instead of false
+	if the array constructor is empty.
+
+2008-11-24  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/37779
+	* resolve.c (resolve_procedure_expression): New method.
+	(resolve_variable): Call it.
+	(resolve_actual_arglist): Call gfc_resolve_expr for procedure arguments.
+
+2008-11-24  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34820
+	* trans-expr.c (gfc_conv_function_call): Remove all code to
+	deallocate intent out derived types with allocatable
+	components.
+	(gfc_trans_assignment_1): An assignment from a scalar to an
+	array of derived types with allocatable components, requires
+	a deep copy to each array element and deallocation of the
+	converted rhs expression afterwards.
+	* trans-array.c : Minor whitespace.
+	* trans-decl.c (init_intent_out_dt): Add code to deallocate
+	allocatable components of derived types with intent out.
+	(generate_local_decl): If these types are unused, set them
+	referenced anyway but allow the uninitialized warning.
+
+	PR fortran/34143
+	* trans-expr.c (gfc_trans_subcomponent_assign): If a conversion
+	expression has a null data pointer argument, nullify the
+	allocatable component.
+
+	PR fortran/32795
+	* trans-expr.c (gfc_trans_subcomponent_assign): Only nullify
+	the data pointer if the source is not a variable.
+
+2008-11-23  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/37735
+	* trans-array.c (structure_alloc_comps): Do not duplicate the
+	descriptor if this is a descriptorless array!
+
+2008-11-12  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/38160
+	* trans-types.c (gfc_validate_c_kind): Remove function.
+	* decl.c (gfc_match_kind_spec): Add C kind parameter check.
+	(verify_bind_c_derived_type): Remove gfc_validate_c_kind call.
+	(verify_c_interop_param): Update call.
+	* gfortran.h (verify_bind_c_derived_type): Update prototype.
+	(gfc_validate_c_kind): Remove.
+	* symbol.c (verify_bind_c_derived_type): Update verify_c_interop call.
+	* resolve.c (gfc_iso_c_func_interface): Ditto.
+
+2008-11-22  Jakub Jelinek  <jakub@redhat.com>
+
+	PR libfortran/37839
+	* trans-io.c (gfc_build_io_library_fndecls): Decrease pad size back
+	to 16 pointers plus 32 integers.  Don't use max integer kind
+	alignment, only gfc_intio_kind's alignment.
+	(gfc_trans_inquire): Only set flags2 if mask2 is non-zero.
+	* ioparm.def: Fix order, bitmasks and types of inquire round, sign
+	and pending fields.  Move u in dt before id.
+	* io.c (gfc_free_inquire): Free decimal and size exprs.
+	(match_inquire_element): Match size instead of matching blank twice.
+	(gfc_resolve_inquire): Resolve size.
+
+2008-11-20  Jakub Jelinek  <jakub@redhat.com>
+
+	PR middle-end/29215
+	* trans-array.c (trans_array_constructor_value,
+	gfc_build_constant_array_constructor): Fill in TREE_PURPOSE.
+
+	* trans-intrinsic.c (gfc_conv_intrinsic_minmaxloc): Use
+	gfc_index_one_node.
+	(gfc_conv_intrinsic_size): Use gfc_index_{zero,one}_node.
+
+	PR fortran/38181
+	* trans-intrinsic.c (gfc_conv_intrinsic_size): Inline 2 argument
+	size if the second argument is not optional and one argument size
+	for rank 1 arrays.
+
+2008-11-19  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/38171
+	* module.c (load_equiv): Regression fix; check that equivalence
+	members come from the same module only.
+
+2008-11-16  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/35681
+	* dependency.c (gfc_check_argument_var_dependency): Add
+	elemental check flag. Issue a warning if we find a dependency
+	but don't generate a temporary. Add the case of an elemental
+	function call as actual argument to an elemental procedure.
+	Add the case of an operator expression as actual argument
+	to an elemental procedure.
+	(gfc_check_argument_dependency): Add elemental check flag.
+	Update calls to gfc_check_argument_var_dependency.
+	(gfc_check_fncall_dependency): Add elemental check flag.
+	Update call to gfc_check_argument_dependency.
+	* trans-stmt.c (gfc_trans_call): Make call to
+	gfc_conv_elemental_dependencies unconditional, but with a flag
+	whether we should check dependencies between variables.
+	(gfc_conv_elemental_dependencies): Add elemental check flag.
+	Update call to gfc_check_fncall_dependency.
+	* trans-expr.c (gfc_trans_arrayfunc_assign): Update call to
+	gfc_check_fncall_dependency.
+	* resolve.c (find_noncopying_intrinsics): Update call to
+	gfc_check_fncall_dependency.
+	* dependency.h (enum gfc_dep_check): New enum.
+	(gfc_check_fncall_dependency): Update prototype.
+
+2008-11-16  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/37992
+	* gfortran.h (gfc_namespace): Added member old_cl_list, 
+	backup of cl_list.
+	(gfc_free_charlen): Added prototype.
+	* symbol.c (gfc_free_charlen): New function.
+	(gfc_free_namespace): Use gfc_free_charlen.
+	* parse.c (next_statement): Backup gfc_current_ns->cl_list.
+	(reject_statement): Restore gfc_current_ns->cl_list.
+	Free cl_list's elements before dropping them.
+
+2008-11-16  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/38095
+	* trans-expr.c (gfc_map_intrinsic_function): Fix pointer access.
+
+2008-11-16  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/38119
+	* trans-array.c (gfc_trans_create_temp_array): Set the
+	loop->from to zero and the renormalisation of loop->to for all
+	dimensions.
+
+2008-11-16  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/37926
+	* trans-expr.c (gfc_free_interface_mapping): Null sym->formal
+	(gfc_add_interface_mapping): Copy the pointer to the formal
+	arglist, rather than using copy_formal_args - fixes regression.
+
+2008-11-15  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/37926
+	* trans-expr.c (gfc_add_interface_mapping): Transfer the formal
+	arglist and the always_explicit attribute if the dummy arg is a
+	procedure.
+
+2008-11-14  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/37988
+	* io.c (enum format_token): For readability replace FMT_POS with FMT_T,
+	FMT_TL, and FMT_TR.  (format_lex): Use new enumerators. (check_format):
+	Add check for missing positive integer.
+
+2008-10-14  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/38033
+	* trans-array.c (gfc_trans_create_temp_array): Stabilize the
+	'to' expression.
+	(gfc_conv_loop_setup): Use the end expression for the loop 'to'
+	if it is available.
+
+2008-11-12  Jakub Jelinek  <jakub@redhat.com>
+
+	PR target/35366
+	PR fortran/33759
+	* trans-const.c (gfc_conv_constant_to_tree): Warn when
+	converting an integer outside of LOGICAL's range to
+	LOGICAL.
+	* trans-intrinsic.c (gfc_conv_intrinsic_function,
+	gfc_conv_intrinsic_array_transfer, gfc_conv_intrinsic_transfer):
+	Use INTEGER_TYPE instead of BOOLEAN_TYPE for TRANSFER as
+	argument of another TRANSFER.
+
+2008-11-12  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/38065
+	* resolve.c (resolve_fntype): Fix private derived type checking.
+
+2008-11-09  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/37836
+	* intrinsic.c (add_functions): Reference gfc_simplify._minval
+	and gfc_simplify_maxval.
+	* intrinsic.h : Add prototypes for gfc_simplify._minval and
+	gfc_simplify_maxval.
+	* simplify.c (min_max_choose): New function extracted from
+	simplify_min_max.
+	(simplify_min_max): Call it.
+	(simplify_minval_maxval, gfc_simplify_minval,
+	gfc_simplify_maxval): New functions.
+
+2008-11-04  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/37597
+	* parse.c (gfc_fixup_sibling_symbols ): Fixup contained, even
+	when symbol not found.
+
+2008-11-03  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/37821
+	* cpp.c (gfc_cpp_add_include_path): Use BRACKET.
+	* scanner.c (add_path_to_list): Argument to add at head.
+	(gfc_add_include_path): Add new argument.
+	(gfc_add_intrinsic_modules_path) Update call.
+	(load_file): Print filename/line in the error message.
+	* gfortran.h (gfc_add_include_path): Update prototype.
+	* options.c (gfc_post_options,gfc_handle_module_path_options,
+	gfc_handle_option): Update call.
+	* lang-spec.h (F951_OPTIONS): Don't insert include path twice.
+
+	* arith.c (arith_error): Add -fno-range-error to the message.
+
+2008-11-03  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/37445
+	* resolve.c (resolve_actual_arglist ): Correct comparison of
+	FL_VARIABLE with e->expr_type.
+	(resolve_call): Check that host association is correct.
+	(resolve_actual_arglist ): Remove return is old_sym is use
+	associated.  Only reparse expression if old and new symbols
+	have different types.
+
+	PR fortran/PR35769
+	* resolve.c (gfc_resolve_assign_in_forall): Change error to a
+	warning.
+
+2008-11-01  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/36426
+	* expr.c (replace_symbol): Replace all symbols which lie in the
+	formal namespace of the interface and copy their attributes.
+	* resolve.c (resolve_symbol): Add charlen to namespace.
+
+2008-11-01  Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/19925
+	* trans-array.c (gfc_trans_array_constructor_value): Fix comment.
+	(gfc_conv_array_initializer): Convert internal_error() to gfc_error_now.
+	* array.c: Remove GFC_MAX_AC_EXPAND macro.
+	(gfc_expand_constructor): Use gfc_option.flag_max_array_constructor.
+	* gfortran.h (gfc_option): Add flag_max_array_constructor member.
+	* lang.opt: Add -fmax-array-constructor option.
+	* expr.c (gfc_match_init_expr): Fix error message to mention new option.
+	* invoke.texi: Document new option.
+	* options.c (gfc_init_options): Set default value for new option.
+	(gfc_handle_option): Deal with commandline.
+
+2008-11-01  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/35681
+	* gfortran.h (struct gfc_code): New field `resolved_isym'.
+	* trans.h (gfc_build_memcpy_call): Made public.
+	* trans-array.h (gfc_trans_create_temp_array): New argument `initial'.
+	* intrinsic.c (gfc_intrinsic_sub_interface): Set resolved_isym.
+	* iresolve.c (create_formal_for_intents): New helper method.
+	(gfc_resolve_mvbits): Put dummy formal arglist on resolved_sym.
+	* resolve.c (resolve_call): Initialize resolved_isym to NULL.
+	* trans-array.c (gfc_trans_allocate_array_storage): New argument
+	`initial' to allow initializing the allocated storage to some initial
+	value copied from another array.
+	(gfc_trans_create_temp_array): Allow initialization of the temporary
+	with a copy of some other array by using the new extension.
+	(gfc_trans_array_constructor): Pass NULL_TREE for initial argument.
+	(gfc_conv_loop_setup): Ditto.
+	* trans-intrinsic.c (gfc_conv_intrinsic_array_transfer): Ditto.
+	* trans-expr.c (gfc_conv_function_call): Ditto.
+	(gfc_build_memcpy_call): Made public.
+	* trans-stmt.c (gfc_conv_elemental_dependencies): Initialize created
+	temporary for INTENT(INOUT) arguments to the value of the mirrored
+	array and clean up the temporary as very last intructions in the created
+	block.
+	* trans.c (gfc_trans_code): For EXEC_CALL, see if we have a MVBITS call
+	and enable elemental dependency checking if we have.
+
+2008-11-01  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/36322
+	PR fortran/36463
+	* gfortran.h: New function gfc_expr_replace_symbols.
+	* decl.c (match_procedure_decl): Increase reference count for interface.
+	* expr.c: New functions replace_symbol and gfc_expr_replace_symbols.
+	* resolve.c (resolve_symbol): Correctly copy array spec and char len
+	of PROCEDURE declarations from their interface.
+	* symbol.c (gfc_get_default_type): Enhanced error message.
+	(copy_formal_args): Call copy_formal_args recursively for arguments.
+	* trans-expr.c (gfc_conv_function_call): Bugfix.
+
+2008-11-01  Dennis Wassel  <dennis.wassel@gmail.com>
+
+	PR fortran/37159
+	* fortran/check.c (gfc_check_random_seed): Check PUT size
+	at compile time.
+
+2008-10-31  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/35840
+	* expr.c (gfc_reduce_init_expr): New function, containing checking code
+	from gfc_match_init_expr, so that checking can be deferred. 
+	(gfc_match_init_expr): Use gfc_reduce_init_expr.
+	* io.c (check_io_constraints): Use gfc_reduce_init_expr instead of 
+	checking that the expression is a constant. 
+	* match.h (gfc_reduce_init_expr): Prototype added. 
+
+2008-10-31  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/35820
+	* resolve.c (gfc_count_forall_iterators): New function.
+	(gfc_resolve_forall): Use gfc_count_forall_iterators to evaluate 
+	the needed memory amount to allocate. Don't forget to free allocated 
+	memory.  Add an assertion to check for memory leaks. 
+
+2008-10-30  Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/37930
+	* fortran/arith.c (gfc_mpfr_to_mpz):  Test for NaN and Inf values.
+	Remove stale comment and kludge code for MPFR 2.0.1 and older.
+	(gfc_real2int): Error on conversion of NaN or Inf.
+	(gfc_complex2int): Ditto.
+	* fortran/arith.h: Update mpfr_to_mpz prototype.
+	* fortran/simplify.c (gfc_simplify_ceiling, gfc_simplify_floor,
+	gfc_simplify_ifix, gfc_simplify_idint, simplify_nint): Update function
+	calls to include locus.
+
+2008-10-30  Mikael Morin  <mikael@gcc.gnu.org>
+
+        PR fortran/37903
+        * trans-array.c (gfc_trans_create_temp_array): If n is less
+	than the temporary dimension, assert that loop->from is
+	zero (reverts to earlier versions). If there is at least one
+	null loop->to[n], it is a callee allocated array so set the
+	size to NULL and break.
+	(gfc_trans_constant_array_constructor): Set the offset to zero.
+	(gfc_trans_array_constructor): Remove loop shifting around the
+	temporary creation.
+	(gfc_conv_loop_setup): Prefer zero-based descriptors if
+	possible.  Calculate the translation from loop variables to
+	array indices if an array constructor.
+
+2008-10-30  Mikael Morin  <mikael@gcc.gnu.org>
+
+        PR fortran/37749
+        * trans-array.c (gfc_trans_create_temp_array): If size is NULL
+	use the array bounds for loop->to.
+
+2008-10-28  Tobias Burnus  <burnus@net-b.de>
+
+	* intrinsic.texi: Update OpenMP section for OMPv3.
+
+2008-10-24  Jakub Jelinek  <jakub@redhat.com>
+
+	* Make-lang.in (check-f95-subtargets, check-fortran-subtargets): New
+	aliases for check-gfortran-subtargets.
+	(lang_checks_parallelized): Add check-gfortran.
+	(check_gfortran_parallelize): New variable.
+
+2008-10-19  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/37723
+	* dependency.c (gfc_dep_resolver ): If we find equal array
+	element references, go on to the next reference.
+
+2008-10-16  Daniel Kraft  <d@domob.eu>
+
+	* resolve.c (resolve_elemental_actual): Handle calls to intrinsic
+	subroutines correctly.
+
+2008-10-13  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
+
+	* simplify.c: Remove MPFR_VERSION_NUM(2,3,0) conditionals.
+
+2008-10-12  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/37688
+	* expr.c (gfc_expr_check_typed): Extend permission of untyped
+	expressions to both top-level variable and basic arithmetic expressions.
+
+2008-10-12  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/37787
+	* dependency.c (gfc_are_equivalenced_arrays): Look in symbol
+	namespace rather than current namespace, if it is available.
+
+2008-10-12  Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/37792
+	* fortran/resolve.c (resolve_fl_variable): Simplify the
+	initializer if there is one.
+
+2008-10-11  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/37794
+	* module.c (check_for_ambiguous): Remove redundant code.
+
+2008-10-09  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/35723
+	* gfortran.h (gfc_suppress_error): Removed from header.
+	(gfc_push_suppress_errors), (gfc_pop_suppress_errors): New methods.
+	* array.c (gfc_array_size): Use new gfc_push/pop_suppress_errors
+	instead of directly changing gfc_suppress_error.
+	* intrinsic.c (gfc_intrinsic_func_interface): Ditto.
+	(gfc_intrinsic_sub_interface): Ditto.
+	* error.c (suppress_errors): Made static from `gfc_suppress_error'.
+	(gfc_push_suppress_errors), (gfc_pop_suppress_errors): New methods.
+	(gfc_notify_std), (gfc_error): Use new static name of global.
+	* expr.c (check_arglist), (check_references): New methods.
+	(check_restricted): Check arglists and references of EXPR_FUNCTIONs
+	and EXPR_VARAIBALEs, respectively.  Allow PARAMETER symbols.
+
+2008-10-07  Jakub Jelinek  <jakub@redhat.com>
+
+	* f95-lang.c (poplevel): Don't clear BLOCK_VARS if functionbody.
+	* trans-decl.c (gfc_build_qualified_array): Build accurate debug type
+	even if nest.
+	(build_entry_thunks, gfc_generate_function_code,
+	gfc_generate_constructors): Ensure DECL_SAVED_TREE is a BIND_EXPR
+	with DECL_INITIAL as its BLOCK.
+
+2008-10-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/35680
+	* gfortran.h : Add 'error' bit field to gfc_expr structure.
+	* expr.c (check_inquiry): When checking a restricted expression
+	check that arguments are either variables or restricted.
+	(check_restricted): Do not emit error if the expression has
+	'error' set.  Clean up detection of host-associated variable.
+
+2008-10-05  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/37638
+	* gfortran.h (struct gfc_typebound_proc): New flag `error'.
+	* resolve.c (update_arglist_pass): Added assertion.
+	(update_compcall_arglist): Fail early for erraneous procedures to avoid
+	confusion later.
+	(resolve_typebound_generic_call): Ignore erraneous specific targets
+	and added assertions.
+	(resolve_typebound_procedure): Set new `error' flag.
+
+2008-10-04  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/37706
+	* module.c (load_equiv): Check the module before negating the
+	unused flag.
+
+2008-10-02  Steven Bosscher  <steven@gcc.gnu.org>
+
+	PR fortran/37635
+	* intrinsic.c (add_functions): Add LEADZ and TRAILZ as generics.
+	* intrinsic.h (gfc_simplify_leadz, gfc_simplify_trailz): New protos.
+	* gfortran.h <enum gfc_isym_id>: (GFC_ISYM_LEADZ, GFC_ISYM_TRAILZ): New.
+	* f95-lang (gfc_init_builtin_functions): Add BUILT_IN_CLZ,
+	BUILT_IN_CLZL, BUILT_IN_CLZLL, BUILT_IN_CTZ, BUILT_IN_CTZL, and
+	BUILT_IN_CTZLL.
+	* trans-intrinsic.c (gfc_conv_intrinsic_leadz,
+	gfc_conv_intrinsic_trails): New code-generation functions for LEADZ
+	and TRAILZ intrinsics.
+	(gfc_conv_intrinsic_function): Use them
+	* intrinsic.texi: Add documentation for LEADZ and TRAILZ.
+	* simplify.c (gfc_simplify_leadz, gfc_simplify_trailz): New functions.
+
+2008-09-30  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/36592
+	* symbol.c (check_conflict): If a symbol in a COMMON block is a
+	procedure, it must be a procedure pointer.
+	(gfc_add_in_common): Symbols in COMMON blocks may be variables or
+	procedure pointers.
+	* trans-types.c (gfc_sym_type): Make procedure pointers in COMMON
+	blocks work.
+
+2008-09-25  Jerry DeLisle  <jvdelisle@gcc.gnu.org
+
+	PR fortran/37498
+	* trans-io.c (build_dt): Revert previous patch..
+	* ioparm.def: Delete IOPARM_dt_f2003.
+
+2008-09-25  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/37504
+	* expr.c (gfc_check_pointer_assign): Allow assignment of
+	protected pointers.
+	* match.c (gfc_match_assignment,gfc_match_pointer_assignment):
+	Remove unreachable code.
+
+2008-09-24  Tobias Burnus  <burnus@net-b.de>
+
+	* options.c (set_default_std_flags,gfc_init_options):
+	Add comment: keep in sync with libgfortran.
+
+2008-09-24  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/37626
+	* trans-array.c (gfc_trans_deferred_array): Don't auto-deallocate
+	result variables.
+
+2008-09-23  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/37588
+	* gfortran.h (gfc_compare_actual_formal): Removed, made private.
+	(gfc_arglist_matches_symbol): New method.
+	* interface.c (compare_actual_formal): Made static.
+	(gfc_procedure_use): Use new name of compare_actual_formal.
+	(gfc_arglist_matches_symbol): New method.
+	(gfc_search_interface): Moved code partially to new
+	gfc_arglist_matches_symbol.
+	* resolve.c (resolve_typebound_generic_call): Resolve actual arglist
+	before checking against formal and use new gfc_arglist_matches_symbol
+	for checking.
+	(resolve_compcall): Set type-spec of generated expression.
+
+2008-09-23  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/37580
+	* expr.c (gfc_check_pointer_assign): Add checks for pointer
+	remapping.
+
+2008-09-22  Jerry DeLisle  <jvdelisle@gcc.gnu.org
+
+	PR fortran/37498
+	* trans-io.c (gfc_build_io_library_fndecls): Bump pad size.
+	(build_dt): Set mask bit for IOPARM_dt_f2003.
+	* ioparm.def: Add IOPARM_dt_f2003.
+
+2008-09-22  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/37486
+	* gfortran.h (gfc_option_t): New members flag_align_commons and
+	warn_align_commons. 
+	* lang.opt: New options falign-commons and Walign-commons.
+	* invoke.texi: Documentation for new options.
+	* options.c (gfc_init_options): Initialize new options.
+	(gfc_handle_options): Handle new options.
+	* trans-common.c (translate_common): Implement new options.
+	(gfc_trans_common): Set correct locus.
+
+2008-09-21  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/37583
+	* decl.c (scalarize_intrinsic_call): Both subroutines and
+	functions can give a true for get_proc_mame's last argument so
+	remove the &&gfc_current_ns->proc_name->attr.function.
+	resolve.c (resolve_actual_arglist): Add check for recursion by
+	reference to procedure as actual argument.
+
+2008-09-21  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/35846
+	* trans.h (gfc_conv_string_length): New argument `expr'.
+	* trans-expr.c (flatten_array_ctors_without_strlen): New method.
+	(gfc_conv_string_length): New argument `expr' that is used in a new
+	special case handling if cl->length is NULL.
+	(gfc_conv_subref_array_arg): Pass expr to gfc_conv_string_length.
+	* trans-array.c (gfc_conv_expr_descriptor): Ditto.
+	(gfc_trans_auto_array_allocation): Pass NULL as new expr.
+	(gfc_trans_g77_array), (gfc_trans_dummy_array_bias): Ditto.
+	(gfc_trans_deferred_array): Ditto.
+	(gfc_trans_array_constructor): Save and restore old values of globals
+	used for bounds checking.
+	* trans-decl.c (gfc_trans_dummy_character): Ditto.
+	(gfc_trans_auto_character_variable): Ditto.
+
+2008-09-21  Daniel Kraft  <d@domob.eu>
+
+	* decl.c (match_procedure_in_type): Changed misleading error message
+	for not yet implemented PROCEDURE(interface) syntax.
+
+2008-09-18  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/35945
+       * resolve.c (resolve_fl_variable_derived):  Remove derived type
+       comparison for use associated derived types.  Host association
+       of a derived type will not arise if there is a local derived type
+       whose use name is the same.
+
+       PR fortran/36700
+       * match.c (gfc_match_call):  Use the existing symbol even if
+       it is a function.
+
+2008-09-18  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/37507
+	* trans.h (gfc_trans_runtime_error): New method.
+	(gfc_trans_runtime_error_vararg): New method.
+	(gfc_allocate_array_with_status): New argument `expr' for locus/varname.
+	(gfc_deallocate_array_with_status): Ditto.
+	* trans-array.h (gfc_array_deallocate): Ditto.
+	* trans.c (gfc_trans_runtime_error): New method.
+	(gfc_trans_runtime_error_vararg): New method, moved parts of the code
+	from gfc_trans_runtime_check here.
+	(gfc_trans_runtime_error_check): Moved code partly to new method.
+	(gfc_call_malloc): Fix tab-indentation.
+	(gfc_allocate_array_with_status): New argument `expr' and call
+	gfc_trans_runtime_error for error reporting to include locus.
+	(gfc_deallocate_with_status): Ditto.
+	* trans-stmt.c (gfc_trans_deallocate): Pass expr as new argument.
+	* trans-array.c (gfc_array_allocate): Ditto.
+	(gfc_array_deallocate): New argument `expr', passed on.
+	(gfc_trans_dealloc_allocated): Pass NULL for expr.
+	* trans-openmp.c (gfc_omp_clause_default): Ditto.
+
+2008-09-18  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/37274
+	PR fortran/36374
+	* module.c (check_for_ambiguous): New function to test loaded
+	symbol for ambiguity with fixup symbol.
+	(read_module): Call check_for_ambiguous.
+	(write_symtree): Do not write the symtree for symbols coming
+	from an interface body.
+
+	PR fortran/36374
+	* resolve.c (count_specific_procs ): New function to count the
+	number of specific procedures with the same name as the generic
+	and emit appropriate errors for and actual argument reference.
+	(resolve_assumed_size_actual): Add new argument no_formal_args.
+	Correct logic around passing generic procedures as arguments.
+	Call count_specific_procs from two locations.
+	(resolve_function): Evaluate and pass no_formal_args.
+	(resolve call): The same and clean up a bit by using csym more
+	widely.
+
+	PR fortran/36454
+	* symbol.c (gfc_add_access): Access can be updated if use
+	associated and not private.
+
+2008-09-17  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/37536
+	* trans-stmt.c (gfc_trans_do): Optimize integer type non-simple
+	do loop initialization.
+
+2008-09-14  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+	    Tobias Burnus  <burnus@net.b.de>
+
+	PR fortran/35840
+	* io.c (match_vtag): Add tag name to error message.
+	(match_out_tag): Cleanup whitespace.
+	(gfc_resolve_dt): Resolve id and async tags. 
+
+2008-09-13  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/35770
+	* primary.c (gfc_match_varspec): Added missing type-spec clearing
+	after wrong implicit character typing.
+
+2008-09-12  Richard Guenther  <rguenther@suse.de>
+
+	* trans-intrinsic.c (gfc_conv_intrinsic_transfer): Use
+	build_fold_addr_expr to properly mark the argument
+	addressable.
+
+2008-09-11  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/36214
+	* simplify.c (simplify_cmplx): Added linebreak to long line.
+	* target-memory.c (gfc_convert_boz): Fix indentation.
+	(gfc_interpret_float): Set mpfr precision to right value before
+	calling mpfr_init.
+
+2008-09-10  H.J. Lu  <hongjiu.lu@intel.com>
+
+	* expr.c (find_array_element): Reformat comment.
+
+2008-09-10  H.J. Lu  <hongjiu.lu@intel.com>
+
+	* expr.c (find_array_element): Reformat.
+
+2008-09-10  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/37420
+	* trans-decl.c (get_proc_pointer_decl): Fix -Wunused-variable.
+
+2008-09-09  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/37429
+	* resolve.c (expression_rank): Added assertion to guard against
+	EXPR_COMPCALL expressions.
+	(resolve_compcall): Set expression's rank from the target procedure's.
+
+2008-09-09  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/37411
+	* trans-array.c (gfc_conv_array_parameter): Added assertion that the
+	symbol has an array spec.
+
+2008-09-08  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/37199
+	* trans-expr.c (gfc_add_interface_mapping): Set new_sym->as.
+	(gfc_map_intrinsic_function): Added checks against NULL bounds in
+	array specs.
+
+2008-09-08  Tobias Burnus  <burnus@net.b.de>
+
+	PR fortran/37400
+	* symbol.c (gfc_set_default_type): Copy char len.
+
+2008-09-06  Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/36153
+	* fortran/resolve.c (resolve_function): Shortcircuit for SIZE and
+	UBOUND if 2nd argument is KIND.
+
+2008-09-06  Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/33229
+	* resolve.c (resolve_function): An intrinsic subroutine should not be
+	called as a function.
+
+2008-09-05  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/35837
+	* resolve.c (resolve_types): Restore gfc_current_ns on exit.
+	* symbol.c (gfc_save_all): Removed blank line.
+
+2008-09-05  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/36746
+	* primary.c (gfc_match_rvalue): Removed logic to handle implicit
+	typing to a derived-type if a component reference is found.
+	(gfc_match_varspec): Moved it here.
+
+2008-09-04  Richard Guenther  <rguenther@suse.de>
+
+	* trans-array.c (gfc_conv_array_parameter): Use correct types
+	in building COND_EXPRs.
+	* trans-expr.c (gfc_conv_missing_dummy): Likewise.
+	* trans-intrinsics.c (gfc_conv_intrinsic_merge): Likewise.
+
+2008-09-04  Daniel Kraft  <d@domob.eu>
+
+	* PR fortran/37099
+	* expr.c (simplify_const_ref): Update expression's character length
+	when pulling out a substring reference.
+
+2008-09-04  Ian Lance Taylor  <iant@google.com>
+
+	* symbol.c (generate_isocbinding_symbol): Compare
+	gfc_notification_std with ERROR rather than FAILURE.
+	* resolve.c (check_assumed_size_reference): Compare array type
+	with AR_FULL rather than DIMEN_ELEMENT.
+	(resolve_actual_arglist): Compare with EXPR_VARIABLE rather than
+	FL_VARIABLE.
+
+2008-09-01  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/37228
+	* io.c (check_format): Allow specifying precision with g0 format.
+
+2008-09-02  Daniel Kraft  <d@domob.eu>
+
+	* gfortran.h (struct gfc_namespace): New member `implicit_loc'.
+	(gfc_add_abstract): New method.
+	* decl.c (gfc_get_type_attr_spec): Match ABSTRACT attribute.
+	(gfc_match_derived_decl): Copy abstract attribute in derived symbol.
+	* dump-parse-tree.c (show_attr): Show ABSTRACT attribute as `ABSTRACT'
+	only to allow for ABSTRACT types.
+	* parse.c (parse_interface): Use new gfc_add_abstract.
+	* primary.c (gfc_match_structure_constructor): Check that no ABSTRACT
+	type is constructed.
+	* resolve.c (resolve_typespec_used): New method.
+	(resolve_fl_derived): Check type in respect to ABSTRACT attribute and
+	check that no component is of an ABSTRACT type.
+	(resolve_symbol): Check that no symbol is of an ABSTRACT type.
+	(resolve_types): Check IMPLICIT declarations for ABSTRACT types.
+	* symbol.c (gfc_merge_new_implicit): Remember loci of IMPLICIT's.
+	(gfc_add_abstract): New method.
+
+2008-09-01  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/37193
+	* module.c (read_module): Initialize use_only flag on used symbols.
+
+2008-09-01  Daniel Kraft  <d@domob.eu>
+
+	* gfc-internals.texi (F2003 OOP), (Type-bound Procedures): New chapter
+	and section to document the internals of type-bound procedures.
+	(gfc_expr): Document EXPR_COMPCALL.
+	* gfortran.h (struct gfc_expr): Remove unused `derived' from compcall.
+	* dump-parse-tree.c (show_compcall): New method.
+	(show_expr): Call it for EXPR_COMPCALL.
+	(show_typebound), (show_f2k_derived): New methods.
+	(show_symbol): Call show_f2k_derived.
+	(show_code_node): Handle EXEC_COMPCALL.
+	* primary.c (gfc_match_varspec): Don't initialize removed `derived' in
+	primary->value.compcall.
+
+2008-08-31  Richard Guenther  <rguenther@suse.de>
+
+	* trans-expr.c (gfc_trans_string_copy): Use the correct types
+	to compute slen and dlen.
+
+2008-08-31  Daniel Kraft  <d@domob.eu>
+
+	* gfortran.h (enum gfc_statement): New entry `ST_GENERIC'.
+	(struct gfc_tbp_generic): New type.
+	(struct gfc_typebound_proc): Removed `target' and added union with
+	`specific' and `generic' members; new members `overridden',
+	`subroutine', `function' and `is_generic'.
+	(struct gfc_expr): New members `derived' and `name' in compcall union
+	member and changed type of `tbp' to gfc_typebound_proc.
+	(gfc_compare_interfaces), (gfc_compare_actual_formal): Made public.
+	* match.h (gfc_typebound_default_access): New global.
+	(gfc_match_generic): New method.
+	* decl.c (gfc_match_generic): New method.
+	(match_binding_attributes): New argument `generic' and handle it.
+	(match_procedure_in_type): Mark matched binding as non-generic.
+	* interface.c (gfc_compare_interfaces): Made public.
+	(gfc_compare_actual_formal): Ditto.
+	(check_interface_1), (compare_parameter): Use new public names.
+	(gfc_procedure_use), (gfc_search_interface): Ditto.
+	* match.c (match_typebound_call): Set base-symbol referenced.
+	* module.c (binding_generic): New global array.
+	(current_f2k_derived): New global.
+	(mio_typebound_proc): Handle IO of GENERIC bindings.
+	(mio_f2k_derived): Record current f2k-namespace in current_f2k_derived.
+	* parse.c (decode_statement): Handle GENERIC statement.
+	(gfc_ascii_statement): Ditto.
+	(typebound_default_access), (set_typebound_default_access): Removed.
+	(gfc_typebound_default_access): New global.
+	(parse_derived_contains): New default-access implementation and handle
+	GENERIC statements encountered.
+	* primary.c (gfc_match_varspec): Adapted to new gfc_typebound_proc
+	structure and removed check for SUBROUTINE/FUNCTION from here.
+	* resolve.c (extract_compcall_passed_object): New method.
+	(update_compcall_arglist): Use it.
+	(resolve_typebound_static): Adapted to new gfc_typebound_proc structure.
+	(resolve_typebound_generic_call): New method.
+	(resolve_typebound_call): Check target is a SUBROUTINE and handle calls
+	to GENERIC bindings.
+	(resolve_compcall): Ditto (check for target being FUNCTION).
+	(check_typebound_override): Handle GENERIC bindings.
+	(check_generic_tbp_ambiguity), (resolve_typebound_generic): New methods.
+	(resolve_typebound_procedure): Handle GENERIC bindings and set new
+	attributes subroutine, function and overridden in gfc_typebound_proc.
+	(resolve_fl_derived): Ensure extended type is resolved before the
+	extending one is.
+	* st.c (gfc_free_statement): Fix bug with free'ing EXEC_COMPCALL's.
+	* symbol.c (gfc_find_typebound_proc): Adapt for GENERIC changes.
+
+2008-08-29  Jan Hubicka  <jh@suse.cz>
+	
+	* parse.c (parse_interface): Silence uninitialized var warning.
+
+2008-08-29  Jakub Jelinek  <jakub@redhat.com>
+
+	* trans.h (struct lang_type): Add span.
+	(GFC_TYPE_ARRAY_SPAN): Define.
+	* trans-decl.c (gfc_get_symbol_decl): For subref array pointers,
+	copy TREE_STATIC from decl to span instead of setting it
+	unconditionally, set DECL_ARTIFICIAL, fix type of initializer
+	and set GFC_TYPE_ARRAY_SPAN on decl's type.
+	* trans-types.c (gfc_get_array_descr_info): If
+	GFC_TYPE_ARRAY_SPAN is non-NULL, use it as element size.
+
+	* trans-decl.c (check_constant_initializer,
+	gfc_emit_parameter_debug_info): New functions.
+	(gfc_generate_module_vars, gfc_generate_function_code): Emit
+	PARAMETERs and unreferenced variables with initializers into
+	debug info.
+
+	* gfortran.h (gfc_use_list): Add where field.
+	* module.c (use_locus): New static variable.
+	(gfc_match_use): Set it.
+	(gfc_use_module): Copy it to gfc_use_list's where field.
+	* trans-decl.c (gfc_generate_module_vars): Call gfc_trans_use_stmts.
+	(gfc_trans_use_stmts): Set backend locus before calling the debug
+	hook.  Allow non-VAR_DECLs to be created even for non-external
+	module.  Don't emit anything so far for renames from different
+	modules.
+
+	PR fortran/24790
+	* trans-decl.c (create_function_arglist): Set DECL_BY_REFERENCE on
+	PARM_DECLs with pointer or reference type.
+
+	* trans-decl.c (gfc_build_qualified_array): Build non-flat
+	array type for debug info purposes.
+
+	PR fortran/29635
+	PR fortran/23057
+	* f95-lang.c (gfc_init_ts): New function.
+	(LANG_HOOKS_INIT_TS): Define.
+	* gfortran.h (gfc_use_rename): New type, moved from module.c.
+	(gfc_get_use_rename): New macro, moved from module.c.
+	(gfc_use_list): New type.
+	(gfc_get_use_list): New macro.
+	(gfc_namespace): Add use_stmts field.
+	(gfc_free_use_stmts): New prototype.
+	* Make-lang.in (fortran/trans-decl.o): Depend on debug.h.
+	* module.c (gfc_use_rename, gfc_get_use_rename): Moved to
+	gfortran.h.
+	(gfc_use_module): Chain the USE statement info to
+	ns->use_stmts.
+	(gfc_free_use_stmts): New function.
+	* symbol.c (gfc_free_namespace): Call gfc_free_use_stmts.
+	* trans.h (struct module_htab_entry): New type.
+	(gfc_find_module, gfc_module_add_decl): New functions.
+	* trans.c (gfc_generate_module_code): Create NAMESPACE_DECL for
+	the module, adjust DECL_CONTEXTs of module procedures and
+	call gfc_module_add_decl for them.
+	* trans-common.c (build_common_decl): Set DECL_IGNORED_P
+	on the common variable.
+	(create_common): Set DECL_IGNORED_P for use associated vars.
+	* trans-decl.c: Include debug.h.
+	(gfc_get_symbol_decl): Set DECL_IGNORED_P on use_assoc vars from
+	modules.
+	(build_function_decl): Allow current_function_decl's context
+	to be a NAMESPACE_DECL.
+	(module_htab, cur_module): New variables.
+	(module_htab_do_hash, module_htab_eq, module_htab_decls_hash,
+	module_htab_decls_eq, gfc_find_module, gfc_module_add_decl): New
+	functions.
+	(gfc_create_module_variable): Adjust DECL_CONTEXTs of module
+	variables and types and call gfc_module_add_decl for them.
+	(gfc_generate_module_vars): Temporarily set cur_module.
+	(gfc_trans_use_stmts): New function.
+	(gfc_generate_function_code): Call it.
+	(gfc_generate_block_data): Set DECL_IGNORED_P on decl.
+	* trans-types.c (gfc_get_derived_type): Adjust DECL_CONTEXT
+	and TYPE_CONTEXT of module derived types.
+
+2008-08-28  Daniel Kraft  <d@domob.eu>
+
+	* gfortran.h (enum expr_t): New value `EXPR_COMPCALL'.
+	(gfc_get_typebound_proc): New macro.
+	(struct gfc_expr): New union-member `compcall' for EXPR_COMPCALL.
+	(enum gfc_exec_op): New value `EXEC_COMPCALL'.
+	(gfc_find_typebound_proc): New argument.
+	(gfc_copy_ref), (gfc_match_varspec): Made public.
+	* decl.c (match_procedure_in_type): Use gfc_get_typebound_proc.
+	* expr.c (free_expr0), (gfc_copy_expr): Handle EXPR_COMPCALL.
+	(gfc_copy_ref): Made public and use new name.
+	(simplify_const_ref): Use new name of gfc_copy_ref.
+	(simplify_parameter_variable): Ditto.
+	(gfc_simplify_expr): gcc_unreachable for EXPR_COMPCALL.
+	* match.c (match_typebound_call): New method.
+	(gfc_match_call): Allow for CALL's to typebound procedures.
+	* module.c (binding_passing), (binding_overriding): New variables.
+	(expr_types): Add EXPR_COMPCALL.
+	(mio_expr): gcc_unreachable for EXPR_COMPCALL.
+	(mio_typebound_proc), (mio_typebound_symtree): New methods.
+	(mio_f2k_derived): Handle type-bound procedures.
+	* primary.c (gfc_match_varspec): Made public and parse trailing
+	references to type-bound procedures; new argument `sub_flag'.
+	(gfc_match_rvalue): New name and argument of gfc_match_varspec.
+	(match_variable): Ditto.
+	* resolve.c (update_arglist_pass): New method.
+	(update_compcall_arglist), (resolve_typebound_static): New methods.
+	(resolve_typebound_call), (resolve_compcall): New methods.
+	(gfc_resolve_expr): Handle EXPR_COMPCALL.
+	(resolve_code): Handle EXEC_COMPCALL.
+	(resolve_fl_derived): New argument to gfc_find_typebound_proc.
+	(resolve_typebound_procedure): Ditto and removed not-implemented error.
+	* st.c (gfc_free_statement): Handle EXEC_COMPCALL.
+	* symbol.c (gfc_find_typebound_proc): New argument `noaccess' and
+	implement access-checking.
+	* trans-expr.c (gfc_apply_interface_mapping_to_expr): gcc_unreachable
+	on EXPR_COMPCALL.
+	* trans-intrinsic.c (gfc_conv_intrinsic_bound): Add missing break.
+	* trans-openmp.c (gfc_trans_omp_array_reduction): Add missing
+	intialization of ref->type.
+
+2008-08-28  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/37253
+	* module.c (ab_attribute,attr_bits,mio_symbol_attribute): Take care of
+	saving attr.procedure and attr.proc_ptr to the module file.
+
+2008-08-25  Daniel Kraft  <d@domob.eu>
+
+	* gfortran.h (gfc_find_component): Add new arguments.
+	* parse.c (parse_derived_contains): Check if the derived-type containing
+	the CONTAINS section is SEQUENCE/BIND(C).
+	* resolve.c (resolve_typebound_procedure): Check for name collision with
+	components.
+	(resolve_fl_derived): Check for name collision with inherited
+	type-bound procedures.
+	* symbol.c (gfc_find_component): New arguments `noaccess' and `silent'.
+	(gfc_add_component): Adapt for new arguments.
+	* primary.c (match_varspec), (gfc_match_structure_constructor): Ditto.
+
+2008-08-24  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/37201
+	* decl.c (verify_bind_c_sym): Reject array/string returning
+	functions.
+
+2008-08-24  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/37201
+	* trans-expr.c (gfc_conv_function_call): Add string_length
+	for character-returning bind(C) functions.
+
+2008-08-24  Daniel Kraft  <d@domob.eu>
+
+	* gfortran.h (gfc_typebound_proc):  New struct.
+	(gfc_symtree):  New member typebound.
+	(gfc_find_typebound_proc):  Prototype for new method.
+	(gfc_get_derived_super_type):  Prototype for new method.
+	* parse.h (gfc_compile_state):  New state COMP_DERIVED_CONTAINS.
+	* decl.c (gfc_match_procedure):  Handle PROCEDURE inside derived-type
+	CONTAINS section.
+	(gfc_match_end):  Handle new context COMP_DERIVED_CONTAINS.
+	(gfc_match_private):  Ditto.
+	(match_binding_attributes), (match_procedure_in_type):  New methods.
+	(gfc_match_final_decl):  Rewrote to make use of new
+	COMP_DERIVED_CONTAINS parser state.
+	* parse.c (typebound_default_access):  New global helper variable.
+	(set_typebound_default_access):  New callback method.
+	(parse_derived_contains):  New method.
+	(parse_derived):  Extracted handling of CONTAINS to new parser state
+	and parse_derived_contains.
+	* resolve.c (resolve_bindings_derived), (resolve_bindings_result):  New.
+	(check_typebound_override), (resolve_typebound_procedure):  New methods.
+	(resolve_typebound_procedures):  New method.
+	(resolve_fl_derived):  Call new resolving method for typebound procs.
+	* symbol.c (gfc_new_symtree):  Initialize new member typebound to NULL.
+	(gfc_find_typebound_proc):  New method.
+	(gfc_get_derived_super_type):  New method.
+
+2008-08-23  Janus Weil  <janus@gcc.gnu.org>
+
+	* gfortran.h (gfc_component): Add field "symbol_attribute attr", remove
+	fields "pointer", "allocatable", "dimension", "access".
+	Remove functions "gfc_set_component_attr" and "gfc_get_component_attr".
+	* interface.c (gfc_compare_derived_types): Ditto.
+	* trans-array.c (gfc_array_allocate,structure_alloc_comps): Ditto.
+	* trans-expr.c (gfc_conv_component_ref,gfc_trans_subcomponent_assign,
+	gfc_conv_structure): Ditto.
+	* symbol.c (gfc_find_component,free_components,gfc_set_component_attr,
+	gfc_get_component_attr,verify_bind_c_derived_type,
+	generate_isocbinding_symbol): Ditto.
+	* decl.c (build_struct): Ditto.
+	* dump-parse-tree.c (show_components): Ditto.
+	* trans-stmt.c (gfc_trans_deallocate): Ditto.
+	* expr.c (gfc_check_assign,gfc_check_pointer_assign,
+	gfc_default_initializer): Ditto.
+	* module.c (mio_component): Ditto.
+	* trans-types.c (copy_dt_decls_ifequal,gfc_get_derived_type): Ditto.
+	* resolve.c (has_default_initializer,resolve_structure_cons,
+	gfc_iso_c_func_interface,find_array_spec,resolve_ref,
+	resolve_deallocate_expr,resolve_allocate_expr,resolve_fl_derived,
+	resolve_equivalence_derived): Ditto.
+	* trans-io.c (transfer_expr): Ditto.
+	* parse.c (parse_derived): Ditto.
+	* dependency.c (gfc_check_dependency): Ditto.
+	* primary.c (gfc_variable_attr): Ditto.
+
+2008-08-23  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/37076
+	* arith.c (gfc_arith_concat): Fix concat of kind=4 strings.
+
+2008-08-23  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/37025
+	* target-memory.c (gfc_interpret_character): Support
+	kind=4 characters.
+
+2008-08-22  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/30239
+	* symbol.c (gfc_add_type): Warn on -Wsurprising if a function-result
+	type is re-declared but neither -pedantic nor -std=f* is given and so
+	this is no error.
+	* invoke.texi (-Wsurprising): Document this new behaviour.
+
+2008-08-22  Daniel Kraft  <d@domob.eu>
+
+	* gfortran.h (in_prefix): Removed from this header.
+	* match.h (gfc_matching_prefix): Moved and renamed from `in_prefix'.
+	* decl.c (in_prefix): Removed from here.
+	(gfc_match_prefix): Use new name of `gfc_matching_prefix'.
+	* symbol.c (gfc_check_symbol_typed): Ditto.
+	* expr.c (check_typed_ns): New helper variable.
+	(expr_check_typed_help): New helper method.
+	(gfc_expr_check_typed): Rewrote to use gfc_traverse_expr to do the
+	work, fixing a minor problem.
+	* match.c (gfc_matching_prefix): New variable.
+
+2008-08-22  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/32095
+	PR fortran/34228
+	* gfortran.h (in_prefix): New global.
+	(gfc_check_symbol_typed), (gfc_check_expr_typed): New methods.
+	* array.c (match_array_element_spec): Check that bounds-expressions
+	don't have symbols not-yet-typed in them.
+	* decl.c (var_element): Check that variable used is already typed.
+	(char_len_param_value): Check that expression does not contain
+	not-yet-typed symbols.
+	(in_prefix): New global.
+	(gfc_match_prefix): Record using `in_prefix' if we're at the moment
+	parsing a prefix or not.
+	* expr.c (gfc_expr_check_typed): New method.
+	* parse.c (verify_st_order): New argument to disable error output.
+	(check_function_result_typed): New helper method.
+	(parse_spec): Check that the function-result declaration, if given in
+	a prefix, contains no not-yet-typed symbols when the IMPLICIT rules are
+	parsed.
+	* symbol.c (gfc_check_symbol_typed): Check that a symbol already has
+	a type associated to it, otherwise use the IMPLICIT rules or signal
+	an error.
+
+2008-08-21  Manuel Lopez-Ibanez  <manu@gcc.gnu.org>
+
+	* f95-lang.c: Update all calls to pedwarn.
+
+2008-08-18  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/37032
+	* gfortran.texi: Document decision on include file handling in
+	preprocessed files.
+
+2008-08-16  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/36825
+	* libgfortran.h: Reduce GFC_MAX_DIMENSIONS to 7.
+
+2008-08-15  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/35863
+	* io.c (gfc_match_open): Enable UTF-8 in checks.
+	* simplify.c (gfc_simplify_selected_char_kind): Enable iso_10646.
+
+2008-08-14  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/36705
+	* symbol.c (check_conflict): Move conflict checks for (procedure,save)
+	and (procedure,intent) to resolve_fl_procedure.
+	* resolve.c (resolve_fl_procedure): Ditto.
+
+2008-08-09  Manuel Lopez-Ibanez  <manu@gcc.gnu.org>
+
+	PR 36901
+	* f95-lang.c (gfc_mark_addressable): Use "pedwarn (0," instead of
+	'pedwarn0'.
+
+2008-08-09  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/37011
+	* symbol.c (gfc_add_extension): New function.
+	* decl.c (gfc_get_type_attr_spec): Call it.
+	(gfc_match_derived_decl): Set symbol extension attribute from
+	attr.extension.
+	* gfortran.h : Add prototype for gfc_add_extension.
+
+2008-08-08  Manuel Lopez-Ibanez  <manu@gcc.gnu.org>
+
+	PR 28875
+	* options.c (set_Wall): Replace set_Wunused by warn_unused.
+
+2008-08-08  Daniel Kraft  <d@domob.eu>
+
+	* gfortran.h (gfc_finalizer):  Replaced member `procedure' by two
+	new members `proc_sym' and `proc_tree' to store the symtree after
+	resolution.
+	(gfc_find_sym_in_symtree):  Made public.
+	* decl.c (gfc_match_final_decl):  Adapted for new member name.
+	* interface.c (gfc_find_sym_in_symtree):  Made public.
+	(gfc_extend_expr), (gfc_extend_assign):  Changed call accordingly.
+	* module.c (mio_finalizer), (mio_f2k_derived), (mio_full_f2k_derived):
+	New methods for module-file IO of f2k_derived.
+	(mio_symbol):  Do IO of f2k_derived namespace.
+	* resolve.c (gfc_resolve_finalizers):  Adapted for new member name and
+	finding the symtree for the symbol here.
+	* symbol.c (gfc_free_finalizer):  Adapted for new members.
+
+2008-07-30  Ralf Wildenhues  <Ralf.Wildenhues@gmx.de>
+
+	* gfc-internals.texi: Update to GFDL 1.2.  Do not list GPL as
+	Invariant Section.
+	* gfortran.texi: Likewise.
+	* intrinsic.texi: Do not list GPL as Invariant Section.
+	* invoke.texi: Likewise.  Update copyright years.
+
+2008-07-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	* trans-expr.c (conv_parent_component_references): New function
+	to build missing parent references.
+	(gfc_conv_variable): Call it
+	* symbol.c (gfc_add_component): Check that component name in a
+	derived type extension does not appear in parent.
+	(gfc_find_component): For a derived type extension, check if
+	the component appears in the parent derived type by calling
+	self. Separate errors for private components and private types.
+	* decl.c (match_data_constant): Add extra arg to call to
+	gfc_match_structure_constructor.
+	(check_extended_derived_type): New function to check that a
+	parent derived type exists and that it is OK for exension.
+	(gfc_get_type_attr_spec): Add extra argument 'name' and return
+	it if extends is specified.
+	(gfc_match_derived_decl): Match derived type extension and
+	build a first component of the parent derived type if OK. Add
+	the f2k namespace if not present.
+	* gfortran.h : Add the extension attribute.
+	* module.c : Handle attribute 'extension'.
+	* match.h : Modify prototypes for gfc_get_type_attr_spec and
+	gfc_match_structure_constructor.
+	* primary.c (build_actual_constructor): New function extracted
+	from gfc_match_structure_constructor and modified to call self
+	iteratively to build derived type extensions, when f2k named
+	components are used.
+	(gfc_match_structure_constructor): Do not throw error for too
+	many components if a parent type is being handled. Use
+	gfc_find_component to generate errors for non-existent or
+	private components.  Iteratively call self for derived type
+	extensions so that parent constructor is built.  If extension
+	and components left over, throw error.
+	(gfc_match_rvalue): Add extra arg to call to
+	gfc_match_structure_constructor.
+
+	* trans-array.c (gfc_conv_resolve_dependencies): If lhs and rhs
+	are the same symbol, aliassing does not matter.
+
+2008-07-29  Jan Hubicka  <jh@suse.cz>
+
+	* options.c (gfc_post_options): Do not set flag_no_inline.
+
+2008-07-29  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/36403
+	* trans-intrinsic.c (conv_generic_with_optional_char_arg):  New method
+	to append a string-length even if the string argument is missing, e.g.
+	for EOSHIFT.
+	(gfc_conv_intrinsic_function):  Call the new method for EOSHIFT, PACK
+	and RESHAPE.
+
+2008-07-28  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
+
+	* gfortran.h (try): Remove macro.  Replace try with gfc_try
+	throughout.
+	* array.c: Likewise.
+	* check.c: Likewise.
+	* cpp.c: Likewise.
+	* cpp.h: Likewise.
+	* data.c: Likewise.
+	* data.h: Likewise.
+	* decl.c: Likewise.
+	* error.c: Likewise.
+	* expr.c: Likewise.
+	* interface.c: Likewise.
+	* intrinsic.c: Likewise.
+	* intrinsic.h: Likewise.
+	* io.c: Likewise.
+	* match.h: Likewise.
+	* parse.c: Likewise.
+	* parse.h: Likewise.
+	* resolve.c: Likewise.
+	* scanner.c: Likewise.
+	* simplify.c: Likewise.
+	* symbol.c: Likewise.
+	* trans-openmp.c: Likewise.
+	* trans-types.c: Likewise.
+
+2008-07-28  Tobias Burnus  <burnus@net-b.de>
+
+	* Make-lang.in: Remove -Wno-* from fortran-warn.
+
+2008-07-28  Richard Guenther  <rguenther@suse.de>
+
+	Merge from gimple-tuples-branch.
+
+	2008-07-18  Aldy Hernandez  <aldyh@redhat.com>
+
+	* trans-expr.c: Include gimple.h instead of tree-gimple.h.
+	* trans-array.c: Same.
+	* trans-openmp.c: Same.
+	* trans-stmt.c: Same.
+	* f95-lang.c: Same.
+	* trans-io.c: Same.
+	* trans-decl.c: Same.
+	* trans-intrinsic.c: Same.
+	* trans.c: Same.  Include tree-iterator.h.
+	* Make-lang.in (trans.o): Depend on tree-iterator.h
+
+	2008-07-14  Aldy Hernandez  <aldyh@redhat.com>
+
+	* trans-array.h (gfc_conv_descriptor_data_set_internal):
+	Rename to gfc_conv_descriptor_data_set.
+	(gfc_conv_descriptor_data_set_tuples): Remove.
+	* trans-array.c (gfc_conv_descriptor_data_get): Rename
+	from gfc_conv_descriptor_data_set_internal.
+	Remove last argument to gfc_add_modify.
+	(gfc_trans_allocate_array_storage): Rename gfc_add_modify_expr to
+	gfc_add_modify.
+	(gfc_trans_create_temp_array): Same.
+	(gfc_conv_array_transpose): Same.
+	(gfc_grow_array): Same.
+	(gfc_put_offset_into_var): Same.
+	(gfc_trans_array_ctor_element): Same.
+	(gfc_trans_array_constructor_subarray): Same.
+	(gfc_trans_array_constructor_value): Same.
+	(gfc_trans_scalarized_loop_end): Same.
+	(gfc_array_init_size): Same.
+	(gfc_array_allocate): Same.
+	(gfc_trans_array_bounds): Same.
+	(gfc_trans_auto_array_allocation): Same.
+	(gfc_trans_g77_array): Same.
+	(gfc_trans_dummy_array_bias): Same.
+	(gfc_conv_expr_descriptor): Same.
+	(structure_alloc_comps): Same.
+	* trans-expr.c: Same.
+	* trans-openmp.c (gfc_omp_clause_default_ctor): Same.
+	Rename gfc_conv_descriptor_data_set_tuples to
+	gfc_conv_descriptor_data_set.
+	(gfc_omp_clause_copy_ctor): Change build_gimple_modify_stmt to
+	build2_v.
+	(gfc_omp_clause_assign_op): Same.
+	(gfc_trans_omp_array_reduction): Rename gfc_add_modify_expr to
+	gfc_add_modify.
+	(gfc_trans_omp_atomic): Same.
+	(gfc_trans_omp_do): Same.  Change GIMPLE_MODIFY_STMT to MODIFY_EXPR.
+	Rename gfc_add_modify_stmt to gfc_add_modify.
+	* trans-stmt.c: Rename gfc_add_modify_expr to
+	gfc_add_modify.
+	* trans.c: Rename gfc_add_modify_expr to
+	gfc_add_modify.
+	(gfc_add_modify): Remove last argument.
+	Rename GIMPLE_MODIFY_STMT to MODIFY_EXPR.
+	* trans.h: Remove gfc_add_modify_expr, gfc_add_modify_stmt.
+	Add prototype for gfc_add_modify.
+	* f95-lang.c (union lang_tree_node): Rename GENERIC_NEXT to TREE_CHAIN.
+	* trans-decl.c: Rename gfc_add_modify_stmt to gfc_add_modify.
+	* trans-io.c: Same.
+	* trans-intrinsic.c: Same.
+
+	2008-02-25  Aldy Hernandez  <aldyh@redhat.com>
+
+	* Make-lang.in (fortran-warn): Add -Wno-format.
+
+	2008-02-19  Diego Novillo  <dnovillo@google.com>
+
+	http://gcc.gnu.org/ml/gcc-patches/2008-02/msg00804.html
+
+	* fortran/Make-lang.in (fortran-warn): Remove.
+
+	2007-11-22  Aldy Hernandez  <aldyh@redhat.com>
+
+	* trans-expr.c (gfc_trans_string_copy): Use "void *" when building a
+	memset.
+
+	2007-11-10  Aldy Hernandez  <aldyh@redhat.com>
+
+	* Make-lang.in (fortran-warn): Set to -Wno-format.
+	* trans.c (gfc_trans_code): Update comment to say GENERIC.
+	Call tree_annotate_all_with_locus instead of annotate_all_with_locus.
+
+2008-07-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/36132
+	PR fortran/29952
+	PR fortran/36909
+	* trans.c (gfc_trans_runtime_check): Allow run-time warning besides
+	run-time error.
+	* trans.h (gfc_trans_runtime_check): Update declaration.
+	* trans-array.c (gfc_trans_array_ctor_element,gfc_trans_array_bound_check,
+	gfc_conv_array_ref,gfc_conv_ss_startstride,gfc_trans_dummy_array_bias):
+	Updated gfc_trans_runtime_check calls.
+	(gfc_conv_array_parameter): Implement flag_check_array_temporaries,
+	fix packing/unpacking for nonpresent optional actuals to optional
+	formals.
+	* trans-array.h (gfc_conv_array_parameter): Update declaration.
+	* trans-expr.c (gfc_conv_substring,gfc_trans_arrayfunc_assign,
+	gfc_conv_function_call): Updated gfc_trans_runtime_check calls.
+	(gfc_conv_function_call): Update gfc_conv_array_parameter calls.
+	* trans-expr.c (gfc_trans_goto): Updated gfc_trans_runtime_check
+	calls.
+	* trans-io.c (set_string,gfc_conv_intrinsic_repeat): Ditto.
+	(gfc_conv_intrinsic_transfer,gfc_conv_intrinsic_loc): Same for
+	gfc_conv_array_parameter.
+	* trans-intrinsics.c (gfc_conv_intrinsic_bound): Ditto.
+	* trans-decl.c (gfc_build_builtin_function_decls): Add
+	gfor_fndecl_runtime_warning_at.
+	* lang.opt: New option fcheck-array-temporaries.
+	* gfortran.h (gfc_options): New flag_check_array_temporaries.
+	* options.c (gfc_init_options, gfc_handle_option): Handle flag.
+	* invoke.texi: New option fcheck-array-temporaries.
+
+2008-07-24  Jan Hubicka  <jh@suse.cz>
+
+	* fortran/options.c (gfc_post_options): Remove flag_unline_trees code.
+
+2008-07-24  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/33141
+	* lang.opt (Wnonstd-intrinsics):  Removed option.
+	(Wintrinsics-std), (Wintrinsic-shadow):  New options.
+	* invoke.texi (Option Summary):  Removed -Wnonstd-intrinsics
+	from the list and added -Wintrinsics-std and -Wintrinsic-shadow.
+	(Error and Warning Options):  Documented the new options and removed
+	the documentation for -Wnonstd-intrinsics.
+	* gfortran.h (gfc_option_t):  New members warn_intrinsic_shadow and
+	warn_intrinsics_std, removed warn_nonstd_intrinsics.
+	(gfc_is_intrinsic):  Renamed from gfc_intrinsic_name.
+	(gfc_warn_intrinsic_shadow), (gfc_check_intrinsic_standard):  New.
+	* decl.c (match_procedure_decl):  Replaced gfc_intrinsic_name by
+	the new name gfc_is_intrinsic.
+	(warn_intrinsic_shadow):  New helper method.
+	(gfc_match_function_decl), (gfc_match_subroutine):  Call the new method
+	warn_intrinsic_shadow to check the just-parsed procedure.
+	* expr.c (check_init_expr):  Call new gfc_is_intrinsic to check whether
+	the function called is really an intrinsic in the selected standard.
+	* intrinsic.c (gfc_is_intrinsic):  Renamed from gfc_intrinsic_name and
+	extended to take into account the selected standard settings when trying
+	to find out whether a symbol is an intrinsic or not.
+	(gfc_check_intrinsic_standard):  Made public and extended.
+	(gfc_intrinsic_func_interface), (gfc_intrinsic_sub_interface):  Removed
+	the calls to check_intrinsic_standard, this check now happens inside
+	gfc_is_intrinsic.
+	(gfc_warn_intrinsic_shadow):  New method defined.
+	* options.c (gfc_init_options):  Initialize new warning flags to false
+	and removed intialization of Wnonstd-intrinsics flag.
+	(gfc_post_options):  Removed logic for Wnonstd-intrinsics flag.
+	(set_Wall):  Set new warning flags and removed Wnonstd-intrinsics flag.
+	(gfc_handle_option):  Handle the new flags and removed handling of the
+	old Wnonstd-intrinsics flag.
+	* primary.c (gfc_match_rvalue):  Replaced call to gfc_intrinsic_name by
+	the new name gfc_is_intrinsic.
+	* resolve.c (resolve_actual_arglist):  Ditto.
+	(resolve_generic_f), (resolve_unknown_f):  Ditto.
+	(is_external_proc):  Ditto.
+	(resolve_generic_s), (resolve_unknown_s):  Ditto.
+	(resolve_symbol):  Ditto and ensure for symbols declared INTRINSIC that
+	they are really available in the selected standard setting.
+
+2008-07-24  Daniel Kraft  <d@domob.eu>
+
+	* match.c (gfc_match):  Add assertion to catch wrong calls trying to
+	match upper-case characters.
+
+2008-07-24  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/29952
+	* gfortran.h:  Add "warn_array_temp" to gfc_option_t.
+	* lang.opt:  Add -Warray-temporaries.
+	* invoke.texi:  Document -Warray-temporaries
+	* trans-array.h (gfc_trans_create_temp_array):  Add argument of
+	type *locus.
+	(gfc_conv_loop_setup):  Likewise.
+	* trans-array.c (gfc_trans_create_temp_array):  If
+	-Warray-temporaries is given and locus is present, warn about
+	creation of array temporaries.
+	(gfc_trans_array_constructor_subarray):  Add locus to call
+	of gfc_conv_loop_setup.
+	(gfc_trans_array_constructor):  Add where argument.  Pass where
+	argument to call of gfc_trans_create_temp_array.
+	(gfc_add_loop_ss_code):  Add where argument.  Pass where argument
+	to recursive call of gfc_add_loop_ss_code and to call of
+	gfc_trans_array_constructor.
+	(gfc_conv_loop_setup):  Add where argument.  Pass where argument
+	to calls to gfc_add_loop_ss_code and to gfc_trans_create_temp_array.
+	(gfc_conv_expr_descriptor):  Pass location to call of
+	gfc_conv_loop_setup.
+	(gfc_conv_array_parameter):  If -Warray-temporaries is given,
+	warn about creation of temporary arrays.
+	* trans-expr.c (gfc_conv_subref_array_arg):  Add where argument
+	to call to gfc_conv_loop_setup.
+	(gfc_conv_function_call):  Add where argument to call to
+	gfc_trans_creat_temp_array.
+	(gfc_trans_subarray_assign):  Likewise.
+	(gfc_trans_assignment_1):  Add where argument to call to
+	gfc_conv_loop_setup.
+	* trans-stmt.c (gfc_conv_elemental_dependencies):  Add where
+	argument to call to gfc_trans_create_temp_array.
+	(gfc_trans_call):  Add where argument to call to gfc_conv_loop_setup.
+	(generate_loop_for_temp_to_lhs):  Likewise.
+	(generate_loop_for_rhs_to_temp):  Likewise.
+	(compute_inner_temp_size):  Likewise.
+	(gfc_trans-pointer_assign_need_temp):  Likewise.
+	(gfc_evaluate_where_mask):  Likewise.
+	(gfc_trans_where_assign):  Likewise.
+	(gfc_trans_where_3):  Likewise.
+	* trans-io.c (transfer_srray_component):  Add where argument
+	to function. Add where argument to call to gfc_conv_loop_setup.
+	(transfer_expr):  Add where argument to call to
+	transfer_array_component.
+	(gfc_trans_transfer):  Add where expression to call to
+	gfc_conv_loop_setup.
+	* trans-intrinsic.c (gfc_conv_intrinsic_anyall):  Add
+	where argument to call to gfc_conv_loop_setup.
+	(gfc_conv_intrinsic_count):  Likewise.
+	(gfc_conv_intrinsic_arith):  Likewise.
+	(gfc_conv_intrinsic_dot_product):  Likewise.
+	(gfc_conv_intrinsic_minmaxloc):  Likewise.
+	(gfc_conv_intrinsic_minmaxval):  Likewise.
+	(gfc_conv_intrinsic_array_transfer):  Warn about
+	creation of temporary array.
+	Add where argument to call to gfc_trans_create_temp_array.
+	* options.c (gfc_init_options):  Initialize gfc_option.warn_array_temp.
+	(gfc_handle_option):  Set gfc_option.warn_array_temp.
+
+2008-07-23  Manuel Lopez-Ibanez  <manu@gcc.gnu.org>
+
+	PR 35058
+	* f95-lang.c (gfc_mark_addressable): All calls to pedwarn changed.
+
+2008-07-22  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/29835
+	* io.c (error_element), (format_locus):  New static globals.
+	(unexpected_element):  Spelled out this message fully.
+	(next_char):  Keep track of locus when not MODE_STRING.
+	(next_char_not_space):  Remember last parsed element in error_element.
+	(format_lex):  Fix two indentation errors.
+	(check_format):  Use format_locus and possibly error_element for a
+	slightly better error message on invalid format.
+	(check_format_string):  Set format_locus to start of the string
+	expression used as format.
+
+2008-07-21  Ralf Wildenhues  <Ralf.Wildenhues@gmx.de>
+
+	* expr.c (gfc_check_pointer_assign): Fix typo in string.
+	* io.c (check_format): Fix typo in string.  Fix comment typos.
+	* parse.c (gfc_global_used): Likewise.
+	* resolve.c (resolve_allocate_expr): Likewise.
+	* symbol.c (gfc_set_default_type): Likewise.
+	* arith.c: Fix typos in comments.
+	* array.c: Likewise.
+	* data.c: Likewise.
+	* decl.c: Likewise.
+	* dependency.c: Likewise.
+	* f95-lang.c: Likewise.
+	* gfortran.h: Likewise.
+	* matchexp.c: Likewise.
+	* module.c: Likewise.
+	* primary.c: Likewise.
+	* scanner.c: Likewise.
+	* trans-array.c: Likewise.
+	* trans-common.c: Likewise.
+	* trans-decl.c: Likewise.
+	* trans-expr.c: Likewise.
+	* trans-intrinsic.c: Likewise.
+	* trans-types.c: Likewise.
+	* trans.c: Likewise.
+	* trans.h: Likewise.
+
+2008-07-19  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/36795
+	* matchexp.c (gfc_get_parentheses): Remove obsolete workaround,
+	which caused the generation of wrong code.
+
+2008-07-19  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/36342
+	* scanner.c (load_file): Add argument to destinguish between
+	true filename and displayed filename.
+	(include_line,gfc_new_file): Adapt accordingly.
+
+2008-07-19  Tobias Burnus  <burnus@net-b.de>
+
+	* check.c (gfc_check_cshift,gfc_check_eoshift,gfc_check_unpack): Add rank
+	checks for cshift's shift and eoshift's shift and boundary args.
+	(gfc_check_unpack): Add rank and shape tests for unpack.
+
+2008-07-19  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
+
+	* gfortran.h (new): Remove macro.
+	* array.c (gfc_append_constructor, match_array_list,
+	gfc_match_array_constructor): Likewise.
+	* bbt.c (insert, gfc_insert_bbt): Likewise.
+	* decl.c (var_element, top_var_list, top_val_list, gfc_match_data,
+	get_proc_name): Likewise.
+	* expr.c (gfc_copy_actual_arglist): Likewise.
+	* interface.c (compare_actual_formal, check_new_interface,
+	gfc_add_interface): Likewise.
+	* intrinsic.c gfc_convert_type_warn, gfc_convert_chartype):
+	Likewise.
+	* io.c (match_io_iterator, match_io_list): Likewise.
+	* match.c (match_forall_header): Likewise.
+	* matchexp.c (build_node): Likewise.
+	* module.c (gfc_match_use): Likewise.
+	* scanner.c (load_file): Likewise.
+	* st.c (gfc_append_code): Likewise.
+	* symbol.c (save_symbol_data, gfc_get_sym_tree, gfc_undo_symbols,
+	gfc_commit_symbols): Likewise.
+	* trans-common.c (build_field): Likewise.
+	* trans-decl.c (gfc_finish_var_decl): Likewise.
+	* trans-expr.c (gfc_free_interface_mapping,
+	gfc_get_interface_mapping_charlen, gfc_add_interface_mapping,
+	gfc_finish_interface_mapping,
+	gfc_apply_interface_mapping_to_expr): Likewise.
+	* trans.h (gfc_interface_sym_mapping): Likewise.
+
+2008-07-19  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
+
+	* gfortran.h (operator): Remove macro.
+	(gfc_namespace, gfc_expr): Avoid C++ keywords.
+	* arith.c (eval_intrinsic, eval_intrinsic_f2, eval_intrinsic_f3):
+	Likewise.
+	* decl.c (access_attr_decl): Likewise.
+	* dependency.c (gfc_dep_compare_expr): Likewise.
+	* dump-parse-tree.c (show_expr, show_uop, show_namespace):
+	Likewise.
+	* expr.c (gfc_copy_expr, gfc_type_convert_binary,
+	simplify_intrinsic_op, check_intrinsic_op): Likewise.
+	* interface.c (fold_unary, gfc_match_generic_spec,
+	gfc_match_interface, gfc_match_end_interface,
+	check_operator_interface, check_uop_interfaces,
+	gfc_check_interfaces, gfc_extend_expr, gfc_extend_assign,
+	gfc_add_interface, gfc_current_interface_head,
+	gfc_set_current_interface_head): Likewise.
+	* iresolve.c (gfc_resolve_dot_product, gfc_resolve_matmul):
+	Likewise.
+	* matchexp.c (gfc_get_parentheses, build_node): Likewise.
+	* module.c (gfc_use_rename, gfc_match_use, find_use_name_n,
+	number_use_names, mio_expr, load_operator_interfaces, read_module,
+	write_operator, write_module): Likewise.
+	* openmp.c (resolve_omp_atomic): Likewise.
+	* resolve.c (resolve_operator, gfc_resolve_character_operator,
+	gfc_resolve_uops): Likewise.
+	* symbol.c (free_uop_tree, gfc_free_namespace): Likewise.
+	* trans-expr.c (gfc_conv_expr_op): Likewise.
+	* trans-openmp.c (gfc_trans_omp_atomic): Likewise.
+
+2008-07-19  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
+
+	* gfortran.h (protected): Remove macro.
+	* dump-parse-tree.c (show_attr): Avoid C++ keywords.
+	* expr.c (gfc_check_pointer_assign): Likewise.
+	* interface.c (compare_parameter_protected): Likewise.
+	* intrinsic.c (enum class, add_sym, add_sym_0, add_sym_1,
+	add_sym_1s, add_sym_1m, add_sym_2, add_sym_2s, add_sym_3,
+	add_sym_3ml, add_sym_3red, add_sym_3s, add_sym_4, add_sym_4s,
+	add_sym_5s): Likewise.
+	* match.c (gfc_match_assignment, gfc_match_pointer_assignment):
+	Likewise.
+	* module.c (mio_symbol_attribute): Likewise.
+	* primary.c (match_variable): Likewise.
+	* resolve.c (resolve_equivalence): Likewise.
+	* symbol.c (check_conflict, gfc_add_protected, gfc_copy_attr):
+	Likewise.
+	* trans-types.c (gfc_get_array_type_bounds): Likewise.
+
+2008-07-18  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
+
+	* arith.c (eval_type_intrinsic0): Avoid C++ keywords.
+	* gfortran.h (try, protected, operator, new): Likewise.
+
+2008-07-17  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/36825
+	PR fortran/36824
+	* array.c (gfc_match_array_spec): Fix array-rank check.
+	* resolve.c (resolve_fl_derived): Fix constentness check
+	for the array dimensions.
+
+2008-07-14  Ralf Wildenhues  <Ralf.Wildenhues@gmx.de>
+
+	* Make-lang.in (gfortranspec.o): Fix dependencies.
+
+2008-07-13  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/36725
+	* io.c: Add error check for g0 edit descriptor followed by '.'.
+
+2008-07-12  Daniel Kraft  <d@domob.eu>
+
+	* resolve.c (resolve_fl_derived):  Allow pointer components to empty
+	derived types fixing a missing part of PR fortran/33221.
+
+2008-07-10  Daniel Kraft  <d@domob.eu>
+
+	* gfc-internals.texi (section gfc_expr):  Created documentation about
+	the gfc_expr internal data structure.
+
+2008-07-07  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/36670
+	* iresolve.c (gfc_resolve_product):  Set shape of return
+	value from array.
+	(gfc_resolve_sum):  Likewise.
+
+2008-07-07  Jakub Jelinek  <jakub@redhat.com>
+
+	PR middle-end/36726
+	* f95-lang.c (poplevel): Don't ever add subblocks to
+	global_binding_level.
+
+2008-07-02  Janus Weil  <janus@gcc.gnu.org>
+	    Tobias Burnus  <burnus@net-b.de>
+	    Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/32580
+	* gfortran.h (struct gfc_symbol): New member "proc_pointer".
+	* check.c (gfc_check_associated,gfc_check_null): Implement
+	procedure pointers.
+	* decl.c (match_procedure_decl): Ditto.
+	* expr.c (gfc_check_pointer_assign,gfc_check_assign_symbol): Ditto.
+	* interface.c (compare_actual_formal): Ditto.
+	* match.h: Ditto.
+	* match.c (gfc_match_pointer_assignment): Ditto.
+	* parse.c (parse_interface): Ditto.
+	* primary.c (gfc_match_rvalue,match_variable): Ditto.
+	* resolve.c (resolve_fl_procedure): Ditto.
+	* symbol.c (check_conflict,gfc_add_external,gfc_add_pointer,
+	gfc_copy_attr,gen_fptr_param,build_formal_args): Ditto.
+	* trans-decl.c (get_proc_pointer_decl,gfc_get_extern_function_decl,
+	create_function_arglist): Ditto.
+	* trans-expr.c (gfc_conv_variable,gfc_conv_function_val,
+	gfc_conv_function_call,gfc_trans_pointer_assignment): Ditto.
+
+2008-07-02  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/36590
+	PR fortran/36681
+	* iresolve.c (resolve_mask_arg):  Don't convert mask to
+	kind=1 logical if it is of that type already.
+
+2008-06-29  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/36341
+	* iresolve.c (gfc_resolve_matmul): Copy shapes
+	from arguments.
+
+2008-06-29  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	* invoke.texi: Add documentation for runtime behavior of
+	-fno-range-check.
+
+2008-06-28  Daniel Kraft  <d@domob.eu>
+
+	* gfc-internals.texi (section gfc_code):  Extended documentation about
+	gfc_code in the internal datastructures chapter including details about
+	how IF, DO and SELECT blocks look like and an example for how the
+	block-chaining works.
+
+2008-06-25  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/36526
+	* interface.c (check_intents):  Correct error where the actual
+	arg was checked for a pointer argument, rather than the formal.
+
+2008-06-24  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34371
+	* expr.c (gfc_check_assign):  Change message and locus for
+	error when conform == 0.
+
+2008-06-23  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/36597
+	* cpp.c (cpp_define_builtins): Change _OPENMP value to 200805.
+
+2008-06-20  Laurynas Biveinis  <laurynas.biveinis@gmail.com>
+	    Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34908
+	PR fortran/36276
+	* scanner.c (preprocessor_line): do not call gfc_free for
+	current_file->filename if it differs from filename.
+
+2008-06-20  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
+
+	* arith.c (hollerith2representation): Fix for -Wc++-compat.
+	* array.c (gfc_get_constructor): Likewise.
+	* decl.c (gfc_get_data_variable, gfc_get_data_value, gfc_get_data,
+	create_enum_history, gfc_match_final_decl): Likewise.
+	* error.c (error_char): Likewise.
+	* expr.c (gfc_get_expr, gfc_copy_expr): Likewise.
+	* gfortran.h (gfc_get_charlen, gfc_get_array_spec,
+	gfc_get_component, gfc_get_formal_arglist, gfc_get_actual_arglist,
+	gfc_get_namelist, gfc_get_omp_clauses, gfc_get_interface,
+	gfc_get_common_head, gfc_get_dt_list, gfc_get_array_ref,
+	gfc_get_ref, gfc_get_equiv, gfc_get_case, gfc_get_iterator,
+	gfc_get_alloc, gfc_get_wide_string): Likewise.
+	* interface.c (count_types_test): Likewise.
+	* intrinsic.c (add_char_conversions, gfc_intrinsic_init_1):
+	Likewise.
+	* io.c (gfc_match_open, gfc_match_close, match_filepos, match_io,
+	gfc_match_inquire, gfc_match_wait): Likewise.
+	* match.c (gfc_match, match_forall_iterator): Likewise.
+	* module.c (gfc_get_pointer_info, gfc_get_use_rename, add_fixup,
+	add_true_name, parse_string, write_atom, quote_string,
+	mio_symtree_ref, mio_gmp_real, write_common_0): Likewise.
+	* options.c (gfc_post_options): Likewise.
+	* primary.c (match_integer_constant, match_hollerith_constant,
+	match_boz_constant, match_real_constant,
+	gfc_get_structure_ctor_component, gfc_match_structure_constructor): Likewise.
+	* scanner.c (gfc_widechar_to_char, add_path_to_list,
+	add_file_change, load_line, get_file, preprocessor_line,
+	load_file, unescape_filename, gfc_read_orig_filename): Likewise.
+	* simplify.c (gfc_simplify_ibits, gfc_simplify_ishft,
+	gfc_simplify_ishftc): Likewise.
+	* symbol.c (gfc_get_st_label, gfc_get_namespace, gfc_new_symtree,
+	gfc_get_uop, gfc_new_symbol, save_symbol_data, gfc_get_gsymbol):
+	Likewise.
+	* target-memory.c (gfc_target_interpret_expr): Likewise.
+	* trans-const.c (gfc_build_wide_string_const): Likewise.
+	* trans-expr.c (gfc_add_interface_mapping): Likewise.
+	* trans-intrinsic.c (gfc_conv_intrinsic_conversion,
+	gfc_conv_intrinsic_int, gfc_conv_intrinsic_lib_function,
+	gfc_conv_intrinsic_cmplx, gfc_conv_intrinsic_ctime,
+	gfc_conv_intrinsic_fdate, gfc_conv_intrinsic_ttynam,
+	gfc_conv_intrinsic_minmax, gfc_conv_intrinsic_minmax_char,
+	gfc_conv_intrinsic_ishftc, gfc_conv_intrinsic_index_scan_verify,
+	gfc_conv_intrinsic_merge, gfc_conv_intrinsic_trim): Likewise.
+	* trans.c (gfc_get_backend_locus): Likewise.
+	* trans.h (gfc_get_ss): Likewise.
+
+2008-06-18  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/36517, fortran/36492
+	* array.c (gfc_resolve_character_array_constructor):  Call
+	gfc_set_constant_character_len with changed length-chec argument.
+	* decl.c (gfc_set_constant_character_len):  Changed array argument to
+	be a generic length-checking argument that can be used for correct
+	checking with typespec and in special cases where the should-be length
+	is different from the target length.
+	(build_struct):  Call gfc_set_constant_character_len with changed length
+	checking argument and introduced additional checks for exceptional
+	conditions on invalid code.
+	(add_init_expr_to_sym), (do_parm):  Call gfc_set_constant_character_len
+	with changed argument.
+	* match.h (gfc_set_constant_character_len):  Changed third argument to
+	int for the should-be length rather than bool.
+
+2008-06-17  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/36112
+	* array.c (gfc_resolve_character_array_constructor):  Check that all
+	elements with constant character length have the same one rather than
+	fixing it if no typespec is given, emit an error if they don't.  Changed
+	return type to "try" and return FAILURE for the case above.
+	(gfc_resolve_array_constructor):  Removed unneeded call to
+	gfc_resolve_character_array_constructor in this function.
+	* gfortran.h (gfc_resolve_character_array_constructor):  Returns try.
+	* trans-array.c (get_array_ctor_strlen):  Return length of first element
+	rather than last element.
+	* resolve.c (gfc_resolve_expr):  Handle FAILURE return from
+	gfc_resolve_character_array_constructor.
+
+2008-06-17  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34396
+	* resolve.c (add_dt_to_dt_list):  New function.
+	(resolve_fl_derived): Call new function for pointer components
+	and when derived type resolved.
+
+2008-06-15  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/36515
+	* trans-decl.c (gfc_generate_function_code): Add range_check to options
+	array.
+
+2008-06-15  Ralf Wildenhues  <Ralf.Wildenhues@gmx.de>
+
+	* gfc-internals.texi: Expand TABs, drop indentation outside examples.
+	* gfortran.texi: Likewise.
+	* intrinsic.texi: Likewise.
+	* invoke.texi: Likewise.
+
+2008-06-13  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/35863
+	* trans-io.c (gfc_build_io_library_fndecls): Build declaration for
+	transfer_character_wide which includes passing in the character kind to
+	support wide character IO. (transfer_expr): If the kind == 4, create the
+	argument and build the call.
+	* gfortran.texi: Fix typo.
+
+2008-06-13  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/36476
+	* decl.c (do_parm): Handle init expression for len=*.
+
+2008-06-12  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/36462
+	* trans-intrinsic.c (gfc_conv_intrinsic_index_scan_verify):
+	Fix passing of the BACK= argument.
+
+2008-06-10  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	* cpp.c: Add copyright notice.
+	* cpp.h: Add copyright notice.
+
+2008-06-08  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/36459
+	* decl.c (match_procedure_decl): Correctly recognize if the interface
+	is an intrinsic procedure.
+
+2008-06-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/35830
+	* resolve.c (resolve_symbol): Copy more attributes for
+	PROCEDUREs with interfaces.
+
+2008-06-07  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/36420
+	PR fortran/36422
+	* io.c (check_format): Add new error message for zero width.
+	Use new	error message for FMT_A and with READ, FMT_G.  Allow
+	FMT_G with WRITE except when -std=F95 and -std=F2003.
+
+2008-06-07  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/36437
+	* intrinsic.c (add_functions): Implement c_sizeof.
+	* trans-intrinsic.c (gfc_conv_intrinsic_sizeof): Do not
+	create unneeded variable in the scalar case.
+	* intrinsic.texi: Add C_SIZEOF documentation.
+
+2008-06-06  Tobias Burnus  <burnus@net-b.de>
+
+	* intrinsic.texi (BESSEL_J1): Fix BES(S)EL_J1 typo.
+
+2008-06-06  Jakub Jelinek  <jakub@redhat.com>
+
+	* scanner.c (skip_free_comments, skip_fixed_comments): Handle tabs.
+	* parse.c (next_free): Allow tab after !$omp.
+	(decode_omp_directive): Handle !$omp task, !$omp taskwait
+	and !$omp end task.
+	(case_executable): Add ST_OMP_TASKWAIT.
+	(case_exec_markers): Add ST_OMP_TASK.
+	(gfc_ascii_statement): Handle ST_OMP_TASK, ST_OMP_END_TASK and
+	ST_OMP_TASKWAIT.
+	(parse_omp_structured_block, parse_executable): Handle ST_OMP_TASK.
+	* gfortran.h (gfc_find_sym_in_expr): New prototype.
+	(gfc_statement): Add ST_OMP_TASK, ST_OMP_END_TASK and ST_OMP_TASKWAIT.
+	(gfc_omp_clauses): Add OMP_SCHED_AUTO to sched_kind,
+	OMP_DEFAULT_FIRSTPRIVATE to default_sharing.  Add collapse and
+	untied fields.
+	(gfc_exec_op): Add EXEC_OMP_TASK and EXEC_OMP_TASKWAIT.
+	* f95-lang.c (LANG_HOOKS_OMP_CLAUSE_COPY_CTOR,
+	LANG_HOOKS_OMP_CLAUSE_ASSIGN_OP, LANG_HOOKS_OMP_CLAUSE_DTOR,
+	LANG_HOOKS_OMP_PRIVATE_OUTER_REF): Define.
+	* trans.h (gfc_omp_clause_default_ctor): Add another argument.
+	(gfc_omp_clause_copy_ctor, gfc_omp_clause_assign_op,
+	gfc_omp_clause_dtor, gfc_omp_private_outer_ref): New prototypes.
+	* types.def (BT_ULONGLONG, BT_PTR_ULONGLONG,
+	BT_FN_BOOL_ULONGLONGPTR_ULONGLONGPTR,
+	BT_FN_BOOL_BOOL_ULL_ULL_ULL_ULLPTR_ULLPTR,
+	BT_FN_BOOL_BOOL_ULL_ULL_ULL_ULL_ULLPTR_ULLPTR,
+	BT_FN_VOID_PTR_PTR, BT_PTR_FN_VOID_PTR_PTR,
+	BT_FN_VOID_OMPFN_PTR_OMPCPYFN_LONG_LONG_BOOL_UINT): New.
+	(BT_BOOL): Use integer type with BOOL_TYPE_SIZE rather
+	than boolean_type_node.
+	* dump-parse-tree.c (gfc_show_omp_node): Handle EXEC_OMP_TASK,
+	EXEC_OMP_TASKWAIT, OMP_SCHED_AUTO, OMP_DEFAULT_FIRSTPRIVATE,
+	untied and collapse clauses.
+	(gfc_show_code_node): Handle EXEC_OMP_TASK and EXEC_OMP_TASKWAIT.
+	* trans.c (gfc_trans_code): Handle EXEC_OMP_TASK and
+	EXEC_OMP_TASKWAIT.
+	* st.c (gfc_free_statement): Likewise.
+	* resolve.c (gfc_resolve_blocks, resolve_code): Likewise.
+	(find_sym_in_expr): Rename to...
+	(gfc_find_sym_in_expr): ... this.  No longer static.
+	(resolve_allocate_expr, resolve_ordinary_assign): Adjust caller.
+	* match.h (gfc_match_omp_task, gfc_match_omp_taskwait): New
+	prototypes.
+	* openmp.c (resolve_omp_clauses): Allow allocatable arrays in
+	firstprivate, lastprivate, reduction, copyprivate and copyin
+	clauses.
+	(omp_current_do_code): Made static.
+	(omp_current_do_collapse): New variable.
+	(gfc_resolve_omp_do_blocks): Compute omp_current_do_collapse,
+	clear omp_current_do_code and omp_current_do_collapse on return.
+	(gfc_resolve_do_iterator): Handle collapsed do loops.
+	(resolve_omp_do): Likewise, diagnose errorneous collapsed do loops.
+	(OMP_CLAUSE_COLLAPSE, OMP_CLAUSE_UNTIED): Define.
+	(gfc_match_omp_clauses): Handle default (firstprivate),
+	schedule (auto), untied and collapse (n) clauses.
+	(OMP_DO_CLAUSES): Add OMP_CLAUSE_COLLAPSE.
+	(OMP_TASK_CLAUSES): Define.
+	(gfc_match_omp_task, gfc_match_omp_taskwait): New functions.
+	* trans-openmp.c (gfc_omp_private_outer_ref): New function.
+	(gfc_omp_clause_default_ctor): Add outer argument.  For allocatable
+	arrays allocate them with the bounds of the outer var if outer
+	var is allocated.
+	(gfc_omp_clause_copy_ctor, gfc_omp_clause_assign_op,
+	gfc_omp_clause_dtor): New functions.
+	(gfc_trans_omp_array_reduction): If decl is allocatable array,
+	allocate it with outer var's bounds in OMP_CLAUSE_REDUCTION_INIT
+	and deallocate it in OMP_CLAUSE_REDUCTION_MERGE.
+	(gfc_omp_predetermined_sharing): Return OMP_CLAUSE_DEFAULT_SHARED
+	for assumed-size arrays.
+	(gfc_trans_omp_do): Add par_clauses argument.  If dovar is
+	present in lastprivate clause and do loop isn't simple,
+	set OMP_CLAUSE_LASTPRIVATE_STMT.  If dovar is present in
+	parallel's lastprivate clause, change it to shared and add
+	lastprivate clause to OMP_FOR_CLAUSES.  Handle collapsed do loops.
+	(gfc_trans_omp_directive): Adjust gfc_trans_omp_do callers.
+	(gfc_trans_omp_parallel_do): Likewise.  Move collapse clause to
+	OMP_FOR from OMP_PARALLEL.
+	(gfc_trans_omp_clauses): Handle OMP_SCHED_AUTO,
+	OMP_DEFAULT_FIRSTPRIVATE, untied and collapse clauses.
+	(gfc_trans_omp_task, gfc_trans_omp_taskwait): New functions.
+	(gfc_trans_omp_directive): Handle EXEC_OMP_TASK and
+	EXEC_OMP_TASKWAIT.
+
+2008-06-04  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/36322
+	PR fortran/36275
+	* resolve.c (resolve_symbol): Correctly copy the interface for a
+	PROCEDURE declaration.
+
+2008-06-02  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/36361
+	* symbol.c (gfc_add_allocatable,gfc_add_dimension,
+	gfc_add_explicit_interface): Added checks.
+	* decl.c (attr_decl1): Added missing "var_locus".
+	* parse.c (parse_interface): Checking for errors.
+
+2008-06-02  Daniel Kraft  <d@domob.eu>
+
+	* gfortran.h:  New statement-type ST_FINAL for FINAL declarations.
+	(struct gfc_symbol):  New member f2k_derived.
+	(struct gfc_namespace):  New member finalizers, for use in the above
+	mentioned f2k_derived namespace.
+	(struct gfc_finalizer):  New type defined for finalizers linked list.
+	* match.h (gfc_match_final_decl):  New function header.
+	* decl.c (gfc_match_derived_decl):  Create f2k_derived namespace on
+	constructed symbol node.
+	(gfc_match_final_decl):  New function to match a FINAL declaration line.
+	* parse.c (decode_statement):  match-call for keyword FINAL.
+	(parse_derived):  Parse CONTAINS section and accept FINAL statements.
+	* resolve.c (gfc_resolve_finalizers):  New function to resolve (that is
+	in this case, check) a list of finalizer procedures.
+	(resolve_fl_derived):  Call gfc_resolve_finalizers here.
+	* symbol.c (gfc_get_namespace):  Initialize new finalizers to NULL.
+	(gfc_free_namespace):  Free finalizers list.
+	(gfc_new_symbol):  Initialize new f2k_derived to NULL.
+	(gfc_free_symbol):  Free f2k_derived namespace.
+	(gfc_free_finalizer):  New function to free a single gfc_finalizer node.
+	(gfc_free_finalizer_list):  New function to free a linked list of
+	gfc_finalizer nodes.
+
+2008-06-02  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/36375
+	PR fortran/36377
+	* cpp.c (gfc_cpp_init): Do not initialize builtins if
+	processing already preprocessed input.
+	(gfc_cpp_preprocess): Finalize output with newline.
+
+2008-05-31  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	* intrinsic.texi: Revert wrong commit.
+
+2008-05-31  Steven G. Kargl  <kargls@comcast.net>
+
+	* arith.c (gfc_arith_init_1): Remove now unused r and c variables.
+	Cleanup numerical inquiry function initialization.
+	(gfc_arith_done_1): Replace multiple mpfr_clear() invocations with
+	a single mpfr_clears().
+	(gfc_check_real_range): Re-arrange logic to eliminate multiple
+	unnecessary branching and assignments.
+	(gfc_arith_times): Use mpfr_clears() in preference to multiple
+	mpfr_clear().
+	(gfc_arith_divide): Ditto.
+	(complex_reciprocal): Eliminate now unused variables a, re, im.
+	Cleanup the mpfr abuse.  Use mpfr_clears() in preference to
+	multiple mpfr_clear().
+	(complex_pow): Fix comment whitespace.  Use mpfr_clears() in
+	preference to multiple mpfr_clear().
+	* simplify.c (gfc_simplify_and): Remove blank line.
+	(gfc_simplify_atan2): Move error checking earlier to eliminate
+	a now unnecessay gfc_free_expr().
+	(gfc_simplify_bessel_j0): Remove unnecessary gfc_set_model_kind().
+	(gfc_simplify_bessel_j1): Ditto.
+	(gfc_simplify_bessel_jn): Ditto.
+ 	(gfc_simplify_bessel_y0): Ditto.
+	(gfc_simplify_bessel_y1): Ditto.
+	(gfc_simplify_bessel_yn): Ditto. 
+	(only_convert_cmplx_boz): Eliminate unnecessary duplicate code, and
+	combine nested if statement rational expressions.
+	(gfc_simplify_cos): Use mpfr_clears() in preference to multiple
+	mpfr_clear().
+	(gfc_simplify_exp): Ditto.
+	(gfc_simplify_fraction): Move gfc_set_model_kind() to after the
+	special case of 0.  Use mpfr_clears() in preference to multiple
+	mpfr_clear().
+	(gfc_simplify_gamma): Eliminate unnecessary gfc_set_model_kind().
+ 	(gfc_simplify_lgamma): Ditto.
+	(gfc_simplify_log10): Ditto.
+	(gfc_simplify_log): Move gfc_set_model_kind () inside switch
+	statement. Use mpfr_clears() in preference to multiple mpfr_clear().
+	(gfc_simplify_mod):  Eliminate now unused variables quot, iquot,
+	and term.  Simplify the mpfr magic.
+	(gfc_simplify_modulo): Ditto.
+	(gfc_simplify_nearest): Eliminate unnecessary gfc_set_model_kind().
+	(gfc_simplify_scale): Use mpfr_clears() in preference to multiple
+	mpfr_clear().
+	(gfc_simplify_sin): Ditto
+	(gfc_simplify_sqrt): Ditto
+	(gfc_simplify_set_exponent):  Move gfc_set_model_kind() to after the
+	special case of 0.  Use mpfr_clears() in preference to multiple
+	mpfr_clear().
+
+2008-05-29  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR target/36348
+	* Make-lang.in (F95_OBJS): Added dependency on FORTRAN_TARGET_OBJS.
+
+2008-05-29  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* scanner.c (load_line): Add first_char argument. Don't call ungetc.
+	(gfc_read_orig_filename): Adjust call to load_line. Don't call
+	ungetc.
+	(load_file): Adjust call to load_line.
+
+2008-05-28  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/36325
+	PR fortran/35830
+	* interface.c (gfc_procedure_use): Enable argument checking for
+	external procedures with explicit interface.
+	* symbol.c (check_conflict): Fix conflict checking for externals.
+	(copy_formal_args): Fix handling of arrays.
+	* resolve.c (resolve_specific_f0, resolve_specific_s0): Fix handling
+	of intrinsics.
+	* parse.c (parse_interface): Non-abstract INTERFACE statement implies
+	EXTERNAL attribute.
+
+2008-05-28  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/36319
+	* intrinsic.c (gfc_convert_chartype): Don't mark conversion
+	function as pure.
+	* trans-array.c (gfc_trans_array_ctor_element): Divide element
+	size by the size of one character to obtain length.
+	* iresolve.c (gfc_resolve_cshift): Call the _char4 variant when
+	appropriate.
+	(gfc_resolve_eoshift): Likewise.
+	* trans-intrinsic.c (gfc_conv_intrinsic_ctime): Minor beautification.
+	(gfc_conv_intrinsic_fdate): Minor beautification.
+	(gfc_conv_intrinsic_ttynam): Minor beautification.
+	(gfc_conv_intrinsic_minmax_char): Allow all character kinds.
+	(size_of_string_in_bytes): New function.
+	(gfc_conv_intrinsic_size): Call size_of_string_in_bytes for
+	character expressions.
+	(gfc_conv_intrinsic_sizeof): Likewise.
+	(gfc_conv_intrinsic_array_transfer): Likewise.
+	(gfc_conv_intrinsic_trim): Allow all character kinds. Minor
+	beautification.
+	(gfc_conv_intrinsic_repeat): Fix comment typo.
+	* simplify.c (gfc_convert_char_constant): Take care of conversion
+	of array constructors.
+
+2008-05-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/36316
+	* trans-array.c (gfc_set_loop_bounds_from_array_spec):
+	Add missing fold_convert.
+
+2008-05-26  Daniel Franke  <franke.daniel@gmail.com>
+
+	* fortran/cpp.c (cpp_define_builtins): Remove usage of TARGET_* macros,
+	added FIXME instead.
+
+2008-05-26  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/18428
+	* lang.opt (A, C, CC, D, E, H, P, U, cpp, d, fworking-directory,
+	imultilib, iprefix, iquote, isysroot, isystem, nocpp, nostdinc,
+	o, undef, v): New options.
+	* options.c (gfc_init_options): Also initialize preprocessor
+	options.
+	(gfc_post_options): Also handle post-initialization of preprocessor
+	options.
+	(gfc_handle_option): Check if option is a preprocessor option.
+	If yes, let gfc_cpp_handle_option() handle the option.
+	* lang-specs.h: Reorganized to handle new options.
+	* scanner.c (gfc_new_file): Read temporary file instead of
+	input source if preprocessing is enabled.
+	* f95-lang.c (gfc_init): Initialize preprocessor.
+	(gfc_finish): Clean up preprocessor.
+	* cpp.c: New.
+	* cpp.h: New.
+	* Make-lang.in: Added new objects and dependencies.
+	* gfortran.texi: Updated section "Preprocessing and
+	conditional compilation".
+	* invoke.texi: Added new section "Preprocessing Options",
+	listed and documented the preprocessing options handled
+	by gfortran.
+
+2008-05-25  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/32600
+	* trans-expr.c (gfc_conv_function_call): Remove library
+	call for c_f_pointer with scalar Fortran pointers and for
+	c_f_procpointer.
+
+2008-05-21  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/36257
+	* iresolve.c (check_charlen_present): Don't force the rank to 1.
+
+2008-05-19  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/36265
+	* trans-expr.c (gfc_conv_string_tmp): Pick the correct type for
+	the temporary variable.
+
+2008-05-19  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* simplify.c (gfc_simplify_dble, gfc_simplify_real): Initialize
+	result variable to avoid warnings.
+
+2008-05-18  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* intrinsic.c (char_conversions, ncharconv): New static variables.
+	(find_char_conv): New function.
+	(add_functions): Add simplification functions for ADJUSTL and
+	ADJUSTR. Don't check the kind of their argument. Add checking for
+	LGE, LLE, LGT and LLT.
+	(add_subroutines): Fix argument type for SLEEP. Fix argument name
+	for SYSTEM.
+	(add_char_conversions): New function.
+	(gfc_intrinsic_init_1): Call add_char_conversions.
+	(gfc_intrinsic_done_1): Free char_conversions.
+	(check_arglist): Use kind == 0 as a signal that we don't want
+	the kind value to be checked.
+	(do_simplify): Also simplify character functions.
+	(gfc_convert_chartype): New function
+	* trans-array.c (gfc_trans_array_ctor_element): Don't force the
+	use of default character type.
+	(gfc_trans_array_constructor_value): Likewise.
+	(get_array_ctor_var_strlen): Use integer kind to build an integer
+	instead of a character kind!
+	(gfc_build_constant_array_constructor): Don't force the use of
+	default character type.
+	(gfc_conv_loop_setup): Likewise.
+	* trans-expr.c (gfc_conv_string_tmp): Don't force the use of
+	default character type. Allocate enough memory for wide strings.
+	(gfc_conv_concat_op): Make sure operand kind are the same.
+	(string_to_single_character): Remove gfc_ prefix. Reindent.
+	Don't force the use of default character type.
+	(gfc_conv_scalar_char_value): Likewise.
+	(gfc_build_compare_string): Call string_to_single_character.
+	(fill_with_spaces): New function
+	(gfc_trans_string_copy): Add kind arguments. Use them to deal
+	with wide character kinds.
+	(gfc_conv_statement_function): Whitespace fix. Call
+	gfc_trans_string_copy with new kind arguments.
+	(gfc_conv_substring_expr): Call gfc_build_wide_string_const
+	instead of using gfc_widechar_to_char.
+	(gfc_conv_string_parameter): Don't force the use of default
+	character type.
+	(gfc_trans_scalar_assign): Pass kind args to gfc_trans_string_copy.
+	* intrinsic.h (gfc_check_lge_lgt_lle_llt, gfc_convert_char_constant,
+	gfc_resolve_adjustl, gfc_resolve_adjustr): New prototypes.
+	* decl.c (gfc_set_constant_character_len): Don't assert the
+	existence of a single character kind.
+	* trans-array.h (gfc_trans_string_copy): New prototype.
+	* gfortran.h (gfc_check_character_range, gfc_convert_chartype):
+	New prototypes.
+	* error.c (print_wide_char_into_buffer): New function lifting
+	code from gfc_print_wide_char. Fix order to output '\x??' instead
+	of 'x\??'.
+	(gfc_print_wide_char): Call print_wide_char_into_buffer.
+	(show_locus): Call print_wide_char_into_buffer with buffer local
+	to this function.
+	* trans-const.c (gfc_build_wide_string_const): New function.
+	(gfc_conv_string_init): Deal with wide characters strings
+	constructors.
+	(gfc_conv_constant_to_tree): Call gfc_build_wide_string_const.
+	* trans-stmt.c (gfc_trans_label_assign): Likewise.
+	(gfc_trans_character_select): Deal with wide strings.
+	* expr.c (gfc_check_assign): Allow conversion between character
+	kinds on assignment.
+	* trans-const.h (gfc_build_wide_string_const): New prototype.
+	* trans-types.c (gfc_get_character_type_len_for_eltype,
+	gfc_get_character_type_len): Create too variants of the old
+	gfc_get_character_type_len, one getting kind argument and the
+	other one directly taking a type tree.
+	* trans.h (gfor_fndecl_select_string_char4,
+	gfor_fndecl_convert_char1_to_char4,
+	gfor_fndecl_convert_char4_to_char1): New prototypes.
+	* trans-types.h (gfc_get_character_type_len_for_eltype): New
+	prototype.
+	* resolve.c (resolve_operator): Exit early when kind mismatches
+	are detected, because that makes us issue an error message later.
+	(validate_case_label_expr): Fix wording of error message.
+	* iresolve.c (gfc_resolve_adjustl, gfc_resolve_adjustr): New
+	functions.
+	(gfc_resolve_pack): Call _char4 variants of library function
+	when dealing with wide characters.
+	(gfc_resolve_reshape): Likewise.
+	(gfc_resolve_spread): Likewise.
+	(gfc_resolve_transpose): Likewise.
+	(gfc_resolve_unpack): Likewise.
+	* target-memory.c (size_character): Take character kind bit size
+	correctly into account (not that it changes anything for now, but
+	it's more generic).
+	(gfc_encode_character): Added gfc_ prefix. Encoding each
+	character of a string by calling native_encode_expr for the
+	corresponding unsigned integer.
+	(gfc_target_encode_expr): Add gfc_ prefix to encode_character.
+	* trans-decl.c (gfc_build_intrinsic_function_decls): Build
+	gfor_fndecl_select_string_char4, gfor_fndecl_convert_char1_to_char4
+	and gfor_fndecl_convert_char4_to_char1.
+	* target-memory.h (gfc_encode_character): New prototype.
+	* arith.c (gfc_check_character_range): New function.
+	(eval_intrinsic): Allow non-default character kinds.
+	* check.c (gfc_check_access_func): Only allow default
+	character kind arguments.
+	(gfc_check_chdir): Likewise.
+	(gfc_check_chdir_sub): Likewise.
+	(gfc_check_chmod): Likewise.
+	(gfc_check_chmod_sub): Likewise.
+	(gfc_check_lge_lgt_lle_llt): New function.
+	(gfc_check_link): Likewise.
+	(gfc_check_link_sub): Likewise.
+	(gfc_check_symlnk): Likewise.
+	(gfc_check_symlnk_sub): Likewise.
+	(gfc_check_rename): Likewise.
+	(gfc_check_rename_sub): Likewise.
+	(gfc_check_fgetputc_sub): Likewise.
+	(gfc_check_fgetput_sub): Likewise.
+	(gfc_check_stat): Likewise.
+	(gfc_check_stat_sub): Likewise.
+	(gfc_check_date_and_time): Likewise.
+	(gfc_check_ctime_sub): Likewise.
+	(gfc_check_fdate_sub): Likewise.
+	(gfc_check_gerror): Likewise.
+	(gfc_check_getcwd_sub): Likewise.
+	(gfc_check_getarg): Likewise.
+	(gfc_check_getlog): Likewise.
+	(gfc_check_hostnm): Likewise.
+	(gfc_check_hostnm_sub): Likewise.
+	(gfc_check_ttynam_sub): Likewise.
+	(gfc_check_perror): Likewise.
+	(gfc_check_unlink): Likewise.
+	(gfc_check_unlink_sub): Likewise.
+	(gfc_check_system_sub): Likewise.
+	* primary.c (got_delim): Perform correct character range checking
+	for all kinds.
+	* trans-intrinsic.c (gfc_conv_intrinsic_conversion): Generate
+	calls to library functions convert_char4_to_char1 and
+	convert_char1_to_char4 for character conversions.
+	(gfc_conv_intrinsic_char): Allow all character kings.
+	(gfc_conv_intrinsic_strcmp): Fix whitespace.
+	(gfc_conv_intrinsic_repeat): Take care of all character kinds.
+	* intrinsic.texi: For all GNU intrinsics accepting character
+	arguments, mention that they're restricted to the default kind.
+	* simplify.c (simplify_achar_char): New function.
+	(gfc_simplify_achar, gfc_simplify_char): Call simplify_achar_char.
+	gfc_simplify_ichar): Don't error out for wide characters.
+	(gfc_convert_char_constant): New function.
+
+2008-05-18  Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/36251
+	* symbol.c (check_conflict): Issue errors for abuse of PUBLIC, PRIVATE,
+	and BIND(C).
+	* resolve.c (gfc_verify_binding_labels): Fix NULL pointer dereference.
+
+2008-05-17  Tobias Burnus  <burnus@net-b.de>
+
+	* intrinsic.texi: Correct description of GET_COMMAND_ARGUMENT
+	and GET_ENVIRONMENT_VARIABLE; fix keyword= name for GETENV,
+	GETLOG, GMTIME, HOSTNM, IRAND, ITIME, KILL.
+	Move LOG_GAMMA after LOG10.
+
+2008-05-17  Tobias Burnus  <burnus@net-b.de>
+
+	* intrinsic.c (add_functions): Change FLUSH(C) to FLUSH(UNIT).
+	* intrinsic.texi: Change INTEGER(*) to INTEGER; fix keyword= name for
+	ABS, ADJUSTL, AINT, ALLOCATED, ANINT, ASSOCIATED, C_ASSOCIATED,
+	CEILING, DBLE, DFLOAT, DOT_PRODUCT, DREAL, FLOAT, FLOOR, GET_COMMAND.
+
+2008-05-16  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/35756
+	PR fortran/35759
+	* trans-stmt.c (gfc_trans_where): Tighten up the dependency
+	check for calling gfc_trans_where_3.
+
+	PR fortran/35743
+	* trans-stmt.c (gfc_trans_where_2): Set the mask size to zero
+	if it is calculated to be negative.
+
+	PR fortran/35745
+	* trans-stmt.c (gfc_trans_where_3, gfc_trans_where_assign): Set
+	ss->where for scalar right hand sides.
+	* trans-array.c (gfc_add_loop_ss_code): If ss->where is set do
+	not evaluate scalars outside the loop.  Clean up whitespace.
+	* trans.h : Add a bitfield 'where' to gfc_ss.
+
+2008-05-16  Tobias Burnus  <burnus@net-b.de>
+
+	* libgfortran.h: Increase GFC_MAX_DIMENSIONS to 15.
+	* array.c (gfc_match_array_spec): Error with -std=f2003 if rank > 7.
+
+2008-04-16  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/27997
+	* gfortran.h:  Added field "length_from_typespec" to gfc_charlength.
+	* aray.c (gfc_match_array_constructor):  Added code to parse typespec.
+	(check_element_type, check_constructor_type, gfc_check_constructor_type):
+	Extended to support explicit typespec on constructor.
+	(gfc_resolve_character_array_constructor):  Pad strings correctly for
+	explicit, constant character length.
+	* trans-array.c:  New static global variable "typespec_chararray_ctor"
+	(gfc_trans_array_constructor):  New code to support explicit but dynamic
+	character lengths.
+
+2008-05-16  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/34325
+	* decl.c (match_attr_spec): Check for matching pairs of parenthesis.
+	* expr.c (gfc_specification_expr): Supplement the error message with the
+	type that was found.
+	* resolve.c (gfc_resolve_index): Likewise.
+	* match.c (gfc_match_parens): Clarify error message with "at or before".
+	(gfc_match_do): Check for matching pairs of parenthesis.
+
+2008-05-16  Tobias Burnus  <burnus@net-b.de
+
+	* intrinsic.texi: Write Fortran 77/90/95 instead of F77/90/95;
+	add missing KIND argument to ACHAR and NINT; and state that
+	the KIND argument is a F2003 extension for ACHAR, COUNT, IACHAR,
+	ICHAR, INDEX, LBOUND, LEN, LEN_TRIM, SCAN, SIZE, UBOUND, VERIFY.
+
+2008-05-16  Daniel Kraft  <d@domob.eu>
+
+	* primary.c:  New private structure "gfc_structure_ctor_component".
+	(gfc_free_structure_ctor_component):  New helper function.
+	(gfc_match_structure_constructor):  Extended largely to support named
+	arguments and default initialization for structure constructors.
+
+2008-05-15  Steven G. Kargl  <kargls@comcast.net>
+
+	* simplify.c (gfc_simplify_dble, gfc_simplify_float,
+	simplify_bound, gfc_simplify_nearest, gfc_simplify_real): Plug
+	possible memory leaks.
+	(gfc_simplify_reshape): Plug possible memory leaks and dereferencing
+	of NULL pointers.
+
+2008-05-15  Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/36239
+	* simplify.c (gfc_simplify_int, gfc_simplify_intconv): Replaced hand
+	rolled integer conversion with gfc_int2int, gfc_real2int, and
+	gfc_complex2int.
+	(gfc_simplify_intconv): Renamed to simplify_intconv.
+	
+2008-05-15  Steven G. Kargl,   <kargl@comcast.net>
+	* gfortran.dg/and_or_xor.f90: New test
+
+	* fortran/simplify.c (gfc_simplify_and, gfc_simplify_or,
+	gfc_simplify_xor): Don't range check logical results.
+
+2008-05-15  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* trans-expr.c (gfc_conv_concat_op): Take care of nondefault
+	character kinds.
+	(gfc_build_compare_string): Add kind argument and use it.
+	(gfc_conv_statement_function): Fix indentation.
+	* gfortran.h (gfc_character_info): New structure.
+	(gfc_character_kinds): New array.
+	* trans-types.c (gfc_character_kinds, gfc_character_types,
+	gfc_pcharacter_types): New array.
+	(gfc_init_kinds): Fill character kinds array.
+	(validate_character): Take care of nondefault character kinds.
+	(gfc_build_uint_type): New function.
+	(gfc_init_types): Take care of nondefault character kinds.
+	(gfc_get_char_type, gfc_get_pchar_type): New functions.
+	(gfc_get_character_type_len): Use gfc_get_char_type.
+	* trans.h (gfc_build_compare_string): Adjust prototype.
+	(gfor_fndecl_compare_string_char4, gfor_fndecl_concat_string_char4,
+	gfor_fndecl_string_len_trim_char4, gfor_fndecl_string_index_char4,
+	gfor_fndecl_string_scan_char4, gfor_fndecl_string_verify_char4,
+	gfor_fndecl_string_trim_char4, gfor_fndecl_string_minmax_char4,
+	gfor_fndecl_adjustl_char4, gfor_fndecl_adjustr_char4): New
+	prototypes.
+	* trans-types.h (gfc_get_char_type, gfc_get_pchar_type): New
+	prototypes.
+	* trans-decl.c (gfor_fndecl_compare_string_char4,
+	gfor_fndecl_string_len_trim_char4, gfor_fndecl_string_index_char4,
+	gfor_fndecl_string_scan_char4, gfor_fndecl_string_verify_char4,
+	gfor_fndecl_string_trim_char4, gfor_fndecl_string_minmax_char4,
+	gfor_fndecl_adjustl_char4, gfor_fndecl_adjustr_char4,
+	gfor_fndecl_concat_string_char4): New function decls.
+	(gfc_build_intrinsic_function_decls): Define new *_char4 function
+	decls.
+	* trans-intrinsic.c (gfc_conv_intrinsic_minmax_char,
+	gfc_conv_intrinsic_len_trim, gfc_conv_intrinsic_ichar,
+	gfc_conv_intrinsic_strcmp, gfc_conv_intrinsic_trim,
+	gfc_conv_intrinsic_function): Deal with nondefault character kinds.
+
+2008-05-15  Sa Liu  <saliu@de.ibm.com>
+
+	* iso-c-binding.def: Add standard parameter to macro NAMED_INTCST.
+	All existing NAMED_INTCST definitions has standard GFC_STD_F2003,
+	c_int128_t, c_int_least128_t and c_int_fast128_t are added as
+	GNU extensions.
+	* iso-fortran-evn.def: Add standard parameter GFC_STD_F2003
+	to macro NAMED_INTCST.
+	* symbol.c (std_for_isocbinding_symbol): New helper function to 
+	return the standard that supports this isocbinding symbol.
+	(generate_isocbinding_symbol): Do not generate GNU extension symbols
+	if std=f2003. Add new parameter to NAMED_INTCST.
+	* module.c (use_iso_fortran_env_module): Add new parameter to
+	NAMED_INTCST and new field standard to struct intmod_sym.
+	* gfortran.h: Add new parameter to NAMED_INTCST.
+	* trans-types.c (init_c_interop_kinds): Add new parameter to 
+	NAMED_INTCST.
+	* intrinsic.texi: Documented new types C_INT128_T, C_INT_LEASE128_T
+	and C_INT_FAST128_T.
+
+2008-05-14  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/36059
+	* trans-decl.c (gfc_build_dummy_array_decl): Don't repack
+	arrays that have the TARGET attribute.
+
+2008-05-14  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/36186
+	* simplify.c (only_convert_cmplx_boz): New function.
+	(gfc_simplify_cmplx, gfc_simplify_complex, gfc_simplify_dcmplx):
+	Call only_convert_cmplx_boz.
+
+2008-05-14  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/36233
+	* interface.c (compare_actual_formal): Do not check sizes if the
+	actual is BT_PROCEDURE.
+
+2008-05-14  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/35682
+	* trans-array.c (gfc_conv_ss_startstride): Any negative size is
+	the same as zero size.
+	(gfc_conv_loop_setup): Fix size calculation.
+
+2008-05-14  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/35685
+	* trans-intrinsic.c (gfc_conv_intrinsic_bound): Correctly
+	handle zero-size sections.
+
+2008-05-14  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/36215
+	* scanner.c (preprocessor_line): Allocate enough memory for a
+	wide string.
+
+2008-05-12  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/36176
+	* target-memory.c (gfc_target_expr_size): Correctly treat
+	substrings.
+	(gfc_target_encode_expr): Likewise.
+	(gfc_interpret_complex): Whitespace change.
+
+2008-05-11  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/35719
+	* trans.c (gfc_call_malloc): If size equals zero, allocate one
+	byte; don't return a null pointer.
+
+2008-05-10  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/36197
+	* module.c (quote_string): Fix sprintf format.
+
+2008-05-09  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/36162
+	* module.c (quote_string, unquote_string,
+	mio_allocated_wide_string): New functions.
+	(mio_expr): Call mio_allocated_wide_string where needed.
+
+2008-05-07 Kenneth Zadeck <zadeck@naturalbridge.com>
+
+	 * trans-decl.c (gfc_get_extern_function_decl, build_function_decl):
+	 Rename DECL_IS_PURE to DECL_PURE_P.
+
+2008-05-06  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* arith.c: (gfc_arith_concat, gfc_compare_string,
+	gfc_compare_with_Cstring, hollerith2representation,
+	gfc_hollerith2int, gfc_hollerith2real, gfc_hollerith2complex,
+	gfc_hollerith2character, gfc_hollerith2logical): Use wide
+	characters for character constants.
+	* data.c (create_character_intializer): Likewise.
+	* decl.c (gfc_set_constant_character_len): Likewise.
+	* dump-parse-tree.c (show_char_const): Correctly dump wide
+	character strings.
+	error.c (print_wide_char): Rename into gfc_print_wide_char.
+	(show_locus): Adapt to new prototype of gfc_print_wide_char.
+	expr.c (free_expr0): Representation is now disjunct from
+	character string value, so we always free it.
+	(gfc_copy_expr, find_substring_ref, gfc_simplify_expr): Adapt
+	to wide character strings.
+	* gfortran.h (gfc_expr): Make value.character.string a wide string.
+	(gfc_wide_toupper, gfc_wide_strncasecmp, gfc_wide_memset,
+	gfc_widechar_to_char, gfc_char_to_widechar): New prototypes.
+	(gfc_get_wide_string): New macro.
+	(gfc_print_wide_char): New prototype.
+	* io.c (format_string): Make a wide string.
+	(next_char, gfc_match_format, compare_to_allowed_values, 
+	gfc_match_open): Deal with wide strings.
+	* module.c (mio_expr): Convert between wide strings and ASCII ones.
+	* primary.c (match_hollerith_constant, match_charkind_name): 
+	Handle wide strings.
+	* resolve.c (build_default_init_expr): Likewise.
+	* scanner.c (gfc_wide_toupper, gfc_wide_memset,
+	gfc_char_to_widechar): New functions.
+	(wide_strchr, gfc_widechar_to_char, gfc_wide_strncasecmp):
+	Changes in prototypes.
+	(gfc_define_undef_line, load_line, preprocessor_line,
+	include_line, load_file, gfc_read_orig_filename): Handle wide
+	strings.
+	* simplify.c (gfc_simplify_achar, gfc_simplify_adjustl,
+	gfc_simplify_adjustr, gfc_simplify_char, gfc_simplify_iachar,
+	gfc_simplify_ichar, simplify_min_max, gfc_simplify_new_line,
+	gfc_simplify_repeat): Handle wide strings.
+	(wide_strspn, wide_strcspn): New helper functions.
+	(gfc_simplify_scan, gfc_simplify_trim, gfc_simplify_verify):
+	Handle wide strings.
+	* symbol.c (generate_isocbinding_symbol): Likewise.
+	* target-memory.c (size_character, gfc_target_expr_size,
+	encode_character, gfc_target_encode_expr, gfc_interpret_character,
+	gfc_target_interpret_expr): Handle wide strings.
+	* trans-const.c (gfc_conv_string_init): Lower wide strings to
+	narrow ones.
+	(gfc_conv_constant_to_tree): Likewise.
+	* trans-expr.c (gfc_conv_substring_expr): Handle wide strings.
+	* trans-io.c (gfc_new_nml_name_expr): Likewise.
+	* trans-stmt.c (gfc_trans_label_assign): Likewise.
+
+2008-05-06  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* simplify.c (gfc_simplify_bessel_j0,gfc_simplify_bessel_j1,
+	gfc_simplify_bessel_jn,gfc_simplify_bessel_y0,
+	gfc_simplify_bessel_y1,gfc_simplify_bessel_yn): Mark arguments
+	with ATTRIBUTE_UNUSED.
+
+2008-05-06  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* check.c (gfc_check_sizeof): Switch to ATTRIBUTE_UNUSED.
+	* simplify.c (gfc_simplify_lgamma): Likewise.
+
+2008-05-06  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* openmp.c (gfc_match_omp_eos): Use gfc_next_ascii_char and
+	gfc_peek_ascii_char.
+	* decl.c (gfc_match_kind_spec, gfc_match_type_spec,
+	gfc_match_implicit_none, match_implicit_range, gfc_match_implicit,
+	match_string_p, match_attr_spec, gfc_match_suffix,
+	match_procedure_decl, gfc_match_entry, gfc_match_subroutine):
+	Likewise.
+	* gfortran.h (gfc_char_t): New type.
+	(gfc_linebuf): Make line member a gfc_char_t.
+	(locus): Make nextc member a gfc_char_t.
+	(gfc_wide_is_printable, gfc_wide_is_digit, gfc_wide_fits_in_byte,
+	gfc_wide_tolower, gfc_wide_strlen, gfc_next_ascii_char,
+	gfc_peek_ascii_char, gfc_check_digit): New prototypes.
+	* error.c (print_wide_char): New function.
+	(show_locus): Use print_wide_char and gfc_wide_strlen.
+	* io.c (next_char): Use gfc_char_t type.
+	(match_io): Use gfc_peek_ascii_char and gfc_next_ascii_char.
+	* match.c (gfc_match_parens, gfc_match_eos,
+	gfc_match_small_literal_int, gfc_match_name, gfc_match_name_C,
+	gfc_match_intrinsic_op, gfc_match_char,  gfc_match_return,
+	gfc_match_common): Likewise.
+	* match.h (gfc_match_special_char): Change prototype.
+	* parse.c (decode_specification_statement, decode_statement,
+	decode_omp_directive, next_free, next_fixed): Use
+	gfc_peek_ascii_char and gfc_next_ascii_char.
+	* primary.c (gfc_check_digit): Change name.
+	(match_digits, match_hollerith_constant, match_boz_constant,
+	match_real_constant, next_string_char, match_charkind_name,
+	match_string_constant, match_logical_constant_string,
+	match_complex_constant, match_actual_arg, match_varspec,
+	gfc_match_rvalue, match_variable): Use gfc_peek_ascii_char and
+	gfc_next_ascii_char.
+	* scanner.c (gfc_wide_fits_in_byte, wide_is_ascii,
+	gfc_wide_is_printable, gfc_wide_tolower, gfc_wide_is_digit,
+	gfc_wide_is_digit, wide_atoi, gfc_wide_strlen, wide_strcpy,
+	wide_strchr, widechar_to_char, wide_strncmp, wide_strncasecmp,
+	gfc_next_ascii_char, gfc_peek_ascii_char):
+	New functions.
+	(next_char, gfc_define_undef_line, skip_free_comments,
+	gfc_next_char_literal, gfc_next_char, gfc_peek_char,
+	gfc_error_recovery, load_line, preprocessor_line, include_line,
+	load_file, gfc_read_orig_filename): Use gfc_char_t for source
+	characters and the {gfc_,}wide_* functions to manipulate wide
+	strings.
+
+2008-05-06  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/36117
+	* intrinsic.c (add_functions): Call gfc_simplify_bessel_*.
+	* intrinsic.h: Add prototypes for gfc_simplify_bessel_*.
+	* simplify.c (gfc_simplify_bessel_j0,gfc_simplify_bessel_j1,
+	gfc_simplify_bessel_jn,gfc_simplify_bessel_y0,
+	gfc_simplify_bessel_y1,gfc_simplify_bessel_yn): New.
+
+2008-05-03  Janus Weil  <jaydub66@gmail.com>
+
+	* misc.c (gfc_clear_ts): Set interface to NULL.
+
+2008-05-03  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/33268
+	* gfortran.h: Add extra_comma pointer to gfc_dt structure. Add iokind to
+	gfc_expr value union. Add io_kind enum to here from io.c.
+	* io.c (gfc_free_dt): Free extra_comma.
+	(gfc_resolve_dt): If an extra comma was encountered and io_unit is type
+	BT_CHARACTER, resolve to format_expr and set default unit.  Error if
+	io_kind is M_WRITE. (match_io):  Match the extra comma and set new
+	pointer, extra_comma.
+
+2008-05-01  Bud Davis  <bdavis9659@sbcglobal.net>
+
+	PR35940/Fortran
+	* simplify.c (gfc_simplify_index): Check for direction argument 
+	being a constant.
+
+2008-05-01  Janus Weil  <jaydub66@gmail.com>
+
+	* gfortran.h (struct gfc_symbol): Moving "interface" member to
+	gfc_typespec (plus fixing a small docu error).
+	* interface.c (gfc_procedure_use): Ditto.
+	* decl.c (match_procedure_decl): Ditto.
+	* resolve.c (resolve_specific_f0,
+	resolve_specific_f0, resolve_symbol): Ditto.
+
+2008-04-30  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* intrinsic.c (add_functions): Add SELECTED_CHAR_KIND intrinsic.
+	* intrinsic.h (gfc_check_selected_char_kind,
+	gfc_simplify_selected_char_kind): New prototypes.
+	* gfortran.h (gfc_isym_id): Add GFC_ISYM_SC_KIND.
+	* trans.h (gfor_fndecl_sc_kind): New function decl.
+	* trans-decl.c (gfor_fndecl_sc_kind): Build new decl.
+	* arith.c (gfc_compare_with_Cstring): New function.
+	* arith.h (gfc_compare_with_Cstring): New prototype.
+	* check.c (gfc_check_selected_char_kind): New function.
+	* primary.c (match_string_constant, match_kind_param): Mark
+	symbols used as literal constant kind param as referenced.
+	* trans-intrinsic.c (gfc_conv_intrinsic_sc_kind): New function.
+	(gfc_conv_intrinsic_function): Call gfc_conv_intrinsic_sc_kind.
+	* intrinsic.texi (SELECTED_CHAR_KIND): Document new intrinsic.
+	* simplify.c (gfc_simplify_selected_char_kind): New function.
+
+2008-04-28  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/35997
+	* module.c (find_symbol): Do not return a result for a symbol
+	that has been renamed in another module.
+
+2008-04-26  George Helffrich <george@gcc.gnu.org>
+
+	PR fortran/35892
+	PR fortran/35154
+	* trans-common.c (create_common):  Add decl to function
+	chain (if inside one) to preserve identifier scope in debug output.
+
+2008-04-25  Jan Hubicka  <jh@suse.cz>
+
+	* trans-decl.c (trans_function_start): Update.
+
+2008-04-25  Tobias Burnus  <burnus@net-b.de>
+	    Daniel Franke <franke.daniel@gmail.com>
+
+	PR fortran/35156
+	* gfortranspec.c (lang_specific_driver): Deprecate
+	-M option; fix ICE when "-M" is last argument and
+	make "-M<dir>" work.
+	* options.c (gfc_handle_module_path_options): 
+	Use -J instead of -M in error messages.
+	* invoke.texi: Mark -M as depecated.
+
+2008-04-23  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+	    Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/35994
+	* trans-instrinsic.c (gfc_conv_intrinsic_minmaxloc): Correctly adjust
+	loop counter offset.
+
+2008-04-23  Paolo Bonzini  <bonzini@gnu.org>
+
+	* trans-expr.c (gfc_conv_structure): Don't set TREE_INVARIANT.
+	* trans-array.c (gfc_build_null_descriptor): Don't set TREE_INVARIANT.
+	(gfc_trans_array_constructor_value): Don't set TREE_INVARIANT.
+	(gfc_build_constant_array_constructor): Don't set TREE_INVARIANT.
+	(gfc_conv_array_initializer): Don't set TREE_INVARIANT.
+	* trans-common.c (get_init_field): Don't set TREE_INVARIANT.
+	(create_common): Don't set TREE_INVARIANT.
+	* trans-stmt.c (gfc_trans_character_select): Don't set TREE_INVARIANT.
+	* trans-decl.c (gfc_generate_function_code): Don't set TREE_INVARIANT.
+
+2008-04-21  Steve Ellcey  <sje@cup.hp.com>
+
+	* f95-lang.c (gfc_init_decl_processing): use ptr_mode instead of Pmode.
+
+2008-04-21  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/35019
+	* gfortranspec.c (lookup_option): Properly handle separated arguments
+	in -J option, print missing argument message when necessary.
+
+2008-04-20  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/35882
+	* scanner.c (skip_fixed_comments): Update continue_line when comment is
+	detected. (gfc_next_char_literal): Likewise.
+
+2008-04-19  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/35944
+	PR fortran/35946
+	PR fortran/35947
+	* trans_array.c (gfc_trans_array_constructor): Temporarily
+	realign loop, if loop->from is not zero, before creating
+	the temporary array and provide an offset.
+
+	PR fortran/35959
+	* trans-decl.c (gfc_init_default_dt): Add gfc_ prefix to name
+	and allow for NULL body.  Change all references from
+	init_default_dt to gfc_init_default_dt.
+	* trans.h : Add prototype for gfc_init_default_dt.
+	* trans-array.c (gfc_trans_deferred_vars): After nullification
+	call gfc_init_default_dt for derived types with allocatable
+	components.
+
+2008-04-18  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/35892
+	* trans-common.c (create_common): Revert patch causing regression.
+
+2008-04-16  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/35724
+	* iresolve.c (gfc_resolve_eoshift): Check for NULL symtree in test for
+	optional argument attribute.
+	
+2008-04-16  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/35932
+	* trans-intrinsic.c (gfc_conv_intrinsic_char): Even though KIND
+	is not used, the argument must be converted.
+
+2008-04-16  Jakub Jelinek  <jakub@redhat.com>
+
+	PR target/35662
+	* f95-lang.c (gfc_init_builtin_functions): Make sure
+	BUILT_IN_SINCOS{,F,L} types aren't varargs.
+
+2008-04-15  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/35864
+	* expr.c (scalarize_intrinsic_call): Reorder identification of
+	array argument so that if one is not found a segfault does not
+	occur.  Return FAILURE if all scalar arguments.
+
+2008-04-13  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+	    Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/35882
+	* options.c (gfc_init_options): Set the default maximum continuation
+	lines to 255 for both free and fixed form source for warnings.
+	(gfc_handle_option): Set -std=f95 fixed form max continuations to 19 and
+	the -std=f95 free form max continuations to 39 for warnings.
+	* scanner.c (gfc_next_char_literal): Adjust the current_line number only
+	if it is less than the current locus.
+
+2008-04-07  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/25829 28655
+	* io.c (io_tag): Add new tags for decimal, encoding, asynchronous,
+	round, sign, and id. (match_open_element): Match new tags.
+	(gfc_resolve_open): Resolve new tags. (gfc_match_open): Enable encoding
+	for DEFAULT only. Update error messages. (match_dt_element): Fix match
+	tag for asynchronous. Update error messages. (gfc_free_inquire): Free
+	new expressions. (match_inquire_element): Match new tags.
+	(gfc_match_inquire): Add constraint for ID and PENDING.
+	(gfc_resolve_inquire): Resolve new tags.
+	* trans-io.c (gfc_trans_inquire): Clean up whitespace and fix setting of
+	mask for ID parameter.
+	* ioparm.def: Fix order of parameters for pending, round, and sign.
+	NOTE: These must line up with the definitions in libgfortran/io/io.h. or
+	things don't work.
+
+2008-04-06  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/35780
+	* expr.c (scalarize_intrinsic_call): Identify which argument is
+	an array and use that as the template.
+	(check_init_expr): Remove tests that first argument is an array
+	in the call to scalarize_intrinsic_call.
+
+2008-04-06  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	PR fortran/35832
+	* io.c (io_tag): Add field 'value'.  Split 'spec' field in
+	existing io_tags.
+	(match_etag, match_vtag, match_ltag): Split parsing in two steps
+	to give better error messages.
+
+2008-04-06  Tobias Burnus  <burnus@net-b.de>
+
+	* io.c (check_io_constraints): Add constrains. ID= requires
+	asynchronous= and asynchronous= must be init expression.
+
+2008-04-06  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* f95-lang.c: Set LANG_HOOKS_NAME to "GNU Fortran".
+
+2008-04-06  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* dump-parse-tree.c: Use fprintf, fputs and fputc instead of
+	gfc_status and gfc_status_char. Remove gfc_ prefix of the gfc_show_*
+	functions and make them static. Add new gfc_dump_parse_tree
+	function.
+	* gfortran.h (gfc_option_t): Rename verbose into dump_parse_tree.
+	(gfc_status, gfc_status_char): Delete prototypes.
+	* error.c (gfc_status, gfc_status_char): Remove functions.
+	* scanner.c (gfc_new_file): Use printf instead of gfc_status.
+	* options.c (gfc_init_options): Rename verbose into dump_parse_tree.
+	(gfc_handle_module_path_options): Use gfc_fatal_error instead of
+	gfc_status and exit.
+	(gfc_handle_option): Rename verbose into dump_parse_tree.
+	* parse.c (gfc_parse_file): Use gfc_dump_parse_tree.
+
+2008-04-05  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+	    Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/25829 28655
+	* dump-parse-tree.c (gfc_show_code_node): Show new I/O parameters.
+	* gfortran.h (gfc_statement): Add ST_WAIT enumerator.
+	(gfc_open): Add pointers for decimal, encoding, round, sign,
+	asynchronous. (gfc_inquire): Add pointers for asynchronous, decimal,
+	encoding, pending, round, sign, size, id.
+	(gfc_wait): New typedef struct. (gfc_dt): Add pointers for id, pos,
+	asynchronous, blank, decimal, delim, pad, round, sign.
+	(gfc_exec_op): Add EXEC_WAIT enumerator. (gfc_code): Add pointer for
+	wait. (gfc_free_wait), (gfc_resolve_wait): New function prototypes.
+	* trans-stmt.h (gfc_trans_wait): New function prototype.
+	* trans.c (gfc_trans_code): Add case for EXEC_WAIT.
+	* io.c (io_tag): Add new tags for DECIMAL, ENCODING, ROUND, SIGN,
+	ASYCHRONOUS, ID. (match_open_element): Add matchers for new tags.
+	(gfc_free_open): Free new pointers. (gfc_resolve_open): Resolve new
+	tags. (gfc_resolve_open): Remove comment around check for allowed
+	values and ASYNCHRONOUS, update it.  Likewise for DECIMAL, ENCODING,
+	ROUND, and SIGN. (match_dt_element): Add matching for new tags.
+	(gfc_free_wait): New function. (gfc_resolve_wait): New function.
+	(match_wait_element): New function. (gfc_match_wait): New function.
+	* resolve.c (gfc_resolve_blocks): Add case for EXEC_WAIT.
+	(resolve_code): Add case for EXEC_WAIT. 
+	* st.c (gfc_free_statement): Add case for EXEC_WAIT.
+	* trans-io.c (ioparam_type): Add IOPARM_ptype_wait. (gfc_st_parameter):
+	Add "wait" entry. (iocall): Add IOCALL_WAIT enumerator.
+	(gfc_build_io_library_fndecls): Add function declaration for st_wait.
+	(gfc_trans_open): Add mask bits for new I/O tags.
+	(gfc_trans_inquire): Add mask bits for new I/O tags.
+	(gfc_trans_wait): New translation function.
+	(build_dt): Add mask bits for new I/O tags.
+	* match.c (gfc_match_if) Add matcher for "wait".
+	* match.h (gfc_match_wait): Prototype for new function.
+	* ioparm.def: Add new I/O parameter definitions.
+	* parse.c (decode_statement): Add match for "wait" statement.
+	(next_statement): Add case for ST_WAIT. (gfc_ascii_statement): Same.
+
+2008-04-03  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/35786
+	* openmp.c (resolve_omp_clauses): Diagnose if a clause symbol
+	isn't a variable.
+
+2008-04-03  Tom Tromey  <tromey@redhat.com>
+
+	* Make-lang.in (fortran_OBJS): New variable.
+
+2008-04-03  Paolo Bonzini  <bonzini@gnu.org>
+
+	* f95-lang.c (insert_block): Kill.
+
+2008-04-01  George Helffrich <george@gcc.gnu.org>
+
+	PR fortran/35154, fortran/23057
+	* trans-common.c (create_common):  Add decl to function
+	chain to preserve identifier scope in debug output.
+
+2008-04-01  Joseph Myers  <joseph@codesourcery.com>
+
+	* gfortran.texi: Include gpl_v3.texi instead of gpl.texi
+	* Make-lang.in (GFORTRAN_TEXI): Include gpl_v3.texi instead of
+	gpl.texi.
+
+2008-03-30  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/35740
+	* resolve.c (resolve_function, resolve_call): If the procedure
+	is elemental do not look for noncopying intrinsics.
+
+2008-03-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/35698
+	* trans-array.c (gfc_array_init_size): Set 'size' zero if
+	negative in one dimension.
+
+	PR fortran/35702
+	* trans-expr.c (gfc_trans_string_copy): Only assign a char
+	directly if the lhs and rhs types are the same.
+
+2008-03-28  Daniel Franke  <franke.daniel@gmail.com>
+	    Paul Richard Thomas <paul.richard.thomas@gmail.com>
+
+	PR fortran/34714
+	* primary.c (match_variable): Improved matching of function 
+	result variables.
+	* resolve.c (resolve_allocate_deallocate): Removed checks if
+	the actual argument for STAT is a variable.
+
+2008-03-28  Tobias Burnus  <burnus@net-b.de>
+
+	* symbol.c (gfc_get_default_type): Fix error message; option
+	-fallow_leading_underscore should be -fallow-leading-underscore
+
+2008-03-27  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/35724
+	* iresolve.c (gfc_resolve_cshift): Check for NULL symtree in test for
+	optional argument attribute.
+
+2008-03-27  Tom Tromey  <tromey@redhat.com>
+
+	* Make-lang.in: Revert automatic dependency patch.
+
+2008-03-25  Tom Tromey  <tromey@redhat.com>
+
+	* Make-lang.in: Remove .o targets.
+	(fortran_OBJS): New variable.
+	(fortran/gfortranspec.o): Move to fortran/.  Reduce to variable
+	setting.
+	(GFORTRAN_D_OBJS): Update.
+	(GFORTRAN_TRANS_DEPS): Remove.
+
+2008-03-24  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34813
+	* resolve.c (resolve_structure_cons): It is an error to assign
+	NULL to anything other than a pointer or allocatable component.
+
+	PR fortran/33295
+	* resolve.c (resolve_symbol): If the symbol is a derived type,
+	resolve the derived type.  If the symbol is a derived type
+	function, ensure that the derived type is visible in the same
+	namespace as the function.
+
+2008-03-23  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	* trans.h: Use fold_build in build1_v, build2_v and build3_v
+	macros.
+	* trans-openmp.c (gfc_trans_omp_critical, gfc_trans_omp_single):
+	Don't use build2_v macro.
+
+2008-03-19  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/35152
+	* interface.c (gfc_procedure_use): Check for keyworded arguments in
+	procedures without explicit interfaces.
+
+2008-03-16  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/35470
+	* resolve.c (check_assumed_size_reference):  Only visit the
+	first reference and look directly at the highest dimension.
+
+2008-03-15  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/35184
+	* trans-array.c (gfc_conv_array_index_offset): Remove unnecessary
+	assert.
+
+2008-03-15  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/35584
+	* resolve.c (resolve_branch): Less strict and pessimistic warning
+	message.
+
+2008-03-11  Paolo Bonzini  <bonzini@gnu.org>
+
+	* f95-lang.c (LANG_HOOKS_CLEAR_BINDING_STACK): Delete.
+	(gfc_be_parse_file): Call clear_binding_stack from here.
+	(gfc_clear_binding_stack): Rename to clear_binding_stack.
+		
+2008-03-09  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/35474
+	* module.c (mio_symtree_ref): After providing a symbol for a
+	missing equivalence member, resolve and NULL the fixups.
+
+2008-03-09  Ralf Wildenhues  <Ralf.Wildenhues@gmx.de>
+
+	* invoke.texi (Error and Warning Options): Document
+	-Wline-truncation.
+
+2008-03-08  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/34956
+	* trans-array.c (gfc_conv_ss_startstride): Fix the logic to avoid
+	checking bounds of absent optional arguments.
+
+2008-03-06  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/33197
+	* intrinsic.c (add_functions): Add simplification routines for
+	ERF, DERF, ERFC and DERFC.
+	* decl.c (gfc_match_suffix, gfc_match_subroutine): Change GNU
+	extensions into Fortran 2008 features.
+	* intrinsic.h (gfc_simplify_erf, gfc_simplify_erfc): New
+	prototypes.
+	* simplify.c (gfc_simplify_erf, gfc_simplify_erfc): New functions.
+
+2008-03-03  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/33197
+	* intrinsic.c (add_functions): Modify intrinsics ACOSH, ASINH,
+	ATANH, ERF, ERFC and GAMMA. Add intrinsics BESSEL_{J,Y}{0,1,N},
+	ERFC_SCALED, LOG_GAMMA and HYPOT.
+	* intrinsic.h (gfc_check_hypot, gfc_simplify_hypot,
+	gfc_resolve_hypot): New prototypes.
+	* mathbuiltins.def: Add HYPOT builtin. Make complex versions of
+	ACOSH, ASINH and ATANH available.
+	* gfortran.h (GFC_ISYM_ERFC_SCALED, GFC_ISYM_HYPOT): New values.
+	* lang.opt: Add -std=f2008 option.
+	* libgfortran.h: Define GFC_STD_F2008.
+	* lang-specs.h: Add .f08 and .F08 file suffixes.
+	* iresolve.c (gfc_resolve_hypot): New function.
+	* parse.c (parse_contained): Allow empty CONTAINS for Fortran 2008.
+	* check.c (gfc_check_hypot): New function.
+	* trans-intrinsic.c (gfc_intrinsic_map): Define ERFC_SCALE builtin.
+	* options.c (set_default_std_flags): Allow Fortran 2008 by default.
+	(form_from_filename): Add .f08 suffix.
+	(gfc_handle_option): Handle -std=f2008 option.
+	* simplify.c (gfc_simplify_hypot): New function.
+	* gfortran.texi: Document Fortran 2008 status and file extensions.
+	* intrinsic.texi: Document new BESSEL_{J,Y}{0,1,N} intrinsics,
+	as well as HYPOT and ERFC_SCALED. Update documentation of ERF,
+	ERFC, GAMMA, LGAMMA, ASINH, ACOSH and ATANH.
+	* invoke.texi: Document the new -std=f2008 option.
+
+2008-03-02  Jakub Jelinek  <jakub@redhat.com>
+
+	* gfortranspec.c (lang_specific_driver): Update copyright notice
+	dates.
+
+2008-02-29  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/35059
+	* expr.c (find_array_element): Modify traversing the constructor to
+	avoid trying to access NULL memory pointed to by next for the
+	last element. (find_array_section): Exit while loop if cons->next is
+	NULL.
+	* trans-expr.c (gfc_conv_scalar_char_value): Initialize gfc_typespec.
+	(gfc_conv_function_call): Same.
+	* decl.c (gfc_match_implicit): Same.
+	* trans-intrinsic.c (gfc_conv_intrinsic_sr_kind): Same.
+
+2008-02-28  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/31463
+	PR fortran/33950
+	PR fortran/34296
+	* lang.opt: Added -Wreturn-type.
+	* options.c (gfc_handle_option): Recognize -Wreturn-type.
+	* trans-decl.c (gfc_trans_deferred_vars): Emit warnings for funtions
+	where the result value is not set.
+	(gfc_generate_function_code): Likewise.
+	(generate_local_decl): Emit warnings for funtions whose RESULT
+	variable is not set.
+
+2008-02-28  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/34868
+	* trans-expr.c (gfc_conv_variable): Don't build indirect
+	references when explicit interface is mandated.
+	* resolve.c (resolve_formal_arglist): Set attr.always_explicit
+	on the result symbol as well as the procedure symbol.
+
+2008-02-27  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/33387
+	* trans.h: Remove prototypes for gfor_fndecl_math_exponent4,
+	gfor_fndecl_math_exponent8, gfor_fndecl_math_exponent10 and
+	gfor_fndecl_math_exponent16.
+	* f95-lang.c (build_builtin_fntypes): Add new function types.
+	(gfc_init_builtin_functions): Add new builtins for nextafter,
+	frexp, ldexp, fabs, scalbn and inf.
+	* iresolve.c (gfc_resolve_rrspacing): Don't add hidden arguments.
+	(gfc_resolve_scale): Don't convert type of second argument.
+	(gfc_resolve_set_exponent): Likewise.
+	(gfc_resolve_size): Don't add hidden arguments.
+	* trans-decl.c: Remove gfor_fndecl_math_exponent4,
+	gfor_fndecl_math_exponent8, gfor_fndecl_math_exponent10 and
+	gfor_fndecl_math_exponent16.
+	* trans-intrinsic.c (gfc_intrinsic_map): Remove intrinsics
+	for scalbn, fraction, nearest, rrspacing, set_exponent and
+	spacing.
+	(gfc_conv_intrinsic_exponent): Directly call frexp.
+	(gfc_conv_intrinsic_fraction, gfc_conv_intrinsic_nearest,
+	gfc_conv_intrinsic_spacing, gfc_conv_intrinsic_rrspacing,
+	gfc_conv_intrinsic_scale, gfc_conv_intrinsic_set_exponent): New
+	functions.
+	(gfc_conv_intrinsic_function): Use the new functions above.
+
+2008-02-26  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/35033
+	* interface.c (check_operator_interface): Show better line for error
+	messages; fix constrains for user-defined assignment operators.
+	(gfc_extend_assign): Fix constrains for user-defined assignment
+	operators.
+
+2008-02-26  Tom Tromey  <tromey@redhat.com>
+
+	* trans-io.c (set_error_locus): Remove old location code.
+	* trans-decl.c (gfc_set_decl_location): Remove old location code.
+	* f95-lang.c (gfc_init): Remove test of USE_MAPPED_LOCATION.
+	* scanner.c (gfc_gobble_whitespace): Remove old location code.
+	(get_file): Likewise.
+	(preprocessor_line): Likewise.
+	(load_file): Likewise.
+	(gfc_new_file): Likewise.
+	* trans.c (gfc_trans_runtime_check): Remove old location code.
+	(gfc_get_backend_locus): Likewise.
+	(gfc_set_backend_locus): Likewise.
+	* data.c (gfc_assign_data_value): Remove old location code.
+	* error.c (show_locus): Remove old location code.
+	* gfortran.h (gfc_linebuf): Remove old location code.
+	(gfc_linebuf_linenum): Remove old-location variant.
+
+2008-02-25  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/34729
+	* trans-const.c (gfc_build_string_const): Don't call gettext.
+	(gfc_build_localized_string_const): New function.
+	* trans-const.h (gfc_build_localized_string_const): New prototype.
+	* trans.c (gfc_trans_runtime_check): Use
+	gfc_build_localized_string_const instead of gfc_build_string_const.
+	(gfc_call_malloc): Likewise.
+	(gfc_allocate_with_status): Likewise.
+	(gfc_allocate_array_with_status): Likewise.
+	(gfc_deallocate_with_status): Likewise.
+	(gfc_call_realloc): Likewise.
+	* trans-io.c (gfc_trans_io_runtime_check): Likewise.
+
+2008-02-24  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	* arith.c: Update copyright years.
+	* arith.h: Likewise.
+	* array.c: Likewise.
+	* bbt.c: Likewise.
+	* check.c: Likewise.
+	* data.c: Likewise.
+	* data.h: Likewise.
+	* decl.c: Likewise.
+	* dependency.c: Likewise.
+	* dependency.h: Likewise.
+	* dump-parse-tree.c: Likewise.
+	* error.c: Likewise.
+	* expr.c: Likewise.
+	* gfc-internals.texi: Likewise.
+	* gfortran.h: Likewise.
+	* gfortran.texi: Likewise.
+	* gfortranspec.c: Likewise.
+	* interface.c: Likewise.
+	* intrinsic.c: Likewise.
+	* intrinsic.h: Likewise.
+	* intrinsic.texi: Likewise.
+	* invoke.texi: Likewise.
+	* io.c: Likewise.
+	* iresolve.c: Likewise.
+	* iso-c-binding.def: Likewise.
+	* iso-fortran-env.def: Likewise.
+	* lang-specs.h: Likewise.
+	* lang.opt: Likewise.
+	* libgfortran.h: Likewise.
+	* match.c: Likewise.
+	* match.h: Likewise.
+	* matchexp.c: Likewise.
+	* misc.c: Likewise.
+	* module.c: Likewise.
+	* openmp.c: Likewise.
+	* options.c: Likewise.
+	* parse.c: Likewise.
+	* parse.h: Likewise.
+	* primary.c: Likewise.
+	* resolve.c: Likewise.
+	* scanner.c: Likewise.
+	* simplify.c: Likewise.
+	* st.c: Likewise.
+	* symbol.c: Likewise.
+	* target-memory.c: Likewise.
+	* target-memory.h: Likewise.
+	* trans-array.h: Likewise.
+	* trans-const.h: Likewise.
+	* trans-stmt.h: Likewise.
+	* trans-types.c: Likewise.
+	* trans-types.h: Likewise.
+	* types.def: Likewise.
+
+2008-02-24  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/35223
+	* simplify.c (gfc_simplify_ibclr), (gfc_simplify_ibits),
+	(gfc_simplify_ibset): Remove call to range_check.
+	(simplify_cmplx), (gfc_simplify_dble), (gfc_simplify_float)
+	(gfc_simplify_real): Add call gfc_clear_ts to initialize the
+	temporary gfc_typspec variable.
+
+2008-02-24  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	* trans-array.c (gfc_conv_descriptor_data_get,
+	gfc_conv_descriptor_data_set_internal,
+	gfc_conv_descriptor_data_addr, gfc_conv_descriptor_offset,
+	gfc_conv_descriptor_dtype, gfc_conv_descriptor_dimension,
+	gfc_conv_descriptor_stride, gfc_conv_descriptor_lbound,
+	gfc_conv_descriptor_ubound, gfc_trans_create_temp_array,
+	gfc_conv_array_transpose, gfc_grow_array,
+	gfc_trans_array_constructor_subarray,
+	gfc_trans_array_constructor_value, gfc_trans_scalarized_loop_end,
+	gfc_array_init_size, gfc_array_allocate, gfc_array_deallocate,
+	gfc_conv_array_initializer, gfc_trans_array_bounds,
+	gfc_trans_auto_array_allocation, gfc_trans_dummy_array_bias,
+	gfc_get_dataptr_offset, gfc_conv_array_parameter,
+	gfc_trans_dealloc_allocated, get_full_array_size,
+	gfc_duplicate_allocatable, structure_alloc_comps): Use fold_buildN
+	instead of buildN.
+	* trans-expr.c (gfc_conv_expr_present, gfc_conv_missing_dummy,
+	gfc_conv_component_ref, gfc_conv_cst_int_power,
+	gfc_conv_function_call, gfc_trans_structur_assign): Likewise.
+	* trans-common.c (create_common): Likewise.
+	* trans-openmp.c (gfc_trans_omp_atomic, gfc_trans_omp_do):
+	Likewise.
+	* trans-const.c (gfc_conv_constant_to_tree): Likewise.
+	* trans-stmt.c (gfc_trans_goto, gfc_trans_return, gfc_trans_do,
+	gfc_trans_integer_select, gfc_trans_character_select,
+	gfc_trans_forall_loop, compute_overall_iter_number,
+	gfc_trans_forall_1, gfc_evaluate_where_mask, gfc_trans_allocate,
+	gfc_trans_deallocate): Likewise.
+	* trans.c (gfc_build_addr_expr, gfc_trans_runtime_check,
+	gfc_allocate_with_status, gfc_allocate_array_with_status,
+	gfc_deallocate_with_status): Likewise.
+	* f95-lang.c (gfc_truthvalue_conversion): Likewise.
+	* trans-io.c (set_parameter_const, set_parameter_value,
+	set_parameter_ref, set_string, set_internal_unit, io_result,
+	set_error_locus, nml_get_addr_expr, transfer_expr): Likewise.
+	* trans-decl.c (gfc_build_qualified_array, build_entry_thunks,
+	gfc_get_fake_result_decl, gfc_trans_auto_character_variable,
+	gfc_generate_function_code): Likewise.
+	* convert.c (convert): Likewise.
+	* trans-intrinsic.c (gfc_conv_intrinsic_conversion,
+	build_fixbound_expr, build_fix_expr, gfc_conv_intrinsic_aint,
+	gfc_conv_intrinsic_int, gfc_conv_intrinsic_imagpart,
+	gfc_conv_intrinsic_conjg, gfc_conv_intrinsic_abs,
+	gfc_conv_intrinsic_cmplx, gfc_conv_intrinsic_mod,
+	gfc_conv_intrinsic_dim, gfc_conv_intrinsic_dprod,
+	gfc_conv_intrinsic_ctime, gfc_conv_intrinsic_fdate,
+	gfc_conv_intrinsic_ttynam, gfc_conv_intrinsic_minmax,
+	gfc_conv_intrinsic_minmax_char, gfc_conv_intrinsic_count,
+	gfc_conv_intrinsic_arith, gfc_conv_intrinsic_dot_product,
+	gfc_conv_intrinsic_minmaxloc, gfc_conv_intrinsic_minmaxval,
+	gfc_conv_intrinsic_btest, gfc_conv_intrinsic_not,
+	gfc_conv_intrinsic_ibits, gfc_conv_intrinsic_ishft,
+	gfc_conv_intrinsic_ichar, gfc_conv_intrinsic_size,
+	gfc_conv_intrinsic_array_transfer, gfc_conv_intrinsic_transfer,
+	gfc_conv_allocated, gfc_conv_associated, gfc_conv_intrinsic_trim,
+	gfc_conv_intrinsic_repeat): Likewise.
+
+2008-02-23  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR target/25477
+	* trans-expr.c (gfc_conv_power_op): Use BUILT_IN_CPOW{F,,L}.
+	* f95-lang.c (gfc_init_builtin_functions): Define BUILT_IN_CPOW{F,,L}.
+	* trans.h (gfor_fndecl_math_cpow, gfor_fndecl_math_cpowf,
+	gfor_fndecl_math_cpowl10, gfor_fndecl_math_cpowl16): Remove.
+	* trans-decl.c: Likewise.
+
+2008-02-22  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/35059
+	* expr.c (find_array_element): Modify traversing the constructor to
+	avoid trying to access NULL memory pointed to by next for the
+	last element. (find_array_section): Exit while loop if cons->next is
+	NULL.
+
+2008-02-22  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/34907
+	* iresolve.c (resolve_mask_arg): Add gfc_clear_ts to initialize
+	structure.
+	(gfc_resolve_aint): Likewise.
+	(gfc_resolve_anint): Likewise.
+	(gfc_resolve_besn): Likewise.
+	(gfc_resolve_cshift): Likewise.
+	(gfc_resolve_ctime): Likewise.
+	(gfc_resolve_eoshift): Likewise.
+	(gfc_resolve_index_func): Likewise.
+	(gfc_resolve_isatty): Likewise.
+	(gfc_resolve_malloc): Likewise.
+	(gfc_resolve_rrspacing): Likewise.
+	(gfc_resolve_scale): Likewise.
+	(gfc_resolve_set_exponent): Likewise.
+	(gfc_resolve_spacing): Likewise.
+	(gfc_resolve_spacing): Likewise.
+	(gfc_resolve_fgetc): Likewise.
+	(gfc_resolve_fputc): Likewise.
+	(gfc_resolve_ftell): Likewise.
+	(gfc_resolve_ttynam): Likewise.
+	(gfc_resolve_alarm_sub): Likewise.
+	(gfc_resolve_mvbits): Likewise.
+	(gfc_resolve_getarg): Likewise.
+	(gfc_resolve_signal_sub): Likewise.
+	(gfc_resolve_exit): Likewise.
+	(gfc_resolve_flush): Likewise.
+	(gfc_resolve_free): Likewise.
+	(gfc_resolve_ctime_sub): Likewise.
+	(gfc_resolve_fgetc_sub): Likewise.
+	(gfc_resolve_fputc_sub): Likewise.
+	(gfc_resolve_fseek_sub): Likewise.
+	(gfc_resolve_ftell_sub): Likewise.
+	(gfc_resolve_ttynam_sub): Likewise.
+
+2008-02-22  Ralf Wildenhues  <Ralf.Wildenhues@gmx.de>
+
+	* gfc-internals.texi: Fix typos and markup nits.
+	* gfortran.texi: Likewise.
+	* intrinsic.texi: Likewise.
+
+2008-02-21  Richard Guenther  <rguenther@suse.de>
+
+	* trans-expr.c (gfc_conv_expr_op): Expand INTRINSIC_PARENTHESES
+	as unary PAREN_EXPR for real and complex typed expressions.
+	(gfc_conv_unary_op): Fold the built tree.
+
+2008-02-20  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34997
+	* match.c (gfc_match_name): Improve error message for '$'.
+
+2008-02-19  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/35030
+	* expr.c (gfc_check_pointer_assign): Add type and kind information
+	to type-mismatch message.
+	(gfc_check_assign): Unify error messages.
+
+2008-02-16  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/34952
+	* gfortran.texi: Create new section for unimplemented extensions.
+	Add "STRUCTURE and RECORD" and "ENCODE and DECODE statements".
+	Remove "smaller projects" list. Fix a few typos.
+
+2008-02-15  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* intrinsic.texi: Rename INDEX node to avoid clashing with
+	index.html on case-insensitive systems.
+
+2008-02-15  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/35150
+	* trans-expr.c (gfc_conv_function_call): Force evaluation of
+	se->expr.
+
+2008-02-10  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/35019
+	* lang.opt: Allow '-J<dir>' next to '-J <dir>', 
+	likewise '-I <dir>' and '-I<dir>'.
+
+2008-02-06  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
+
+	PR other/35107
+	* Make-lang.in (f951): Add $(GMPLIBS).
+
+2008-02-05  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/35037
+	* trans-common.c (build_field): Mark fields as volatile when needed.
+
+2008-02-05  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/35093
+	* data.c (gfc_assign_data_value): Only free "size" if
+	it has not already been freed.
+
+2008-02-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34945
+	* array.c (match_array_element_spec): Remove check for negative
+	array size.
+	(gfc_resolve_array_spec): Add check for negative size.
+
+2008-02-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/32315
+	* data.c (gfc_assign_data_value): Add bounds check for array
+	references.
+
+2008-02-04  Daniel Franke  <franke.daniel@gmail.com>
+
+	* resolve.c (resolve_where): Fix typo.
+	(gfc_resolve_where_code_in_forall): Likewise.
+
+2008-02-03  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/32760
+	* resolve.c (resolve_allocate_deallocate): New function.
+	(resolve_code): Call it for allocate and deallocate.
+	* match.c (gfc_match_allocate, gfc_match_deallocate) : Remove
+	the checking of the STAT tag and put in above new function.
+	* primary,c (match_variable): Do not fix flavor of host
+	associated symbols yet if the type is not known.
+
+2008-01-31  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34910
+	* expr.c (gfc_check_assign): It is an error to assign
+	to a sibling procedure.
+
+2008-01-30  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34975
+	* symbol.c (gfc_delete_symtree, gfc_undo_symbols): Rename
+	delete_symtree to gfc_delete_symtree.
+	* gfortran.h : Add prototype for gfc_delete_symtree.
+	* module.c (load_generic_interfaces): Transfer symbol to a
+	unique symtree and delete old symtree, instead of renaming.
+	(read_module): The rsym and the found symbol are the same, so
+	the found symtree can be deleted.
+
+	PR fortran/34429
+	* decl.c (match_char_spec): Remove the constraint on deferred
+	matching of functions and free the length expression.
+	delete_symtree to gfc_delete_symtree.
+	(gfc_match_type_spec): Whitespace.
+	(gfc_match_function_decl): Defer characteristic association for
+	all types except BT_UNKNOWN.
+	* parse.c (decode_specification_statement): Only derived type
+	function matching is delayed to the end of specification.
+
+2008-01-28  Tobias Burnus  <burnus@net-b.de>
+
+	PR libfortran/34980
+	* simplify.c (gfc_simplify_shape): Simplify rank zero arrays.
+
+2008-01-27  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/34990
+	* array.c (gfc_check_constructor_type): Revert clearing the expression.
+
+2008-01-26  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34848
+	* trans-expr.c (gfc_conv_function_call): Don't call
+	gfc_add_interface_mapping if the expression is NULL.
+
+2008-01-26  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/31610
+	* trans-array.c (gfc_trans_create_temp_array): Remove call to
+	gcc_assert (integer_zerop (loop->from[n])).
+
+2008-01-25  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/34661
+	* resolve.c (resolve_where): Added check if user-defined assignment 
+	operator is an elemental subroutine.
+	(gfc_resolve_where_code_in_forall): Likewise.
+
+2008-01-24  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/33375
+	PR fortran/34858
+	* gfortran.h: Revert changes from 2008-01-17.
+	* match.c: Likewise.
+	* symbol.c: Likewise.
+	(gfc_undo_symbols): Undo namespace changes related to common blocks.
+
+2008-01-24  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/34202
+	* data.c (formalize_structure_cons): Skip formalization on
+	empty structures.
+
+2008-01-24  Daniel Franke  <franke.daniel@gmail.com>
+
+	* gfortran.texi (OpenMP): Extended existing documentation.
+	(contributors): Added major contributors of 2008 that were
+	not listed yet.
+	(proposed extensions): Removed implemented items.
+
+2008-01-24  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34872
+	* parse.c (next_statement) : If ST_GET_FCN_CHARACTERISTICS  is
+	seen, check for a statement label and, if present, delete it
+	and set the locus to the start of the statement.
+
+2008-01-22  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34875
+	* trans-io.c (gfc_trans_transfer): If the array reference in a
+	read has a vector subscript, use gfc_conv_subref_array_arg to
+	copy back the temporary.
+
+2008-01-22  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34848
+	* interface.c (compare_actual_formal): Fix adding type
+	to missing_arg_type for absent optional arguments.
+
+2008-01-22  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34907
+	* parse.c (parse_spec): Change = into ==.
+
+2008-01-22  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/34915
+	* expr.c (check_elemental): Fix check for valid data types.
+
+2008-01-22  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34899
+	* scanner.c (load_line): Support <tab><digit> continuation lines.
+	* invoke.texi (-Wtabs): Document this.
+
+2008-01-22  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34896
+	* module.c (read_module): Set use_rename attribute.
+
+2008-01-21  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34901
+	* interface.c (compare_parameter): Improved error message
+	for arguments of same type and mismatched kinds.
+
+2008-01-20  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34861
+	* resolve.c (resolve_entries): Do not do an array bounds check
+	if the result symbols are the same.
+
+	PR fortran/34854
+	* module.c (read_module) : Hide the symtree of the previous
+	version of the symbol if this symbol is renamed.
+
+2008-01-20  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34784
+	* array.c (gfc_check_constructor_type): Clear the expression ts
+	so that the checking starts from the deepest level of array
+	constructor.
+	* primary.c (match_varspec): If an unknown type is changed to
+	default character and the attempt to match a substring fails,
+	change it back to unknown.
+
+	PR fortran/34785
+	* trans-array.c (gfc_add_loop_ss_code) : If ss->string_length is
+	NULL for an array constructor, use the cl.length expression to
+	build it.
+	(gfc_conv_array_parameter): Change call to gfc_evaluate_now to
+	a tree assignment.
+
+2008-01-19  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/34817
+	PR fortran/34838
+	* iresolve.c (gfc_resolve_all):  Remove conversion of mask
+	argument to kind=1 by removing call to resolve_mask_arg().
+	(gfc_resolve_any):  Likewise.
+
+2008-01-19  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34760
+	* primary.c (match_variable): Handle FL_UNKNOWN without
+	uneducated guessing.
+	(match_variable): Improve error message.
+
+2008-01-18  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/32616
+	* interface.c (get_expr_storage_size): Return storage size
+	for array element designators.
+	(compare_actual_formal): Reject unequal string sizes for
+	assumed-shape dummy arguments. And fix error message for
+	array-sections with vector subscripts.
+
+2008-01-17  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/34556
+	* simplify.c (is_constant_array_expr): New static function that returns
+	true if the given expression is an array and is constant.
+	(gfc_simplify_reshape): Use new function.
+
+2008-01-17  H.J. Lu  <hongjiu.lu@intel.com>
+
+	PR fortran/33375
+	* symbol.c (free_common_tree): Renamed to ...
+	(gfc_free_common_tree): This.  Remove static.
+	(gfc_free_namespace): Updated.
+
+	* gfortran.h (gfc_free_common_tree): New.
+
+	* match.c (gfc_match_common): Call gfc_free_common_tree () with
+	gfc_current_ns->common_root and set gfc_current_ns->common_root
+	to NULL on syntax error.
+
+2008-01-18  Richard Sandiford  <rsandifo@nildram.co.uk>
+
+	PR fortran/34686
+	* trans-expr.c (gfc_conv_function_call): Use proper
+	type for returned character pointers.
+
+2008-01-17  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34429
+	PR fortran/34431
+	PR fortran/34471
+	* decl.c : Remove gfc_function_kind_locus and
+	gfc_function_type_locus. Add gfc_matching_function.
+	(match_char_length): If matching a function and the length
+	does not match, return MATCH_YES and try again later.
+	(gfc_match_kind_spec): The same.
+	(match_char_kind): The same.
+	(gfc_match_type_spec): The same for numeric and derived types.
+	(match_prefix): Rename as gfc_match_prefix.
+	(gfc_match_function_decl): Except for function valued character
+	lengths, defer applying kind, type and charlen info until the
+	end of specification block.
+	gfortran.h (gfc_statement): Add ST_GET_FCN_CHARACTERISTICS.
+	parse.c (decode_specification_statement): New function.
+	(decode_statement): Call it when a function has kind = -1. Set
+	and reset gfc_matching function, as function statement is being
+	matched.
+	(match_deferred_characteristics): Simplify with a single call
+	to gfc_match_prefix. Do appropriate error handling. In any
+	case, make sure that kind = -1 is reset or corrected.
+	(parse_spec): Call above on seeing ST_GET_FCN_CHARACTERISTICS.
+	Throw an error if kind = -1 after last specification statement.
+	parse.h : Prototype for gfc_match_prefix.
+
+2008-01-16  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34796
+	* interface.c (compare_parameter): Allow AS_DEFERRED array
+	elements and reject attr.pointer array elemenents.
+	(get_expr_storage_size): Return storage size of elements of
+	assumed-shape and pointer arrays.
+
+2008-01-15  Sebastian Pop  <sebastian.pop@amd.com>
+
+	* f95-lang.c (gfc_init_builtin_functions): Initialize GOMP builtins
+	for flag_tree_parallelize_loops.
+
+2008-01-15  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR libfortran/34671
+	* iresolve.c (gfc_resolve_all):  Call resolve_mask_arg.
+	(gfc_resolve_any):  Likewise.
+	(gfc_resolve_count):  Likewise.  Don't append kind of
+	argument to function name.
+
+2008-01-13  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34665
+	* resolve.c (resolve_actual_arglist): For expressions,
+	also check for assume-sized arrays.
+	* interface.c (compare_parameter): Move F2003 character checks
+	here, print error messages here, reject elements of
+	assumed-shape array as argument to dummy arrays.
+	(compare_actual_formal): Update for the changes above.
+
+2008-01-13  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34763
+	* decl.c (contained_procedure): Only check directly preceeding state.
+
+2008-01-13  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34759
+	* check.c (gfc_check_shape): Accept array ranges of
+	assumed-size arrays.
+
+2008-01-12  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/34432
+	* match.c (gfc_match_name): Don't error if leading character is a '(',
+	just return MATCH_NO.
+
+2008-01-11  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/34722
+	* trans-io.c (create_dummy_iostat): Commit the symbol.
+
+2008-01-11  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34537
+	* simplify.c (gfc_simplify_transfer): Return NULL if the size
+	of the element is unavailable and only assign character length
+	to the result, if 'mold' is constant.
+
+2008-01-10  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34396
+	* trans-array.c (gfc_trans_array_ctor_element):  Use gfc_trans_string_copy
+	to assign strings and perform bounds checks on the string length.
+	(get_array_ctor_strlen): Remove bounds checking.
+	(gfc_trans_array_constructor): Initialize string length checking.
+	* trans-array.h : Add prototype for gfc_trans_string_copy.
+
+2008-01-08  Richard Guenther  <rguenther@suse.de>
+
+	PR fortran/34706
+	PR tree-optimization/34683
+	* trans-types.c (gfc_get_array_type_bounds): Use an array type
+	with known size for accesses if that is known.
+
+2008-01-08  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34476
+	* expr.c (find_array_element): Check that the array bounds are
+	constant before using them.  Use lower, as well as upper bound.
+	(check_restricted): Allow implied index variable.
+
+2008-01-08  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34681
+	* trans_array.c (gfc_trans_deferred_array): Do not null the
+	data pointer on entering scope, nor deallocate it on leaving
+	scope, if the symbol has the 'save' attribute.
+
+	PR fortran/34704
+	* trans_decl.c (gfc_finish_var_decl): Derived types with
+	allocatable components and an initializer must be TREE_STATIC.
+
+2008-01-07  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34672
+	* module.c (write_generic): Rewrite completely.
+	(write_module): Change call to write_generic.
+
+2008-01-06  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/34659
+	* scanner.c (load_line): Do not count ' ' as printable when checking for
+	continuations.
+
+2008-01-06  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34545
+	* module.c (load_needed): If the namespace has no proc_name
+	give it the module symbol.
+
+2008-01-06  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/34387
+	* trans-expr.c (gfc_conv_missing_dummy): Use a temporary to type convert
+	the dummy variable expression, test for NULL, and pass the variable
+	address to the called function.
+
+2008-01-06  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34658
+	* match.c (gfc_match_common): Remove blank common in
+	DATA BLOCK warning.
+	* resolve.c (resolve_common_vars): New function.
+	(resolve_common_blocks): Move checks to resolve_common_vars
+	and invoke that function.
+	(resolve_types): Call resolve_common_vars for blank commons.
+
+2008-01-06  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34655
+	* resolve.c (resolve_equivalence_derived): Reject derived types with
+	default initialization if equivalenced with COMMON variable.
+
+2008-01-06  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34654
+	* io.c (check_io_constraints): Disallow unformatted I/O for
+	internal units.
+
+2008-01-06  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34660
+	* resolve.c (resolve_formal_arglist): Reject dummy procedure in
+	ELEMENTAL functions.
+
+2008-01-06  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34662
+	* interface.c (compare_actual_formal): Reject parameter
+	actual to intent(out) dummy.
+
+2008-01-04  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34557
+	* primary.c (match_varspec): Gobble whitespace before
+	checking for '('.
+
+
+Copyright (C) 2008 Free Software Foundation, Inc.
+
+Copying and distribution of this file, with or without modification,
+are permitted in any medium without royalty provided the copyright
+notice and this notice are preserved.
diff --git a/gcc-4.9/gcc/fortran/ChangeLog-2009 b/gcc-4.9/gcc/fortran/ChangeLog-2009
new file mode 100644
index 000000000..c5b7e621b
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/ChangeLog-2009
@@ -0,0 +1,3710 @@
+2009-12-29  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42517
+	* invoke.texi: Document the interference of
+	-fcheck=recursion and -fopenmp.
+	* trans-decl.c (gfc_generate_function_code): Disable -fcheck=recursion
+	when used with -fopenmp.
+
+2009-12-28  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42353
+	* symbol.c (gfc_find_derived_vtab): Make vtabs and vtypes private.
+
+2009-12-27  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+	    Daniel Kraft  <d@domob.eu>
+
+	PR fortran/22552
+	* lang.opt (Wimplicit-procedure): New option.
+	* gfortran.h (struct gfc_option_t): New member `warn_implicit_procedure'
+	* options.c (gfc_handle_option): Handle -Wimplicit-procedure.
+	* interface.c (gfc_procedure_use): Warn about procedure never
+	explicitly declared if requested by the new flag.
+	* invoke.texi: Document new flag -Wimplicit-procedure.
+
+2009-12-17  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42144
+	* trans-expr.c (select_class_proc): Skip abstract base types.
+
+2009-12-16  Kazu Hirata  <kazu@codesourcery.com>
+
+	* gfc-internals.texi, gfortran.texi, invoke.texi: Fix typos.
+	Follow spelling conventions.
+
+2009-12-15  Tobias Burnus  <burnus@net-b.de>
+	    Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/41235
+	* resolve.c (resolve_global_procedure): Add check for
+	presence of an explicit interface for nonconstant,
+	nonassumed character-length functions.
+	(resolve_fl_procedure): Remove check for nonconstant
+	character-length functions.
+
+2009-12-14  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/42354
+	* expr.c (check_init_expr): Do not check for specification functions.
+
+2009-12-11  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42257
+	* module.c (write_dt_extensions): Check for accessibility.
+
+2009-12-11  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/40290
+	* expr.c (gfc_type_convert_binary): Added warn-on-conversion flag,
+	passed on to gfc_convert_type_warn() instead of gfc_convert_type();
+	enabled warnings on all callers but ...
+	* arith.c (eval_intrinsic): Disabled warnings on implicit type
+	conversion.
+	* gfortran.h gfc_type_convert_binary): Adjusted prototype.
+
+2009-12-11  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42335
+	* symbol.c (select_type_insert_tmp): Add an extra check for
+	error recovery.
+
+2009-12-10  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/40287
+	* iresolve.c (resolve_mask_arg): Disabled warning on conversion
+	to LOGICAL(1).
+
+2009-12-10  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/41369
+	* parse.c (match_deferred_characteristics): Removed check for empty
+	types in function return values.
+
+2009-12-10  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/34402
+	* expr.c (check_alloc_comp_init): New.
+	(check_init_expr): Verify that allocatable components
+	are not data-initalized.
+
+2008-12-08  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/41177
+	* gfortran.h (struct symbol_attribute): New flag `class_pointer'.
+	* symbol.c (gfc_build_class_symbol): Set the new flag.
+	* resolve.c (update_compcall_arglist): Remove wrong check for
+	non-scalar base-object.
+	(check_typebound_baseobject): Add the correct version here as well
+	as some 'not implemented' message check in the old case.
+	(resolve_typebound_procedure): Check that the passed-object dummy
+	argument is scalar, non-pointer and non-allocatable as it should be.
+
+2009-12-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40961
+	PR fortran/40377
+	* gfortran.texi (Non-Fortran Main Program): Add
+	_gfortran_set_fpe documentation.
+	(Interoperability with C): Mention array storage order.
+
+2009-12-07  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/41940
+	* match.c (gfc_match_allocate): Improved error message for
+	allocatable scalars that are allocated with a shape.
+
+2009-12-07  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
+
+	PR other/40302
+	* arith.c: Remove HAVE_mpc* checks throughout.
+	* expr.c: Likewise.
+	* gfortran.h: Likewise.
+	* resolve.c: Likewise.
+	* simplify.c: Likewise.
+	* target-memory.c: Likewise.
+	* target-memory.h: Likewise.
+
+2009-12-06  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/40904
+	* intrinsics.texi: Fixed description of COUNT.
+
+2009-12-01  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	PR fortran/42131
+	* trans-stmt.c (gfc_trans_do): Sign test using ternary operator.
+
+2009-11-30  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42053
+	* resolve.c (resolve_select_type): Check for duplicate CLASS IS blocks.
+
+2009-11-30  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41631
+	* decl.c (gfc_match_derived_decl): Set extension level.
+	* gfortran.h (symbol_attribute): Expand 'extension' bit field to 8 bit.
+	* iresolve.c (gfc_resolve_extends_type_of): Return value of
+	'is_extension_of' has kind=4.
+	* match.c (select_type_set_tmp,gfc_match_class_is): Create temporary
+	for CLASS IS blocks.
+	* module.c (MOD_VERSION): Bump module version.
+	(ab_attribute,attr_bits): Remove AB_EXTENSION.
+	(mio_symbol_attribute): Handle expanded 'extension' field.
+	* resolve.c (resolve_select_type): Implement CLASS IS blocks.
+	(resolve_fl_variable_derived): Show correct type name.
+	* symbol.c (gfc_build_class_symbol): Set extension level.
+
+2009-11-30  Janus Weil  <janus@gcc.gnu.org>
+
+	* intrinsic.h (gfc_resolve_extends_type_of): Add prototype.
+	* intrinsic.c (add_functions): Use 'gfc_resolve_extends_type_of'.
+	* iresolve.c (gfc_resolve_extends_type_of): New function, which
+	replaces the call to EXTENDS_TYPE_OF by the library function
+	'is_extension_of' and modifies the arguments.
+	* trans-intrinsic.c (gfc_conv_extends_type_of): Removed.
+	(gfc_conv_intrinsic_function): FOR EXTENDS_TYPE_OF, don't call
+	gfc_conv_extends_type_of but gfc_conv_intrinsic_funcall.
+
+2009-11-30  Paul Thomas  <pault@gcc.gnu.org>
+	    Janus Weil  <janus@gcc.gnu.org>
+
+	* decl.c (encapsulate_class_symbol): Replaced by
+	'gfc_build_class_symbol'.
+	(build_sym,build_struct): Call 'gfc_build_class_symbol'.
+	(gfc_match_derived_decl): Replace vindex by hash_value.
+	* dump-parse-tree.c (show_symbol): Replace vindex by hash_value.
+	* gfortran.h (symbol_attribute): Add field 'vtab'.
+	(gfc_symbol): Replace vindex by hash_value.
+	(gfc_class_esym_list): Ditto.
+	(gfc_get_derived_type,gfc_build_class_symbol,gfc_find_derived_vtab):
+	New prototypes.
+	* module.c (mio_symbol): Replace vindex by hash_value.
+	* resolve.c (vindex_expr): Rename to 'hash_value_expr'.
+	(resolve_class_compcall,resolve_class_typebound_call): Renamed
+	'vindex_expr'.
+	(resolve_select_type): Replace $vindex by $vptr->$hash.
+	* symbol.c (gfc_add_save): Handle vtab symbols.
+	(gfc_type_compatible): Rewrite.
+	(gfc_build_class_symbol): New function which replaces
+	'encapsulate_class_symbol'.
+	(gfc_find_derived_vtab): New function to set up a vtab symbol for a
+	derived type.
+	* trans-decl.c (gfc_create_module_variable): Handle vtab symbols.
+	* trans-expr.c (select_class_proc): Replace vindex by hash_value.
+	(gfc_conv_derived_to_class): New function to construct a temporary
+	CLASS variable from a derived type expression.
+	(gfc_conv_procedure_call): Call 'gfc_conv_derived_to_class'.
+	(gfc_conv_structure): Initialize the $extends and $size fields of
+	vtab symbols.
+	(gfc_trans_class_assign): Replace $vindex by $vptr. Remove the $size
+	assignment.
+	* trans-intrinsic.c (gfc_conv_same_type_as): Replace $vindex by
+	$vptr->$hash, and replace vindex by hash_value.
+	* trans-stmt.c (gfc_trans_allocate): Insert $vptr references, replace
+	$vindex by $vptr. Remove the $size assignment.
+	* trans-types.c (gfc_get_derived_type): Make it non-static.
+
+2009-11-30  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/42131
+	* trans-stmt.c (gfc_trans_do):  Calculate loop count
+	without if statements.
+
+2009-11-28  Jakub Jelinek  <jakub@redhat.com>
+
+	* trans-common.c (create_common): Remove unused offset variable.
+	* io.c (gfc_match_wait): Remove unused loc variable.
+	* trans-openmp.c (gfc_trans_omp_clauses): Remove unused old_clauses
+	variable.
+	(gfc_trans_omp_do): Remove unused outermost variable.
+	* iresolve.c (gfc_resolve_alarm_sub, gfc_resolve_fseek_sub): Remove
+	unused status variable.
+	* module.c (number_use_names): Remove unused c variable.
+	(load_derived_extensions): Remove unused nuse variable.
+	* trans-expr.c (gfc_conv_substring): Remove unused var variable.
+	* trans-types.c (gfc_get_array_descr_info): Remove unused offset_off
+	variable.
+	* matchexp.c (match_primary): Remove unused where variable.
+	* trans-intrinsic.c (gfc_conv_intrinsic_bound): Remove unused cond2
+	variable.
+	(gfc_conv_intrinsic_sizeof): Remove unused source variable.
+	(gfc_conv_intrinsic_transfer): Remove unused stride variable.
+	(gfc_conv_intrinsic_function): Remove unused isym variable.
+	* arith.c (gfc_hollerith2real, gfc_hollerith2complex,
+	gfc_hollerith2logical): Remove unused len variable.
+	* parse.c (parse_derived): Remove unused derived_sym variable.
+	* decl.c (variable_decl): Remove unused old_locus variable.
+	* resolve.c (check_class_members): Remove unused tbp_sym variable.
+	(resolve_ordinary_assign): Remove unused assign_proc variable.
+	(resolve_equivalence): Remove unused value_name variable.
+	* data.c (get_array_index): Remove unused re variable.
+	* trans-array.c (gfc_conv_array_transpose): Remove unused src_info
+	variable.
+	(gfc_conv_resolve_dependencies): Remove unused aref and temp_dim
+	variables.
+	(gfc_conv_loop_setup): Remove unused dim and len variables.
+	(gfc_walk_variable_expr): Remove unused head variable.
+	* match.c (match_typebound_call): Remove unused var variable.
+	* intrinsic.c (gfc_convert_chartype): Remove unused from_ts variable.
+
+2009-11-26  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/41807
+	* trans-const.c (gfc_conv_const): Set se->expr to a constant on error.
+
+2009-11-26  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/41278
+	* trans-array.c (gfc_conv_array_transpose): Delete unnecessary assert.
+
+2009-11-26  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42048
+	PR fortran/42167
+	* gfortran.h (gfc_is_function_return_value): New prototype.
+	* match.c (gfc_match_call): Use new function
+	'gfc_is_function_return_value'.
+	* primary.c (gfc_is_function_return_value): New function to check if a
+	symbol is the return value of an encompassing function.
+	(match_actual_arg,gfc_match_rvalue,match_variable): Use new function
+	'gfc_is_function_return_value'.
+	* resolve.c (resolve_common_blocks,resolve_actual_arglist): Ditto.
+
+2009-11-25  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/42162
+	* trans-openmp.c (gfc_trans_omp_do): When dovar isn't a VAR_DECL,
+	don't use simple loop and handle clauses properly.
+
+2009-11-24  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/42008
+	* decl.c (variable_decl): Do not error on initialization within a
+	derived type specification of a pure procedure.
+
+2009-11-24  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42045
+	* resolve.c (resolve_actual_arglist): Make sure procedure pointer
+	actual arguments are resolved correctly.
+	(resolve_function): An EXPR_FUNCTION which is a procedure pointer
+	component, has already been resolved.
+	(resolve_fl_derived): Procedure pointer components should not be
+	implicitly typed.
+
+2009-11-21  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/41807
+	* trans-const.c (gfc_conv_const): Fix typo in comment. Replace assert
+	with error message if not constant.
+	* resolve.c (next_data_value): Delete check for constant.
+
+2009-11-20  Janus Weil  <janus@gcc.gnu.org>
+
+	* intrinsic.texi (C_F_PROCPOINTER): Remove obsolete comment.
+
+2009-11-20  Paul Thomas  <pault@gcc.gnu.org>
+	    Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42104
+	* trans-expr.c (gfc_conv_procedure_call): If procedure pointer
+	component call, use the component's 'always_explicit' attr
+	for array arguments.
+
+2009-11-19  Janus Weil  <janus@gcc.gnu.org>
+
+	* trans-expr.c (conv_isocbinding_procedure): New function.
+	(gfc_conv_procedure_call): Move ISO_C_BINDING stuff to
+	separate function.
+
+2009-11-19  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.texi (Interoperable Subroutines and Functions): Fix
+	example.
+
+2009-11-18  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42072
+	* trans-expr.c (gfc_conv_procedure_call): Handle procedure pointer
+	dummies which are passed to C_F_PROCPOINTER.
+
+2009-11-18  Alexandre Oliva  <aoliva@redhat.com>
+
+	* module.c (mio_f2k_derived): Initialize op.
+
+2009-11-15  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42048
+	* match.c (gfc_match_call): If we're inside a function with derived
+	type return value, allow calling a TBP of the result variable.
+
+2009-11-12  Tobias Burnus  <burnus@net-b.de>
+
+	* intrinsic.texi (XOR): Refer also to .NEQV.
+	(ISO_FORTRAN_ENV): State which parameters are F2008.
+
+2009-11-11  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41978
+	* resolve.c (resolve_ref): Take care of procedure pointer component
+	references.
+
+2009-11-06  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/41909
+	* resolve.c (is_illegal_recursion): Return false if sym is program.
+
+2009-11-06  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* resolve.c (check_typebound_override): Remove duplicate "in" in error
+	message.
+
+2009-11-05  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/41918
+	* fortran/trans-decl.c: Silence intent(out) warning for derived type
+	dummy arguments with default initialization.
+
+2009-11-05  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41556
+	* interface.c (matching_typebound_op,gfc_extend_assign): Handle CLASS
+	variables.
+
+2009-11-05  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41556
+	PR fortran/41873
+	* resolve.c (resolve_function,resolve_call): Prevent abstract interfaces
+	from being called, but allow deferred type-bound procedures with
+	abstract interface.
+
+2009-11-04  Tobias Burnus <burnus@gcc.gnu.org>
+	    Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41556
+	PR fortran/41937
+	* interface.c (gfc_check_operator_interface): Handle CLASS arguments.
+	* resolve.c (resolve_allocate_expr): Handle allocatable components of
+	CLASS variables.
+
+2009-11-04  Richard Guenther  <rguenther@suse.de>
+
+	* options.c (gfc_post_options): Rely on common code processing
+	LTO options.  Only enable -fwhole-file here.
+
+2009-11-03  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/41907
+	* trans-expr.c (gfc_conv_procedure_call): Fix presence check
+	for optional arguments.
+
+2009-11-01  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/41872
+	* trans-decl.c (gfc_trans_deferred_vars): Do not nullify
+	autodeallocated allocatable scalars at the end of scope.
+	(gfc_generate_function_code): Fix indention.
+	* trans-expr.c (gfc_conv_procedure_call): For allocatable
+	scalars, fix calling by reference and autodeallocating
+	of intent out variables.
+
+2009-11-01  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/41850
+	* trans-expr.c (gfc_conv_procedure_call): Deallocate intent-out
+	variables only when present. Remove unneccessary present check.
+
+2009-10-29  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/41777
+	* trans-expr.c (gfc_conv_procedure_call,gfc_conv_expr_reference):
+	Use for generic EXPR_FUNCTION the attributes of the specific
+	function.
+
+2009-10-29  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	PR fortran/41860
+	* resolve.c (apply_default_init_local): Treat -fno-automatic as if
+	var was saved.
+
+2009-10-28  Rafael Avila de Espindola  <espindola@google.com>
+
+	* trans-common.c (create_common): Set TREE_PUBLIC to false on
+	fake variables.
+
+2009-10-26  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41714
+	* trans.c (gfc_trans_code): Remove call to
+	'tree_annotate_all_with_location'. Location should already be set.
+	* trans-openmp.c (gfc_trans_omp_workshare): Ditto.
+	* trans-stmt.c (gfc_trans_allocate): Do correct data initialization for
+	CLASS variables with SOURCE tag, plus some cleanup.
+
+2009-10-24  Janus Weil  <janus@gcc.gnu.org>
+	    Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/41784
+	* module.c (load_derived_extensions): Skip symbols which are not being
+	loaded.
+
+2009-10-24  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/41772
+	* trans-intrinsic.c (gfc_conv_intrinsic_transfer): Stop'extent'
+	from going negative.
+
+2009-10-23  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41800
+	* trans-expr.c (gfc_trans_scalar_assign): Handle CLASS variables.
+
+2009-10-23  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41758
+	* match.c (conformable_arrays): Move to resolve.c.
+	(gfc_match_allocate): Don't resolve SOURCE expr yet, and move some
+	checks to resolve_allocate_expr.
+	* resolve.c (conformable_arrays): Moved here from match.c.
+	(resolve_allocate_expr): Moved some checks here from gfc_match_allocate.
+	(resolve_code): Resolve SOURCE tag for ALLOCATE expressions.
+
+2009-10-22  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41781
+	* resolve.c (resolve_codes): Don't clear 'cs_base' for BLOCK constructs,
+	to make sure labels are treated correctly.
+	* symbol.c (gfc_get_st_label): Create labels in the right namespace.
+	For BLOCK constructs go into the parent namespace.
+
+2009-10-21  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41706
+	PR fortran/41766
+	* match.c (select_type_set_tmp): Set flavor for temporary.
+	* resolve.c (resolve_class_typebound_call): Correctly resolve actual
+	arguments.
+
+2009-10-20  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/41706
+	* resolve.c (resolve_arg_exprs): New function.
+	(resolve_class_compcall): Call the above.
+	(resolve_class_typebound_call): The same.
+
+2009-10-19  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41586
+	* parse.c (parse_derived): Correctly set 'alloc_comp' and 'pointer_comp'
+	for CLASS variables.
+	* trans-array.c (structure_alloc_comps): Handle deallocation and
+	nullification of allocatable scalar components.
+	* trans-decl.c (gfc_get_symbol_decl): Remember allocatable scalars for
+	automatic deallocation.
+	(gfc_trans_deferred_vars): Automatically deallocate allocatable scalars.
+
+2009-10-19  Tobias Burnus  <burnus@net-b.de>
+	    Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/41755
+	* symbol.c (gfc_undo_symbols): Add NULL check.
+	* match.c (gfc_match_equivalence): Add check for
+	missing comma.
+
+2009-10-19  Richard Guenther  <rguenther@suse.de>
+
+	PR fortran/41494
+	* trans-expr.c (gfc_trans_scalar_assign): Do not call
+	gfc_evaluate_now.
+
+2009-10-17  Janus Weil  <janus@gcc.gnu.org>
+	    Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/41608
+	* decl.c (gfc_match_data_decl): Add BT_CLASS for undefined type
+	and empty type errors.
+	* parse.c (gfc_build_block_ns): Only set recursive if parent ns
+	has a proc_name.
+
+	PR fortran/41629
+	PR fortran/41618
+	PR fortran/41587
+	* gfortran.h : Add class_ok bitfield to symbol_attr.
+	* decl.c (build_sym): Set attr.class_ok if dummy, pointer or
+	allocatable.
+	(build_struct): Use gfc_try 't' to carry errors past the call
+	to encapsulate_class_symbol.
+	(attr_decl1): For a CLASS object, apply the new attribute to
+	the data component.
+	* match.c (gfc_match_select_type): Set attr.class_ok for an
+	assigned selector.
+	* resolve.c (resolve_fl_variable_derived): Check a CLASS object
+	is dummy, pointer or allocatable by testing the class_ok and
+	the use_assoc attribute.
+
+2009-10-16  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41719
+	* resolve.c (resolve_ordinary_assign): Reject intrinsic assignments
+	to polymorphic variables.
+
+2009-10-16  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/41648
+	PR fortran/41656
+	* trans-expr.c (select_class_proc): Convert the expression for the
+	vindex, carried on the first member of the esym list.
+	* gfortran.h : Add the vindex field to the esym_list structure.
+	and eliminate the class_object field.
+	* resolve.c (check_class_members): Remove the setting of the
+	class_object field.
+	(vindex_expr): New function.
+	(get_class_from_expr): New function.
+	(resolve_class_compcall): Call the above to find the ultimate
+	class or derived component.  If derived, do not generate the
+	esym list.  Add and expression for the vindex to the esym list
+	by calling the above.
+	(resolve_class_typebound_call): The same.
+
+2009-10-15  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/41712
+	* intrinsic.texi: Explicitly state that ETIME and DTIME take
+	REAL(4) arguments.  Fix nearby typographically errors where 
+	/leq was used instead of \leq.
+
+2009-10-13  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41581
+	* decl.c (encapsulate_class_symbol): Add new component '$size'.
+	* resolve.c (resolve_allocate_expr): Move CLASS handling to
+	gfc_trans_allocate.
+	(resolve_class_assign): Replaced by gfc_trans_class_assign.
+	(resolve_code): Remove calls to resolve_class_assign.
+	* trans.c (gfc_trans_code): Use new function gfc_trans_class_assign.
+	* trans-expr.c (get_proc_ptr_comp): Fix a memory leak.
+	(gfc_conv_procedure_call): For CLASS dummies, set the
+	$size component.
+	(gfc_trans_class_assign): New function, replacing resolve_class_assign.
+	* trans-stmt.h (gfc_trans_class_assign): New prototype.
+	* trans-stmt.c (gfc_trans_allocate): Use correct size when allocating
+	CLASS variables. Do proper initialization. Move some code here from
+	resolve_allocate_expr.
+
+2009-10-11 Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/38439
+	* io.c (check_format): Fix locus for error messages and fix a comment.
+
+2009-10-11  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/41583
+	* decl.c (hash_value): New function.
+	(gfc_match_derived_decl): Call it.
+
+2009-10-09  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41585
+	* decl.c (build_struct): Bugfix for CLASS components.
+
+2009-10-09  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/41582
+	* decl.c (encapsulate_class_symbol): Save attr.abstract.
+	* resolve.c (resolve_allocate_expr): Reject class allocate
+	without typespec or source=.
+	* trans-stmt.c (gfc_trans_allocate): Change gfc_warning
+	into gfc_error for "not yet implemented".
+
+2009-10-09  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41579
+	* gfortran.h (gfc_select_type_stack): New struct, to be used as a stack
+	for SELECT TYPE statements.
+	(select_type_stack): New global variable.
+	(type_selector,select_type_tmp): Removed.
+	* match.c (type_selector,type_selector): Removed.
+	(select_type_stack): New variable, serving as a stack for
+	SELECT TYPE statements.
+	(select_type_push,select_type_set_tmp): New functions.
+	(gfc_match_select_type): Call select_type_push.
+	(gfc_match_type_is): Call select_type_set_tmp.
+	* parse.c (select_type_pop): New function.
+	(parse_select_type_block): Call select_type_pop.
+	* symbol.c (select_type_insert_tmp): New function.
+	(gfc_find_sym_tree): Call select_type_insert_tmp.
+
+2009-10-07  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
+
+	* arith.c (arith_power): Use mpc_pow_z.
+	* gfortran.h (HAVE_mpc_pow_z): Define.
+
+2009-10-07  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/41615
+	* resolve.c (resolve_contained_fntype): Clarify error message for
+	invalid assumed-length character result on module procedures.
+
+2009-10-07  Janus Weil  <janus@gcc.gnu.org>
+
+	* expr.c (gfc_check_pointer_assign): Do the correct type checking when
+	CLASS variables are involved.
+	* match.c (gfc_match_select_type): Parse associate-name in SELECT TYPE
+	statements, and set up a local namespace for the SELECT TYPE block.
+	* parse.h (gfc_build_block_ns): New prototype.
+	* parse.c (parse_select_type_block): Return from local namespace to its
+	parent after SELECT TYPE block.
+	(gfc_build_block_ns): New function for setting up the local namespace
+	for a BLOCK construct.
+	(parse_block_construct): Use gfc_build_block_ns.
+	* resolve.c (resolve_select_type): Insert assignment for the selector
+	variable, in case an associate-name is given, and put the SELECT TYPE
+	statement inside a BLOCK.
+	(resolve_code): Call resolve_class_assign after checking the assignment.
+	* symbol.c (gfc_find_sym_tree): Moved some code here from
+	gfc_get_ha_sym_tree.
+	(gfc_get_ha_sym_tree): Moved some code to gfc_find_sym_tree.
+
+2009-10-07  Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/41613
+	* resolve.c (check_class_members): Reset compcall.assign.
+
+2009-10-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	* trans-expr.c (select_class_proc): New function.
+	(conv_function_val): Deal with class methods and call above.
+	* symbol.c (gfc_type_compatible): Treat case where both ts1 and
+	ts2 are BT_CLASS.
+	gfortran.h : Add structure gfc_class_esym_list and include in
+	the structure gfc_expr.
+	* module.c (load_derived_extensions): New function.
+	(read_module): Call above.
+	(write_dt_extensions): New function.
+	(write_derived_extensions): New function.
+	(write_module): Use the above.
+	* resolve.c (resolve_typebound_call): Add a function expression
+	for class methods.  This carries the chain of symbols for the
+	dynamic dispatch in select_class_proc.
+	(resolve_compcall): Add second, boolean argument to indicate if
+	a function is being handled.
+	(check_members): New function.
+	(check_class_members): New function.
+	(resolve_class_compcall): New function.
+	(resolve_class_typebound_call): New function.
+	(gfc_resolve_expr): Call above for component calls.. 
+
+2009-10-05  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/41403
+	* trans-stmt.c (gfc_trans_goto): Ignore statement list on assigned goto
+	if it is present.
+
+2009-10-03  Richard Guenther  <rguenther@suse.de>
+
+	* options.c (gfc_post_options): Handle -flto and -fwhopr.
+
+2009-10-02  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/41479
+	* trans-decl.c (gfc_init_default_dt): Check for presence of
+	the argument only if it is optional or in entry master.
+	(init_intent_out_dt): Ditto; call gfc_init_default_dt
+	for all derived types with initializers.
+
+2009-10-01  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
+
+	PR fortran/33197
+	* gfortran.h (HAVE_mpc_arc): Define.
+	* simplify.c (gfc_simplify_acos): Handle complex acos.
+	(gfc_simplify_acosh): Likewise for acosh.
+	(gfc_simplify_asin): Likewise for asin.
+	(gfc_simplify_asinh): Likewise for asinh.
+	(gfc_simplify_atan): Likewise for atan.
+	(gfc_simplify_atanh): Likewise for atanh.
+
+2009-10-01  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/41515
+	* decl.c (do_parm): Call add_init_expr_to_sym.
+
+2009-09-30  Dennis Wassel  <dennis.wassel@gmail.com>
+
+	* gcc/fortran/trans-array.c (gfc_trans_array_bound_check): Improved
+	bounds checking error messages. (gfc_conv_array_ref): Likewise.
+	(gfc_conv_ss_startstride): Likewise.
+
+2009-09-30  Janus Weil  <janus@gcc.gnu.org>
+
+	* resolve.c (check_typebound_baseobject): Don't check for
+	abstract types for CLASS.
+	(resolve_class_assign): Adapt for RHS being a CLASS.
+	* trans-intrinsic.c (gfc_conv_associated): Add component ref
+	if expr is a CLASS.
+
+2009-09-30  Janus Weil  <janus@gcc.gnu.org>
+
+	* check.c (gfc_check_same_type_as): New function for checking
+	SAME_TYPE_AS and EXTENDS_TYPE_OF.
+	* decl.c (encapsulate_class_symbol): Set ABSTRACT attribute for class
+	container, if the contained type has it. Add an initializer for the
+	class container.
+	(add_init_expr_to_sym): Handle BT_CLASS.
+	(vindex_counter): New counter for setting vindices.
+	(gfc_match_derived_decl): Set vindex for all derived types, not only
+	those which are being extended.
+	* expr.c (gfc_check_assign_symbol): Handle NULL initialization of class
+	pointers.
+	* gfortran.h (gfc_isym_id): New values GFC_ISYM_SAME_TYPE_AS and
+	GFC_ISYM_EXTENDS_TYPE_OF.
+	(gfc_type_is_extensible): New prototype.
+	* intrinsic.h (gfc_check_same_type_as): New prototype.
+	* intrinsic.c (add_functions): Add SAME_TYPE_AS and EXTENDS_TYPE_OF.
+	* primary.c (gfc_expr_attr): Handle CLASS-valued functions.
+	* resolve.c (resolve_structure_cons): Handle BT_CLASS.
+	(type_is_extensible): Make non-static and rename to
+	'gfc_type_is_extensible.
+	(resolve_select_type): Renamed type_is_extensible.
+	(resolve_class_assign): Handle NULL pointers.
+	(resolve_fl_variable_derived): Renamed type_is_extensible.
+	(resolve_fl_derived): Ditto.
+	* trans-expr.c (gfc_trans_subcomponent_assign): Handle NULL
+	initialization of class pointer components.
+	(gfc_conv_structure): Handle BT_CLASS.
+	* trans-intrinsic.c (gfc_conv_same_type_as,gfc_conv_extends_type_of):
+	New functions.
+	(gfc_conv_intrinsic_function): Handle SAME_TYPE_AS and EXTENDS_TYPE_OF.
+
+2009-09-30  Janus Weil  <janus@gcc.gnu.org>
+
+	* gfortran.h (type_selector, select_type_tmp): New global variables.
+	* match.c (type_selector, select_type_tmp): New global variables,
+	used for SELECT TYPE statements.
+	(gfc_match_select_type): Better error handling. Remember selector.
+	(gfc_match_type_is): Create temporary variable.
+	* module.c (ab_attribute): New value 'AB_IS_CLASS'.
+	(attr_bits): New string.
+	(mio_symbol_attribute): Handle 'is_class'.
+	* resolve.c (resolve_select_type): Insert pointer assignment statement,
+	to assign temporary to selector.
+	* symbol.c (gfc_get_ha_sym_tree): Replace selector by a temporary
+	in SELECT TYPE statements.
+
+2009-09-30  Janus Weil  <janus@gcc.gnu.org>
+
+	* dump-parse-tree.c (show_code_node): Renamed 'alloc_list'.
+	* gfortran.h (gfc_code): Rename 'alloc_list'. Add member 'ts'.
+	(gfc_expr_to_initialize): New prototype.
+	* match.c (alloc_opt_list): Correctly check type compatibility.
+	Renamed 'alloc_list'.
+	(dealloc_opt_list): Renamed 'alloc_list'.
+	* resolve.c (expr_to_initialize): Rename to 'gfc_expr_to_initialize'
+	and make it non-static.
+	(resolve_allocate_expr): Set vindex for CLASS variables correctly.
+	Move initialization code to gfc_trans_allocate. Renamed 'alloc_list'.
+	(resolve_allocate_deallocate): Renamed 'alloc_list'.
+	(check_class_pointer_assign): Rename to 'resolve_class_assign'. Change
+	argument type. Adjust to work with ordinary assignments.
+	(resolve_code): Call 'resolve_class_assign' for ordinary assignments.
+	Renamed 'check_class_pointer_assign'.
+	* st.c (gfc_free_statement): Renamed 'alloc_list'.
+	* trans-stmt.c (gfc_trans_allocate): Renamed 'alloc_list'. Handle
+	size determination and initialization of CLASS variables. Bugfix for
+	ALLOCATE statements with default initialization and SOURCE block.
+	(gfc_trans_deallocate): Renamed 'alloc_list'.
+
+2009-09-30  Paul Thomas  <pault@gcc.gnu.org>
+
+	* trans-expr.c (gfc_conv_procedure_call): Convert a derived
+	type actual to a class object if the formal argument is a
+	class.
+
+2009-09-30  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40996
+	* decl.c (build_struct): Handle allocatable scalar components.
+	* expr.c (gfc_add_component_ref): Correctly set typespec of expression,
+	after inserting component reference.
+	* match.c (gfc_match_type_is,gfc_match_class_is): Make sure that no
+	variables are being used uninitialized.
+	* primary.c (gfc_match_varspec): Handle CLASS array components.
+	* resolve.c (resolve_select_type): Transform EXEC_SELECT_TYPE to
+	EXEC_SELECT.
+	* trans-array.c (structure_alloc_comps,gfc_trans_deferred_array):
+	Handle allocatable scalar components.
+	* trans-expr.c (gfc_conv_component_ref): Ditto.
+	* trans-types.c (gfc_get_derived_type): Ditto.
+
+2009-09-30  Janus Weil  <janus@gcc.gnu.org>
+
+	* decl.c (encapsulate_class_symbol): Modify names of class container
+	components by prefixing with '$'.
+	(gfc_match_end): Handle COMP_SELECT_TYPE.
+	* expr.c (gfc_add_component_ref): Modify names of class container
+	components by prefixing with '$'.
+	* gfortran.h (gfc_statement): Add ST_SELECT_TYPE, ST_TYPE_IS and
+	ST_CLASS_IS.
+	(gfc_case): New field 'ts'.
+	(gfc_exec_op): Add EXEC_SELECT_TYPE.
+	(gfc_type_is_extension_of): New prototype.
+	* match.h (gfc_match_select_type,gfc_match_type_is,gfc_match_class_is):
+	New prototypes.
+	* match.c (match_derived_type_spec): New function.
+	(match_type_spec): Use 'match_derived_type_spec'.
+	(match_case_eos): Modify error message.
+	(gfc_match_select_type): New function.
+	(gfc_match_case): Modify error message.
+	(gfc_match_type_is): New function.
+	(gfc_match_class_is): Ditto.
+	* parse.h (gfc_compile_state): Add COMP_SELECT_TYPE.
+	* parse.c (decode_statement): Handle SELECT TYPE, TYPE IS and CLASS IS
+	statements.
+	(next_statement): Handle ST_SELECT_TYPE.
+	(gfc_ascii_statement): Handle ST_SELECT_TYPE, ST_TYPE_IS, ST_CLASS_IS.
+	(parse_select_type_block): New function.
+	(parse_executable): Handle ST_SELECT_TYPE.
+	* resolve.c (resolve_deallocate_expr): Handle BT_CLASS. Modify names of
+	class container components by prefixing with '$'.
+	(resolve_allocate_expr): Ditto.
+	(resolve_select_type): New function.
+	(gfc_resolve_blocks): Handle EXEC_SELECT_TYPE.
+	(check_class_pointer_assign): Modify names of class container
+	components by prefixing with '$'.
+	(resolve_code): Ditto.
+	* st.c (gfc_free_statement): Ditto.
+	* symbol.c (gfc_type_is_extension_of): New function.
+	(gfc_type_compatible): Use 'gfc_type_is_extension_of', plus a bugfix.
+	* trans.c (gfc_trans_code): Handel EXEC_SELECT_TYPE.
+
+2009-09-30  Janus Weil  <janus@gcc.gnu.org>
+	    Paul Thomas <pault@gcc.gnu.org> 
+
+	* check.c (gfc_check_move_alloc): Arguments don't have to be arrays.
+	The second argument needs to be type-compatible with the first (not the
+	other way around, which makes a difference for CLASS entities).
+	* decl.c (encapsulate_class_symbol): New function.
+	(build_sym,build_struct): Handle BT_CLASS, call
+	'encapsulate_class_symbol'.
+	(gfc_match_decl_type_spec): Remove warning, use BT_CLASS.
+	(gfc_match_derived_decl): Set vindex;
+	* expr.c (gfc_add_component_ref): New function.
+	(gfc_copy_expr,gfc_check_pointer_assign,gfc_check_assign_symbol):
+	Handle BT_CLASS.
+	* dump-parse-tree.c (show_symbol): Print vindex.
+	* gfortran.h (bt): New basic type BT_CLASS.
+	(symbol_attribute): New field 'is_class'.
+	(gfc_typespec): Remove field 'is_class'.
+	(gfc_symbol): New field 'vindex'.
+	(gfc_get_ultimate_derived_super_type): New prototype.
+	(gfc_add_component_ref): Ditto.
+	* interface.c (gfc_compare_derived_types): Pointer equality check
+	moved here from gfc_compare_types.
+	(gfc_compare_types): Handle BT_CLASS and use
+	gfc_type_compatible.
+	* match.c (gfc_match_allocate,gfc_match_deallocate,gfc_match_call):
+	Handle BT_CLASS.
+	* misc.c (gfc_clear_ts): Removed is_class.
+	(gfc_basic_typename,gfc_typename): Handle BT_CLASS.
+	* module.c (bt_types,mio_typespec): Handle BT_CLASS.
+	(mio_symbol): Handle vindex.
+	* primary.c (gfc_match_varspec,gfc_variable_attr): Handle BT_CLASS.
+	* resolve.c (find_array_spec,check_typebound_baseobject):
+	Handle BT_CLASS.
+	(resolve_ppc_call,resolve_expr_ppc): Don't call 'gfc_is_proc_ptr_comp'
+	inside 'gcc_assert'.
+	(resolve_deallocate_expr,resolve_allocate_expr): Handle BT_CLASS.
+	(check_class_pointer_assign): New function.
+	(resolve_code): Handle BT_CLASS, call check_class_pointer_assign.
+	(resolve_fl_var_and_proc,type_is_extensible,resolve_fl_variable_derived,
+	resolve_fl_variable): Handle BT_CLASS.
+	(check_generic_tbp_ambiguity): Add special case.
+	(resolve_typebound_procedure,resolve_fl_derived): Handle BT_CLASS.
+	* symbol.c (gfc_get_ultimate_derived_super_type): New function.
+	(gfc_type_compatible): Handle BT_CLASS.
+	* trans-expr.c (conv_parent_component_references): Handle CLASS
+	containers.
+	(gfc_conv_initializer): Handle BT_CLASS.
+	* trans-types.c (gfc_typenode_for_spec,gfc_get_derived_type):
+	Handle BT_CLASS.
+
+2009-09-29  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/39626
+	* gfortran.h (enum gfc_statement): Add ST_BLOCK and ST_END_BLOCK.
+	(struct gfc_namespace): Convert flags to bit-fields and add flag
+	`construct_entities' for use with BLOCK constructs.
+	(enum gfc_exec_code): Add EXEC_BLOCK.
+	(struct gfc_code): Add namespace field to union for EXEC_BLOCK.
+	* match.h (gfc_match_block): New prototype.
+	* parse.h (enum gfc_compile_state): Add COMP_BLOCK.
+	* trans.h (gfc_process_block_locals): New prototype.
+	(gfc_trans_deferred_vars): Made public, new prototype.
+	* trans-stmt.h (gfc_trans_block_construct): New prototype.
+	* decl.c (gfc_match_end): Handle END BLOCK correctly.
+	(gfc_match_intent): Error if inside of BLOCK.
+	(gfc_match_optional), (gfc_match_value): Ditto.
+	* match.c (gfc_match_block): New routine.
+	* parse.c (decode_statement): Handle BLOCK statement.
+	(case_exec_markers): Add ST_BLOCK.
+	(case_end): Add ST_END_BLOCK.
+	(gfc_ascii_statement): Handle ST_BLOCK and ST_END_BLOCK.
+	(parse_spec): Check for statements not allowed inside of BLOCK.
+	(parse_block_construct): New routine.
+	(parse_executable): Parse BLOCKs.
+	(parse_progunit): Disallow CONTAINS in BLOCK constructs.
+	* resolve.c (is_illegal_recursion): Find real container procedure and
+	don't get confused by BLOCK constructs.
+	(resolve_block_construct): New routine.
+	(gfc_resolve_blocks), (resolve_code): Handle EXEC_BLOCK.
+	* st.c (gfc_free_statement): Handle EXEC_BLOCK statements.
+	* trans-decl.c (saved_local_decls): New static variable.
+	(add_decl_as_local): New routine.
+	(gfc_finish_var_decl): Add variable as local if inside BLOCK.
+	(gfc_trans_deferred_vars): Make public.
+	(gfc_process_block_locals): New routine.
+	* trans-stmt.c (gfc_trans_block_construct): New routine.
+	* trans.c (gfc_trans_code): Handle EXEC_BLOCK statements.
+
+2009-09-28  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/35862
+	* io.c (format_token): Add enumerators for rounding format specifiers.
+	(format_lex): Tokenize the rounding format specifiers.
+	(gfc_match_open): Enable rounding modes in OPEN statement.
+
+2009-09-28  Richard Henderson  <rth@redhat.com>
+
+	* f95-lang.c (gfc_init_builtin_functions): Update call to
+	build_common_builtin_nodes.
+
+2009-09-25  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
+
+	* simplify.c (gfc_simplify_acos, gfc_simplify_acosh,
+	gfc_simplify_asin, gfc_simplify_asinh, gfc_simplify_atan,
+	gfc_simplify_atanh): Fix error message.
+
+2009-09-24  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/41459
+	* error.c(gfc_warning_now): Move warnings_are_errors test to 
+	after actual emitting of the warning.
+	* parse.c (next_free): Improve error locus printing.
+	(next_fixed): Change gfc_warn to gfc_warning_now, and improve
+	locus reporting.
+
+2009-09-16  Michael Matz  <matz@suse.de>
+
+	PR fortran/41212
+	* trans.h (struct lang_type): Remove nontarget_type member.
+	* trans.c (gfc_add_modify): Don't access it.
+	* trans-decl.c (gfc_finish_var_decl): Don't allocate and set it,
+	instead set DECL_RESTRICTED_P on affected decls.
+
+2009-09-14  Richard Henderson  <rth@redhat.com>
+
+	* f95-lang.c (gfc_init_builtin_functions): Update call to
+	build_common_builtin_nodes.
+	(gfc_maybe_initialize_eh): Don't call
+	default_init_unwind_resume_libfunc.
+
+2009-09-13  Richard Guenther  <rguenther@suse.de>
+	Rafael Avila de Espindola  <espindola@google.com>
+
+	* f95-lang.c (gfc_maybe_initialize_eh): Do not init
+	eh_personality_libfunc.
+
+2009-09-11  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41242
+	* resolve.c (resolve_ordinary_assign): Don't call resolve_code,
+	to avoid that subsequent codes are resolved more than once.
+	(resolve_code): Make sure that type-bound assignment operators are
+	resolved correctly.
+
+
+2009-09-10  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/31292
+	* fortran/decl.c(gfc_match_modproc): Check that module procedures
+	from a module can USEd in module procedure statements in other
+	program units.  Update locus for better error message display.
+	Detect intrinsic procedures in module procedure statements.
+
+2009-09-09  Richard Guenther  <rguenther@suse.de>
+
+	PR fortran/41297
+	* trans-expr.c (gfc_trans_scalar_assign): Correct typo that
+	left 'tmp' unused in derived type assignment.
+
+2009-09-07  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/41197
+	* resolve_c (resolve_allocate_deallocate):  Complain
+	if stat or errmsg varaible is an array.
+
+2009-09-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/41258
+	* primary.c (gfc_match_varspec): Do not look for typebound
+	procedures unless the derived type has a f2k_derived namespace.
+
+2009-09-03  Diego Novillo  <dnovillo@google.com>
+
+	* f95-lang.c (lang_hooks): Remove const qualifier.
+
+2009-09-01  Richard Guenther  <rguenther@suse.de>
+
+	* f95-lang.c (gfc_mark_addressable): Remove.
+	(LANG_HOOKS_MARK_ADDRESSABLE): Likewise.
+
+2009-08-31  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/39229
+	* scanner.c (next_char): Fix typo in comment.
+	(gfc_get_char_literal): Warn if truncate flag is set for both fixed and
+	free form source, adjusting error locus as needed.
+	* parse.c (next_fixed): Clear the truncate flag.
+	(next_statement): Remove truncate warning.
+
+2009-08-31  Janus Weil  <janus@gcc.gnu.org>
+	    Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/40940
+	* array.c (gfc_match_array_constructor): Rename gfc_match_type_spec.
+	* decl.c (gfc_match_type_spec): Rename to gfc_match_decl_type_spec,
+	and reject CLASS with -std=f95.
+	(gfc_match_implicit, gfc_match_data_decl,gfc_match_prefix,
+	match_procedure_interface): Rename gfc_match_type_spec.
+	* gfortran.h (gfc_type_compatible): Add prototype.
+	* match.h (gfc_match_type_spec): Rename to gfc_match_decl_type_spec.
+	* match.c (match_intrinsic_typespec): Rename to match_type_spec, and
+	add handling of derived types.
+	(gfc_match_allocate): Rename match_intrinsic_typespec and check
+	type compatibility of derived types.
+	* symbol.c (gfc_type_compatible): New function to check if two types
+	are compatible.
+
+2009-08-31  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40996
+	* check.c (gfc_check_allocated): Implement allocatable scalars.
+	* resolve.c (resolve_allocate_expr,resolve_fl_var_and_proc): Ditto.
+	* trans-intrinsic.c (gfc_conv_allocated): Ditto.
+
+2009-08-30  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/37425
+	* dump-parse-tree.c (show_typebound_proc): Renamed from `show_typebound'
+	and accept gfc_typebound_proc and name instead of the symtree, needed
+	for intrinsic operator output.
+	(show_typebound_symtree): New method calling `show_typebound_proc'.
+	(show_f2k_derived): Output type-bound operators also.
+	(show_symbol): Moved output of `Procedure bindings:' label to
+	`show_f2k_derived'.
+	* gfortran.texi (Fortran 2003 status): Mention support of
+	array-constructors with explicit type specification, type-bound
+	procedures/operators, type extension, ABSTRACT types and DEFERRED.
+	Link to Fortran 2003 wiki page.
+	(Fortran 2008 status): Fix typo.  Link to Fortran 2008 wiki page.
+	* gfc-internals.texi (Type-bound Procedures): Document the new
+	members/attributes of gfc_expr.value.compcall used for type-bound
+	operators.
+	(Type-bound Operators): New section documenting their internals.
+
+2009-08-27  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40869
+	* expr.c (gfc_check_pointer_assign): Enable interface check for
+	pointer assignments involving procedure pointer components.
+	* gfortran.h (gfc_compare_interfaces): Modified prototype.
+	* interface.c (gfc_compare_interfaces): Add argument 'name2', to be
+	used instead of s2->name. Don't rely on the proc_pointer attribute,
+	but instead on the flags handed to this function.
+	(check_interface1,compare_parameter): Add argument for
+	gfc_compare_interfaces.
+	* resolve.c (check_generic_tbp_ambiguity): Ditto.
+
+2009-08-27  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/37425
+	* gfortran.h (gfc_expr): Optionally store base-object in compcall value
+	and add a new flag to distinguish assign-calls generated.
+	(gfc_find_typebound_proc): Add locus argument.
+	(gfc_find_typebound_user_op), (gfc_find_typebound_intrinsic_op): Ditto.
+	(gfc_extend_expr): Return if failure was by a real error.
+	* interface.c (matching_typebound_op): New routine.
+	(build_compcall_for_operator): New routine.
+	(gfc_extend_expr): Handle type-bound operators, some clean-up and
+	return if failure was by a real error or just by not finding an
+	appropriate operator definition.
+	(gfc_extend_assign): Handle type-bound assignments.
+	* module.c (MOD_VERSION): Incremented.
+	(mio_intrinsic_op): New routine.
+	(mio_full_typebound_tree): New routine to make typebound-procedures IO
+	code reusable for type-bound user operators.
+	(mio_f2k_derived): IO of type-bound operators.
+	* primary.c (gfc_match_varspec): Initialize new fields in gfc_expr and
+	pass locus to gfc_find_typebound_proc.
+	* resolve.c (resolve_operator): Only output error about no matching
+	interface if gfc_extend_expr did not already fail with an error.
+	(extract_compcall_passed_object): Use specified base-object if present.
+	(update_compcall_arglist): Handle ignore_pass field.
+	(resolve_ordinary_assign): Update to handle extended code for
+	type-bound assignments, too.
+	(resolve_code): Handle EXEC_ASSIGN_CALL statement code.
+	(resolve_tb_generic_targets): Pass locus to gfc_find_typebound_proc.
+	(resolve_typebound_generic), (resolve_typebound_procedure): Ditto.
+	(resolve_typebound_intrinsic_op), (resolve_typebound_user_op): Ditto.
+	(ensure_not_abstract_walker), (resolve_fl_derived): Ditto.
+	(resolve_typebound_procedures): Remove not-implemented error.
+	(resolve_typebound_call): Handle assign-call flag.
+	* symbol.c (find_typebound_proc_uop): New argument to pass locus for
+	error message about PRIVATE, verify that a found procedure is not marked
+	as erraneous.
+	(gfc_find_typebound_intrinsic_op): Ditto.
+	(gfc_find_typebound_proc), (gfc_find_typebound_user_op): New locus arg.
+
+2009-08-22  Bud Davis <bdavis9659@sbcglobal.net>
+
+	PR fortran/28093
+	* io.c: reverted previous patch.
+
+2009-08-25  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	* gfortran.texi: Fix ENCODE example.
+
+2009-08-25  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41139
+	* primary.c (gfc_match_varspec): Make sure EXPR_PPC is only used for
+	calls to procedure pointer components, other references to procedure
+	pointer components are EXPR_VARIABLE.
+	* resolve.c (resolve_actual_arglist): Bugfix (there can be calls without
+	actual arglist).
+	* trans-expr.c (gfc_get_proc_ptr_comp): Renamed to 'get_proc_ptr_comp',
+	removed argument 'se' and made static. Avoid inserting a temporary
+	variable for calling the PPC.
+	(conv_function_val): Renamed gfc_get_proc_ptr_comp.
+	(gfc_conv_procedure_call): Distinguish functions returning a procedure
+	pointer from calls to a procedure pointer. Distinguish calls to
+	procedure pointer components from procedure pointer components as
+	actual arguments.
+	* trans-stmt.h (gfc_get_proc_ptr_comp): Make it static.
+
+2009-08-24  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/41162
+	* io.c (check_format): Fix to not error on slash after P. Fix some
+	error loci.
+	
+2009-08-24  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/41154
+	* io.c (check_format): Fix to not error on right paren after P.
+
+2009-08-24  Aldy Hernandez  <aldyh@redhat.com>
+
+	PR fortran/40660
+	* trans-io.c (build_dt): Pass UNKNOWN_LOCATION to build_call_expr_loc.
+	(transfer_array_desc): Same.
+
+2009-08-23  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/35754
+	* io.c (check_format): Add checks for comma and the allowed
+	format specifiers after the 'P' specifier. Fix typo in error message
+	and adjust locus.
+
+2009-08-23  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/37446
+	* io.c (enum format_token): Change FMT_EXT to FMT_EN and FMT_ES.
+	(format_lex): Likewise.
+	(token_to_string): New function.
+	(check_format): Use the new tokens and the new function. Add
+	check for positive width.
+
+2009-08-22  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* fortran/decl.c: Disallow procedure pointers with -std=f95.
+
+2009-08-22 Steven K. kargl  <kargl@gcc.gnu.org>
+	   Paul Thomas  <pault@gcc.gnu.org>
+
+	* fortran/decl.c (match_char_spec): Rename to gfc_match_char_spec,
+	and remove static.
+	* fortran/gfortran.h: Add *expr3 entity to gfc_code.  Add prototype
+	for gfc_match_char_spec.
+	* fortran/trans-stmt.c (gfc_trans_allocate): Translate the SOURCE=
+	tag.
+	* fortran/match.c (match_intrinsic_typespec): New function to match
+	F2003 intrinsic-type-spec.
+	(conformable_arrays): New function. Check SOURCE= and
+	allocation-object are conformable.
+	(gfc_match_allocate): Use new functions.  Match SOURCE= tag.
+
+2009-08-22  Bud Davis <bdavis9659@sbcglobal.net>
+
+	PR fortran/28093
+	* io.c : added variable to store original len of fmt
+	* io.c (check_format): Consume H items using next_char
+	in both modes to handle consecutive single quotes.
+	Test for extra characters in fmt, issue warning.
+
+2009-08-21  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41106
+	* primary.c (gfc_variable_attr): Make it work also on EXPR_FUNCTION.
+	(gfc_expr_attr): Use gfc_variable_attr for procedure pointer components.
+	* resolve.c (resolve_fl_derived): Handle CHARACTER-valued procedure
+	pointer components.
+	* trans-expr.c (gfc_conv_component_ref): Ditto.
+	(gfc_conv_variable): Ditto.
+	(gfc_conv_procedure_call): Ditto.
+	(gfc_trans_pointer_assignment): Ditto.
+	* trans-types.c (gfc_get_derived_type): Ditto.
+
+2009-08-20  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	* trans-stmt.c (gfc_trans_do): Add a few missing folds.
+
+2009-08-20  Michael Matz  <matz@suse.de>
+
+	PR fortran/41126
+	* trans-expr.c (gfc_conv_string_tmp): Check type compatibility
+	instead of equality.
+
+2009-08-20  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41121
+	* resolve.c (resolve_symbol): Don't resolve formal_ns of intrinsic
+	procedures.
+
+2009-08-18  Michael Matz  <matz@suse.de>
+
+	* trans-expr.c (gfc_conv_substring): Don't evaluate casted decl early,
+	change order of length calculation to (end - start) + 1.
+	(gfc_get_interface_mapping_array): Adjust call to
+	gfc_get_nodesc_array_type.
+	* trans-array.c (gfc_trans_create_temp_array,
+	gfc_build_constant_array_constructor, gfc_conv_expr_descriptor): Ditto.
+	* trans-stmt.c (gfc_trans_pointer_assign_need_temp): Ditto.
+	* trans.c (gfc_add_modify): Assignment between base type and nontarget
+	type are equal enough.
+	(gfc_call_malloc): Use prvoid_type_node for return value of
+	__builtin_malloc.
+	(gfc_allocate_with_status): Ditto.
+	* trans-types.c (gfc_array_descriptor_base): Double size of this array.
+	(gfc_init_types): Build prvoid_type_node.
+	(gfc_build_array_type): New bool parameter "restricted".
+	(gfc_get_nodesc_array_type): Ditto, build restrict qualified pointers,
+	if it's true.
+	(gfc_get_array_descriptor_base): Ditto.
+	(gfc_get_array_type_bounds): Ditto.
+	(gfc_sym_type): Use symbol attributes to feed calls to above functions.
+	(gfc_get_derived_type): Ditto.
+	* trans.h (struct lang_type): Add nontarget_type member.
+	* trans-types.h (prvoid_type_node): Declare.
+	(gfc_get_array_type_bounds, gfc_get_nodesc_array_type): Declare new
+	parameter.
+	* trans-decl.c (gfc_finish_var_decl): Give scalars that can't be
+	aliased a type with a different alias set than the base type.
+	(gfc_build_dummy_array_decl): Adjust call to gfc_get_nodesc_array_type.
+
+2009-08-18  Janus Weil  <janus@gcc.gnu.org>
+	    Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/40870
+	* trans-types.c (gfc_get_ppc_type): Include formal args in backend_decl
+	using the interface symbol. Character types are returned by reference.
+	(gfc_get_derived_type): Prevent infinite recursion loop
+	if a PPC has a derived-type formal arg.
+
+2008-08-17  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/41062
+	* trans-decl.c (gfc_trans_use_stmts):  Keep going through use
+	list if symbol is not use associated.
+
+2009-08-17  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/37425
+	* resolve.c (get_checked_tb_operator_target): New routine to do checks
+	on type-bound operators in common between intrinsic and user operators.
+	(resolve_typebound_intrinsic_op): Call it.
+	(resolve_typebound_user_op): Ditto.
+
+2009-08-17  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/41075
+	* scanner.c (gfc_next_char_literal): Add comment to improve 
+	readability.
+	* io.c (enum format_token): Add FMT_STAR. (format_lex): Add case
+	for '*'. (check_format): Check for left paren after '*'.  Change
+	format checks to use %L to improve format string error locus.
+
+2009-08-17  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40877
+	* array.c (gfc_resolve_character_array_constructor): Add NULL argument
+	to gfc_new_charlen.
+	* decl.c (add_init_expr_to_sym,variable_decl,match_char_spec,
+	gfc_match_implicit): Ditto.
+	* expr.c (simplify_const_ref): Fix memory leak.
+	(gfc_simplify_expr): Add NULL argument to gfc_new_charlen.
+	* gfortran.h (gfc_new_charlen): Modified prototype.
+	* iresolve.c (check_charlen_present,gfc_resolve_char_achar): Add NULL
+	argument to gfc_new_charlen.
+	* module.c (mio_charlen): Ditto.
+	* resolve.c (gfc_resolve_substring_charlen,
+	gfc_resolve_character_operator,fixup_charlen): Ditto.
+	(resolve_fl_derived,resolve_symbol): Add argument to gfc_charlen.
+	* symbol.c (gfc_new_charlen): Add argument 'old_cl' (to make a copy of
+	an existing charlen).
+	(gfc_set_default_type,generate_isocbinding_symbol): Fix memory leak.
+	(gfc_copy_formal_args_intr): Add NULL argument to gfc_new_charlen.
+	* trans-decl.c (create_function_arglist): Fix memory leak.
+
+2009-08-17  Richard Guenther  <rguenther@suse.de>
+
+	* trans-expr.c (gfc_trans_scalar_assign): Replace hack with
+	more proper hack.
+
+2009-08-15  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/41080
+	* gfortranspec.c (lookup_option): Remove gfortran-specific
+	version of -dumpversion.
+
+2009-08-14  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41070
+	* resolve.c (resolve_structure_cons): Make sure that ts.u.derived is
+	only used if type is BT_DERIVED.
+
+2009-08-13  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40941
+	* gfortran.h (gfc_typespec): Put 'derived' and 'cl' into union.
+	* decl.c (build_struct): Make sure 'cl' is only used
+	if type is BT_CHARACTER.
+	* symbol.c (gfc_set_default_type): Ditto.
+	* resolve.c (resolve_symbol, resolve_fl_derived): Ditto.
+	(resolve_equivalence,resolve_equivalence_derived): Make sure 'derived'
+	is only used if type is BT_DERIVED.
+	* trans-io.c (transfer_expr): Make sure 'derived' is only used if type
+	is BT_DERIVED or BT_INTEGER (special case: C_PTR/C_FUNPTR).
+	* array.c: Mechanical replacements to accomodate union in gfc_typespec.
+	* check.c: Ditto.
+	* data.c: Ditto.
+	* decl.c: Ditto.
+	* dump-parse-tree.c: Ditto.
+	* expr.c: Ditto.
+	* interface.c: Ditto.
+	* iresolve.c: Ditto.
+	* match.c: Ditto.
+	* misc.c: Ditto.
+	* module.c: Ditto.
+	* openmp.c: Ditto.
+	* parse.c: Ditto.
+	* primary.c: Ditto.
+	* resolve.c: Ditto.
+	* simplify.c: Ditto.
+	* symbol.c: Ditto.
+	* target-memory.c: Ditto.
+	* trans-array.c: Ditto.
+	* trans-common.c: Ditto.
+	* trans-const.c: Ditto.
+	* trans-decl.c: Ditto.
+	* trans-expr.c: Ditto.
+	* trans-intrinsic.c: Ditto.
+	* trans-io.c: Ditto.
+	* trans-stmt.c: Ditto.
+	* trans-types.c: Ditto.
+
+2009-08-13  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40995
+	* resolve.c (resolve_symbol): Move some checking code to
+	resolve_intrinsic, and call this from here.
+	(resolve_intrinsic): Some checking code moved here from resolve_symbol.
+	Make sure each intrinsic is only resolved once.
+
+2009-08-12  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/41034
+	* symbol.c (gfc_copy_attr): Merge bits instead of replace
+	bits in gfc_copy_attr.
+	* gfc_check_pointer_assign (gfc_check_pointer_assign):
+	Initialize ext_attr bits by zero.
+
+2009-08-11  Richard Guenther  <rguenther@suse.de>
+
+	* trans-types.c (gfc_get_derived_type): Do not clear TYPE_CANONICAL.
+
+2009-08-11  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41022
+	* trans-expr.c (gfc_conv_procedure_call): Handle procedure pointer
+	components as actual arguments.
+
+2009-08-10  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/37425
+	* gfortran.h (struct gfc_namespace): New fields tb_uop_root and tb_op.
+	(gfc_find_typebound_user_op): New routine.
+	(gfc_find_typebound_intrinsic_op): Ditto.
+	(gfc_check_operator_interface): Now public routine.
+	* decl.c (gfc_match_generic): Match OPERATOR(X) or ASSIGNMENT(=).
+	* interface.c (check_operator_interface): Made public, renamed to
+	`gfc_check_operator_interface' accordingly and hand in the interface
+	as gfc_symbol rather than gfc_interface so it is useful for type-bound
+	operators, too.  Return boolean result.
+	(gfc_check_interfaces): Adapt call to `check_operator_interface'.
+	* symbol.c (gfc_get_namespace): Initialize new field `tb_op'.
+	(gfc_free_namespace): Free `tb_uop_root'-based tree.
+	(find_typebound_proc_uop): New helper function.
+	(gfc_find_typebound_proc): Use it.
+	(gfc_find_typebound_user_op): New method.
+	(gfc_find_typebound_intrinsic_op): Ditto.
+	* resolve.c (resolve_tb_generic_targets): New helper function.
+	(resolve_typebound_generic): Use it.
+	(resolve_typebound_intrinsic_op), (resolve_typebound_user_op): New.
+	(resolve_typebound_procedures): Resolve operators, too.
+	(check_uop_procedure): New, code from gfc_resolve_uops.
+	(gfc_resolve_uops): Moved main code to new `check_uop_procedure'.
+
+2009-08-10  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40940
+	* decl.c (gfc_match_type_spec): Match CLASS statement and warn about
+	missing polymorphism.
+	* gfortran.h (gfc_typespec): Add field 'is_class'.
+	* misc.c (gfc_clear_ts): Initialize 'is_class' to zero.
+	* resolve.c (type_is_extensible): New function to check if a derived
+	type is extensible.
+	(resolve_fl_variable_derived): Add error checks for CLASS variables.
+	(resolve_typebound_procedure): Disallow non-polymorphic passed-object
+	dummy arguments, turning warning into error.
+	(resolve_fl_derived): Use 'type_is_extensible'. Disallow non-polymorphic
+	passed-object dummy arguments for procedure pointer components,
+	turning warning into error. Add error check for CLASS components.
+
+2009-08-05  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40955
+	* gfortran.h (ext_attr_id_t): Add typedef for this enum.
+	(gfc_add_ext_attribute): Use it.
+	* decl.c (gfc_match_gcc_attributes): Ditto.
+	* expr.c (gfc_check_pointer_assign): Ditto.
+	* symbol.c (gfc_add_ext_attribute): Ditto.
+	(gfc_copy_attr): Copy also ext_attr.
+	* resolve.c (resolve_fl_derived,resolve_symbol): Ditto.
+	* module.c (mio_symbol_attribute): Save ext_attr in the mod file.
+
+2009-08-05  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40969
+	Revert:
+	2009-08-04  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40949
+	* trans-types.c (gfc_get_function_type): Fix typelist of
+	functions without argument.
+
+2009-08-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/40847
+	* iresolve.c (gfc_resolve_transfer): Correct error in 'mold'
+	character length for case where length expresson is NULL.
+
+2009-08-04  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40949
+	* trans-types.c (gfc_get_function_type): Fix typelist of
+	functions without argument.
+
+2009-08-04  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/40875
+	* decl.c (add_init_expr_to_sym): Character symbols can only be
+	initialized with character expressions.
+
+2009-08-02  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40881
+	* decl.c (match_char_length): Warn about old-style character length
+	declarations.
+	* match.c (match_arithmetic_if,gfc_match_if): Modify warning message
+	for arithmetic if.
+	(gfc_match_goto): Warn about computed gotos.
+	(gfc_match_return): Warn about alternate return.
+	(gfc_match_st_function): Warn about statement functions.
+	* resolve.c (resolve_fl_procedure): Modify warning message for
+	assumed-length character functions.
+
+2009-08-01  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/40011
+	* error.c : Add static flag 'warnings_not_errors'.
+	(gfc_error): If 'warnings_not_errors' is set, branch to code
+	from gfc_warning.
+	(gfc_clear_error): Reset 'warnings_not_errors'.
+	(gfc_errors_to_warnings): New function.
+	* options.c (gfc_post_options): If pedantic and flag_whole_file
+	change the latter to a value of 2.
+	* parse.c (parse_module): Add module namespace to gsymbol.
+	(resolve_all_program_units): New function.
+	(clean_up_modules): New function.
+	(translate_all_program_units): New function.
+	(gfc_parse_file): If whole_file, do not clean up module right
+	away and add derived types to namespace derived types. In
+	addition, call the three new functions above.
+	* resolve.c (not_in_recursive): New function.
+	(not_entry_self_reference): New function.
+	(resolve_global_procedure): Symbol must not be IFSRC_UNKNOWN,
+	procedure must not be in the course of being resolved and
+	must return false for the two new functions. Pack away the
+	current derived type list before calling gfc_resolve for the
+	gsymbol namespace.  It is unconditionally an error if the ranks
+	of the reference and ther procedure do not match. Convert
+	errors to warnings during call to gfc_procedure_use if not
+	pedantic or legacy.
+	(gfc_resolve): Set namespace resolved flag to -1 during
+	resolution and store current cs_base.
+	* trans-decl.c (gfc_get_symbol_decl): If whole_file compilation
+	substitute a use associated variable, if it is available in a
+	gsymbolnamespace.
+	(gfc_get_extern_function_decl): If the procedure is use assoc,
+	do not attempt to find it in a gsymbol because it could be an
+	interface. If the symbol exists in a module namespace, return
+	its backend_decl.
+	* trans-expr.c (gfc_trans_scalar_assign): If a derived type
+	assignment, set the rhs TYPE_MAIN_VARIANT to that of the rhs.
+	* trans-types.c (copy_dt_decls_ifequal): Add 'from_gsym' as a
+	boolean argument. Copy component backend_decls directly if the
+	components are derived types and from_gsym is true.
+	(gfc_get_derived_type): If whole_file copy the derived type from
+	the module if it is use associated, otherwise, if can be found
+	in another gsymbol namespace, use the existing derived type as
+	the TYPE_CANONICAL and build normally.
+	* gfortran.h : Add derived_types and resolved fields to
+	gfc_namespace. Include prototype for gfc_errors_to_warnings.
+
+2009-07-29  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40898
+	* trans-types.c (gfc_get_function_type): Do not add hidden
+	string-length argument for BIND(C) procedures.
+	* trans-decl.c (create_function_arglist): Skip over nonexisting
+	string-length arguments for BIND(C) procedures.
+
+2009-07-28  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/40878
+	* openmp.c (gfc_match_omp_clauses): Use gfc_error_now instead of
+	gfc_error to diagnose invalid COLLAPSE arguments.
+
+2009-07-28  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40882
+	* trans-types.c (gfc_get_ppc_type): For derived types, directly use the
+	backend_decl, instead of calling gfc_typenode_for_spec, to avoid
+	infinte loop.
+	(gfc_get_derived_type): Correctly handle PPCs returning derived types,
+	avoiding infinite recursion.
+
+2009-07-27  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40848
+	* interface.c (gfc_compare_interfaces): Call 'count_types_test' before
+	'generic_correspondence', and only if checking a generic interface.
+
+2009-07-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40851
+	* resolve.c (resolve_symbol): Do not initialize pointer derived-types.
+	* trans-decl.c (init_intent_out_dt): Ditto.
+	(generate_local_decl): No need to set attr.referenced for DT pointers.
+
+2009-07-26  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/33197
+	* intrinsic.c (make_generic): Remove assert as "atan" can be
+	both ISYM_ATAN and ISYM_ATAN2.
+	(add_functions): Add two-argument variant of ATAN.
+	* intrinsic.h (gfc_check_atan_2): Add check for it.
+	* intrinsic.texi (ATAN2): Correct and enhance description.
+	(ATAN): Describe two-argument variant of ATAN.
+
+2009-07-25  Tobias Burnus  <burnus@net-b.de>
+	    Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/33197
+	* intrinsic.c (add_functions): Support complex arguments for
+	acos,acosh,asin,asinh,atan,atanh.
+	* invoke.texi (ACOS,ACOSH,ASIN,ASINH,ATAN,ATANH): Support
+	complex arguments.
+	* simplify.c (gfc_simplify_acos,gfc_simplify_acosh,
+	gfc_simplify_asin,gfc_simplify_asinh,gfc_simplify_atan,
+	gfc_simplify_atanh,gfc_simplify_atan,gfc_simplify_asinh,
+	gfc_simplify_acosh,gfc_simplify_atanh): Support
+	complex arguments.
+
+2009-07-25  Richard Guenther  <rguenther@suse.de>
+
+	PR fortran/40005
+	* trans-types.c (gfc_get_array_type_bounds): Use
+	build_distinct_type_copy with a proper TYPE_CANONICAL and
+	re-use the type-decl of the original type.
+	* trans-decl.c (build_entry_thunks): Signal cgraph we may not
+	garbage collect.
+	(create_main_function): Likewise.
+	(gfc_generate_function_code): Likewise.
+	* trans-expr.c (gfc_trans_subcomponent_assign): Do not use
+	fold_convert on record types.
+
+2009-07-25  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/39630
+	* decl.c (match_ppc_decl): Implement the PASS attribute for procedure
+	pointer components.
+	(match_binding_attributes): Ditto.
+	* gfortran.h (gfc_component): Add member 'tb'.
+	(gfc_typebound_proc): Add member 'ppc' and make 'pass_arg' const.
+	* module.c (MOD_VERSION): Bump module version.
+	(binding_ppc): New string constants.
+	(mio_component): Only use formal args if component is a procedure
+	pointer and add 'tb' member.
+	(mio_typebound_proc): Include pass_arg and take care of procedure
+	pointer components.
+	* resolve.c (update_arglist_pass): Add argument 'name' and take care of
+	optional arguments.
+	(extract_ppc_passed_object): New function, analogous to
+	extract_compcall_passed_object, but for procedure pointer components.
+	(update_ppc_arglist): New function, analogous to
+	update_compcall_arglist, but for procedure pointer components.
+	(resolve_typebound_generic_call): Added argument to update_arglist_pass.
+	(resolve_ppc_call, resolve_expr_ppc): Take care of PASS attribute.
+	(resolve_fl_derived): Check the PASS argument for procedure pointer
+	components.
+	* symbol.c (verify_bind_c_derived_type): Reject procedure pointer
+	components in BIND(C) types.
+
+2009-07-24  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40822
+	* array.c (gfc_resolve_character_array_constructor): Use new function
+	gfc_new_charlen.
+	* decl.c (add_init_expr_to_sym,variable_decl,match_char_spec,
+	gfc_match_implicit): Ditto.
+	* expr.c (gfc_simplify_expr): Ditto.
+	* gfortran.h (gfc_new_charlen): New prototype.
+	* iresolve.c (check_charlen_present,gfc_resolve_char_achar): Use new
+	function gfc_new_charlen.
+	* module.c (mio_charlen): Ditto.
+	* resolve.c (gfc_resolve_substring_charlen,
+	gfc_resolve_character_operator,fixup_charlen,resolve_fl_derived,
+	resolve_symbol): Ditto.
+	* symbol.c (gfc_new_charlen): New function to create a new gfc_charlen
+	structure and add it to a namespace.
+	(gfc_copy_formal_args_intr): Make sure ts.cl is present
+	for CHARACTER variables.
+
+2009-07-24  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/40643
+	PR fortran/31067
+	* trans-intrinsic.c (gfc_conv_intrinsic_minmaxloc,
+	gfc_conv_intrinsic_minmaxval): Handle Infinities and NaNs properly,
+	optimize.
+	* trans-array.c (gfc_trans_scalarized_loop_end): No longer static.
+	* trans-array.h (gfc_trans_scalarized_loop_end): New prototype.
+
+2009-07-23  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/40839
+	* io.c (gfc_resolve_dt): Add LOC argument.  Fail if
+	dt->io_unit is NULL.  Return FAILURE after issuing error about
+	negative UNIT number.
+	(match_io_element): Don't segfault if current_dt->io_unit is NULL.
+	* gfortran.h (gfc_resolve_dt): Adjust prototype.
+	* resolve.c (resolve_code): Adjust caller.
+
+2009-07-22  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/40796
+	* trans-decl.c (generate_local_decl): Unreferenced result
+	variables with allocatable components should be treated like
+	INTENT_OUT dummy variables.
+
+2009-07-22  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* trans.h (gfc_set_decl_assembler_name): New prototype.
+	* trans-decl.c (gfc_set_decl_assembler_name): New function.
+	(gfc_get_symbol_decl, gfc_get_extern_function_decl,
+	build_function_decl): Use gfc_set_decl_assembler_name instead of
+	SET_DECL_ASSEMBLER_NAME.
+	* trans-common.c (build_common_decl): Use
+	gfc_set_decl_assembler_name instead of SET_DECL_ASSEMBLER_NAME.
+
+2009-07-21  Richard Guenther  <rguenther@suse.de>
+
+	PR fortran/40726
+	* trans-decl.c (gfc_get_extern_function_decl): Do not set
+	DECL_IS_MALLOC for pointer valued functions.
+	(build_function_decl): The same.
+
+2009-07-19  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/40727
+	* fortran/check.c (gfc_check_cmplx, gfc_check_dcmplx): Add check that
+	the optional second argument isn't of COMPLEX type.
+
+2009-07-17  Richard Guenther  <rguenther@suse.de>
+
+	PR c/40401
+	* f95-lang.c (gfc_be_parse_file): Do not finalize the CU here.
+	* trans-decl.c (gfc_gimplify_function): Remove.
+	(build_entry_thunks): Do not gimplify here.
+	(create_main_function): Likewise.
+	(gfc_generate_function_code): Likewise.
+
+2009-07-17  Aldy Hernandez  <aldyh@redhat.com>
+	    Manuel López-Ibáñez  <manu@gcc.gnu.org>
+
+	PR 40435 
+	* trans-expr.c, trans-array.c, trans-openmp.c, trans-stmt.c,
+	trans.c, trans-io.c, trans-decl.c, trans-intrinsic.c: Add location
+	argument to fold_{unary,binary,ternary}, fold_build[123],
+	build_call_expr, build_size_arg, build_fold_addr_expr,
+	build_call_array, non_lvalue, size_diffop,
+	fold_build1_initializer, fold_build2_initializer,
+	fold_build3_initializer, fold_build_call_array,
+	fold_build_call_array_initializer, fold_single_bit_test,
+	omit_one_operand, omit_two_operands, invert_truthvalue,
+	fold_truth_not_expr, build_fold_indirect_ref, fold_indirect_ref,
+	combine_comparisons, fold_builtin_*, fold_call_expr,
+	build_range_check, maybe_fold_offset_to_address, round_up,
+	round_down.
+
+2009-07-15  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40743
+	* resolve.c (resolve_symbol): Don't resolve the formal namespace of a
+	contained procedure.
+
+2009-07-14  Taras Glek  <tglek@mozilla.com>
+	    Rafael Espindola  <espindola@google.com>
+
+	* Make-lang.in (fortran.install-plugin): New target for
+	installing plugin headers.
+
+2009-07-13  H.J. Lu  <hongjiu.lu@intel.com>
+
+	* module.c (mio_symbol): Remove the unused variable, formal.
+
+2009-07-13  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40646
+	* module.c (mio_symbol): If the symbol has formal arguments,
+	the formal namespace will be present.
+	* resolve.c (resolve_actual_arglist): Correctly handle 'called'
+	procedure pointer components as actual arguments.
+	(resolve_fl_derived,resolve_symbol): Make sure the formal namespace
+	is present.
+	* trans-expr.c (gfc_conv_procedure_call): Correctly handle the formal
+	arguments of procedure pointer components.
+
+2009-07-12  Tobias Burnus  <burnus@net-b.de>
+	    Philippe Marguinaud <philippe.marguinaud@meteo.fr>
+
+	PR fortran/40588
+	* primary.c (match_charkind_name): Fix condition for $ matching.
+
+	PR libfortran/22423
+	* libgfortran.h: Typedef the GFC_DTYPE_* enum.
+
+2009-07-11  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/33197
+	* check.c (gfc_check_fn_rc2008): New function.
+	* intrinsic.h (gfc_check_fn_rc2008): New prototype.
+	* intrinsic.c (add_functions): Add complex tan, cosh, sinh,
+	and tanh.
+
+2009-07-10  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/39334
+	* primary.c (match_kind_param): Return MATCH_NO if the symbol
+	has no value.
+
+2008-07-09  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/40629
+	* resolve.c (check_host_association):  Use the existing
+	accessible symtree and treat function expressions with
+	symbols that have procedure flavor.
+
+2009-07-09  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40646
+	* dump-parse-tree.c (show_expr): Renamed 'is_proc_ptr_comp'.
+	* expr.c (is_proc_ptr_comp): Renamed to 'gfc_is_proc_ptr_comp'.
+	(gfc_check_pointer_assign): Renamed 'is_proc_ptr_comp'.
+	(replace_comp,gfc_expr_replace_comp): New functions, analogous
+	to 'replace_symbol' and 'gfc_expr_replace_symbol', just with components
+	instead of symbols.
+	* gfortran.h (gfc_expr_replace_comp): New prototype.
+	(is_proc_ptr_comp): Renamed to 'gfc_is_proc_ptr_comp'.
+	* interface.c (compare_actual_formal): Renamed 'is_proc_ptr_comp'.
+	* match.c (gfc_match_pointer_assignment): Ditto.
+	* primary.c (gfc_match_varspec): Handle array-valued procedure pointers
+	and procedure pointer components. Renamed 'is_proc_ptr_comp'.
+	* resolve.c (resolve_fl_derived): Correctly handle interfaces with
+	RESULT statement, and handle array-valued procedure pointer components.
+	(resolve_actual_arglist,resolve_ppc_call,resolve_expr_ppc): Renamed
+	'is_proc_ptr_comp'.
+	* trans-array.c (gfc_walk_function_expr): Ditto.
+	* trans-decl.c (gfc_get_symbol_decl): Security check for presence of
+	ns->proc_name.
+	* trans-expr.c (gfc_conv_procedure_call): Handle array-valued procedure
+	pointer components. Renamed 'is_proc_ptr_comp'.
+	(conv_function_val,gfc_trans_arrayfunc_assign): Renamed
+	'is_proc_ptr_comp'.
+	(gfc_get_proc_ptr_comp): Do not modify the argument 'e', but instead
+	make a copy of it.
+	* trans-io.c (gfc_trans_transfer): Handle array-valued procedure
+	pointer components.
+
+2009-07-09  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40604
+	* intrinsic.c (gfc_convert_type_warn): Set sym->result.
+	* trans-expr.c (gfc_conv_procedure_call): Fix -fcheck=pointer
+	for optional arguments.
+
+2009-07-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40675
+	* simplify.c (gfc_simplify_sign): Handle signed zero correctly.
+	* trans-intrinsic.c (gfc_conv_intrinsic_sign): Support
+	-fno-sign-zero.
+	* invoke.texi (-fno-sign-zero): Add text regarding SIGN intrinsic.
+
+2008-07-08  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/40591
+	* decl.c (match_procedure_interface):  Correct the association
+	or creation of the interface procedure's symbol.
+
+2009-07-04  Jakub Jelinek  <jakub@redhat.com>
+
+	* trans-intrinsic.c (gfc_conv_intrinsic_minmaxloc): For integer
+	maxloc initialize limit to -huge-1 rather than just -huge.
+
+2009-07-04  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40593
+	* interface.c (compare_actual_formal): Take care of proc-pointer-valued
+	functions as actual arguments.
+	* trans-expr.c (gfc_conv_procedure_call): Ditto.
+	* resolve.c (resolve_specific_f0): Use the correct ts.
+
+2009-07-02  Michael Matz  <matz@suse.de>
+
+	PR fortran/32131
+	* trans-array.c (gfc_conv_descriptor_stride_get): Return
+	constant one for strides in the first dimension of ALLOCATABLE
+	arrays.
+
+2009-06-30  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40594
+	* trans-types.c (gfc_get_derived_type): Bugfix, reverting one hunk from
+	r147206.
+
+2009-06-29  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40580
+	* trans-expr.c  (gfc_conv_procedure_call): Add -fcheck=pointer check.
+	* libgfortran.h: Add GFC_RTCHECK_POINTER.
+	* invoke.texi (-fcheck): Document new pointer option.
+	* options.c (gfc_handle_runtime_check_option): Handle pointer option.
+
+	* gfortran.texi (C Binding): Improve wording.
+	* iso-c-binding.def: Remove obsolete comment.
+
+2009-06-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/40551
+	* dependency.h : Add second bool* argument to prototype of
+	gfc_full_array_ref_p.
+	* dependency.c (gfc_full_array_ref_p): If second argument is
+	present, return true if last dimension of reference is an
+	element or has unity stride.
+	* trans-array.c : Add NULL second argument to references to
+	gfc_full_array_ref_p.
+	* trans-expr.c : The same, except for;
+	(gfc_trans_arrayfunc_assign): Return fail if lhs reference
+	is not a full array or a contiguous section.
+
+2009-06-28  Tobias Burnus  <burnus@net-b.de>
+	    Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/34112
+	* symbol.c (gfc_add_ext_attribute): New function.
+	(gfc_get_sym_tree): New argument allow_subroutine.
+	(gfc_get_symbol,gfc_get_ha_sym_tree,gen_cptr_param,gen_fptr_param
+	gen_shape_param,generate_isocbinding_symbol): Use it.
+	* decl.c (find_special): New argument allow_subroutine.
+	(add_init_expr_to_sym,add_hidden_procptr_result,attr_decl1,
+	match_procedure_in_type,gfc_match_final_decl): Use it.
+	(gfc_match_gcc_attributes): New function.
+	* gfortran.texi (Mixed-Language Programming): New section
+	"GNU Fortran Compiler Directives".
+	* gfortran.h (ext_attr_t): New struct.
+	(symbol_attributes): Use it.
+	(gfc_add_ext_attribute): New prototype.
+	(gfc_get_sym_tree): Update pototype.
+	* expr.c (gfc_check_pointer_assign): Check whether call
+	convention is the same.
+	* module.c (import_iso_c_binding_module, create_int_parameter,
+	use_iso_fortran_env_module): Update gfc_get_sym_tree call.
+	* scanner.c (skip_gcc_attribute): New function.
+	(skip_free_comments,skip_fixed_comments): Use it.
+	(gfc_next_char_literal): Support !GCC$ lines.
+	* resolve.c (check_host_association): Update
+	gfc_get_sym_tree call.
+	* match.c (gfc_match_sym_tree,gfc_match_call): Update
+	gfc_get_sym_tree call.
+	* trans-decl.c (add_attributes_to_decl): New function.
+	(gfc_get_symbol_decl,get_proc_pointer_decl,
+	gfc_get_extern_function_decl,build_function_decl: Use it.
+	* match.h (gfc_match_gcc_attributes): Add prototype.
+	* parse.c (decode_gcc_attribute): New function.
+	(next_free,next_fixed): Support !GCC$ lines.
+	* primary.c (match_actual_arg,check_for_implicit_index,
+	gfc_match_rvalue,gfc_match_rvalue): Update
+	gfc_get_sym_tree call.
+
+2009-06-28  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
+
+	* gfortran.h: Define HAVE_mpc_pow.
+	* arith.c (complex_reciprocal, complex_pow): If HAVE_mpc_pow,
+	don't define these functions.
+	(arith_power): If HAVE_mpc_pow, use mpc_pow.
+
+2009-06-26  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/39997
+	PR fortran/40541
+	* decl.c (add_hidden_procptr_result): Copy the typespec to the hidden
+	result.
+	* expr.c (gfc_check_pointer_assign): Enable interface check for
+	procedure pointer assignments where the rhs is a function returning a
+	procedure pointer.
+	* resolve.c (resolve_symbol): If an external procedure with unspecified
+	return type can not be implicitly typed, it must be a subroutine.
+
+2009-06-24  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40427
+	* gfortran.h (gfc_component): New member 'formal_ns'.
+	(gfc_copy_formal_args_ppc,void gfc_ppc_use): New.
+	* interface.c (gfc_ppc_use): New function, analogous to
+	gfc_procedure_use, but for procedure pointer components.
+	* module.c (MOD_VERSION): Bump module version.
+	(mio_component): Treat formal arguments.
+	(mio_formal_arglist): Changed argument from gfc_symbol to
+	gfc_formal_arglist.
+	(mio_symbol): Changed argument of mio_formal_arglist.
+	* resolve.c (resolve_ppc_call,resolve_expr_ppc): Call gfc_ppc_use,
+	to check actual arguments and treat formal args correctly.
+	(resolve_fl_derived): Copy formal args of procedure pointer components
+	from their interface.
+	* symbol.c (gfc_copy_formal_args_ppc): New function, analogous to
+	gfc_copy_formal_args, but for procedure pointer components.
+
+2009-06-22  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/37254
+	PR fortran/39850
+	* interface.c (compare_parameter): Set implicit type for function
+	actual arguments with BT_UNKNOWN.
+
+2009-06-22  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40472
+	PR fortran/50520
+	* simplify.c (gfc_simplify_spread): Fix the case that source=
+	is a scalar.
+
+2009-06-22  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/40443
+	* interface.c (gfc_search_interface): Hold back a match to an
+	elementary procedure until all other possibilities are
+	exhausted.
+
+2009-06-22  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/40472
+	* simplify.c (gfc_simplify_spread): Restrict the result size to
+	the limit for an array constructor.
+
+2009-06-21  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/39850
+	* interface.c (gfc_compare_interfaces): Take care of implicit typing
+	when checking the function attribute. Plus another bugfix.
+	(compare_parameter): Set attr.function and attr.subroutine according
+	to the usage of a procedure as actual argument.
+
+2009-06-20  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40452
+	* trans-decl.c (add_argument_checking): Disable bounds check
+	for allowed argument storage association.
+
+2009-06-19  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/40440
+	* trans-expr.c (gfc_conv_procedure_call): Do not deallocate
+	allocatable components if the argument is a pointer.
+
+2009-06-19  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
+
+	* gfortran.h (gfc_expr): Use mpc_t to represent complex numbers.
+
+	* arith.c, dump-parse-tree.c, expr.c, module.c, resolve.c,
+	simplify.c, target-memory.c, target-memory.h, trans-const.c,
+	trans-expr.c: Convert to mpc_t throughout.
+
+2009-06-19  Ian Lance Taylor  <iant@google.com>
+
+	* cpp.c (struct gfc_cpp_option_data): Give this struct, used for
+	the global variable gfc_cpp_option, a name.
+
+2009-06-19  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40450
+	* trans-expr.c (gfc_conv_procedure_call): Only add an extra addr_expr
+	to a procedure pointer actual argument, if it is not itself a
+	dummy arg.
+
+2009-06-18  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40451
+	* resolve.c (resolve_contained_fntype): Prevent implicit typing for
+	procedures with explicit interface.
+	* symbol.c (gfc_check_function_type): Ditto.
+
+2009-06-16  Ian Lance Taylor  <iant@google.com>
+
+	* decl.c (build_struct): Rewrite loop over constructor elements.
+
+2009-06-16  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/36947
+	PR fortran/40039
+	* expr.c (gfc_check_pointer_assign): Call 'gfc_compare_interfaces' with
+	error message.
+	* gfortran.h (gfc_compare_interfaces): Additional argument.
+	* interface.c (operator_correspondence): Removed.
+	(gfc_compare_interfaces): Additional argument to return error message.
+	Directly use the code from 'operator_correspondence' instead of calling
+	the function. Check for OPTIONAL. Some rearrangements.
+	(check_interface1): Call 'gfc_compare_interfaces' without error message.
+	(compare_parameter): Call 'gfc_compare_interfaces' with error message.
+	* resolve.c (check_generic_tbp_ambiguity): Call 'gfc_compare_interfaces'
+	without error message.
+
+2009-06-16  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40383
+	* trans-decl.c (create_function_arglist): Copy formal charlist to
+	have a proper passed_length for -fcheck=bounds.
+
+2009-06-12  Steven G. Kargl  <kargls@comcast.net>
+
+	* arith.c (gfc_enum_initializer): Move function ...
+	* decl.c: ... here.  Remove gfc_ prefix and make static.
+	(enumerator_decl): Update function call.
+	* gfortran.h:  Remove gfc_enum_initializer prototype.
+
+2009-06-12  Aldy Hernandez  <aldyh@redhat.com>
+
+	* trans-array.c (gfc_trans_allocate_array_storage): Pass
+	location on down.
+	(gfc_trans_array_constructor_value): Same.
+	(gfc_trans_scalarized_loop_end): Same.
+	(gfc_conv_ss_startstride): Same.
+	(gfc_trans_g77_array): Same.
+	(gfc_trans_dummy_array_bias): Same.
+	(gfc_conv_array_parameter): Same.
+	(structure_alloc_comps): Same.
+	* trans-expr.c (gfc_conv_function_call): Same.
+	(fill_with_spaces): Same.
+	(gfc_trans_string_copy): Same.
+	(gfc_trans_scalar_assign): Same.
+	* trans-stmt.c (gfc_trans_goto): Same.
+	(gfc_trans_if_1): Same.
+	(gfc_trans_simple_do): Same.
+	(gfc_trans_do): Same.
+	(gfc_trans_do_while): Same.
+	(gfc_trans_logical_select): Same.
+	(gfc_trans_select): Same.
+	(gfc_trans_forall_loop): Same.
+	(gfc_trans_nested_forall_loop): Same.
+	(generate_loop_for_temp_to_lhs): Same.
+	(generate_loop_for_rhs_to_temp): Same.
+	(gfc_trans_forall_1): Same.
+	(gfc_trans_where_assign): Same.
+	(gfc_trans_where_3): Same.
+	(gfc_trans_allocate): Same.
+	* trans.c (gfc_finish_block): Same.
+	(gfc_trans_runtime_check): Same.
+	(gfc_call_malloc): Same.
+	(gfc_allocate_with_status): Same.
+	(gfc_call_free): Same.
+	(gfc_deallocate_with_status): Same.
+	(gfc_call_realloc): Same.
+	(gfc_trans_code): Same.
+	* trans-decl.c (gfc_init_default_dt): Same.
+	(gfc_generate_constructors): Same.
+	* trans-io.c (gfc_trans_io_runtime_check): Same.
+	* trans-intrinsic.c (gfc_conv_intrinsic_ctime): Same.
+	(gfc_conv_intrinsic_fdate): Same.
+	(gfc_conv_intrinsic_ttynam): Same.
+	(gfc_conv_intrinsic_minmax): Same.
+	(gfc_conv_intrinsic_minmax_char): Same.
+	(gfc_conv_intrinsic_anyall): Same.
+	(gfc_conv_intrinsic_count): Same.
+	(gfc_conv_intrinsic_arith): Same.
+	(gfc_conv_intrinsic_minmaxloc): Same.
+	(gfc_conv_intrinsic_minmaxval): Same.
+	(gfc_conv_intrinsic_rrspacing): Same.
+	(gfc_conv_intrinsic_array_transfer): Same.
+	(gfc_conv_intrinsic_trim): Same.
+	(gfc_conv_intrinsic_repeat): Same.
+	
+2009-06-12  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40176
+	* resolve.c (resolve_symbol): Additional error check, preventing an
+	infinite loop.
+
+2009-06-11  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/40402
+	* resolve.c (next_data_value): It is an error if the value is
+	not constant.
+
+2009-06-11  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/38718
+	* intrinsic.c (add_functions): Add simplifiers for ISNAN,
+	IS_IOSTAT_END and IS_IOSTAT_EOR.
+	* intrinsic.h (gfc_simplify_is_iostat_end, gfc_simplify_is_iostat_eor,
+	gfc_simplify_isnan): New prototypes.
+	* intrinsic.c (gfc_simplify_is_iostat_end, gfc_simplify_is_iostat_eor,
+	gfc_simplify_isnan): New functions.
+
+2009-06-11  Jakub Jelinek  <jakub@redhat.com>
+
+	* interface.c (fold_unary): Rename to...
+	(fold_unary_intrinsic): ... this.
+	(gfc_extend_expr): Adjust caller.
+	(gfc_match_generic_spec): Likewise.  Initialize *op to INTRINSIC_NONE
+	to avoid warnings.
+	* expr.c (gfc_simplify_expr): Initialize start and end before calling
+	gfc_extract_int.
+
+2009-06-10  Dave Korn  <dave.korn.cygwin@gmail.com>
+
+	* trans-decl.c (create_main_function):  Don't build main decl twice.
+
+2009-06-09  Tobias Burnus  <burnus@net-b.de>
+
+	* trans-decl.c (gfc_generate_function_code): Use gfc_option.rtcheck
+	instead of flag_bounds_check.
+	* intrinsic.texi (ISO_FORTRAN_ENV): Document INT{8,16,32,64} and
+	REAL{32,64,128}.
+
+2009-06-08  Paul Thomas  <pault@gcc.gnu.org>
+
+	* trans-array.h : Replace prototypes for
+	gfc_conv_descriptor_offset, gfc_conv_descriptor_stride,
+	gfc_conv_descriptor_lbound, gfc_conv_descriptor_ubound with new
+	prototypes of the same names with _get or _set appended.
+	* trans-array.c : Make the originals of the above static and
+	new functions for the _get and _set functions. Update all the
+	references to these descriptor access functions.
+	* trans-expr.c : Update references to the above descriptor
+	access functions.
+	* trans-intrinsic.c : The same.
+	* trans-openmp.c : The same.
+	* trans-stmt.c : The same.
+
+2009-06-08  Alexandre Oliva  <aoliva@redhat.com>
+
+	* options.c (gfc_post_options): Disable dump_parse_tree
+	during -fcompare-debug-second.
+
+2009-06-07  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/40008
+	* gfortran.h (gfc_open): Add newunit expression to structure.
+	* io.c (io_tag): Add new unit tag and fix whitespace.
+	(match_open_element): Add matching for newunit.
+	(gfc_free_open): Free the newunit expression.
+	(gfc_resolve_open): Add newunit to resolution and check constraints.
+	(gfc_resolve_close): Add check for non-negative unit.
+	(gfc_resolve_filepos): Likewise.
+	(gfc_resolve_dt): Likewise.
+	* trans-io.c (set_parameter_value): Build runtime checks for unit
+	numbers within range of kind=4 integer. (gfc_trans_open) Set the
+	newunit parameter.
+	* ioparm.def (IOPARM): Define the newunit parameter as a pointer
+	to GFC_INTEGER_4, pint4.
+
+2009-06-07  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/25104
+	PR fortran/29962
+	* array.c (gfc_append_constructor): Added NULL-check.
+	* check.c (gfc_check_spread): Check DIM.
+	(gfc_check_unpack): Check that the ARRAY arguments provides enough
+	values for MASK.
+	* intrinsic.h (gfc_simplify_spread): New prototype.
+	(gfc_simplify_unpack): Likewise.
+	* intrinsic.c (add_functions): Added new simplifier callbacks.
+	* simplify.c (gfc_simplify_spread): New.
+	(gfc_simplify_unpack): New.
+	* expr.c (check_transformational): Allow additional transformational
+	intrinsics in initialization expression.
+
+2009-06-07  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/25104
+	PR fortran/29962
+	* check.c (gfc_check_all_any): Check rank of DIM.
+	(gfc_check_count): Likewise.
+	* intrinsic.h (gfc_simplify_all): New prototype.
+	(gfc_simplify_any): Likewise.
+	(gfc_simplify_count): Likewise.
+	(gfc_simplify_sum): Likewise.
+	(gfc_simplify_product): Likewise.
+	* intrinsic.c (add_functions): Added new simplifier callbacks.
+	* simplify.c (transformational_result): New.
+	(simplify_transformation_to_scalar): New.
+	(simplify_transformation_to_array): New.
+	(gfc_count): New.
+	(gfc_simplify_all): New.
+	(gfc_simplify_any): New.
+	(gfc_simplify_count): New.
+	(gfc_simplify_sum): New.
+	(gfc_simplify_product): New.
+	* expr.c (check_transformational): Allow additional transformational
+	intrinsics in initialization expression.
+
+2009-06-07  Daniel Franke  <franke.daniel@gmail.com>
+
+	* check.c (dim_rank_check): Return SUCCESS if DIM=NULL.
+	(gfc_check_lbound): Removed (now) redundant check for DIM=NULL.
+	(gfc_check_minloc_maxloc): Likewise.
+	(check_reduction): Likewise.
+	(gfc_check_size): Likewise.
+	(gfc_check_ubound): Likewise.
+	(gfc_check_cshift): Added missing shape-conformance checks.
+	(gfc_check_eoshift): Likewise.
+	* gfortran.h (gfc_check_conformance): Modified prototype to printf-style.
+	* expr.c (gfc_check_conformance): Accept error-message chunks in 
+	printf-style. Changed all callers.
+
+
+2009-06-07  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/25104
+	PR fortran/29962
+	* intrinsic.h (gfc_simplify_dot_product): New prototype.
+	(gfc_simplify_matmul): Likewise.
+	(gfc_simplify_transpose): Likewise.
+	* intrinsic.c (add_functions): Added new simplifier callbacks.
+	* simplify.c (init_result_expr): New.
+	(compute_dot_product): New.
+	(gfc_simplify_dot_product): New.
+	(gfc_simplify_matmul): New.
+	(gfc_simplify_transpose): New.
+	* expr.c (check_transformational): Allow transformational intrinsics
+	with simplifier in initialization expression.
+
+2009-06-06  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/37203
+	* simplify.c (gfc_simplify_reshape): Fixed reshaping of empty arrays
+	without padding.
+
+2009-06-06  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/32890
+	* intrinsic.h (gfc_simplify_pack): New prototype.
+	* intrinsic.c (add_functions): Added
+	simplifier-callback to PACK.
+	* simplify.c (is_constant_array_expr): Moved
+	to beginning of file.
+	(gfc_simplify_pack): New.
+	* check.c (gfc_check_pack): Check that VECTOR has enough elements.
+	Added safeguards for empty arrays.
+
+2009-06-05  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
+
+	* simplify.c (call_mpc_func): Use mpc_realref/mpc_imagref
+	instead of MPC_RE/MPC_IM.
+
+2009-06-05  Alexandre Oliva  <aoliva@redhat.com>
+
+	* trans-decl.c (gfc_build_qualified_array): Don't skip generation
+	of range types.
+	* trans.h (struct lang_type): Add base_decls.
+	(GFC_TYPE_ARRAY_BASE_DECL): New.
+	* trans-types.c (gfc_get_array_type_bounds): Initialize base decls
+	proactively and excessively.
+	(gfc_get_array_descr_info): Use existing base decls if available.
+
+2009-06-04  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/37203
+	* check.c (gfc_check_reshape): Additional checks for the
+	SHAPE and ORDER arguments.
+	* simplify.c (gfc_simplify_reshape): Converted argument checks
+	to asserts.
+
+2009-06-03  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.texi: Add mixed-language programming, mention
+	varying string lengths, some clean up of introduction parts.
+	* intrinsic.texi (instrinsic modules): Create @menu for subsections.
+	(ISO_C_BINDING): Support ISOCBINDING_INT_FAST128_T.
+	* libgfortran.h: Comment to rember to keep gfortran.texi in sync.
+	* iso-c-binding.def: Support ISOCBINDING_INT_FAST128_T.
+
+2009-06-03  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+	    Tobias Burnus  <burnus@net-b.de>
+
+	* iso-c-binding.def: Use INTMAX_TYPE instead of intmax_type_node.
+	* trans-types.c (init_c_interop_kinds): Remove intmax_type_node.
+
+2009-06-03  Alexandre Oliva  <aoliva@redhat.com>
+
+	* module.c (mio_f2k_derived): Initialize cur.
+
+2009-06-01  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40309
+	* trans-decl.c (gfc_sym_identifier): Use "MAIN__" for PROGRAM "main".
+	(create_main_function): Set main_identifier_node.
+
+2009-05-29  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/40019
+	* trans-types.c (gfc_build_uint_type): Make nonstatic.
+	* trans.h (gfor_fndecl_clz128, gfor_fndecl_ctz128): New prototypes.
+	* trans-types.h (gfc_build_uint_type): Add prototype.
+	* trans-decl.c (gfc_build_intrinsic_function_decls): Build
+	gfor_fndecl_clz128 and gfor_fndecl_ctz128.
+	* trans-intrinsic.c (gfc_conv_intrinsic_leadz,
+	gfc_conv_intrinsic_trailz): Call the right builtins or library
+	functions, and cast arguments to unsigned types first.
+	* simplify.c (gfc_simplify_leadz): Deal with negative arguments.
+
+2009-05-27  Ian Lance Taylor  <iant@google.com>
+
+	* Make-lang.in (gfortran$(exeext)): Change $(COMPILER) to
+	$(LINKER).
+	(f951$(exeext)): Likewise.
+
+2009-05-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40270
+	* trans-decl.c (create_main_function): Mark MAIN__ and
+	argc/argv as TREE_USED and push/pop function_decl context
+	if needed.
+
+2009-05-26  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/39178
+	* gfortranspec.c (lang_specific_driver): Stop linking
+	libgfortranbegin.
+	* trans-decl.c (gfc_build_builtin_function_decls): Stop
+	making MAIN__ publicly visible.
+	(gfc_build_builtin_function_decls): Add
+	gfor_fndecl_set_args.
+	(create_main_function) New function.
+	(gfc_generate_function_code): Use it.
+
+2009-05-26  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40246
+	* match.c (gfc_match_nullify): NULLify freed pointer.
+
+2009-05-26  Ian Lance Taylor  <iant@google.com>
+
+	* Make-lang.in (gfortranspec.o): Use $(COMPILER).
+	(gfortran$(exeext), f951$(exeext), fortran/cpp.o): Likewise.
+
+2009-05-26  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
+
+	* gfortran.h (GFC_MPC_RND_MODE): New.
+	* simplify.c (call_mpc_func): New helper function.
+	(gfc_simplify_cos, gfc_simplify_exp, gfc_simplify_log,
+	gfc_simplify_sin, gfc_simplify_sqrt): Add MPC support.
+
+2009-05-25  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40176
+	* primary.c (gfc_match_varspec): Handle procedure pointer components
+	with array return value.
+	* resolve.c (resolve_expr_ppc): Ditto.
+	(resolve_symbol): Make sure the interface of a procedure pointer has
+	been resolved.
+	* trans-array.c (gfc_walk_function_expr): Handle procedure pointer
+	components with array return value.
+	* trans-expr.c (gfc_conv_component_ref,gfc_conv_procedure_call,
+	gfc_trans_arrayfunc_assign): Ditto.
+	(gfc_trans_pointer_assignment): Handle procedure pointer assignments,
+	where the rhs is a dummy argument.
+	* trans-types.c (gfc_get_ppc_type,gfc_get_derived_type): Handle
+	procedure pointer components with array return value.
+
+2009-05-24  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+	    Dominique Dhumieres
+
+	PR fortran/35732
+	PR fortran/39872
+	* trans-array.c (gfc_conv_ss_startstride): Add one to index.
+
+2009-05-22  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/40195
+	* module.c (read_md5_from_module_file): Close file before returning.
+
+2009-05-18  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40164
+	* primary.c (gfc_match_rvalue): Handle procedure pointer components in
+	arrays.
+	* resolve.c (resolve_ppc_call,resolve_expr_ppc): Resolve component and
+	array references.
+	(resolve_fl_derived): Procedure pointer components are not required to
+	have constant array bounds in their return value.
+
+2009-05-18  Janus Weil  <janus@gcc.gnu.org>
+
+	* intrinsic.c (add_sym): Fix my last commit (r147655),
+	which broke bootstrap.
+
+2009-05-18  Richard Guenther  <rguenther@suse.de>
+
+	PR fortran/40168
+	* trans-expr.c (gfc_trans_zero_assign): For local array
+	destinations use an assignment from an empty constructor.
+
+2009-05-18  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/36947
+	PR fortran/40039
+	* expr.c (gfc_check_pointer_assign): Check intents when comparing
+	interfaces.
+	* gfortran.h (typedef struct gfc_intrinsic_arg): Add 'intent' member.
+	(gfc_compare_interfaces): Additional argument.
+	* interface.c (operator_correspondence): Add check for equality of
+	intents, and new argument 'intent_check'.
+	(gfc_compare_interfaces): New argument 'intent_check', which is passed
+	on to operator_correspondence.
+	(check_interface1): Don't check intents when comparing interfaces.
+	(compare_parameter): Do check intents when comparing interfaces.
+	* intrinsic.c (add_sym): Add intents for arguments of intrinsic
+	procedures.
+	(add_sym_1,add_sym_1s,add_sym_1m,add_sym_2,add_sym_2s,add_sym_3,
+	add_sym_3ml,add_sym_3red,add_sym_3s,add_sym_4): Use INTENT_IN by
+	default.
+	(add_sym_1_intent,add_sym_1s_intent,add_sym_2s_intent,add_sym_3s_intent)
+	: New functions to add intrinsic symbols, specifying custom intents.
+	(add_sym_4s,add_sym_5s): Add new arguments to specify intents.
+	(add_functions,add_subroutines): Add intents for various intrinsics.
+	* resolve.c (check_generic_tbp_ambiguity): Don't check intents when
+	comparing interfaces.
+	* symbol.c (gfc_copy_formal_args_intr): Copy intent.
+
+2009-05-17  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* iso-fortran-env.def: Define INT8, INT16, INT32, INT64, REAL32,
+	REAL64 and REAL128.
+	* gfortran.h (gfc_get_int_kind_from_width_isofortranenv,
+	gfc_get_real_kind_from_width_isofortranenv): New prototypes.
+	* iso-c-binding.def: Update definitions for the INT*_T,
+	INT_LEAST*_T and INT_FAST*_T named parameters.
+	* trans-types.c (get_typenode_from_name, get_int_kind_from_name,
+	gfc_get_real_kind_from_width_isofortranenv): New functions.
+
+2009-05-17  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/36260
+	* intrinsic.c (add_functions, add_subroutines): Fix argument
+	names and wrap long lines.
+	* intrinsic.texi: Fix documentation and argument names of
+	LOG_GAMMA, DATAN2, DBESJN, DTIME, ETIME, FSTAT, STAT, LSTAT,
+	GET_COMMAND, IDATE, LTIME, MOVE_ALLOC, NINT, OR, PRODUCT,
+	SUM, RAND, RANDOM_SEED, REAL, SELECTED_INT_KIND,
+	SELECTED_REAL_KIND and XOR.
+
+2009-05-16  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/33197
+	* intrinsic.c (add_functions): Use ERFC_SCALED simplification.
+	* intrinsic.h (gfc_simplify_erfc_scaled): New prototype.
+	* simplify.c (fullprec_erfc_scaled, asympt_erfc_scaled,
+	gfc_simplify_erfc_scaled): New functions.
+
+2009-05-16  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/31243
+	* resolve.c (resolve_substring): Don't allow too large substring
+	indexes.
+	(gfc_resolve_substring_charlen): Fix typo.
+	(gfc_resolve_character_operator): Fix typo.
+	(resolve_charlen): Catch unreasonably large string lengths.
+	* simplify.c (gfc_simplify_len): Don't error out on LEN
+	range checks.
+
+2009-05-16  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/36031
+	* decl.c (set_enum_kind): Use global short-enums flag.
+	* gfortran.h (gfc_option_t): Remove short_enums flag.
+	* lang.opt (-fshort-enums): Refer to C documentation.
+	* options.c (gfc_init_options, gfc_handle_option): Use global
+	short-enums flag.
+
+2009-05-15  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/39352
+	* f95-lang.c: Add gfc_maybe_initialize_eh.
+	* gfortran.h: Add gfc_maybe_initialize_eh prototype.
+	* Make-lang.in: Add new .h dendencies for f95-lang.c
+	* openmp.c (resolve_omp_do): Call gfc_maybe_initialize_eh.
+	* misc.c (gfc_free): Avoid #define trickery for free.
+
+2009-05-14  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* dump-parse-tree.c (show_code_node): Add ERRMSG to the dumping
+	of allocate and deallocate statements.
+
+2009-05-14  Ian Lance Taylor  <iant@google.com>
+
+	* decl.c (match_attr_spec): Change d to unsigned int.
+	* dump-parse-tree.c (show_namespace): Change op to int.  Add cast.
+	* interface.c (gfc_check_interfaces): Change i to int.  Add casts.
+	* module.c (read_module): Change i to int.  Add cast.
+	(write_module): Change i to int.
+	* symbol.c (gfc_get_namespace): Change in to int.
+	(gfc_free_namespace): Change i to int.
+	* trans-io.c (gfc_build_io_library_fndecls): Change ptype to
+	unsigned int.  Add cast.
+	* trans-types.c (gfc_init_kinds): Change mode to unsigned int.
+	Add casts.
+
+2009-05-14  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/40045
+	* dump-parse-tree.c (show_typebound): Fix missing adaption to new
+	type-bound procedure storage structure.
+
+2009-05-14  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/39996
+	* decl.c (gfc_match_function_decl): Use gfc_add_type.
+	* symbol.c (gfc_add_type): Better checking for duplicate types in
+	function declarations. And: Always give an error for duplicte types,
+	not just a warning with -std=gnu.
+
+2009-05-14  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/39865
+	* io.c (resolve_tag_format): CHARACTER array in FMT= argument
+	isn't an extension.  Reject non-CHARACTER array element of
+	assumed shape or pointer or assumed size array.
+	* trans-array.c (array_parameter_size): New function.
+	(gfc_conv_array_parameter): Add size argument.  Call
+	array_parameter_size if it is non-NULL.
+	* trans-array.h (gfc_conv_array_parameter): Adjust prototype.
+	* trans-expr.c (gfc_conv_function_call, gfc_trans_arrayfunc_assign):
+	Adjust callers.
+	* trans-intrinsic.c (gfc_conv_intrinsic_loc): Likewise.
+	* trans-io.c (gfc_convert_array_to_string): Rewritten.
+
+2009-05-13  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* gfortran.h (gfc_code): Rename struct member expr to expr1.
+	* openmp.c (resolve_omp_atomic): Update expr to expr1.
+	* interface.c (gfc_extend_assign): Ditto.
+	* trans-expr.c (gfc_conv_expr_reference, gfc_trans_assignment,
+	gfc_trans_init_assign): Ditto.
+	* dump-parse-tree.c (show_code_node): Ditto.
+	* trans-openmp.c (gfc_trans_omp_atomic): Ditto.
+	* trans-stmt.c ( gfc_trans_label_assign, gfc_trans_goto, gfc_trans_call,
+	gfc_trans_return, gfc_trans_pause, gfc_trans_stop, gfc_trans_if_1,
+	gfc_trans_arithmetic_if, gfc_trans_do_while, gfc_trans_integer_select,
+	gfc_trans_logical_select, gfc_trans_character_select
+	forall_make_variable_temp, check_forall_dependencies
+	gfc_trans_forall_1, gfc_trans_where_2, gfc_trans_where_3
+	gfc_trans_where, gfc_trans_allocate, gfc_trans_deallocate): Ditto.
+	* io.c (match_io_element, gfc_match_inquire): Ditto.
+	* resolve.c (resolve_typebound_call, resolve_ppc_call,
+	resolve_allocate_expr, resolve_allocate_deallocate, resolve_select,
+	resolve_transfer, resolve_where, gfc_resolve_assign_in_forall,
+	gfc_resolve_blocks, resolve_code, build_init_assign): Ditto.
+	* st.c (gfc_free_statement): Ditto.
+	* match.c (gfc_match_assignment, gfc_match_pointer_assignment,
+	match_arithmetic_if, gfc_match_if, gfc_match_elseif
+	gfc_match_stopcode, gfc_match_assign, gfc_match_goto,
+	gfc_match_nullify, match_typebound_call, gfc_match_call
+	gfc_match_select, match_simple_where, gfc_match_where
+	gfc_match_elsewhere, match_simple_forall, gfc_match_forall): Ditto.
+	* trans-io.c (gfc_trans_transfer): Ditto.
+	* parse.c (parse_where_block, parse_if_block): Ditto.
+
+2009-05-13  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* gfortran.h (gfc_code): Rename struct member label to label1.
+	* dump-parse-tree.c (show_code_node): Update symbol.
+	* trans-stmt.c (gfc_trans_label_assign, gfc_trans_goto,
+	gfc_trans_arithmetic_if): Ditto.
+	* resolve.c (gfc_resolve_blocks, resolve_code): Ditto.
+	* match.c (match_arithmetic_if, gfc_match_if, gfc_reference_st_label,
+	gfc_match_assign, gfc_match_goto): Ditto.
+	* parse.c (parse_do_block): Ditto.
+
+2009-05-13  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34153
+	* gfortran.h (gfc_exec_op): Add EXEC_END_PROCEDURE.
+	* dump-parse-tree.c (show_code_node): Use EXEC_END_PROCEDURE.
+	* trans.c (gfc_trans_code): Ditto.
+	* resolve.c (resolve_code): Ditto.
+	* st.c (gfc_free_statement): Ditto.
+	* parse.c (accept_statement): Ditto.
+
+2009-05-12  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40110
+	* decl.c (gfc_match_kind_spec): Turn C kind error into a warning.
+
+2009-05-11  Steve Ellcey  <sje@cup.hp.com>
+
+	* resolve.c (check_host_association): Initialize tail.
+
+2009-05-11  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40089
+	* resolve.c (resolve_fl_derived): Only return FAILURE if
+	gfc_notify_std fails.
+
+2009-05-10  Ian Lance Taylor  <iant@google.com>
+
+	* gfortran.h (enum gfc_omp_sched_kind): New enum, broken out of
+	gfc_omp_clauses.
+	(enum gfc_omp_default_sharing): Likewise.
+	* module.c (enum gfc_rsym_state): New enum, broken out of
+	pointer_info.
+	(enum gfc_wsym_state): Likewise.
+	* parse.c (enum state_order): New enum, broken out of st_state.
+
+2009-05-10  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/40018
+	* trans-array.c (gfc_trans_array_constructor_value): Fold
+	convert numeric constants.
+	(gfc_build_constant_array_constructor): The same.
+
+2009-05-10  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/38863
+	* trans-expr.c (gfc_conv_operator_assign): Remove function.
+	* trans.h : Remove prototype for gfc_conv_operator_assign.
+	* trans-stmt.c (gfc_conv_elemental_dependencies): Initialize
+	derivde types with intent(out).
+	(gfc_trans_call): Add mask, count1 and invert arguments. Add
+	code to use mask for WHERE assignments.
+	(gfc_trans_forall_1): Use new arguments for gfc_trans_call.
+	(gfc_trans_where_assign): The gfc_symbol argument is replaced
+	by the corresponding code. If this has a resolved_sym, then
+	gfc_trans_call is called. The call to gfc_conv_operator_assign
+	is removed.
+	(gfc_trans_where_2): Change the last argument in the call to
+	gfc_trans_where_assign.
+	* trans-stmt.h : Modify prototype for gfc_trans_call.
+	* trans.c (gfc_trans_code): Use new args for gfc_trans_call.
+
+2009-05-08  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/39876
+	* intrinsic.c (gfc_is_intrinsic): Do not add the EXTERNAL attribute if
+	the symbol is a module procedure.
+
+2009-05-08  Tobias Burnus  <burnus@net-b.de>
+
+	* invoke.texi: Add do/recursion to the -fcheck= summary.
+
+2009-05-07  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/38830
+	* gfortran.texi: Document that we don't support variable FORMAT
+	expressions.
+
+2009-05-07  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/39576
+	* error.c (error_print): Add missing break statement.
+
+2009-05-07  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/36382
+	* invoke.texi: Document that -fdollar-ok does not allow $ to be
+	used in IMPLICIT statement.
+
+2009-05-06  Janus Weil  <janus@gcc.gnu.org>
+	    Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/39630
+	* decl.c (match_procedure_interface): New function to match the
+	interface for a PROCEDURE statement.
+	(match_procedure_decl): Call match_procedure_interface.
+	(match_ppc_decl): New function to match the declaration of a
+	procedure pointer component.
+	(gfc_match_procedure):  Call match_ppc_decl.
+	(match_binding_attributes): Add new argument 'ppc' and handle the
+	POINTER attribute for procedure pointer components.
+	(match_procedure_in_type,gfc_match_generic): Added new argument to
+	match_binding_attributes.
+	* dump-parse-tree.c (show_expr,show_components,show_code_node): Handle
+	procedure pointer components.
+	* expr.c (free_expr0,gfc_copy_expr,gfc_simplify_expr): Handle EXPR_PPC.
+	(gfc_check_pointer_assign): Handle procedure pointer components, but no
+	full checking yet.
+	(is_proc_ptr_comp): New function to determine if an expression is a
+	procedure pointer component.
+	* gfortran.h (expr_t): Add EXPR_PPC.
+	(symbol_attribute): Add new member 'proc_pointer_comp'.
+	(gfc_component): Add new member 'formal'.
+	(gfc_exec_op): Add EXEC_CALL_PPC.
+	(gfc_get_default_type): Changed first argument.
+	(is_proc_ptr_comp): Add prototype.
+	(gfc_match_varspec): Add new argument.
+	* interface.c (compare_actual_formal): Handle procedure pointer
+	components.
+	* match.c (gfc_match_pointer_assignment,match_typebound_call): Handle
+	procedure pointer components.
+	* module.c (mio_expr): Handle EXPR_PPC.
+	* parse.c (parse_derived): Handle procedure pointer components.
+	* primary.c (gfc_match_varspec): Add new argument 'ppc_arg' and handle
+	procedure pointer components.
+	(gfc_variable_attr): Handle procedure pointer components.
+	(gfc_match_rvalue): Added new argument to gfc_match_varspec and changed
+	first argument of gfc_get_default_type.
+	(match_variable): Added new argument to gfc_match_varspec.
+	* resolve.c (resolve_entries,set_type,resolve_fl_parameter): Changed
+	first argument of gfc_get_default_type.
+	(resolve_structure_cons,resolve_actual_arglist): Handle procedure
+	pointer components.
+	(resolve_ppc_call): New function to resolve a call to a procedure
+	pointer component (subroutine).
+	(resolve_expr_ppc): New function to resolve a call to a procedure
+	pointer component (function).
+	(gfc_resolve_expr): Handle EXPR_PPC.
+	(resolve_code): Handle EXEC_CALL_PPC.
+	(resolve_fl_derived): Copy the interface for a procedure pointer
+	component.
+	(resolve_symbol): Fix overlong line.
+	* st.c (gfc_free_statement): Handle EXEC_CALL_PPC.
+	* symbol.c (gfc_get_default_type): Changed first argument.
+	(gfc_set_default_type): Changed first argument of gfc_get_default_type.
+	(gfc_add_component): Initialize ts.type to BT_UNKNOWN.
+	* trans.h (gfc_conv_function_call): Renamed.
+	* trans.c (gfc_trans_code): Handle EXEC_CALL_PPC.
+	* trans-expr.c (gfc_conv_component_ref): Ditto.
+	(gfc_conv_function_val): Rename to 'conv_function_val', add new
+	argument 'expr' and handle procedure pointer components.
+	(gfc_conv_operator_assign): Renamed gfc_conv_function_val.
+	(gfc_apply_interface_mapping_to_expr): Handle EXPR_PPC.
+	(gfc_conv_function_call): Rename to 'gfc_conv_procedure_call', add new
+	argument 'expr' and handle procedure pointer components.
+	(gfc_get_proc_ptr_comp): New function to get the backend decl for a
+	procedure pointer component.
+	(gfc_conv_function_expr): Renamed gfc_conv_function_call.
+	(gfc_conv_structure): Handle procedure pointer components.
+	* trans-intrinsic.c (gfc_conv_intrinsic_funcall,
+	conv_generic_with_optional_char_arg): Renamed gfc_conv_function_call.
+	* trans-stmt.h (gfc_get_proc_ptr_comp): Add prototype.
+	* trans-stmt.c (gfc_trans_call): Renamed gfc_conv_function_call.
+	* trans-types.h (gfc_get_ppc_type): Add prototype.
+	* trans-types.c (gfc_get_ppc_type): New function to build a tree node
+	for a procedure pointer component.
+	(gfc_get_derived_type): Handle procedure pointer components.
+
+2009-05-06  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40041
+	* resolve.c (resolve_symbol): Print no warning for implicitly
+	typed intrinsic functions.
+
+2009-05-05  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/39998
+	* expr.c (gfc_check_pointer_assign): Check for statement functions and
+	internal procedures in procedure pointer assignments.
+
+2009-04-28  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/39946
+	* resolve.c (resolve_symbol): Correctly copy the interface of a
+	PROCEDURE statement if the interface involves a RESULT variable.
+
+2009-04-28  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/39930
+	PR fortran/39931
+	* expr.c (gfc_check_pointer_assign): Correctly detect if the left hand
+	side is a pointer.
+	* parse.c (gfc_fixup_sibling_symbols): Don't check for ambiguity.
+
+2009-04-28  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/39879
+	* trans_expr.c (gfc_conv_procedure_call): Deep copy a derived
+	type parentheses argument if it is a variable with allocatable
+	components.
+
+2009-04-27  Ian Lance Taylor  <iant@google.com>
+
+	* trans-intrinsic.c (DEFINE_MATH_BUILTIN): Add casts to enum
+	type.
+	* trans-io.c (st_parameter_field): Add casts to enum type.
+
+2009-04-26  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/39893
+	fortran/data.c (gfc_assign_data_value): If the lvalue is an 
+	assumed character length entity in a data statement, then 
+	return FAILURE to prevent segmentation fault.
+
+2009-04-26  Jakub Jelinek  <jakub@redhat.com>
+
+	* trans-decl.c: Include pointer-set.h.
+	(nonlocal_dummy_decl_pset, tree nonlocal_dummy_decls): New variables.
+	(gfc_nonlocal_dummy_array_decl): New function.
+	(gfc_get_symbol_decl): Call it for non-local dummy args with saved
+	descriptor.
+	(gfc_get_symbol_decl): Set DECL_BY_REFERENCE when needed.
+	(gfc_generate_function_code): Initialize nonlocal_dummy_decl{s,_pset},
+	chain it to outermost block's vars, destroy it afterwards.
+	* Make-lang.in (trans-decl.o): Depend on pointer-set.h.
+
+2009-04-25  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/39688
+	* decl.c (gfc_match_import): Use 'sym->name' instead of 'name'.
+	They differ if the symbol has been use-renamed.
+
+2009-04-24  Ian Lance Taylor  <iant@google.com>
+
+	* gfortran.h (enum gfc_symbol_type): New named enum type, broken
+	out of struct gfc_symbol.
+	(struct gfc_symbol): Use enum gfc_symbol_type.
+	(enum gfc_array_ref_dimen_type): New named enum type, broken out
+	of struct gfc_array_ref).
+	(struct gfc_array_ref): Use enum gfc_array_ref_dimen_type.
+	(mod_pointee_as): Update declaration.
+	* decl.c (add_global_entry): Change type to enum gfc_symbol_type.
+	(gfc_mod_pointee_as): Change return type to "match".
+	* module.c (mio_array_ref): Add cast to enum type.
+	(mio_symbol): Likewise.
+	* resolve.c (resolve_global_procedure): Change type to enum
+	gfc_symbol_type.
+	* trans-io.c (gfc_build_st_parameter): Change type to unsigned
+	int.
+
+2009-04-24  Daniel Kraft  <d@domob.eu>
+
+	* gfortran.h (gfc_get_typebound_proc): Removed as macro, now a function.
+	(struct gfc_symtree): Moved "typebound" member inside union.
+	(struct gfc_namespace): Add "tb_sym_root" as new symtree to sort out
+	type-bound procedures there.
+	(gfc_get_tbp_symtree): New procedure.
+	* symbol.c (tentative_tbp_list): New global.
+	(gfc_get_namespace): NULL new "tb_sym_root" member.
+	(gfc_new_symtree): Removed initialization of "typebound" member.
+	(gfc_undo_symbols): Process list of tentative tbp's.
+	(gfc_commit_symbols): Ditto.
+	(free_tb_tree): New method.
+	(gfc_free_namespace): Call it.
+	(gfc_get_typebound_proc): New method.
+	(gfc_get_tbp_symtree): New method.
+	(gfc_find_typebound_proc): Adapt to structural changes of gfc_symtree
+	and gfc_namespace with regards to tbp's.
+	* dump-parse-tree.c (show_typebound): Ditto.
+	* primary.c (gfc_match_varspec): Ditto.  Don't reference tbp-symbol
+	as it isn't a symbol any longer.
+	* module.c (mio_typebound_symtree): Adapt to changes.
+	(mio_typebound_proc): Ditto, create symtrees using "gfc_get_tbp_symtree"
+	rather than "gfc_get_sym_tree".
+	(mio_f2k_derived): Ditto.
+	* decl.c (match_procedure_in_type): Ditto.
+	(gfc_match_generic): Ditto.  Don't reference tbp-symbol.
+	* resolve.c (check_typebound_override): Adapt to changes.
+	(resolve_typebound_generic): Ditto.
+	(resolve_typebound_procedures): Ditto.
+	(ensure_not_abstract_walker): Ditto.
+	(ensure_not_abstract): Ditto.
+	(resolve_typebound_procedure): Ditto, ignore erraneous symbols (for
+	instance, through removed tentative ones).
+	* gfc-internals.texi (Type-bound procedures): Document changes.
+
+2009-04-24  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/39861
+	PR fortran/39864
+	* symbol.c (gfc_copy_formal_args_intr): Set attr.flavor and attr.dummy
+	for the formal arguments.
+
+2009-04-21  Taras Glek <tglek@mozilla.com>
+
+	* f95-lang.c: Update GTY annotations to new syntax.
+	* trans-intrinsic.c: Likewise.
+	* trans-io.c: Likewise.
+	* trans.h: Likewise.
+
+2009-04-22  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/39735
+	* decl.c (add_hidden_procptr_result): Bugfix for procptr results.
+	(match_procedure_decl): Set if_source.
+	* expr.c (gfc_check_pointer_assign): Bugfix: Return after error.
+	And: Check interface also for IFSRC_UNKNOWN (return type may be known).
+	* gfortran.h (typedef enum ifsrc): Remove IFSRC_USAGE,
+	add documentation. Rename copy_formal_args and copy_formal_args_intr.
+	* interface.c (gfc_compare_interfaces): Check for return types,
+	handle IFSRC_UNKNOWN.
+	(compare_intr_interfaces,compare_actual_formal_intr): Obsolete, removed.
+	(gfc_procedure_use): Modified handling of intrinsics.
+	* intrinsic.c (add_functions): Bugfix for "dim".
+	* resolve.c (resolve_intrinsic): New function to resolve intrinsics,
+	which copies the interface from isym to sym.
+	(resolve_procedure_expression,resolve_function): Use new function
+	'resolve_intrinsic'.
+	(resolve_symbol): Add function attribute for externals with return type
+	and use new function 'resolve_intrinsic'.
+	* symbol.c (ifsrc_types): Remove string for IFSRC_USAGE.
+	(copy_formal_args): Renamed to gfc_copy_formal_args.
+	(copy_formal_args_intr): Renamed to gfc_copy_formal_args_intr.
+	* trans-const.c (gfc_conv_const_charlen): Handle cl==NULL.
+
+2009-04-21  Joseph Myers  <joseph@codesourcery.com>
+
+	* ChangeLog, ChangeLog-2002, ChangeLog-2003, ChangeLog-2004,
+	ChangeLog-2005, ChangeLog-2006, ChangeLog-2007, ChangeLog-2008,
+	ChangeLog.ptr, config-lang.in, ioparm.def, mathbuiltins.def: Add
+	copyright and license notices.
+	* ChangeLog, ChangeLog-2005, ChangeLog-2006, ChangeLog-2007,
+	ChangeLog-2008: Correct dates.
+
+2009-04-20  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/39811
+	* scanner.c (load_line): Fix bogus "&" compile-time diagnostic.
+
+2009-04-20  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/39800
+	* resolve.c (is_sym_host_assoc): New function.
+	(resolve_fl_derived): Call it when checking PRIVATE components
+	of PUBLIC derived types.  Change gfc_error to a gfc_notify_std
+	with std=f2003.
+	(resolve_fl_namelist): Call it twice to check for host
+	association.
+
+2009-04-20  Ian Lance Taylor  <iant@google.com>
+
+	* module.c (import_iso_c_binding_module): Add casts to enum type.
+	* trans-intrinsic.c (gfc_conv_intrinsic_minmax): Change op to enum
+	tree_code.
+	(gfc_conv_intrinsic_anyall): Likewise.
+	(gfc_conv_intrinsic_arith): Likewise.
+	(gfc_conv_intrinsic_minmaxloc): Likewise.
+	(gfc_conv_intrinsic_minmaxval): Likewise.
+	(gfc_conv_intrinsic_bitop): Likewise.
+	(gfc_conv_intrinsic_singlebitop): Likewise.
+	(gfc_conv_intrinsic_strcmp): Likewise.
+
+2009-04-20  Vasilis Liaskovitis  <vliaskov@gmail.com>
+	    Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/35423
+	* trans.h (OMPWS_WORKSHARE_FLAG, OMPWS_CURR_SINGLEUNIT,
+	OMPWS_SCALARIZER_WS, OMPWS_NOWAIT): Define.
+	(ompws_flags): New extern decl.
+	* trans-array.c (gfc_trans_scalarized_loop_end): Build OMP_FOR
+	for the outer dimension if ompws_flags allow it.
+	* trans.c (gfc_generate_code): Clear ompws_flags.
+	* trans-expr.c (gfc_trans_assignment_1): Allow worksharing
+	array assignments inside of !$omp workshare.
+	* trans-stmt.c (gfc_trans_where_3): Similarly for where statements
+	and constructs.
+	* trans-openmp.c (ompws_flags): New variable.
+	(gfc_trans_omp_workshare): Rewritten.
+
+2009-04-11  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/37746
+	* gfortran.h (struct gfc_charlen): New field "passed_length" to store
+	the actual passed string length for dummy arguments.
+	* trans-decl.c (gfc_create_string_length): Formatting fixes and added
+	assertion, moved a local variable into the innermost block it is needed.
+	(create_function_arglist): Removed TODO about the check being
+	implemented and initialize cl->passed_length here.
+	(add_argument_checking): New method.
+	(gfc_generate_function_code): Call the argument checking method.
+
+2009-04-11  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/39692
+	* symbol.c (check_conflict): Reject procedure pointers for -std=f95.
+
+2009-04-11  Daniel Franke  <franke.daniel@gmail.com>
+
+	* resolve.c (resolve_global_procedure): Enable whole-file checking for
+	procedures that are declared later in the file.
+	
+2009-04-10  Paolo Bonzini  <bonzini@gnu.org>
+
+	PR middle-end/39701
+	* trans.c (gfc_allocate_with_status): Fix type mismatches
+	on "pstat == 0".
+
+2009-04-10  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/38709
+	* expr.c (find_array_section): Leave early on zero-sized arrays.
+
+2009-04-09  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/36704
+	* decl.c (add_hidden_procptr_result): New function for handling
+	procedure pointer return values by adding a hidden result variable.
+	(variable_decl,match_procedure_decl,gfc_match_function_decl,
+	gfc_match_subroutine,gfc_match_end,attr_decl1): Handle procedure pointer
+	return values.
+	* parse.c (parse_interface): Add EXTERNAL attribute only after
+	FUNCTION/SUBROUTINE declaration is complete.
+	* primary.c (replace_hidden_procptr_result): New function for replacing
+	function symbol by hidden result variable.
+	(gfc_match_rvalue,match_variable): Replace symbol by hidden result
+	variable.
+	* resolve.c (resolve_contained_fntype,resolve_function,resolve_variable,
+	resolve_symbol): Allow for procedure pointer function results.
+	(resolve_fl_procedure): Conflict detection moved here from
+	'check_conflict'.
+	* symbol.c (gfc_check_function_type): Allow for procedure pointer
+	function results.
+	(check_conflict): Move some conflict detection to resolution stage.
+	* trans-types.c (gfc_sym_type,gfc_get_function_type): Handle hidden
+	result variables.
+
+2009-04-08  Jakub Jelinek  <jakub@redhat.com>
+
+	* trans-types.c (gfc_init_types): Ensure gfc_integer_types doesn't
+	contain TYPE_STRING_FLAG types.
+
+2009-04-08  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	PR fortran/39670
+	* invoke.texi (fdollar-ok): Fix typo.
+	
+2009-04-08  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/39670
+	* invoke.texi (fdollar-ok): Clarify limitations.
+
+2009-04-08  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/38863
+	* trans-array.c (gfc_trans_deferred_array): Return if this
+	is a result variable.
+
+2009-04-07  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/38152
+	* trans-decl.c (gfc_get_symbol_decl): Correctly set decl location for
+	procedure pointer decls.
+
+2009-04-07  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/38290
+	* expr.c (gfc_check_pointer_assign): Enable interface check for
+	procedure pointers.
+	* gfortran.h: Add copy_formal_args_intr.
+	* interface.c (gfc_compare_interfaces): Call gfc_compare_intr_interfaces
+	if second argument is an intrinsic.
+	(compare_intr_interfaces): Correctly set attr.function, attr.subroutine
+	and ts.
+	(compare_parameter): Call gfc_compare_interfaces also for intrinsics.
+	* resolve.c (resolve_specific_f0,resolve_specific_s0): Don't resolve
+	intrinsic interfaces here. Must happen earlier.
+	(resolve_symbol): Resolution of intrinsic interfaces moved here from
+	resolve_specific_..., and formal args are now copied from intrinsic
+	interfaces.
+	* symbol.c (copy_formal_args_intr): New function to copy the formal
+	arguments from an intinsic procedure.
+
+2009-04-06  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/38863
+	* dependency.c (ref_same_as_full_array): New function.
+	(gfc_dep_resolver): Call it.
+
+2009-04-06  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/39414
+	* decl.c (match_procedure_decl): Fix double declaration problems with
+	PROCEDURE statements.
+	* symbol.c (gfc_add_type): Ditto.
+
+2009-04-06  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/36091
+	* trans-array.c (gfc_conv_array_ref): If the symbol has the
+	temporary attribute use the array_spec for the bounds.
+	* gfortran.h : Add the temporary field to the structure
+	'symbol_attribute'.
+	* trans-stmt.c (forall_make_variable_temp): Set the symbol's
+	temporary attribute.
+
+2009-04-05  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/29458
+	* trans-array.c (gfc_trans_array_constructor_value): Shadow
+	implied do-loop variable to avoid spurious middle-end warnings.
+
+2009-04-04  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/39577
+	* trans-decl.c (gfc_generate_function_code): Move recursive
+	check to the right position.
+
+2009-04-04  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/37614
+	* trans-common.c (translate_common): Do not offset the whole
+	coomon block.
+
+2009-04-03  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/39594
+	* resolve.c (resolve_common_vars): Add FL_VARIABLE to symbol
+	if it is not a procedure pointer.
+	* primary.c (match_actual_arg): Ditto.
+
+2009-03-31  Joseph Myers  <joseph@codesourcery.com>
+
+	PR preprocessor/15638
+	* cpp.c (cb_cpp_error): Handle CPP_DL_FATAL.
+
+2009-03-30  Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/38389
+	* trans-stmt.c(gfc_trans_allocate): Add translation of ERRMSG.
+	(gfc_trans_deallocate): Add translation of ERRMSG.  Remove stale
+	comments.  Minor whitespace cleanup.
+	* resolve.c(is_scalar_expr_ptr): Whitespace cleanup.
+	(resolve_deallocate_expr (gfc_expr *e): Update error message.
+	(resolve_allocate_expr):  Remove dead code.  Update error message.
+	Move error checking to ...
+	(resolve_allocate_deallocate): ... here.  Add additional error
+	checking for STAT, ERRMSG, and allocate-objects.
+	* match.c(gfc_match_allocate,gfc_match_deallocate):  Parse ERRMSG.
+	Check for redundant uses of STAT and ERRMSG.  Reword error message
+	and add checking for pointer, allocatable, and proc_pointer attributes.
+
+2009-03-30  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/22571
+	PR fortran/26227
+	PR fortran/24886
+	* symbol.c : Add gfc_global_ns_list.
+	* decl.c (add_global_entry): Set the namespace ('ns') field.
+	* gfortran.h : Add the resolved field to gfc_namespace. Add the
+	namespace ('ns') field to gfc_gsymbol.  Add flag_whole_file to
+	gfc_option_t.  Add the prototype for gfc_free_dt_list.
+	* lang.opt : Add the whole-file option.
+	* invoke.texi : Document the whole-file option.
+	* resolve.c (resolve_global_procedure): If the fwhole-file
+	option is set, reorder gsymbols to ensure that translation is
+	in the right order.  Resolve the gsymbol's namespace if that
+	has not occurred and then check interfaces.
+	(resolve_function): Move call to resolve_global_procedure.
+	(resolve_call): The same.
+	(resolve_codes): Store the current labels_obstack.
+	(gfc_resolve) : Return if the namespace is already resolved.
+	trans-decl.c (gfc_get_extern_function_decl): If the whole_file
+	option is selected, use the backend_decl of a gsymbol, if it is
+	available.
+	parse.c (add_global_procedure, add_global_program): If the flag
+	whole-file is set, add the namespace to the gsymbol.
+	(gfc_parse_file): On -fwhole-file, put procedure namespaces on
+	the global namespace list.  Rearrange to do resolution of all
+	the procedures in a file, followed by their translation.
+	* options.c (gfc_init_options): Add -fwhole-file.
+	(gfc_handle_option): The same.
+
+2009-03-30  Ulrich Weigand  <Ulrich.Weigand@de.ibm.com>
+
+	* f95-lang.c (gfc_init_builtin_functions): Define BUILT_IN_HUGE_VAL
+	family of intrinsics instead of BUILT_IN_INF family.
+	* trans-intrinsics.c (gfc_conv_intrinsic_nearest): Use
+	BUILT_IN_HUGE_VAL instead of BUILT_IN_INF.
+
+2009-03-30  Jakub Jelinek  <jakub@redhat.com>
+
+	* trans-types.c (gfc_sym_type, gfc_return_by_reference): For
+	sym->attr.result check sym->ns->proc_name->attr.is_bind_c.
+
+2009-03-30  Joseph Myers  <joseph@codesourcery.com>
+
+	PR rtl-optimization/323
+	* options.c (gfc_post_options): Set
+	flag_excess_precision_cmdline.  Give an error for
+	-fexcess-precision=standard for processors where the option is
+	significant.
+
+2009-03-29  Joseph Myers  <joseph@codesourcery.com>
+
+	PR preprocessor/34695
+	* cpp.c (cb_cpp_error): New.
+	(gfc_cpp_post_options): Don't set cpp_option->inhibit_warnings.
+	Don't check cpp_errors (cpp_in).
+	(gfc_cpp_init_0): Set cb->error.
+
+2009-03-29  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/38823
+	* gfortran.h: Add ARITH_PROHIBIT to arith enum.
+	expr.c (gfc_match_init_expr): Add global variable init_flag to
+	flag matching an initialization expression.
+	(check_intrinsic_op): Move no longer reachable error message to ...
+	* arith.c (arith_power): ... here.  Remove gfc_ prefix in
+	gfc_arith_power.  Use init_flag.  Allow constant folding of x**y
+	when y is REAL or COMPLEX.
+	(eval_intrinsic): Remove restriction that y in x**y must be INTEGER
+	for constant folding.
+	* gfc_power: Update gfc_arith_power to arith_power
+
+2009-03-29  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/37423
+	* gfortran.h (struct gfc_typebound_proc): Added new flag "deferred" and
+	added a comment explaining DEFERRED binding handling.
+	* decl.c (match_binding_attributes): Really match DEFERRED attribute.
+	(match_procedure_in_type): Really match PROCEDURE(interface) syntax
+	and do some validity checks for DEFERRED and this construct.
+	* module.c (binding_overriding): New string constant for DEFERRED.
+	(mio_typebound_proc): Module-IO DEFERRED flag.
+	* resolve.c (check_typebound_override): Ensure that a non-DEFERRED
+	binding is not overridden by a DEFERRED one.
+	(resolve_typebound_procedure): Allow abstract interfaces as targets
+	for DEFERRED bindings.
+	(ensure_not_abstract_walker), (ensure_not_abstract): New methods.
+	(resolve_fl_derived): Use new "ensure_not_abstract" method for
+	non-ABSTRACT types extending ABSTRACT ones to ensure each DEFERRED
+	binding is overridden.
+	(check_typebound_baseobject): New method.
+	(resolve_compcall), (resolve_typebound_call): Check base-object of
+	the type-bound procedure call.
+	* gfc-internals.texi (Type-bound procedures): Document a little bit
+	about internal handling of DEFERRED bindings.
+
+2009-03-29  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	PR fortran/38507
+	* gfortran.h (gfc_st_label): Fix comment.
+	(gfc_exec_op): Add statement code EXEC_END_BLOCK for end of block.
+	* parse.c (accept_statement): Use EXEC_END_BLOCK for END IF and
+	END SELECT with labels.
+	(check_do_closure): Fix formatting.
+	(parse_do_block): Fix typo in error message.
+	* resolve.c (code_stack): Remove tail member.  Update comment to
+	new use of reachable_labels.
+	(reachable_labels): Rename to ...
+	(find_reachable_labels): ... this.  Overhaul.  Update preceding
+	comment.
+	(resolve_branch): Fix comment preceding function.  Rewrite.
+	(resolve_code): Update call to find_reachable_labels.  Add code to
+	deal with EXEC_END_BLOCK.
+	* st.c (gfc_free_statement): Add code to deal with EXEC_END_BLOCK.
+	Add 2009 to copyright years.
+	* trans.c (gfc_trans_code): Likewise on both counts.
+
+2009-03-31  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/38917
+	* expr.c (gfc_check_assign): Allow pointer components when
+	checking for NULL.
+
+	PR fortran/38918
+	* resolve.c (check_data_variable): Treat pointer arrays with
+	scalars.
+
+2009-03-31  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/38915
+	* trans-expr.c (gfc_trans_assignment_1): Ensure temporaries
+	have a string_length.
+
+2009-03-28  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34656
+	* trans-stmt.c (gfc_trans_simple_do, gfc_trans_do):
+	Add GFC_RTCHECK_DO support.
+	* option.c (gfc_handle_runtime_check_option): Enable GFC_RTCHECK_DO.
+	* invoke.texi (-fcheck): Document "do" option.
+
+2009-03-28  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/38538
+	* trans-array.c (get_elemental_fcn_charlen): Remove.
+	(get_array_charlen): New function to replace previous.
+
+2009-03-28  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/38765
+	* parse.c (parse_derived): Do not break on finding pointer,
+	allocatable or private components.
+
+2009-03-28  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/32626
+	* option.c (gfc_handle_runtime_check_option): Enable recursion check.
+	* trans-decl.c (gfc_generate_function_code): Add recursion check.
+	* invoke.texi (-fcheck): Add recursive option.
+
+2009-03-28  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/38432
+	* resolve.c (gfc_resolve_iterator): Add zero-loop warning.
+
+2009-03-28  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+	    Paul Thomas  <pault@gcc.gnu.org>
+	    Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.h (gfc_option_t): Add rtcheck.
+	* lang.opt: New option -fcheck.
+	* libgfortran.h: Add GFC_RTCHECK_* constants.
+	* invoke.texi: Document -fcheck.
+	* options.c (gfc_handle_runtime_check_option): New function.
+	(gfc_init_options,gfc_post_options,gfc_handle_option):
+	Add -fcheck option.
+
+2009-03-27  Richard Guenther  <rguenther@suse.de>
+
+	* trans-array.c (gfc_conv_descriptor_data_addr): Use
+	gfc_build_addr_expr instead of build_fold_addr_expr.
+	(gfc_trans_allocate_array_storage, gfc_trans_array_constructor_value,
+	gfc_trans_constant_array_constructor, gfc_conv_array_data,
+	gfc_conv_expr_descriptor, gfc_conv_array_parameter): Likewise.
+	* trans-expr.c (gfc_conv_missing_dummy, gfc_conv_variable,
+	gfc_conv_function_val, gfc_conv_operator_assign,
+	gfc_conv_subref_array_arg, gfc_conv_function_call,
+	gfc_conv_expr_reference, gfc_trans_scalar_assign): Likewise.
+	* trans-intrinsic.c (gfc_conv_intrinsic_exponent,
+	gfc_conv_intrinsic_ctime, gfc_conv_intrinsic_fdate,
+	gfc_conv_intrinsic_ttynam, gfc_conv_intrinsic_minmax_char,
+	gfc_conv_intrinsic_fraction, gfc_conv_intrinsic_spacing,
+	gfc_conv_intrinsic_rrspacing, gfc_conv_intrinsic_set_exponent,
+	gfc_conv_intrinsic_array_transfer, gfc_conv_intrinsic_transfer,
+	gfc_conv_intrinsic_si_kind, gfc_conv_intrinsic_trim): Likewise.
+	* trans-io.c (gfc_trans_io_runtime_check, set_parameter_ref,
+	gfc_convert_array_to_string, gfc_trans_open, gfc_trans_close,
+	build_filepos, gfc_trans_inquire, gfc_trans_wait,
+	nml_get_addr_expr, transfer_namelist_element, build_dt,
+	gfc_trans_dt_end, transfer_array_component, transfer_expr,
+	transfer_array_desc, gfc_trans_transfer): Likewise.
+	* trans-stmt.c (gfc_trans_allocate, gfc_trans_deallocate): Likewise.
+	* trans.c (gfc_build_addr_expr): Mark the base of the address
+	TREE_ADDRESSABLE.
+
+2009-03-27  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.h (enum init_local_real.): Add GFC_INIT_REAL_SNAN.
+	(gfc_expr): Add is_snan.
+	* trans-const.c (gfc_conv_mpfr_to_tree): Support SNaN.
+	(gfc_conv_constant_to_tree): Update call to gfc_conv_mpfr_to_tree.
+	* trans-const.h (gfc_conv_mpfr_to_tree): Update prototype.
+	* resolve.c (build_default_init_expr): Update call.
+	* target-memory.c (encode_float): Ditto.
+	* trans-intrinsic.c (gfc_conv_intrinsic_aint,gfc_conv_intrinsic_mod,
+
+2009-03-18  Ralf Wildenhues  <Ralf.Wildenhues@gmx.de>
+
+	* lang.opt: Unify help texts for -I, -Wconversion, -d, -fopenmp,
+	and -fpreprocessed.
+
+2009-03-06  Alexandre Oliva <aoliva@redhat.com>
+
+	* simplify.c (gfc_simplify_transfer): Zero-initialize the
+	buffer.
+
+2009-02-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/39309
+	* module.c (read_md5_from_module_file): Add missing quote.
+
+2009-02-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/39309
+	* module.c (read_md5_from_module_file): Include mod version
+	in had-changed test.
+
+2009-02-26  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/39295
+	* interface.c (compare_type_rank_if): Return 1 if the symbols
+	are the same and deal with external procedures where one is
+	identified to be a function or subroutine by usage but the
+	other is not.
+
+2009-02-26  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/39292
+	* trans-array.c (gfc_conv_array_initializer): Convert all
+	expressions rather than ICEing.
+
+2009-02-21  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/38914
+	* array.c (ref_dimen_size):  Rename to gfc_ref_dimen_size,
+	make global.  Change function name in error messages.
+	(ref_size):  Change ref_dimen_size to gfc_ref_dimen_size.
+	(gfc_array_ref_shape):  Likewise.
+	* gfortran.h:  Add prototype for gfc_ref_dimen_size.
+	* simplify.c (simplify_bound_dim):  Add ref argument.
+	If the reference isn't a full array, return one for
+	the lower bound and the extent for the upper bound.
+	(simplify_bound):  For array sections, take as from the
+	argument.  Add reference to all to simplify_bound_dim.
+
+2009-02-19  Daniel Franke  <franke.daniel@gmail.com>
+
+	* scanner.c (load_line): At end of line, skip '\r' without setting
+	the truncation flag.
+
+2009-02-18  Daniel Kraft  <d@domob.eu>
+
+	* gfortran.texi: New chapter about compiler characteristics.
+	(Compiler Characteristics): Document KIND type parameters here.
+
+2009-02-18  Tobias Burnus  <burnus@net-b.de>
+
+	* intrinsic.texi (MALLOC): Make example more portable.
+
+2009-02-13  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/38259
+	* module.c (gfc_dump_module,gfc_use_module): Add module
+	version number.
+
+2009-02-13  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/36703
+	PR fortran/36528
+	* trans-expr.c (gfc_conv_function_val): Stabilize Cray-pointer
+	function references to ensure that a valid expression is used.
+	(gfc_conv_function_call): Pass Cray pointers to procedures.
+
+2009-02-03  Jakub Jelinek  <jakub@redhat.com>
+
+	* gfortranspec.c (lang_specific_driver): Update copyright notice
+	dates.
+
+2009-01-28  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/38852
+	PR fortran/39006
+	* trans-intrinsic.c (gfc_conv_intrinsic_bound): Use the array
+	descriptor ubound for UBOUND, when the array lbound == 1.
+
+2009-01-27  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/38883
+	* trans-stmt.c (gfc_conv_elemental_dependencies):  Create temporary
+	for the real type needed to make it work for subcomponent-references.
+
+2009-01-21  Daniel Kraft  <d@domob.eu>
+
+	* trans-stmt.c (gfc_conv_elemental_dependencies):  Cleaned up comment.
+
+2009-01-20  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/38907
+	* resolve.c (check_host_association): Remove the matching to
+	correct an incorrect host association and use manipulation of
+	the expression instead.
+
+2009-01-20  Tobias Burnus  <burnus@net-b.de>
+
+	* invoke.texi (RANGE): RANGE also takes INTEGER arguments.
+
+2009-01-19  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/38859
+	* simplify.c (simplify_bound): Don't use array specification
+	if variable or component has subsequent references.
+
+2009-01-17  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/38657
+	* module.c (write_common_0): Add argument 'this_module' and
+	check that non-use associated common blocks are written first.
+	(write_common): Call write_common_0 twice, once with true and
+	then with false.
+
+2009-01-17  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34955
+	* trans-intrinsic.c (gfc_conv_intrinsic_array_transfer): Has
+	been absorbed into gfc_conv_intrinsic_transfer. All
+	references to it in trans-intrinsic.c have been changed
+	accordingly.  PR fixed by using a temporary for scalar
+	character transfer, when the source is shorter than the
+	destination.
+
+2009-01-17  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/38657
+	* module.c (write_common_0): Revert patch of 2009-01-05.
+
+2009-01-16  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/38152
+	* expr.c (gfc_check_pointer_assign): Allow use-associated procedure
+	pointers as lvalue.
+	* trans-decl.c (get_proc_pointer_decl,gfc_create_module_variable):
+	Enable procedure pointers as module variables.
+
+2009-01-14  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* ChangeLog-2007: Clean out svn merge droppings.
+
+2009-01-10  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/38763
+	* target-memory.c (encode_derived): Encode NULL.
+
+2009-01-10  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/38765
+	* resolve.c (check_host_association): Use the symtree name to
+	search for a potential contained procedure, since this is the
+	name by which it would be referenced.
+
+2009-01-06  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/38220
+	* interface.c (gfc_procedure_use):  Don't warn about functions
+	from ISO_C_BINDING.
+	* symbol.c (generate_isocbinding_symbol):  Mark c_loc and
+	c_funloc as pure.
+
+2009-01-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/38657
+	* module.c (write_common_0): Use the name of the symtree rather
+	than the common block, to determine if the common has been
+	written.
+
+2009-01-05  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/37159
+	* check.c (gfc_check_random_seed): Added size check for GET
+	dummy argument, reworded error messages to follow common pattern.
+
+2009-01-05  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/38672
+	* trans-types.c (gfc_get_derived_type):  Check for the
+	presence of derived->ns->proc_name before
+	accessing derived->ns->proc_name->attr.flavor .
+	* resolve.c (resolve_symbol):  Likewise.
+
+2009-01-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/38665
+	* gfortran.h : Add bit to gfc_expr 'user_operator'
+	* interface.c (gfc_extend_expr): Set the above if the operator
+	is substituted by a function. 
+	* resolve.c (check_host_association): Return if above is set.
+
+2009-01-04  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/35681
+	* ChangeLog-2008: Fix function name.
+
+	PR fortran/38487
+	* dependency.c (gfc_check_argument_var_dependency):
+	Move the check for pointerness inside the if block
+	so that it doesn't affect the return value.
+
+	PR fortran/38669
+	* trans-stmt.c (gfc_trans_call):
+	Add the dependency code after the loop bounds calculation one.
+
+2009-01-04  Daniel Franke  <franke.daniel@gmail.com>
+
+	* intrinsic.c (do_simplify): Removed already implemented TODO.
+
+2009-01-04  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/38718
+	* simplify.c (gfc_simplify_merge): New.
+	* intrinsic.h (gfc_simplify_merge): New prototype.
+	* intrinsic.c (add_functions): Added simplification for MERGE.
+
+2009-01-04  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/38536
+	* gfortran.h (gfc_is_data_pointer): Added prototype
+	* resolve.c (gfc_iso_c_func_interface):
+	Use gfc_is_data_pointer to test for pointer attribute.
+	* dependency.c (gfc_is_data_pointer):
+	Support pointer-returning functions.
+
+2009-01-03  Daniel Franke  <franke.daniel@gmail.com>
+
+	* symbol.c (save_symbol): Don't SAVE function results.
+
+2009-01-03  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/38594
+	* resolve.c (resolve_call): When searching for proper host
+	association, use symtree rather than symbol.  For everything
+	except generic subroutines, substitute the symtree in the call
+	rather than the symbol.
+
+
+Copyright (C) 2009 Free Software Foundation, Inc.
+
+Copying and distribution of this file, with or without modification,
+are permitted in any medium without royalty provided the copyright
+notice and this notice are preserved.
diff --git a/gcc-4.9/gcc/fortran/ChangeLog-2010 b/gcc-4.9/gcc/fortran/ChangeLog-2010
new file mode 100644
index 000000000..dc25cbd39
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/ChangeLog-2010
@@ -0,0 +1,5556 @@
+2010-12-31  Janus Weil  <janus@gcc.gnu.org>
+
+	* intrinsic.texi (IANY): Correct section title.
+	(IALL, IANY, IPARITY): Fix example codes.
+
+2010-12-31  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/47065
+	* frontend-passes.c (count_arglist):  Static variable to
+	count the nesting of argument lists.
+	(optimize_code):  Set count_arglist to 1 if within a call
+	statement, to 0 otherwise.
+	(optimize_trim):  New function.
+	(optimize_expr):  Adjust count_arglist.  Call optimize_trim.
+
+2010-12-31  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/45338
+	* resolve.c (resolve_operator):  Mark function for user-defined
+	operator as referenced.
+
+2010-12-31  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/46971
+	* gfortran.h (gfc_hash_value): Add prototype.
+	* class.c (get_unique_type_string): Check if proc_name is present and
+	make sure string contains an underscore.
+	(get_unique_hashed_string): New function which creates a hashed string
+	if the given unique string is too long.
+	(gfc_hash_value): Moved here from decl.c, renamed and simplified.
+	(gfc_build_class_symbol, gfc_find_derived_vtab): Use hashed strings.
+	* decl.c (hash_value): Moved to class.c.
+	(gfc_match_derived_decl): Renamed 'hash_value'.
+
+2010-12-30  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47085
+	* match.c (gfc_match_allocate): Check for 'class_ok'.
+	* primary.c (gfc_match_varspec): Ditto.
+
+2010-12-29  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	* dump_parse_tree.c (show_components):  Show
+	ALLOCATABLE.
+
+2010-12-29  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/46838
+	* expr.c (gfc_default_initializer): Handle allocatable CLASS components.
+
+2010-12-29  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	* frontend-passes.c (gfc_code_walker): Handle expressions
+	in EXEC_CALL, EXEC_ASSIGN_CALL and EXEC_CALL_PPC.
+	Separate cases in switch statements by blank lines.
+
+2010-12-28  Janus Weil  <janus@gcc.gnu.org>
+	    Daniel Franke  <dfranke@gcc.gnu.org>
+
+	PR fortran/45827
+	* module.c (mio_component_ref): Handle components of CLASS variables.
+
+2010-12-27  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	* dump-parse-tree.c (show_typespec):  Also show character kind.
+
+2010-12-24  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/31821
+	* check.c (gfc_var_strlen):  New function, also including
+	substring references.
+	(gfc_check_same_strlen):  Use gfc_var_strlen.
+
+2010-12-23  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/46978
+	Revert part of revision 164112
+	* trans-array.c (gfc_trans_create_temp_array):
+	Set loop n'th upper bound from (possibly transposed) array's dim bounds.
+
+2010-12-18  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/46974
+	* target-memory.c (gfc_interpret_derived): Handle C_PTR/C_FUNPTR.
+	* trans-expr.c (gfc_trans_structure_assign): Ditto.
+	(gfc_conv_expr): Avoid crashes using non-C_NULL_(FUN)PTR const expr.
+
+2010-12-17  Janus Weil  <janus@gcc.gnu.org>
+	    Tobias Burnus <burnus@gcc.gnu.org>
+
+	PR fortran/46849
+	* resolve.c (resolve_symbol): Remove symbols that wrongly ended up
+	in a local BLOCK namespace.
+
+2010-12-15  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/46945
+	* trans-array.c (gfc_array_init_size): Perform stride overflow
+	checking and multiplication by element_size in size_type_node instead
+	of sizetype, return value with size_type_node type instead of
+	sometimes with sizetype and sometimes with gfc_array_index_type.
+
+2010-12-15  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	* trans.c (gfc_allocate_with_status): Better error message for
+	malloc() failure.
+	(gfc_call_realloc): Likewise.
+	* misc.c (gfc_getmem): Likewise.
+
+2010-12-15  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	PR fortran/28105
+	* trans.c (gfc_call_malloc): Improve comment.
+	(gfc_allocate_with_status): Remove size < 0 check.
+	(gfc_call_realloc): Likewise.
+
+2010-12-14  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/46937
+	* trans-types.c (create_fn_spec): "."-annotate derived types
+	with (proc-)pointer components.
+
+2010-12-14  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/46874
+	* trans-openmp.c (gfc_trans_omp_array_reduction): Handle allocatable
+	dummy variables.
+
+2010-12-13  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/46201
+	* trans-expr.c (gfc_conv_procedure_call): Handle procedure pointer
+	components called on a dimensionful base object.
+
+2010-12-13  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/46841
+	* trans-expr.c (gfc_trans_subcomponent_assign): Handle array-valued
+	procedure pointer components.
+
+2010-12-13  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/46884
+	* symbol.c (gfc_new_charlen): If old_cl is non-NULL, put it
+	at the ns->old_cl_list spot in the chain rather than at
+	ns->cl_list.
+
+2010-12-12  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	* dump-parse-tree.c (show_expr): Add space for parens.
+
+2010-12-12  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/46809
+	* resolve.c (resolve_select_type): Set the location of the first
+	argument when generating the EXTENDS_TYPE_OF call.
+
+2010-12-11  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/46705
+	* gfortran.h: New enum gfc_instring.
+	(gfc_next_char_literal): Update prototype.
+	* scanner.c (gfc_next_char_literal): Use new enum. Only give missing
+	'&' warning for INSTRING_WARN. (gfc_next_char): Use new enum.
+	(gfc_gobble_whitespace): Likewise.
+	* io.c (next_char): Use new enum. (next_char_not_space): Likewise.
+	(format_lex): Likewise.
+	* match.c (gfc_match_parens): Likewise.
+	(gfc_match_special_char): Likewise. (gfc_match_name_C): Likewise.
+	* parse.c (next_fixed): Likewise.
+	* primary.c (match_hollerith_constant): Likewise.
+	(next_string_char): Likewise.
+
+2010-12-11  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/46370
+	* primary.c (gfc_match_varspec): Pass information about codimension
+	to gfc_match_array_ref also for BT_CLASS.
+	* resolve.c (resolve_procedure): Correct check for C612.
+
+2010-12-11  Mikael Morin   <mikael@gcc.gnu.org>
+	    Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/46842
+	* trans-array.c (dim_ok): New helper function.
+	(gfc_conv_expr_descriptor): Use new helper function to check
+	function array is full.
+
+2010-12-10  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/46540
+	* trans-types.c (gfc_init_kinds): Handle
+	--disable-libquadmath-support.
+
+2010-12-09  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* check.c (gfc_check_sngl): Insert missing space in error message.
+
+2010-12-09  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* check.c (gfc_check_float): Insert missing space in error message.
+
+2010-12-07  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/44352
+	* trans-expr.c (gfc_string_to_single_character): Return if not
+	POINTER_TYPE_P.
+	(gfc_trans_string_copy): gfc_build_addr_expr if src or dest is
+	not a pointer.
+	(gfc_trans_string_copy): Make sure the argument string type
+	has a string length, fix indention, and remove not needed
+	gfc_build_addr_expr.
+
+2010-12-04  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/46794
+	* trans-expr.c (gfc_conv_power_op): Handle kind of result expression
+	correctly for integer kind 1 and 2 operands.
+
+2010-12-03  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/44352
+	* dump-parse-tree.c (show_symbol):  Don't show formal namespace
+	for statement functions in order to avoid infinite recursion.
+
+2010-12-03  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/45159
+	* dependency.c (check_section_vs_section):  Pre-calculate
+	the relationship between the strides and the relationship
+	between the start values.  Use an integer constant one for
+	that purpose.
+	Forward dependencies for positive strides apply for where
+	the lhs start <= rhs start and lhs stride <= rhs stride
+	and vice versa for negative stride.  No need to compare
+	end expressions in either case (assume no bounds violation).
+
+2010-12-03  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	* trans-array.c (gfc_could_be_alias):  Handle BT_CLASS
+	as well as BT_DERIVED.
+	(gfc_array_allocate):  Likewise.
+	(gfc_conv_array_parameter):  Likewise.
+	(structure_alloc_comps):  Likewise.
+	(gfc_is_reallocatable_lhs):  Likewise.
+	(gfc_trans_deferred_array):  Likewise.
+
+2010-12-02  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/46753
+	* trans-openmp.c (gfc_trans_omp_do): Use build2_loc instead of
+	fold_build2_loc for OMP_FOR conditions.
+
+2010-11-30  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	PR fortran/28105
+	* trans-array.c (gfc_unlikely): Helper function to mark boolean
+	expr as unlikely.
+	(gfc_array_index_size): Check whether the size overflows.
+	(gfc_array_allocate): Check whether size overflows and generate
+	error.
+
+2010-11-30  Joseph Myers  <joseph@codesourcery.com>
+
+	* trans-common.c: Don't include toplev.h.
+
+2010-11-29  Joseph Myers  <joseph@codesourcery.com>
+
+	* gfortran.h (alloca): Don't include definitions.
+	(NULL): Don't define.
+
+2010-11-28  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/46662
+	* resolve.c (update_ppc_arglist): Add check for abstract passed object.
+
+2010-11-28  Paul Thomas  <pault@gcc.gnu.org>
+
+	 PR fortran/35810
+	* trans-array.c (gfc_trans_array_constructor): If the loop->to
+	is a VAR_DECL, assume this is dynamic. In this case, use the
+	counter to obtain the value and set loop->to appropriately.
+	(gfc_conv_ss_descriptor): Always save the offset of a variable
+	in info.saved_offset.
+	(gfc_conv_ss_startstride): Do not attempt bound checking of the
+	lhs of an assignment, if allocatable and f2003 is allowed.
+	(gfc_conv_loop_setup): If possible, do not use an allocatable
+	lhs variable for the loopspec.
+	(gfc_is_reallocatable_lhs): New function.
+	(get_std_lbound): New function.
+	(gfc_alloc_allocatable_for_assignment): New function.
+	* gfortran.h : Add flag_realloc_lhs to the options structure.
+	* lang.opt : Add option f(no-)realloc-lhs.
+	* invoke.texi : Document option f(no-)realloc-lhs.
+	* options.c (gfc_init_options, gfc_post_options,
+	gfc_handle_option): Incorporate f(no-)realloc-lhs with default
+	to frealloc_lhs for -std > f95.
+	* trans-array.h : Add primitive for previous.
+	* trans-expr.c (gfc_conv_string_length): Return if character
+	length is a variable and the expression is NULL.
+	(gfc_conv_procedure_call): If the call is of the kind x = f(...)
+	and the lhs is allocatable and reallocation on assignment OK,
+	call gfc_alloc_allocatable_for_assignment. Do not generate the
+	function call unless direct by reference.
+	(realloc_lhs_loop_for_fcn_call): New function.
+	(realloc_lhs_bounds_for_intrinsic_call): New function.
+	(gfc_trans_arrayfunc_assign): Reallocation assignments need
+	a loopinfo and for the loop bounds to be set.  With intrinsic
+	functions, free the lhs data and let the library allocate the
+	data array. Done by the new functions above.
+	(gfc_trans_assignment_1): If the lhs is allocatable and
+	reallocation on assignment is allowed, mark the lhs and use
+	gfc_alloc_allocatable_for_assignment to make the reallocation.
+	* trans.h : Add is_alloc_lhs bitfield to gfc_ss structure.
+
+2010-11-27  Tobias Burnus  <burnus@net-b.de>
+	    Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/46678
+	trans-decl.c (gfc_trans_auto_character_variable): Use gfc_init_block
+	instead of gfc_start_block.
+
+2010-11-27  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/46301
+	trans-expr.c (gfc_trans_assignment): Add error message for not
+	implemented assignment to deferred-length character variable.
+
+2010-11-26  Jakub Jelinek  <jakub@redhat.com>
+
+	PR bootstrap/45700
+	* trans.h (build1_stat_loc, build2_stat_loc, build3_stat_loc,
+	build4_stat_loc): Removed.
+	(build1_loc, build2_loc, build3_loc, build4_loc): Removed.
+
+2010-11-25  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/46581
+	* trans.h (gfc_process_block_locals): Removed second argument.
+	* trans-decl.c (trans_associate_var): Moved to trans-stmt.c.
+	(gfc_trans_deferred_vars): Skip ASSOCIATE variables.
+	(gfc_process_block_locals): Don't mark associate names to be
+	initialized.
+	* trans-stmt.c (trans_associate_var): Moved here from trans-decl.c.
+	(gfc_trans_block_construct): Call 'trans_associate_var' from here
+	to make sure SELECT TYPE with associate-name is treated correctly.
+
+2010-11-24  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/46638
+	* target-memory.c (gfc_interpret_derived): Correctly handle
+	component offset.
+
+2010-11-23  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/46545
+	* gfortran.texi (KIND Type Parameters): Quadmath and F2008 changes.
+
+2010-11-22  Michael Matz  <matz@suse.de>
+
+	* gfortranspec.c (library): New global, moved from ...
+	(lang_specific_driver): ... here.
+	(lang_specific_pre_link): Test it here before including
+	libgfortran.spec.
+
+2010-11-21  Michael Matz  <matz@suse.de>
+	    Tobias Burnus  <burnus@net-b.de>
+
+	PR driver/46516
+	* gfortranspec.c (lang_specific_driver,
+	lang_specific_pre_link): Load libgfortran.spec in
+	lang_specific_pre_link unless found in the -L path.
+
+2010-11-20  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	* f95-lang.c (gfc_init_decl_processing): Set size_type_node as
+	unsigned int of pointer size and set sizetype based on that.
+	* trans-types.c (gfc_init_types): Don't set size_type_node to an
+	unsigned type.
+
+2010-11-17  Joseph Myers  <joseph@codesourcery.com>
+
+	* f95-lang.c (gfc_be_parse_file): Take no arguments.
+
+2010-11-16  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+	    Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/32049
+	* gfortranspec.c (find_spec_file): New function.
+	(lang_specific_driver): Try to find .spec file and use it.
+	* trans-io.c (iocall): Define IOCALL_X_REAL128/COMPLEX128(,write).
+	(gfc_build_io_library_fndecls): Build decl for __float128 I/O.
+	(transfer_expr): Call __float128 I/O functions.
+	* trans-types.c (gfc_init_kinds): Allow kind-16 belonging
+	to __float128.
+
+2010-11-15  Tobias Burnus  <burnus@net.b.de>
+
+	PR fortran/46484
+	* check.c (variable_check): Don't treat functions calls as variables;
+	optionally accept function themselves.
+	(gfc_check_all_any, gfc_check_loc, gfc_check_move_alloc,
+	gfc_check_null, gfc_check_present, gfc_check_cpu_time,
+	gfc_check_date_and_time, gfc_check_mvbits, gfc_check_random_number,
+	gfc_check_random_seed, gfc_check_system_clock,
+	gfc_check_dtime_etime, gfc_check_dtime_etime_sub,
+	gfc_check_itime_idate,gfc_check_ltime_gmtime): Update call.
+
+2010-11-13  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/45742
+	* trans-common.c (build_field): Add TREE_SIDE_EFFECTS for volatile.
+	* trans-decl.c (gfc_finish_var_decl): Ditto.
+	(create_function_arglist): Handle volatile dummy arguments.
+
+2010-11-12  Joseph Myers  <joseph@codesourcery.com>
+
+	* Make-lang.in (gfortranspec.o): Use $(OPTS_H).
+	* gfortran.h (gfc_handle_option): Take location_t parameter.
+	* options.c (gfc_handle_option): Take location_t parameter.
+
+2010-11-12  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/45794
+	trans-expr.c (gfc_conv_procedure_call): Avoid NULL array spec.
+	
+2010-11-11  Nathan Froyd  <froydnj@codesourcery.com>
+
+	PR c/44782
+	* options.c (gfc_post_options): Initialize gfc_option.max_errors.
+	(gfc_handle_option) [OPT_fmax_errors_]: Remove.
+	* lang.opt (fmax-errors=): Remove.
+
+2010-11-11  Steven G. Kargl <kargl@gcc.gnu.org>
+
+	* symbol.c (verify_bind_c_derived_type):  Accept BIND(C) on an empty
+	derived type.
+
+2010-11-11  Jan Hubicka  <jh@suse.cz>
+
+	* options.c (gfc_post_options): Remove flag_whopr.
+
+2010-11-11  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/46413
+	* resolve.c (resolve_transfer): Reject I/O transfer of
+	polymorphic type.
+
+	PR fortran/46205
+	* resolve.c (resolve_code): Reject nonscalar FORALL masks.
+
+2010-11-11  Janus Weil  <janus@gcc.gnu.org>
+
+	* resolve.c (resolve_procedure_interface): Copy 'is_bind_c' attribute.
+
+2010-11-10  Joseph Myers  <joseph@codesourcery.com>
+
+	* trans-array.c (gfc_trans_deferred_array): Use "front-end"
+	spelling in diagnostic.
+	* trans.c (gfc_allocate_array_with_status): Add missing space in
+	diagnostic.
+
+2010-11-10  Joseph Myers  <joseph@codesourcery.com>
+
+	* cpp.c (asm_file_name): Don't declare here.
+
+2010-11-10  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/46411
+	* intrinsic.c (gfc_intrinsic_sub_interface): Check for attr.pure
+	and not for attr.elemental.
+	* intrinsic.texi (move_alloc): Document as being pure.
+
+2010-11-10  Tobias Burnus <burnus@net-b.de>
+
+	PR fortran/46244
+	* resolve.c (resolve_fl_derived): Don't allow CLASS in
+	sequence/BIND(C) types.
+
+2010-11-09  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+	    Mikael Morin   <mikael@gcc.gnu.org>
+
+	PR fortran/46331
+	* intrinsic.c: Correctly set the pure attributes for intrinsic
+	functions.
+	* expr.c (check_specification_function): Remove this function and move
+	its code into gfc_is_constant_expr. (gfc_is_constant_expr): Change the
+	order of checks by checking for non-constant arguments first.  Then,
+	check for initialization functions, followed by intrinsics.
+
+2010-11-09  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/46313
+	* gfortran.h (gfc_add_data_component,gfc_add_vptr_component,
+	gfc_add_hash_component,gfc_add_size_component,
+	gfc_add_def_init_component): New macros.
+	* class.c (gfc_add_component_ref): Renamed data component.
+	(get_unique_type_string): New function.
+	(gfc_build_class_symbol): Use 'get_unique_type_string' to construct
+	uniques names for the class containers. Rename components.
+	(gfc_find_derived_vtab): Use 'get_unique_type_string' to construct
+	uniques names for the vtab symbols. Rename components.
+	* decl.c (attr_decl1): Renamed class container components.
+	* iresolve.c (gfc_resolve_extends_type_of): Ditto.
+	* match.c (select_type_set_tmp): Renamed temporaries.
+	* module.c (read_module): Renamed vtab and vtype symbols.
+	* resolve.c (resolve_structure_cons,resolve_typebound_function,
+	resolve_typebound_subroutine,resolve_deallocate_expr,
+	resolve_select_type,resolve_fl_derived): Renamed class container and
+	vtab components.
+	* trans-array.c (structure_alloc_comps): Ditto.
+	* trans-decl.c (gfc_trans_deferred_vars): Ditto.
+	* trans-expr.c (gfc_conv_derived_to_class,gfc_conv_structure,
+	gfc_trans_class_init_assign,gfc_trans_class_assign): Ditto.
+	* trans-intrinsic.c (gfc_conv_intrinsic_sizeof,
+	gfc_conv_intrinsic_storage_size,gfc_conv_allocated,gfc_conv_associated,
+	gfc_conv_same_type_as): Ditto.
+	* trans-stmt.c (gfc_trans_allocate): Ditto.
+
+2010-11-08  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/43899
+	* trans-decl.c (generate_local_decl): Do not generate unused warning
+	for variables in namelists.
+
+2010-11-08  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/46344
+	* decl.c (build_struct): Build vtab immediately if derived type
+	has already been declared.
+
+2010-11-08  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/46344
+	* trans-types.c (gfc_copy_dt_decls_ifequal): Handle CLASS components.
+
+2010-11-06  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/46330
+	* trans-expr.c (gfc_trans_class_assign): Find 'vtab' symbol in correct
+	namespace.
+
+2010-11-05  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/45451
+	PR fortran/46174
+	* class.c (gfc_find_derived_vtab): Improved search for existing vtab.
+	Add component '$copy' to vtype symbol for polymorphic deep copying.
+	* expr.c (gfc_check_pointer_assign): Make sure the vtab is generated
+	during resolution stage.
+	* resolve.c (resolve_codes): Don't resolve code if namespace is already
+	resolved.
+	* trans-stmt.c (gfc_trans_allocate): Call '$copy' procedure for
+	polymorphic ALLOCATE statements with SOURCE.
+
+2010-11-03  Thomas Koenig  <tkoenig@gcc.gnu.org>
+	    Paul Thomas  <pault@gcc.gnu.org>
+
+	* dump-parse-tree.c (code_indent):  Take label into acount
+	when calculating indent.
+	(show_typespec):  Also display class.
+	(show_attr):  Add module name to argument.
+	Don't show UNKNOWN for flavor, access and save. Don't show
+	SAVE_NONE.  Don't show INTENT_UNKNOWN.  Show module for use
+	association.  Show intent only for dummy arguments.
+	Set length of shown symbol names to minimum of 12.
+	Show attributes header.
+	(show_symbol):  Adjust show_level.
+	(show_symtree):  Clear up display for ambiguous.  Show if symbol
+	was imported from namespace.
+	(show_code_node):  Clear up indenting.  Traverse symtree and
+	show code directly instead of calling show_namespace.
+
+2010-11-02  Nathan Froyd  <froydnj@codesourcery.com>
+
+	* trans-decl.c (add_argument_checking): Use build_zero_cst instead of
+	fold_convert.
+	* trans-expr.c (gfc_conv_missing_dummy, fill_with_spaces): Likewise.
+	* trans-stmt.c (gfc_trans_do): Likewise.
+
+2010-11-02  Steven G. Kargl  < kargl@gcc.gnu.org>
+	    Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/45170
+	* array.c (gfc_match_array_constructor): Reject deferred type
+	parameter (DTP) in type-spec.
+	* decl.c (char_len_param_value, match_char_length,
+	gfc_match_char_spec, build_sym, variable_decl,
+	enumerator_decl): Support DTP.
+	* expr.c (check_inquiry): Fix check due to support for DTP.
+	* gfortran.h (gfc_typespec): Add Boolean 'deferred'.
+	* misc.c (gfc_clear_ts): Set it to false.
+	* match.c (gfc_match_allocate): Support DTP.
+	* resolve.c (resolve_allocate_expr): Not-implemented error for DTP.
+	(resolve_fl_variable): Add DTP constraint check.
+	* trans-decl.c (gfc_trans_deferred_vars): Add not-implemented
+	error for DTP.
+
+2010-11-01  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/46152
+	* fortran/match.c (match_derived_type_spec): Reoplace gfc_match_symbol
+	with a gfc_find_symbol to prevent namespace pollution.  Remove dead
+	code.
+	(match_type_spec): Remove parsing of '::'.  Collapse character
+	kind checking to one location.
+	(gfc_match_allocate): Use correct locus in error message.
+
+2010-10-30  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	* gfortran.h (gfc_option_t):  Replace dump_parse_tree by
+	dump_fortran_original and add dump_fortran_optimized.
+	* lang.opt: Add fdump-fortran-original and
+	fdump-fortran-optimized.  Document that fdump-parse-tree is
+	deprecated.
+	* gfortran.texi: Add -fdump-fortran-original and
+	-fdump-fortran-optimized.  -fdump-parse-tree is deprecated.
+	* frontend-passes.c (gfc_run_passes):  If optimizing and
+	if gfc_option.dump_fortran_optimized is set, dump the parse tree
+	after optimization.
+	* parse.c:  Rename gfc_option.dump_parse_tree to
+	gfc_option.dump_fortran_original.
+	* options.c (gfc_init_options):  Rename gfc_option.dump_parse_tree
+	to gfc_option.dump_fortran_original and handle
+	gfc_option.dump_fortran_optimize.
+	(gfc_post_options): Rename gfc_option.dump_parse_tree
+	to gfc_option.dump_fortran_original.
+	(gfc_handle_option):  Rename OPT_fdump_parse_tree to
+	OPT_fdump_fortran_original and gfc_option.dump_parse_tree
+	to gfc_option.dump_fortran_original.  Handle
+	OPT_fdump_fortran_optimized.
+
+2010-10-30  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44917
+	PR fortran/44926
+	PR fortran/46196
+	* interface.c (count_types_test): Symmetrize type check.
+	(generic_correspondence): Ditto.
+
+2010-10-27  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/46161
+	* interface.c (compare_allocatable): Handle polymorphic allocatables.
+	(compare_parameter): Add two error messages for polymorphic dummies.
+
+2010-10-26  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42647
+	* trans.h (gfc_deallocate_scalar_with_status): New prototype.
+	* trans.c (gfc_deallocate_scalar_with_status): New function for
+	deallocation of allocatable scalars.
+	* trans-array.c (structure_alloc_comps): Call it here ...
+	* trans-decl.c (gfc_trans_deferred_vars): ... here ...
+	* trans-stmt.c (gfc_trans_deallocate): ... and here.
+
+2010-10-26  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/45451
+	* trans-stmt.c (gfc_trans_allocate): Do a deep-copy for SOURCE=.
+
+	PR fortran/43018
+	* trans-array.c (duplicate_allocatable): Use size of type and not
+	the size of the pointer to the type.
+
+2010-10-25  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/46140
+	* fortran/scanner.c (include_line): Check return value of load_file.
+
+2010-10-23  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/46122
+	* expr.c (gfc_check_vardef_context): Fix PROTECTED check.
+
+2010-10-21  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/46060
+	* match.h (gfc_matching_ptr_assignment): New global variable to indicate
+	we're currently matching a (non-proc-)pointer assignment.
+	* decl.c (match_pointer_init): Set it.
+	* match.c (gfc_match_pointer_assignment): Ditto.
+	* primary.c (matching_actual_arglist): New global variable to indicate
+	we're currently matching an actual argument list.
+	(gfc_match_actual_arglist): Set it.
+	(gfc_match_varspec): Reject procedure pointer component calls with
+	missing argument list.
+
+2010-10-21  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/46067
+	* interface.c (gfc_compare_interfaces): Switch arguments of type
+	comparison (important for polymorphic variables).
+
+2010-10-21  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/46100
+	* expr.c (gfc_check_vardef_context): Treat pointer functions
+	as variables.
+
+2010-10-20  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/46079
+	* trans_stmt.c (gfc_trans_stop): Fix whitespace.  Build a call to new
+	F08 numeric stop function.
+	* trans.h: Add declaration for gfor_fndecl_stop_numeric_f08.
+	* trans-decl.c (gfc_build_builtin_function_decls): Build declaration
+	for stop_numeric_f08.
+
+2010-10-18  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	* gfortran.h: Remove definition of bt enumerator.
+	* libgfortran.h: Add bt enumerator type alighned with defintion.
+	Remove the dtype enumerator, no longer used.
+	previously given in libgfortran/io.h
+	* trans-types.c: Use new bt enumerator.
+	* trans-io.c: Likewise.
+
+2010-10-16  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	* trans-io.c (gfc_build_io_library_fndecls):
+	Array descriptor arguments to transfer_array can be
+	dereferenced recursively.
+
+2010-10-16  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/20165
+	PR fortran/31593
+	PR fortran/43665
+	* trans-io.c (enum iocall): Add IOCALL_X_INTEGER_WRITE,
+	IOCALL_X_LOGICAL_WRITE, IOCALL_X_CHARACTER_WRITE,
+	IOCALL_X_CHARACTER_WIDE_WRIE, IOCALL_X_REAL_WRITE,
+	IOCALL_X_COMPLEX_WRITE and IOCALL_X_ARRAY_WRITE.
+	(gfc_build_io_library_fndecls):  Add corresponding function
+	decls.
+	(transfer_expr):  If the current transfer is a READ, use
+	the iocall with the original version, otherwise the version
+	with _WRITE.
+	(transfer_array_desc):  Likewise.
+
+2010-10-15  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/45186
+	* trans.h (gfc_add_modify_loc, gfc_evaluate_now_loc): New prototypes.
+	(gfc_trans_runtime_error_vararg): Remove prototype.
+	* trans.c (gfc_add_modify_loc, gfc_evaluate_now_loc): New functions.
+	(gfc_add_modify, gfc_evaluate_now): Use them.
+	(trans_runtime_error_vararg): Renamed from
+	gfc_trans_runtime_error_vararg, made static and use locus.
+	(gfc_trans_runtime_error): Use it.
+	(gfc_trans_runtime_check): Ditto and make use of locus.
+	* trans-stmt.c (gfc_trans_if_1, gfc_trans_simple_do,
+	gfc_trans_do, gfc_trans_do_while): Improve line number
+	associated with generated expressions.
+
+2010-10-12  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/38936
+	* parse.c (parse_associate): Set typespec of associate-name if that of
+	the target is already available.
+
+2010-10-10  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/45961
+	* resolve.c (resolve_typebound_function): Bugfix for type-bound
+	operators.
+
+2010-10-09  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	* frontend-passes.c:  Include opts.h.
+	(optimize_comparison):  Renamed from optimize_equality.
+	Change second argument to operation to be compared.
+	Use flag_finite_math_only to avoid comparing REAL and
+	COMPLEX only when NANs are honored.  Simplify comparing
+	of string concatenations where left or right operands are
+	equal.  Simplify all comparison operations, based on the result
+	of gfc_dep_compare_expr.
+	* dependency.c:  Include arith.h.
+	(gfc_are_identical_variables):  Volatile variables should not
+	compare equal to themselves.
+	(gfc_dep_compare_expr):  Handle string constants and string
+	concatenations.
+
+2010-10-08  Joseph Myers  <joseph@codesourcery.com>
+
+	* f95-lang.c (LANG_HOOKS_INIT_OPTIONS_STRUCT): Define.
+	* gfortran.h (gfc_init_options_struct): Declare.
+	* options.c (gfc_init_options_struct): New.  Split out from
+	gfc_init_options.
+
+2010-10-07  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/45933
+	* resolve.c (resolve_typebound_function): Use correct declared type
+	for type-bound operators.
+
+2010-10-07  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/45916
+	Revert revision 165026:
+	2010-10-06  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* decl.c (match_procedure_in_type): Assertify if conditions.
+
+2010-10-06  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/45889
+	* resolve.c (resolve_transfer): Use expression inside parenthesis to
+	find acutal component to be transgferred.
+
+2010-10-06  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-stmt.c (gfc_trans_allocate): free lhs expr.
+
+2010-10-06  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_free_ss_chain): Made non-static.
+	* trans-array.h (gfc_free_ss_chain): New prototype.
+	* trans-stmt.c (gfc_trans_where_2): Free ss chains.
+
+2010-10-06  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-intrinsic.c (gfc_conv_intrinsic_funcall): Also free symbol's
+	subcomponents.
+
+2010-10-06  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-stmt.c (gfc_trans_forall_1): Free forall struct at the end.
+
+2010-10-06  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-expr.c (get_proc_ptr_comp): Restore initial expression type
+	before calling gfc_free_expr.
+
+2010-10-06  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_conv_tmp_array_ref): Add factorized call to
+	gfc_advance_se_ss_chain.
+	* trans-expr.c (gfc_conv_subref_array_ref, gfc_conv_procedure_call,
+	gfc_conv_array_constructor_expr, gfc_trans_assignment_1): Remove
+	calls to gfc_advance_se_ss_chain after gfc_conv_tmp_array_ref.
+	* trans-intrinsic.c (gfc_conv_intrinsic_function): Ditto.
+	* trans-stmt.c (gfc_trans_where_assign, gfc_trans_where_3): Ditto.
+
+2010-10-06  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans.c (gfc_restore_backend_locus): New function.
+	(gfc_get_backend_locus): Renamed to ...
+	(gfc_save_backend_locus): ... this.
+	* trans.h (gfc_restore_backend_locus, gfc_get_backend_locus,
+	gfc_save_backend_locus): Same.
+	* trans-array.c (gfc_trans_g77_array, gfc_trans_dummy_array_bias,
+	gfc_trans_deferred_array): Rename gfc_get_backend_locus to
+	gfc_save_backend_locus.
+	(gfc_trans_dummy_array_bias): Call gfc_restore_backend_locus at the
+	end.
+	(gfc_trans_g77_array, gfc_trans_deferred_array): Use
+	gfc_restore_backend_locus instead of gfc_set_backend_locus.
+	(gfc_trans_deferred_array): Call gfc_restore_backend_locus on early
+	return.
+	* trans-decl.c (gfc_get_extern_function_decl, build_entry_thunks,
+	gfc_trans_deferred_vars):
+	Rename gfc_get_backend_locus to gfc_save_backend_locus.
+	Use gfc_restore_backend_locus insted of gfc_set_backend_locus.
+
+2010-10-06  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_build_constant_array_constructor): Free array
+	spec when done.
+
+2010-10-06  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* symbol.c (gfc_copy_formal_args_ppc): Free previous formal arg list
+	before overwriting it.
+
+2010-10-06  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* array.c (gfc_match_array_spec): Don't re-initialize cleared struct.
+	* symbol.c (gen_shape_param): Ditto.
+
+2010-10-06  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* symbol.c (free_entry_list): New function.
+	(gfc_free_namespace): Free list of entries.
+
+2010-10-06  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* symbol.c (free_components): Free list of formal args and formal
+	namespace.
+
+2010-10-06  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* simplify.c (gfc_simplify_size): Clear temporary mpz int before
+	returning.
+
+2010-10-06  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* resolve.c (add_dt_to_dt_list): Remove unneeded if.
+
+2010-10-06  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* resolve.c (check_typebound_baseobject): Free local expr before
+	returning.
+
+2010-10-06  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* primary.c (gfc_match_structure_constructor): Invert the assert logic.
+
+2010-10-06  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* primary.c (gfc_free_structure_ctor_component): Also free the
+	component structure itself.
+
+2010-10-06  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* module.c (gfc_use_module): Free atom_string when done with it.
+
+2010-10-06  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* module.c (read_module): Remove useless string duplication.
+
+2010-10-06  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* gfortranspec.c (append_arg): Remove commented code.
+
+2010-10-06  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* decl.c (match_procedure_in_type): Assertify if conditions.
+
+2010-10-06  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* cpp.c (gfc_cpp_post_options): Don't create a cpp reader if
+	preprocessing is disabled.
+
+2010-10-06  Jakub Jelinek  <jakub@redhat.com>
+
+	PR middle-end/45838
+	* f95-lang.c (ATTR_NOTHROW_LEAF_LIST, ATTR_CONST_NOTHROW_LEAF_LIST,
+	ATTR_NOTHROW_LIST, ATTR_CONST_NOTHROW_LIST): Define.
+	(gfc_define_builtin): Change last argument to int bitmask from bool,
+	control addition of TREE_NOTHROW and leaf attribute as well.
+	(DO_DEFINE_MATH_BUILTIN): Adjust callers.
+	(gfc_init_builtin_functions): Likewise.  Remove
+	ATTR_{,CONST_}NOTHROW_LIST enum.
+
+2010-10-04  Andi Kleen <ak@linux.intel.com>
+
+	* Make-lang.in (gfortran, f951): Add + to build rule.
+
+2010-10-04  Richard Guenther  <rguenther@suse.de>
+
+	* f95-lang.c (current_translation_unit): New global variable.
+	(gfc_create_decls): Build a translation-unit decl.
+	(pushdecl): In the global binding-level use the
+	translation-unit decl as DECL_CONTEXT.
+	* trans-decl.c (gfc_get_symbol_decl): Use DECL_FILE_SCOPE_P.
+	(build_function_decl): Likewise.  Delay setting the assembler
+	name, leave setting of DECL_CONTEXT to pushdecl.
+	(trans_function_start): Use DECL_FILE_SCOPE_P.
+	(gfc_create_module_variable): Likewise.  Remove questionable
+	asserts.
+	* trans.c (gfc_generate_module_code): Likewise.
+
+2010-10-03  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* cpp.c (cpp_define_builtins): Call functions from cppbuiltin.c
+	instead of duplicating code.
+	* Make-lang.in: Add dependency on cppbuiltin.h. Don't define
+	BASEVER.
+
+2010-10-02  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/45748
+	* resolve.c (resolve_formal_arglist): Avoid setting default type for
+	formal arguments of intrinsic procedures.
+
+2010-09-30  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/45828
+	* resolve.c (resolve_allocate_expr): Do not use
+	'gfc_has_default_initializer'.
+
+2010-09-30  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.tex (Fortran 2008 status): Update list of
+	implemented features.
+
+2010-09-29  Joseph Myers  <joseph@codesourcery.com>
+
+	* lang.opt: Don't use VarExists.
+
+2010-09-29  Joseph Myers  <joseph@codesourcery.com>
+
+	* cpp.c (cpp_define_builtins): Update names of gfc_option_t
+	members.
+	(gfc_cpp_post_options): Update names of cpp_options members.
+	(cb_cpp_error): Update names of diagnostic_context members.
+	* f95-lang.c (gfc_init_builtin_functions): Update names of
+	gfc_option_t members.
+	* gfortran.h (gfc_option_t): Rename warn_conversion and
+	flag_openmp.
+	* intrinsic.c (gfc_convert_type_warn): Update names of
+	gfc_option_t members.
+	* options.c (gfc_init_options, gfc_post_options, set_Wall,
+	gfc_handle_option): Update names of gfc_option_t members.
+	* parse.c (next_free, next_fixed): Update names of gfc_option_t
+	members.
+	* scanner.c (pedantic): Remove extern declaration.
+	(skip_free_comments, skip_fixed_comments, include_line): Update
+	names of gfc_option_t members.
+	* trans-decl.c (gfc_generate_function_code): Update names of
+	gfc_option_t members.
+
+2010-09-28  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40569
+	PR fortran/40568
+	* intrinsic.c (add_functions): Make compiler_version and
+	compiler_options CLASS_INQUIRY.
+	* gfortran.h (gfc_get_option_string): New prototype.
+	* intrinsic.texi (COMPILER_VERSION, COMPILER_OPTIONS):
+	Add documentation.
+	(C_SIZEOF): Mark as inquiry function of ISO_C_BINDING.
+	(ISO_FORTRAN_ENV): Refer to COMPILER_VERSION and COMPILER_OPTIONS.
+	(ISO_C_BINDING): Refer to C_SIZEOF.
+	* options.c (gfc_get_option_string): New function.
+	* simplify.c (gfc_simplify_compiler_options): Use it.
+	(gfc_simplify_compiler_version): Include compiler name.
+
+2010-09-28  Jan Hubicka  <jh@suse.cz>
+
+	* f95-lang.c (gfc_define_builtin): Make leaf.
+	(gfc_init_builtin_functions): Handle only ATTR_CONST_NOTHROW_LEAF_LIST
+	and ATTR_NOTHROW_LEAF_LIST.
+	(DEF_SYNC_BUILTIN): Check ATTR_CONST_NOTHROW_LEAF_LIST.
+	(DEF_GOMP_BUILTIN): Likewise.
+
+2010-09-28  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/45756
+	* trans-decl.c (gfc_get_symbol_decl): Use gsym for decl of
+	module parameters.
+
+2010-09-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40569
+	PR fortran/40568
+	* intrinsic.h (gfc_simplify_compiler_options,
+	gfc_simplify_compiler_version): New prototypes.
+	* intrinsic.c (gfc_intrinsic_function_by_id,
+	make_from_module): New functions.
+	(gfc_find_function, gfc_find_subroutine, gfc_generic_intrinsic,
+	gfc_specific_intrinsic): Don't return module intrinsics.
+	(add_functions): Add compiler_options, compiler_version.
+	(gfc_intrinsic_func_interface): Also lookup symbol by ISYM ID.
+	* symbol.c (std_for_isocbinding_symbol): Add version check for
+	NAMED_FUNCTIONS.
+	* iso-fortran-env.def: Add compiler_options, compiler_version.
+	* iso-c-binding.def: Add c_sizeof.
+	* gfortran.h (gfc_intrinsic_sym): Add from_module:1.
+	(iso_c_binding_symbol, iso_fortran_env_symbol): Add NAMED_FUNCTIONS.
+	(gfc_intrinsic_function_by_id): New prototype.
+	* module.c (create_intrinsic_function): New function.
+	(import_iso_c_binding_module, use_iso_fortran_env_module): Use it.
+	* trans-types.c (init_c_interop_kinds): Add NAMED_FUNCTIONS.
+	* resolve.c (resolve_intrinsic): Try also to resolve intrinsics
+	by ISYM ID.
+	* simplify.c (gfc_simplify_compiler_options,
+	gfc_simplify_compiler_version): New functions.
+
+2010-09-26  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/45783
+	PR fortran/45795
+	* resolve.c (resolve_select_type): Clarify code.
+	(resolve_assoc_var): Only set typespec if it is currently unknown.
+
+2010-09-26  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/45793
+	* module.c (create_int_parameter_array): Set the array value shape.
+
+2010-09-25  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.texi: Re-add accidently removed \input line.
+
+2010-09-25  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/45776
+	* gfortran.h (struct gfc_dt): New member `dt_io_kind'.
+	* io.c (resolve_tag): F2008 check for NEWUNIT and variable
+	definition checks for NEWUNIT, IOSTAT, SIZE and IOMSG.
+	(gfc_free_dt): Correctly handle freeing of `dt_io_kind' and
+	`extra_comma' with changed semantics.
+	(gfc_resolve_dt): Check variable definitions.
+	(match_io_element): Remove INTENT and PURE checks here and
+	initialize code->ext.dt member.
+	(match_io): Set dt->dt_io_kind.
+	(gfc_resolve_inquire): Check variable definition for all tags
+	except UNIT, FILE and ID.
+	* resolve.c (resolve_transfer): Variable definition check.
+
+2010-09-25  Tobias Burnus  <burnus@net-b.de>
+
+	* interface.c (gfc_match_end_interface): Constify char pointer
+	to fix warning.
+
+2010-09-24  Steven G. Kargl  < kargl@gcc.gnu.org>
+
+	* interface.c (gfc_match_end_interface): Deal with user defined
+	operators that overload rational operators and C1202.
+
+2010-09-24  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.texi: Add second space after end-of-sentence period;
+	change / to /@/ to allow hyphenation of URLs.
+	(Standards): Remove duplicated OpenMP, update wording given that
+	Fortran 2008 now released.
+	(Fortran 2008 status): Update and add list of implemented features.
+
+2010-09-24  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40571
+	* iso-fortran-env.def: Add NAMED_KINDARRAY with
+	character_kinds, integer_kinds, logical_kinds and
+	real_kinds.
+	* gfortran.h: Add them to iso_fortran_env_symbol.
+	* libgfortran.h: Rename GFC_INQUIRE_INTERNAL_UNIT to
+	LIBERROR_INQUIRE_INTERNAL_UNIT and move it from
+	libgfortran_stat_codes to libgfortran_error_codes.
+	* module.c (create_int_parameter_array): New function.
+	(use_iso_fortran_env_module): Use it for
+	NAMED_KINDARRAY of iso-fortran-env.def.
+	* trans-decl.c (gfc_get_symbol_decl): Parameter
+	arrays of intrinsics modules become local static variables.
+	* intrinsic.texi (ISO_FORTRAN_ENV): Add character_kinds,
+	integer_kinds, logical_kinds and real_kinds.
+
+2010-09-23  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/45744
+	* frontend-passes.c (optimize_binop_array_assignment):
+	Only re-use lhs as intermediate storage if kind and type
+	parameters match.
+
+2010-09-23  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/45745
+	PR fortran/45648
+	* trans-array.c (gfc_conv_expr_descriptor): Handle
+	ss->type == GFC_SS_INTRINSIC (for {l,u}bound intrinsics) case.
+
+2010-09-23  Tobias Burnus  <burnus@net-b.de>
+
+	* intrinsic.texi (OpenMP modules): Add named constants of
+	OMP_LIB.
+
+2010-09-23  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/38936
+	PR fortran/44044
+	PR fortran/45474
+	* gfortran.h (gfc_check_vardef_context): New method.
+	(struct symbol_attribute): New flag `select_type_temporary'.
+	* primary.c (gfc_variable_attr): Clarify initialization of ref.
+	(match_variable): Remove PROTECTED check and assignment check
+	for PARAMETERs (this is now done later).
+	* match.c (gfc_match_iterator): Remove INTENT(IN) check.
+	(gfc_match_associate): Defer initialization of newAssoc->variable.
+	(gfc_match_nullify): Remove PURE definability check.
+	(select_type_set_tmp): Set new `select_type_temporary' flag.
+	* expr.c (gfc_check_assign): Remove INTENT(IN) check here.
+	(gfc_check_pointer_assign): Ditto (and other checks removed).
+	(gfc_check_vardef_context): New method.
+	* interface.c (compare_parameter_protected): Removed.
+	(compare_actual_formal): Use `gfc_check_vardef_context' for checks
+	related to INTENT([IN]OUT) arguments.
+	* intrinsic.c (check_arglist): Check INTENT for intrinsics.
+	* resolve.c (gfc_resolve_iterator): Use `gfc_check_vardef_context'.
+	(remove_last_array_ref): New method.
+	(resolve_deallocate_expr), (resolve_allocate_expr): Ditto.
+	(resolve_allocate_deallocate): Ditto (for STAT and ERRMSG).
+	(resolve_assoc_var): Remove checks for definability here.
+	(resolve_select_type): Handle resolving of code->block here.
+	(resolve_ordinary_assign): Remove PURE check.
+	(resolve_code): Do not resolve code->blocks for SELECT TYPE here.
+	Use `gfc_check_vardef_context' for assignments and pointer-assignments.
+
+2010-08-22  Ralf Wildenhues  <Ralf.Wildenhues@gmx.de>
+
+	* gfortran.texi (Argument list functions): Allow URL to wrap.
+	* intrinsic.texi (GETGID, GETPID, GETUID, IMAGE_INDEX)
+	(IS_IOSTAT_END, IS_IOSTAT_EOR, NUM_IMAGES, THIS_IMAGE)
+	(ISO_FORTRAN_ENV): Fix markup in index entries, and a couple of
+	code markups in the text.
+	* invoke.texi (Fortran Dialect Options)
+	(Error and Warning Options, Directory Options, Code Gen Options):
+	Likewise.  Remove @code inside @smallexample.
+
+2010-09-22  Joseph Myers  <joseph@codesourcery.com>
+
+	* gfortranspec.c (lang_specific_driver): Handle OPT__version and
+	OPT__help instead of OPT_fversion and OPT_fhelp.
+	* lang.opt (-all-warnings, -assert, -assert=, -comments,
+	-comments-in-macros, -define-macro, -define-macro=, -dependencies,
+	-dump, -dump=, -include-barrier, -include-directory,
+	-include-directory=, -include-directory-after,
+	-include-directory-after=, -include-prefix, -include-prefix=,
+	-no-line-commands, -no-standard-includes, -output, -output=,
+	-preprocess, -print-missing-file-dependencies, -trace-includes,
+	-undefine-macro, -undefine-macro=, -user-dependencies, -verbose,
+	-write-dependencies, -write-user-dependencies): New.
+
+2010-09-21  Jason Blevins  <jrblevin@sdf.org>
+
+	* intrinsics.texi (HYPOT, IMAGE_INDEX, BESSEL_JN, BESSEL_YN,
+	execute_command_line, IEOR, IOR, NORM2, NOT, NULL, PARITY):
+	Correct spelling.
+
+2010-09-21  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/45648
+	* trans-array.c (gfc_conv_expr_descriptor): Calculate dim out of n and
+	info->dim.
+
+	PR fortran/45648
+	* trans-array.c (gfc_conv_expr_descriptor): Unset full if we are
+	accessing dimensions in reversed order. 
+
+	PR fortran/45648
+	* trans-array.c (gfc_conv_expr_descriptor): Special case noncopying
+	intrinsic function call. 
+
+	* trans-array.c (gfc_conv_expr_descriptor): Remove ss lookup.
+	Update asserts accordingly.
+
+	PR fortran/45648
+	* trans.h (gfc_se): New field force_tmp. 
+	* trans-expr.c (gfc_conv_procedure_call): Check for argument alias
+	and set parmse.force_tmp if some alias is found. 
+	* trans-array.c (gfc_conv_expr_descriptor): Force a temporary creation
+	if se->force_tmp is set. 
+
+2010-09-20  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/45438
+	* trans-expr.c (gfc_conv_procedure_call): Fix pointer checking for
+	TBPs, PPCs and pointer/allocatable components.
+
+2010-09-20  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/45081
+	* simplify.c (is_constant_array_expr): Allow structure array
+	elements as well as constants.
+	(gfc_simplify_pack, gfc_simplify_reshape, gfc_simplify_spread,
+	gfc_simplify_transpose, gfc_simplify_unpack): Copy the derived
+	type of source to the result.
+
+2010-09-19  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	* frontend-passes.c (gfc_expr_walker):  Also
+	handle EXPR_SUBSTRING.
+
+2010-09-19  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	* frontend-passes.c (gfc_expr_walker):  Handle
+	constructors and references.
+
+2010-09-16  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/43665
+	* trans-types.c (create_fn_spec): New function.
+	(gfc_get_function_type): Call it.
+
+2010-09-16  Jakub Jelinek  <jakub@redhat.com>
+
+	* gfortran.h (walk_code_fn_t, walk_expr_fn_t): New types.
+	(gfc_expr_walker, gfc_code_walker): New prototypes.
+	* frontend-passes.c (gfc_expr_walker, gfc_code_walker): New functions.
+	(WALK_SUBEXPR, WALK_SUBEXPR_TAIL, WALK_SUBCODE): Define.
+	(optimize_namespace): Use gfc_code_walker.
+	(optimize_code, optimize_expr): Rewritten as gfc_code_walker hooks.
+	(optimize_expr_0, optimize_code_node,
+	optimize_actual_arglist): Removed.
+	(optimize_assignment): Don't call optimize_expr_0.
+
+2010-09-16  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/45674
+	* interface.c (compare_parameter): Create vtab for actual argument,
+	instead of formal (if needed).
+
+2010-09-15  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/45577
+	* resolve.c (resolve_allocate_expr): Do default initialization via
+	EXEC_INIT_ASSIGN.
+
+2010-09-11  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* mathbuiltins.def: Do not defined huge_val built-in.
+	* trans-const.c (gfc_build_inf_or_huge): New function.
+	* trans-const.h (gfc_build_inf_or_huge): New prototype.
+	* f95-lang.c (gfc_init_builtin_functions): Don't defined
+	huge_val built-ins.
+	* trans-intrinsic.c (gfc_build_intrinsic_lib_fndecls): We don't
+	have functions of type (*) (void) anymore.
+	(gfc_conv_intrinsic_minmaxloc): Call gfc_build_inf_or_huge.
+	(gfc_conv_intrinsic_nearest): Call gfc_build_inf_or_huge instead
+	of generating a call to huge_val().
+
+2010-09-11  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* gfortran.h (gfc_expr): Remove inline_noncopying_intrinsic attribute.
+	* dependency.c (gfc_check_dependency): Don't depend on
+	expr's inline_noncopying_intrinsic_attribute.
+	* dependency.c (gfc_check_argument_var_dependency,
+	gfc_check_argument_dependency): Ditto. Recursively check dependency
+	as NOT_ELEMENTAL in the non-copying (=transpose) case.
+	* trans-intrinsic.c (gfc_conv_intrinsic_function): Ditto.
+	* resolve.c (find_noncopying_intrinsics): Remove.
+	(resolve_function, resolve_call): Remove call to
+	find_noncopying_intrinsics.
+
+	* trans-array.c (gfc_conv_array_transpose): Remove.
+	(gfc_walk_subexpr): Make non-static. Move prototype...
+	* trans-array.h (gfc_walk_subexpr): ... here.
+	* trans-intrinsic.c (gfc_conv_intrinsic_function): Update transpose
+	handling.
+	(walk_inline_intrinsic_transpose, walk_inline_intrinsic_function,
+	gfc_inline_intrinsic_function_p): New.
+	(gfc_is_intrinsic_libcall): Return early in inline intrinsic case.
+	Remove transpose from the libcall list.
+	(gfc_walk_intrinsic_function): Special case inline intrinsic.
+	* trans.h (gfc_inline_intrinsic_function_p): New prototype.
+
+2010-09-10  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-expr.c (expr_is_variable): New function taking non-copying
+	intrinsic functions into account.
+	(gfc_trans_assignment_1): Use expr_is_variable.
+
+2010-09-10  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_conv_loop_setup): Access the shape along the
+	real array dimension instead of the scalarizer (loop) dimension.
+
+2010-09-10  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_conv_resolve_dependencies): Handle same-array
+	transposed references.
+
+2010-09-10  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/45186
+	* trans.h (build1_stat_loc, build2_stat_loc, build3_stat_loc,
+	build4_stat_loc): New inline functions.
+	(build1_loc, build2_loc, build3_loc, build4_loc): New macros.
+	(build1_v, build2_v, build3_v, build4_v): Use input_location
+	as locus.
+	* trans-array.c (gfc_trans_scalarized_loop_end,
+	gfc_conv_array_parameter): Replace build[1-4] by build[1-4]_loc.
+	* trans.c (gfc_build_addr_expr, gfc_build_array_ref,
+	gfc_finish_wrapped_block): Ditto.
+	* trans-decl.c (gfc_init_default_dt, init_intent_out_dt): Ditto.
+	* trans-expr.c (gfc_conv_missing_dummy,
+	gfc_trans_alloc_subarray_assign, gfc_trans_zero_assign): Ditto.
+	* trans-openmp.c (gfc_omp_clause_default_ctor,
+	gfc_trans_omp_critical, gfc_trans_omp_parallel,
+	gfc_trans_omp_parallel_do, gfc_trans_omp_parallel_sections,
+	gfc_trans_omp_parallel_workshare, gfc_trans_omp_sections
+	gfc_trans_omp_single, gfc_trans_omp_task,
+	gfc_trans_omp_workshare): Ditto.
+
+2010-09-09  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* fortran/expr.c (check_inquiry): OPTIONAL attribute is not allowed
+	for dummy argument that appears in a specification statement.
+
+2010-09-09  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_get_array_ref_dim): New function.
+	(gfc_trans_create_temp_array): Reconstruct array
+	bounds from loop bounds. Use array bounds instead of loop bounds.
+
+2010-09-09  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_set_loop_bounds_from_array_spec):
+	Get the array dimension from the dim array.
+
+2010-09-09  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_trans_preloop_setup): Unconditionally use the
+	dim array to get the stride in the innermost loop.
+
+2010-09-09  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_trans_create_temp_array): Don't set dim array.
+	(gfc_conv_loop_setup, gfc_walk_function_expr): Set dim array.
+	* trans-intrinsic.c (gfc_walk_intrinsic_libfunc): Ditto.
+
+2010-09-09  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_trans_create_temp_array): Assert loop dimension
+	and info dimension are the same. Loop over loop dimension.
+	* trans-stmt.c (gfc_conv_elemental_dependencies): Set loop dimension
+
+2010-09-09  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_conv_array_transpose): Change generated descriptor
+	name
+
+2010-09-09  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/43665
+	* intrincic.texi (FGET, FGETC, FPUT, FPUTC, FSTAT, GETCWD, KILL,
+	STAT): Show also syntax for the function version.
+	* intrinsic.c (add_sym_1s_intent, add_sym_2s_intent,
+	 add_sym_3s_intent): Remove function.
+	(add_sym_1s, add_sym_2s, add_sym_3s): Take always the intent
+	as argument.
+	(add_sym_2_intent): New function.
+	(add_functions): Set intent for functions which modify
+	the argument: fstat, fgetc, fget, hostnm, lstat, stat. Change
+	argument name of hostnm from "a" to "c"
+	(add_subroutines): Change add_sym_*s_intent to
+	add_sym_*s and add intent to the add_sym_*s calls.
+
+2010-09-08  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/38282
+	* intrinsic.c (add_functions): Add B{G,L}{E,T}, DSHIFT{L,R},
+	MASK{L,R}, MERGE_BITS and SHIFT{A,L,R}.
+	* gfortran.h: Define ISYM values for above intrinsics.
+	* intrinsic.h (gfc_check_bge_bgt_ble_blt, gfc_check_dshift,
+	gfc_check_mask, gfc_check_merge_bits, gfc_check_shift,
+	gfc_simplify_bge, gfc_simplify_bgt, gfc_simplify_ble,
+	gfc_simplify_blt, gfc_simplify_dshiftl, gfc_simplify_dshiftr,
+	gfc_simplify_lshift, gfc_simplify_maskl, gfc_simplify_maskr,
+	gfc_simplify_merge_bits, gfc_simplify_rshift,
+	gfc_simplify_shifta, gfc_simplify_shiftl, gfc_simplify_shiftr,
+	gfc_resolve_dshift, gfc_resolve_mask, gfc_resolve_merge_bits,
+	gfc_resolve_shift): New prototypes.
+	* iresolve.c (gfc_resolve_dshift, gfc_resolve_mask,
+	gfc_resolve_merge_bits, gfc_resolve_shift): New functions.
+	* check.c (gfc_check_bge_bgt_ble_blt, gfc_check_dshift,
+	gfc_check_mask, gfc_check_merge_bits, gfc_check_shift): New
+	functions.
+	* trans-intrinsic.c (gfc_conv_intrinsic_dshift,
+	gfc_conv_intrinsic_bitcomp, gfc_conv_intrinsic_shift,
+	gfc_conv_intrinsic_merge_bits, gfc_conv_intrinsic_mask): New
+	functions.
+	(gfc_conv_intrinsic_function): Call above static functions.
+	* intrinsic.texi: Document new intrinsics.
+	* simplify.c (gfc_simplify_bge, gfc_simplify_bgt, gfc_simplify_ble,
+	gfc_simplify_blt, gfc_simplify_dshiftl, gfc_simplify_dshiftr,
+	gfc_simplify_lshift, gfc_simplify_maskl, gfc_simplify_maskr,
+	gfc_simplify_merge_bits, gfc_simplify_rshift, 
+	gfc_simplify_shifta, gfc_simplify_shiftl, gfc_simplify_shiftr):
+	New functions.
+
+2010-09-08  Jakub Jelinek  <jakub@redhat.com>
+
+	* frontend-passes.c (optimize_code_node): Walk block chain by default.
+
+	PR fortran/45597
+	* trans-openmp.c (gfc_trans_omp_do): Store exit/cycle labels on code
+	instead of code->block.
+
+	PR fortran/45595
+	* openmp.c (resolve_omp_do): Report not enough do loops for
+	collapse even if block->next is NULL.
+
+2010-09-07  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/45576
+	* dependency.c (gfc_deb_compare_expr):  Take missing optional
+	arguments into account.
+
+2010-09-08  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* trans.h (gfor_fndecl_clz128, gfor_fndecl_ctz128): Remove.
+	* trans-decl.c (gfor_fndecl_clz128, gfor_fndecl_ctz128): Remove.
+	(gfc_build_intrinsic_function_decls): Don't build the
+	gfor_fndecl_clz128 and gfor_fndecl_ctz128.
+	* trans-intrinsic.c (gfc_conv_intrinsic_leadz,
+	gfc_conv_intrinsic_trailz): Generate inline arithmetic instead
+	of calling clz128/ctz128 library functions.
+
+2010-09-07  Jan Hubicka  <jh@suse.cz>
+
+	* trans-expr.c (gfc_conv_initializer): Set STATIC flags for
+	initializers.
+
+2010-09-07  Tobias Burnus <burnus@net-b.de>
+	
+	PR fortran/45583
+	* intrinsic.texi (COS): Remove superfluous "n".
+
+2010-09-07  Tobias Burnus <burnus@net-b.de>
+
+	PR fortran/45186
+	* trans-array.c (gfc_conv_descriptor_data_get,
+	gfc_conv_descriptor_data_set, gfc_conv_descriptor_data_addr,
+	gfc_conv_descriptor_offset, gfc_conv_descriptor_dtype,
+	gfc_conv_descriptor_dimension, gfc_conv_descriptor_stride,
+	gfc_conv_descriptor_lbound, gfc_conv_descriptor_ubound,
+	gfc_conv_shift_descriptor_lbound,
+	gfc_set_loop_bounds_from_array_spec,
+	gfc_trans_allocate_array_storage, gfc_trans_create_temp_array,
+	gfc_conv_array_transpose, gfc_get_iteration_count,
+	gfc_grow_array, gfc_trans_array_ctor_element,
+	gfc_trans_array_constructor_subarray,
+	gfc_trans_array_constructor_value,
+	constant_array_constructor_loop_size, gfc_trans_array_constructor,
+	gfc_set_vector_loop_bounds, gfc_trans_array_bound_check,
+	gfc_conv_array_index_offset, gfc_conv_scalarized_array_ref,
+	gfc_conv_array_ref, gfc_trans_preloop_setup,
+	gfc_trans_scalarized_loop_end, gfc_conv_ss_startstride,
+	gfc_conv_loop_setup, gfc_conv_array_extent_dim,
+	gfc_conv_descriptor_size, gfc_array_init_size,
+	gfc_array_allocate, gfc_array_deallocate,
+	gfc_trans_array_bounds, gfc_trans_auto_array_allocation,
+	gfc_trans_dummy_array_bias, gfc_get_dataptr_offset,
+	get_array_charlen, gfc_conv_expr_descriptor,
+	array_parameter_size, gfc_conv_array_parameter,
+	gfc_trans_dealloc_allocated, get_full_array_size,
+	duplicate_allocatable,
+	structure_alloc_comps): Change fold_build[0-9] to
+	fold_build[0-9]_loc.
+	(duplicate_allocatable, structure_alloc_comps,
+	gfc_duplicate_allocatable): Add space after function name.
+
+2010-09-07  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-stmt.c (gfc_trans_character_select): Be conversion-safe while
+	checking string length value.
+	* trans-intrinsic.c (gfc_conv_intrinsic_char): Build integer using
+	gfc_charlen_type_node type.
+
+	PR fortran/45564
+	* trans-intrinsic.c (gfc_conv_intrinsic_transfer): Convert string
+	length to gfc_charlen_type_node.
+
+2010-09-06  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/36931
+	* frontend-passes.c (optimize_binop_array_assignment):  New
+	function.
+	(optimize_assignment):  Call it.
+
+2010-09-06  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/34145
+	* trans-expr.c (gfc_conv_substring):  If start and end
+	of the string reference are equal, set the length to one.
+
+2010-09-06  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/45560
+	* dump-parse-tree.c (gfc_debug_expr): Use stderr instead of stdout.
+
+2010-09-06  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/45560
+	* dump-parse-tree.c (gfc_debug_expr): New function.
+
+2010-09-06  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/38282
+	* intrinsic.c (add_functions): Support IALL, IANY, IPARITY.
+	(check_specific): Special case for those intrinsics.
+	* gfortran.h (gfc_isym_id): Add new intrinsics
+	* intrinsic.h (gfc_check_transf_bit_intrins,
+	gfc_simplify_iall, gfc_simplify_iany, gfc_simplify_iparity,
+	gfc_resolve_iall, gfc_resolve_iany, gfc_resolve_iparity):
+	New prototypes.
+	* iresolve.c (gfc_resolve_iall, gfc_resolve_iany,
+	gfc_resolve_iparity, resolve_transformational): New functions.
+	(gfc_resolve_product, gfc_resolve_sum,
+	gfc_resolve_parity): Use resolve_transformational.
+	* check.c (gfc_check_transf_bit_intrins): New function.
+	* simplify.c (gfc_simplify_iall, gfc_simplify_iany,
+	gfc_simplify_iparity, do_bit_any, do_bit_ior,
+	do_bit_xor, simplify_transformation): New functions.
+	(gfc_simplify_all, gfc_simplify_any, gfc_simplify_parity,
+	gfc_simplify_sum, gfc_simplify_product): Use simplify_transformation.
+	* trans-intrinsic.c (gfc_conv_intrinsic_arith,
+	gfc_conv_intrinsic_function, gfc_is_intrinsic_libcall):
+	Handle IALL, IANY and IPARITY intrinsics.	
+	* intrinsic.texi (IMAGE_INDEX): Move up to fix alphabetic
+	order.
+	(IALL, IANY, IPARITY): Document new intrinsics.
+
+2010-09-05  Tobias Burnus <burnus@net-b.de>
+
+	PR fortran/45186
+	* f95-lang.c (gfc_truthvalue_conversion): Use
+	fold_build[0-9]_loc instead of fold_build[0-9].
+	* convert.c (convert): Ditto.
+	* trans-intrinsic.c (gfc_conv_intrinsic_conversion,
+	build_fixbound_expr, build_fix_expr, gfc_conv_intrinsic_aint,
+	gfc_conv_intrinsic_int, gfc_conv_intrinsic_imagpart,
+	gfc_conv_intrinsic_conjg, gfc_trans_same_strlen_check,
+	gfc_conv_intrinsic_bound, gfc_conv_intrinsic_abs,
+	gfc_conv_intrinsic_cmplx, gfc_conv_intrinsic_mod,
+	gfc_conv_intrinsic_dim, gfc_conv_intrinsic_sign,
+	gfc_conv_intrinsic_dprod, gfc_conv_intrinsic_char,
+	gfc_conv_intrinsic_ctime, gfc_conv_intrinsic_fdate,
+	gfc_conv_intrinsic_ttynam, gfc_conv_intrinsic_minmax,
+	gfc_conv_intrinsic_minmax_char, gfc_conv_intrinsic_anyall,
+	gfc_conv_intrinsic_count, gfc_conv_intrinsic_arith,
+	gfc_conv_intrinsic_dot_product, gfc_conv_intrinsic_minmaxloc,
+	gfc_conv_intrinsic_minmaxval, gfc_conv_intrinsic_btest,
+	gfc_conv_intrinsic_bitop, gfc_conv_intrinsic_not,
+	gfc_conv_intrinsic_singlebitop, gfc_conv_intrinsic_ibits,
+	gfc_conv_intrinsic_rlshift, gfc_conv_intrinsic_ishft,
+	gfc_conv_intrinsic_ishftc, gfc_conv_intrinsic_leadz,
+	gfc_conv_intrinsic_trailz, gfc_conv_intrinsic_popcnt_poppar,
+	gfc_conv_intrinsic_ichar, gfc_conv_has_intvalue,
+	gfc_conv_intrinsic_merge, gfc_conv_intrinsic_spacing,
+	gfc_conv_intrinsic_rrspacing, gfc_conv_intrinsic_size,
+	size_of_string_in_bytes, gfc_conv_intrinsic_sizeof,
+	gfc_conv_intrinsic_storage_size, gfc_conv_intrinsic_strcmp,
+	gfc_conv_intrinsic_transfer, gfc_conv_allocated,
+	gfc_conv_associated, gfc_conv_same_type_as,
+	gfc_conv_intrinsic_trim, gfc_conv_intrinsic_repeat): Ditto.
+
+2010-09-04  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/45530
+	* resolve.c (resolve_fl_namelist): Change constraint checking
+	order to prevent endless loop.
+
+2010-09-04  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/45507
+	* resolve.c (resolve_allocate_expr): Generate default initializers
+	already at this point, resolve them and put them into expr3, ...
+	* trans-stmt.c (gfc_trans_allocate): ... instead of waiting until
+	translation stage.
+
+2010-09-03  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/45186
+	* trans-intrinsic.c (gfc_conv_intrinsic_sign,
+	gfc_conv_intrinsic_leadz): Use build_call_expr_loc instead
+	of build_call_expr.
+	* trans-expr.c (gfc_conv_expr_present, gfc_conv_missing_dummy,
+	gfc_conv_string_length, gfc_conv_substring,
+	gfc_conv_component_ref, gfc_conv_unary_op, gfc_conv_powi,
+	gfc_conv_cst_int_power, gfc_conv_string_tmp, gfc_conv_concat_op,
+	gfc_conv_expr_op, gfc_build_compare_string,
+	gfc_set_interface_mapping_bounds, gfc_conv_subref_array_arg,
+	gfc_conv_derived_to_class, conv_isocbinding_procedure,
+	gfc_conv_procedure_call, fill_with_spaces,
+	gfc_trans_string_copy, gfc_trans_alloc_subarray_assign,
+	gfc_trans_structure_assign, gfc_trans_pointer_assignment,
+	gfc_trans_scalar_assign, gfc_trans_zero_assign,
+	gfc_trans_array_copy, gfc_trans_array_constructor_copy): Change
+	fold_build[0-9] to fold_build[0-9]_loc.
+	* trans-io.c (set_parameter_const, set_parameter_value,
+	set_parameter_ref, gfc_convert_array_to_string, set_string,
+	set_internal_unit, io_result, set_error_locus,
+	nml_get_addr_expr, build_dt): Ditto.
+	* trans-openmp.c (gfc_omp_clause_default_ctor,
+	gfc_omp_clause_copy_ctor, gfc_omp_clause_assign_op,
+	gfc_trans_omp_array_reduction, gfc_trans_omp_atomic,
+	gfc_trans_omp_do): Ditto.
+	* trans.c (gfc_add_modify, gfc_build_addr_expr,
+	gfc_build_array_ref, gfc_trans_runtime_error_vararg,
+	gfc_trans_runtime_check, gfc_call_malloc,
+	gfc_allocate_with_status, gfc_allocate_array_with_status,
+	gfc_call_free, gfc_deallocate_with_status,
+	gfc_call_realloc): Ditto.
+
+2010-09-03  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/45159
+	* dependency.c (gfc_deb_compare_expr):  Compare equal for equal
+	arglists for pure user functions, or for those intrinsic
+	functions which are also pure.
+	* intrinsics.c (add_conv):  Mark conversion functions as pure.
+	(add_char_conversions):  Likewise.
+
+2010-09-03  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/34162
+	* resolve.c (resolve_actual_arglist): Allow internal procedure
+	as actual argument with Fortran 2008.
+
+2010-09-03  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/44602
+	* gfortran.h (struct gfc_code): Renamed `whichloop' to
+	`which_construct' as this is no longer restricted to loops.
+	* parse.h (struct gfc_state_data): New field `construct'.
+	* match.c (match_exit_cycle): Handle EXIT from non-loops.
+	* parse.c (push_state): Set `construct' field.
+	* resolve.c (resolve_select_type): Extend comment.
+	* trans-stmt.c (gfc_trans_if): Add exit label.
+	(gfc_trans_block_construct), (gfc_trans_select): Ditto.
+	(gfc_trans_simple_do): Store exit/cycle labels on the gfc_code itself.
+	(gfc_trans_do), (gfc_trans_do_while): Ditto.
+	(gfc_trans_exit): Use new name `which_construct' instead of `whichloop'.
+	(gfc_trans_cycle): Ditto.
+	(gfc_trans_if_1): Use fold_build3_loc instead of fold_build3.
+
+2010-09-03  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* trans-intrinsic.c (gfc_conv_intrinsic_aint): Fix whitespace.
+	(gfc_conv_intrinsic_ishft): Only evaluate arguments once.
+	(gfc_conv_intrinsic_ishftc): Only evaluate arguments once.
+	* intrinsic.texi (RSHIFT): Fix documentation.
+
+2010-09-02  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/45186
+	* trans-common.c (create_common): Change build[0-9] to
+	build[0-9]_loc.
+	* trans-const.c (gfc_conv_constant_to_tree,
+	gfc_conv_constant_to_tree): Ditto.
+	* trans-decl.c (gfc_build_qualified_array, build_entry_thunks,
+	gfc_get_fake_result_decl, gfc_trans_auto_character_variable,
+	add_argument_checking, create_main_function,
+	gfc_generate_return): Ditto.
+	* trans-types.c (gfc_get_dtype, gfc_get_array_type_bounds): Ditto.
+	* trans-stmt.c (allocate_temp_for_forall_nest_1,
+	compute_inner_temp_size, compute_overall_iter_number,
+	generate_loop_for_rhs_to_temp, generate_loop_for_temp_to_lhs,
+	gfc_conv_elemental_dependencies, gfc_do_allocate,
+	gfc_evaluate_where_mask, gfc_trans_allocate,
+	gfc_trans_arithmetic_if, gfc_trans_call,
+	gfc_trans_character_select, gfc_trans_deallocate,
+	gfc_trans_do, gfc_trans_do_while, gfc_trans_forall_1,
+	gfc_trans_forall_loop, gfc_trans_goto, gfc_trans_if_1,
+	gfc_trans_integer_select, gfc_trans_logical_select,
+	gfc_trans_pointer_assign_need_temp, gfc_trans_return,
+	gfc_trans_simple_do, gfc_trans_sync, gfc_trans_where_2,
+	gfc_trans_where_assign) Ditto.
+
+2010-09-02  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44541
+	* resolve.c (resolve_symbol): Correct check for attributes of CLASS
+	variable.
+
+2010-09-02  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/45489
+	* resolve.c (apply_default_init): Mark symbol as referenced,
+	if it is initialized.
+	(resolve_symbol): Change intialized check for BT_DERIVED such
+	that also function results get initialized; remove now obsolete
+	gfc_set_sym_referenced for BT_CLASS.
+
+2010-09-01  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44541
+	* class.c (gfc_find_derived_vtab): Add component '$def_init'.
+	* resolve.c (resolve_allocate_expr): Defer handling of default
+	initialization to 'gfc_trans_allocate'.
+	(apply_default_init,resolve_symbol): Handle polymorphic dummies.
+	(resolve_fl_derived): Suppress error messages for vtypes.
+	* trans-stmt.c (gfc_trans_allocate): Handle initialization via
+	polymorphic MOLD expression.
+	* trans-expr.c (gfc_trans_class_init_assign): Now only used for
+	dummy initialization.
+
+2010-09-01  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.texi (preprocessing): Update URL to COCO.
+
+2010-09-01  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* trans-intrinsic.c (gfc_build_intrinsic_lib_fndecls): Resize
+	array quad_decls. Remove unnecessary assignment.
+
+2010-09-01  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* trans-expr.c (gfc_conv_power_op): Handle floating-point types
+	other than long double.
+	* mathbuiltins.def: Add builtins from the POW and CPOW family.
+	* trans.h (gfc_builtin_decl_for_float_kind): New prototype.
+	* trans-intrinsic.c (gfc_builtin_decl_for_float_kind): Add gfc_
+	prefix to function name.
+	(gfc_build_intrinsic_lib_fndecls): Add cpow prototype.
+	(gfc_conv_intrinsic_aint): Use gfc_builtin_decl_for_float_kind
+	function name.
+	(gfc_conv_intrinsic_exponent): Likewise.
+	(gfc_conv_intrinsic_abs): Likewise.
+	(gfc_conv_intrinsic_mod): Likewise.
+	(gfc_conv_intrinsic_sign): Likewise.
+	(gfc_conv_intrinsic_arith): Likewise.
+	(gfc_conv_intrinsic_fraction): Likewise.
+	(gfc_conv_intrinsic_nearest): Likewise.
+	(gfc_conv_intrinsic_spacing): Likewise.
+	(gfc_conv_intrinsic_rrspacing): Likewise.
+	(gfc_conv_intrinsic_scale): Likewise.
+	(gfc_conv_intrinsic_set_exponent): Likewise.
+
+2010-09-01  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* intrinsic.c: Add EXECUTE_COMMAND_LINE intrinsic.
+	* intrinsic.h (gfc_resolve_execute_command_line): New function.
+	* iresolve.c (gfc_resolve_execute_command_line): New function.
+	* gfortran.h (GFC_ISYM_EXECUTE_COMMAND_LINE): New value.
+	* intrinsic.texi: Document EXECUTE_COMMAND_LINE.
+
+2010-08-31  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/38282
+	* f95-lang.c (gfc_init_builtin_functions): Define popcount{,l,ll}
+	and parity{,l,ll} builtins.
+	* trans-intrinsic.c (gfc_conv_intrinsic_popcnt_poppar): New function.
+	(gfc_conv_intrinsic_function): Call above new functions.
+	* simplify.c (gfc_simplify_popcnt, gfc_simplify_poppar): New
+	functions.
+	* intrinsic.texi: Document POPCNT and POPPAR.
+
+2010-08-30  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/45456
+	* resolve.c (resolve_structure_cons): Handle pointer-valued PPCs.
+
+2010-08-30  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* Make-lang.in: Add frontend-passes.o dependencies.
+
+2010-08-29  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42769
+	* resolve.c (resolve_structure_cons): For derived types, make sure the
+	type has been resolved.
+	(resolve_typebound_procedures): Make sure the vtab has been generated.
+
+2010-08-29  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/45439
+	* match.c (gfc_match_select_type): Give the associate-name the
+	FL_VARIABLE attribute.
+
+2010-08-28  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* simplify.c (gfc_simplify_bessel_n2): Fix indention
+	and argument type.
+
+2010-08-28  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/45436
+	* trans-types.c (gfc_init_kinds): Disable TFmode.
+
+2010-08-27  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/45432
+	* match.c (gfc_match_allocate): Avoid double free on error.
+
+2010-08-27  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/32049
+	* gfortran.h (gfc_real_info): Add c_float128 field.
+	* mathbuiltins.def: Indicate which builtins are const.
+	* trans-types.h (float128_type_node, complex_float128_type_node,
+	gfc_real16_is_float128): New variables.
+	* trans-types.c (float128_type_node, complex_float128_type_node,
+	gfc_real16_is_float128): New variables.
+	(gfc_init_kinds): Allow TFmode.
+	(gfc_build_real_type): Mark __float128 types as such.
+	(gfc_init_types): Initialize float128_type_node and
+	complex_float128_type_node
+	* f95-lang.c (gfc_init_builtin_functions): Adjust for new
+	argument of OTHER_BUILTIN macro.
+	* trans-intrinsic.c (gfc_intrinsic_map_t): Likewise.
+	(builtin_decl_for_precision): Special case for __float128.
+	(builtin_decl_for_float_kind): Likewise.
+	(define_quad_builtin): New function.
+	(gfc_build_intrinsic_lib_fndecls): Create all __float128
+	library decls if necessary. Store them in the real16_decl and
+	complex16_decl builtin map fields.
+	(gfc_get_intrinsic_lib_fndecl): Handle q-suffixed __float128
+	library function names.
+
+2010-08-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/33197
+	* gcc/fortran/intrinsic.c (add_functions): Add norm2 and parity.
+	* gcc/fortran/intrinsic.h (gfc_check_norm2, gfc_check_parity):
+	gfc_simplify_norm2, gfc_simplify_parity, gfc_resolve_norm2,
+	gfc_resolve_parity): New prototypes.
+	* gcc/fortran/gfortran.h (gfc_isym_id): New enum items
+	GFC_ISYM_NORM2 and GFC_ISYM_PARITY.
+	* gcc/fortran/iresolve.c (gfc_resolve_norm2,
+	gfc_resolve_parity): New functions.
+	* gcc/fortran/check.c (gfc_check_norm2, gfc_check_parity):
+	New functions.
+	* gcc/fortran/trans-intrinsic.c (gfc_conv_intrinsic_arith,
+	gfc_conv_intrinsic_function): Handle NORM2 and PARITY.
+	* gcc/fortran/intrinsic.texi (NORM2, PARITY): Add.
+	* gcc/fortran/simplify.c (simplify_transformation_to_array):
+	Add post-processing opterator.
+	(gfc_simplify_all, gfc_simplify_any, gfc_simplify_count,
+	gfc_simplify_product, gfc_simplify_sum): Update call.
+	(add_squared, do_sqrt, gfc_simplify_norm2, do_xor,
+	gfc_simplify_parity): New functions.
+
+2010-08-27  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/45420
+	* match.c (select_type_set_tmp): Add the possibility to reset the
+	temporary to NULL.
+	(gfc_match_class_is): Reset the temporary in CLASS DEFAULT clauses.
+
+2010-08-27  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/45159
+	* dependency.c (check_section_vs_section):  Single test for
+	identical strides which takes into account that only one
+	of the strides may be NULL.
+
+2010-08-27  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/43217
+	* primary.c (match_hollerith_constant): Calculate padding needed to
+	fill default integer and allocate string for that size.  Set pad bytes
+	to ' '.
+	* gfortran.h: Add hollerith pad value to type spec union.
+	* data.c (create_character_initializer): Fix spelling of function name.
+	Use hollerith pad value to calculate length.
+	* arith.c (hollerith2representation); Use hollerith pad value to
+	calculate length.
+
+2010-08-26  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/38936
+	PR fortran/44047
+	PR fortran/45384
+	* gfortran.h (struct gfc_association_list): New flag `dangling'.
+	(gfc_build_block_ns): Declared here...
+	* parse.h (gfc_build_block_ns): ...instead of here.
+	* trans.h (gfc_process_block_locals): Expect additionally the
+	gfc_association_list of BLOCK (if present).
+	* match.c (select_type_set_tmp): Create sym->assoc for temporary.
+	* resolve.c (resolve_variable): Only check for invalid *array*
+	references on associate-names.
+	(resolve_assoc_var): New method with code previously in resolve_symbol.
+	(resolve_select_type): Use association to give the selector and
+	temporaries their values instead of ordinary assignment.
+	(resolve_fl_var_and_proc): Allow CLASS associate-names.
+	(resolve_symbol): Use new `resolve_assoc_var' instead of inlining here.
+	* trans-stmt.c (gfc_trans_block_construct): Pass association-list
+	to `gfc_process_block_locals' to match new interface.
+	* trans-decl.c (gfc_get_symbol_decl): Don't defer associate-names
+	here automatically.
+	(gfc_process_block_locals): Defer them rather here when linked to
+	from the BLOCK's association list.
+
+2010-08-25  Jakub Jelinek  <jakub@redhat.com>
+
+	* trans-decl.c (gfc_build_intrinsic_function_decls): Set
+	TREE_NOTHROW on fndecls that can't throw.  Set
+	TREE_READONLY on gfor_fndecl_math_ishftc{4,8,16}.
+	(gfc_build_builtin_function_decls): Set TREE_NOTHROW on
+	gfor_fndecl_associated.
+
+2010-08-23  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/45380
+	* frontend-passes.c (optimize_equality): Don't optimize array equality
+
+2010-08-23  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/45366
+	* resolve.c (resolve_procedure_interface): New function split off from
+	'resolve_symbol'.
+	(resolve_formal_arglist): Call it here ...
+	(resolve_symbol): ... and here.
+
+2010-08-22  Joseph Myers  <joseph@codesourcery.com>
+
+	* Make-lang.in (gfortranspec.o): Update dependencies.
+	* gfortranspec.c: Include coretypes.h before gcc.h.  Include
+	opts.h.
+	(MATH_LIBRARY, FORTRAN_LIBRARY): Remove initial "-l".
+	(ADD_ARG_LIBGFORTRAN, Option, lookup_option): Remove.
+	(g77_xargc): Make unsigned.
+	(g77_xargv): Change to g77_x_decoded_options.
+	(g77_newargc): Make unsigned.
+	(g77_newargv): Change to g77_new_decoded_options.
+	(strings_same, options_same): New.
+	(append_arg): Use cl_decoded_option structures.
+	(append_option): New.
+	(add_arg_libgfortran): New.
+	(lang_specific_driver): Use cl_decoded_option structures.
+
+2010-08-21  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/45271
+	PR fortran/45290
+	* class.c (add_proc_comp): Add static initializer for PPCs.
+	(add_procs_to_declared_vtab): Modified comment.
+	* module.c (mio_component): Add argument 'vtype'. Don't read/write the
+	initializer if the component is part of a vtype.
+	(mio_component_list): Add argument 'vtype', pass it on to
+	'mio_component'.
+	(mio_symbol): Modified call to 'mio_component_list'.
+	* trans.h (gfc_conv_initializer): Modified prototype.
+	(gfc_trans_assign_vtab_procs): Removed.
+	* trans-common.c (create_common): Modified call to
+	'gfc_conv_initializer'.
+	* trans-decl.c (gfc_get_symbol_decl,get_proc_pointer_decl,
+	gfc_emit_parameter_debug_info): Modified call to
+	'gfc_conv_initializer'.
+	(build_function_decl): Remove assertion.
+	* trans-expr.c (gfc_conv_derived_to_class,gfc_trans_class_assign):
+	Removed call to 'gfc_trans_assign_vtab_procs'.
+	(gfc_conv_initializer): Add argument 'procptr'.
+	(gfc_conv_structure): Modified call to 'gfc_conv_initializer'.
+	(gfc_trans_assign_vtab_procs): Removed.
+	* trans-stmt.c (gfc_trans_allocate): Removed call to
+	'gfc_trans_assign_vtab_procs'.
+
+2010-08-21  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/36158
+	PR fortran/33197
+	* intrinsic.c (add_sym): Init value attribute.
+	(set_attr_value): New function.
+	(add_functions) Use it and add JN/YN resolvers.
+	* symbol.c (gfc_copy_formal_args_intr): Copy value attr.
+	* intrinsic.h (gfc_resolve_bessel_n2): New prototype.
+	* gfortran.h (gfc_intrinsic_arg): Add value attribute.
+	* iresolve.c (gfc_resolve_bessel_n2): New function.
+	* trans-intrinsic.c (gfc_get_symbol_for_expr): Create
+	formal arg list.
+	(gfc_conv_intrinsic_function,gfc_is_intrinsic_libcall):
+	Add GFC_ISYM_JN2/GFC_ISYM_YN2 as case value.
+	* simplify.c (): For YN set to -INF if previous values
+	was -INF.
+	* trans-expr.c (gfc_conv_procedure_call): Don't crash
+	if sym->as is NULL.
+	* iresolve.c (gfc_resolve_extends_type_of): Set the
+	type of the dummy argument to the one of the actual.
+
+2010-08-20  Joseph Myers  <joseph@codesourcery.com>
+
+	* lang.opt (MD, MMD): Use NoDriverArg instead of NoArgDriver.
+
+2010-08-20  Joseph Myers  <joseph@codesourcery.com>
+
+	* gfortranspec.c (lang_specific_driver): Refer to -lgfortran in
+	comment, not -lg2c.
+
+2010-08-20  Nathan Froyd  <froydnj@codesourcery.com>
+
+	* trans-openmp.c: Use FOR_EACH_VEC_ELT.
+
+2010-08-19  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/29785
+	PR fortran/45016
+	* trans.h (struct gfc_se): New flag `byref_noassign'.
+	* trans-array.h (gfc_conv_shift_descriptor_lbound): New method.
+	(gfc_conv_array_extent_dim), (gfc_conv_descriptor_size): New methods.
+	* expr.c (gfc_check_pointer_assign): Allow bounds and rank remapping
+	and check for compile-time errors with those.
+	* trans-decl.c (trans_associate_var): Use new routine
+	`gfc_conv_shift_descriptor_lbound' instead of doing it manually.
+	* trans-array.c (gfc_conv_shift_descriptor_lbound): New method.
+	(gfc_conv_array_extent_dim), (gfc_conv_descriptor_size): New methods.
+	(gfc_array_init_size): Use new `gfc_conv_array_extent_dim'.
+	(gfc_conv_expr_descriptor): Handle new flag `byref_noassign'.
+	* trans-expr.c (gfc_trans_pointer_assignment): Handle bounds and
+	rank remapping for assignment.
+
+2010-08-19  Tobias Burnus  <burnus@net-b.de>
+
+	* intrinsic.texi (Bessel_jn, Bessel_yn): Fix typo.
+	* * simplify.c (gfc_simplify_bessel_yn): Change recursive
+	into recurrence.
+
+2010-08-19  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/36158
+	PR fortran/33197
+	* check.c (gfc_check_bessel_n2): New function.
+	* gfortran.h (gfc_isym_id): Add GFC_ISYM_JN2 and GFC_ISYM_YN2.
+	* intrinsic.c (add_functions): Add transformational version
+	of the Bessel_jn/yn intrinsics.
+	* intrinsic.h (gfc_check_bessel_n2,gfc_simplify_bessel_jn2,
+	gfc_simplify_bessel_yn2): New prototypes.
+	* intrinsic.texi (Bessel_jn, Bessel_yn): Document
+	transformational variant.
+	* simplify.c (gfc_simplify_bessel_jn, gfc_simplify_bessel_yn):
+	Check for negative order.
+	(gfc_simplify_bessel_n2,gfc_simplify_bessel_jn2,
+	gfc_simplify_bessel_yn2): New functions.
+
+2010-08-19  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/41859
+	* resolve.c (resolve_transfer): Traverse operands and set expression
+	to be checked to a non EXPR_OP type.
+
+2010-08-19  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/45290
+	* gfortran.h (gfc_add_save): Modified prototype.
+	* decl.c (add_init_expr_to_sym): Defer checking of proc pointer init.
+	(match_pointer_init): New function to match F08 pointer initialization.
+	(variable_decl,match_procedure_decl,match_ppc_decl): Use
+	'match_pointer_init'.
+	(match_attr_spec): Module variables are implicitly SAVE.
+	(gfc_match_save): Modified call to 'gfc_add_save'.
+	* expr.c (gfc_check_assign_symbol): Extra checks for pointer
+	initialization.
+	* primary.c (gfc_variable_attr): Handle SAVE attribute.
+	* resolve.c (resolve_structure_cons): Add new argument and do pointer
+	initialization checks.
+	(gfc_resolve_expr): Modified call to 'resolve_structure_cons'.
+	(resolve_values): Call 'resolve_structure_cons' directly with init arg.
+	(resolve_fl_variable): Handle SAVE_IMPLICIT.
+	* symbol.c (gfc_add_save,gfc_copy_attr,save_symbol): Handle
+	SAVE_IMPLICIT.
+	* trans-decl.c (gfc_create_module_variable): Module variables with
+	TARGET can already exist.
+	* trans-expr.c (gfc_conv_variable): Check for 'current_function_decl'.
+	(gfc_conv_initializer): Implement non-NULL pointer
+	initialization.
+
+2010-08-18  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/45295
+	* intrinsic.texi (selected_char_kind): Document ISO_10646
+	support.
+
+2010-08-17  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/45304
+	* trans-decl.c (build_library_function_decl_1): Chain on
+	void_list_node instead of creating a new TREE_LIST.
+	* trans-intrinsic.c (gfc_get_intrinsic_lib_fndecl): Likewise.
+	* trans-types.c (gfc_get_function_type): Likewise.  Set
+	typelist to void_list_node for the main program.
+
+2010-08-17  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/38936
+	* gfortran.h (struct gfc_association_list): New member `where'.
+	(gfc_is_associate_pointer) New method.
+	* match.c (gfc_match_associate): Remember locus for each associate
+	name matched and do not try to set variable flag.
+	* parse.c (parse_associate): Use remembered locus for symbols.
+	* primary.c (match_variable): Instead of variable-flag check for
+	associate names set it for all such names used.
+	* symbol.c (gfc_is_associate_pointer): New method.
+	* resolve.c (resolve_block_construct): Don't generate assignments
+	to give associate-names their values.
+	(resolve_fl_var_and_proc): Allow associate-names to be deferred-shape.
+	(resolve_symbol): Set some more attributes for associate variables,
+	set variable flag here and check it and don't try to build an
+	explicitely shaped array-spec for array associate variables.
+	* trans-expr.c (gfc_conv_variable): Dereference in case of association
+	to scalar variable.
+	* trans-types.c (gfc_is_nodesc_array): Handle array association symbols.
+	(gfc_sym_type): Return pointer type for association to scalar vars.
+	* trans-decl.c (gfc_get_symbol_decl): Defer association symbols.
+	(trans_associate_var): New method.
+	(gfc_trans_deferred_vars): Handle association symbols.
+
+2010-08-16  Joseph Myers  <joseph@codesourcery.com>
+
+	* lang.opt (MDX): Change back to MD.  Mark NoDriverArg instead of
+	RejectDriver.
+	(MMDX): Change back to MMD.  Mark NoDriverArg instead of
+	RejectDriver.
+	* cpp.c (gfc_cpp_handle_option): Use OPT_MD and OPT_MMD instead of
+	OPT_MDX and OPT_MMDX.
+
+2010-08-16  Joseph Myers  <joseph@codesourcery.com>
+
+	* lang.opt (MDX, MMDX): Mark RejectDriver.
+
+2010-08-15  Janus Weil  <janus@gcc.gnu.org>
+
+	* trans-expr.c (gfc_trans_assign_vtab_procs): Clean up (we don't have
+	vtabs for generics any more).
+
+2010-08-15  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/38936
+	* gfortran.h (gfc_find_proc_namespace): New method.
+	* expr.c (gfc_build_intrinsic_call): No need to build symtree messing
+	around with namespace.
+	* symbol.c (gfc_find_proc_namespace): New method.
+	* trans-decl.c (gfc_build_qualified_array): Use it for correct
+	value of nest.
+	* primary.c (gfc_match_varspec): Handle associate-names as arrays.
+	* parse.c (parse_associate): Removed assignment-generation here...
+	* resolve.c (resolve_block_construct): ...and added it here.
+	(resolve_variable): Handle names that are arrays but were not parsed
+	as such because of association.
+	(resolve_code): Fix BLOCK resolution.
+	(resolve_symbol): Generate array-spec for associate-names.
+
+2010-08-15  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/45211
+	* decl.c (verify_c_interop_param): Remove superfluous space (" ").
+	(verify_c_interop): Handle unresolved DT with bind(C).
+
+2010-08-15  Tobias Burnus  <burnus@net-b.de>
+
+	* trans-expr.c (gfc_conv_expr_present): Regard nullified
+	pointer arrays as absent.
+	(gfc_conv_procedure_call): Handle EXPR_NULL for non-pointer
+	dummys as absent argument.
+	* interface.c (compare_actual_formal,compare_parameter):
+	Ditto.
+
+2010-08-15  Tobias Burnus  <burnus@net-b.de>
+
+	* interface.c (compare_pointer, ): Allow passing TARGETs to pointers
+	dummies with intent(in).
+
+2010-08-15  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/45197
+	* decl.c (gfc_match_prefix): Match IMPURE prefix and mark ELEMENTAL
+	routines not IMPURE also as PURE.
+	* intrinsic.c (enum klass): New class `CLASS_PURE' and renamed
+	`NO_CLASS' in `CLASS_IMPURE'.
+	(add_sym): Set symbol-attributes `pure' and `elemental' correctly.
+	(add_sym_0s): Renamed `NO_CLASS' in `CLASS_IMPURE'.
+	(add_functions): Ditto.
+	(add_subroutines): Ditto and mark `MOVE_ALLOC' as CLASS_PURE.
+	* resolve.c (gfc_pure): Do not treat ELEMENTAL as automatically PURE.
+	(resolve_formal_arglist): Check that arguments to ELEMENTAL procedures
+	are not ALLOCATABLE and have their INTENT specified.
+
+2010-08-13  Daniel Kraft  <d@domob.eu>
+
+	* gfortran.h (array_type): New type `AS_IMPLIED_SHAPE'.
+	* array.c (gfc_match_array_spec): Match implied-shape specification and
+	handle AS_IMPLIED_SHAPE correctly otherwise.
+	* decl.c (add_init_expr_to_sym): Set upper bounds for implied-shape.
+	(variable_decl): Some checks for implied-shape declaration.
+	* resolve.c (resolve_symbol): Assert that array-spec is no longer
+	AS_IMPLIED_SHAPE in any case.
+
+2010-08-12  Joseph Myers  <joseph@codesourcery.com>
+
+	* lang.opt (MD, MMD): Change to MDX and MMDX.
+	* cpp.c (gfc_cpp_handle_option): Use OPT_MMD and OPT_MMDX.
+
+2010-08-11  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44595
+	* intrinsic.c (gfc_current_intrinsic_arg): Change type from 'char' to
+	'gfc_intrinsic_arg'.
+	(check_arglist,check_specific): Add reference to 'name' field.
+	(init_arglist): Remove reference to 'name' field.
+	* intrinsic.h (gfc_current_intrinsic_arg): Modify prototype.
+	* check.c (variable_check): Reverse order of checks. Respect intent of
+	formal arg.
+	(int_or_proc_check): New function.
+	(coarray_check): New function.
+	(allocatable_check): New function.
+	(gfc_check_allocated,gfc_check_move_alloc): Use 'allocatable_check'.
+	(gfc_check_complex): Use 'int_or_real_check'.
+	(gfc_check_lcobound,gfc_check_image_index,gfc_check_this_image,
+	gfc_check_ucobound): Use 'coarray_check'.
+	(gfc_check_pack): Use 'real_or_complex_check'.
+	(gfc_check_alarm_sub,gfc_check_signal,gfc_check_signal_sub): Use
+	'int_or_proc_check'.
+	(scalar_check,type_check,numeric_check,int_or_real_check,
+	real_or_complex_check,kind_check,double_check,logical_array_check,
+	array_check,same_type_check,rank_check,nonoptional_check,
+	kind_value_check,gfc_check_a_p,gfc_check_associated,gfc_check_cmplx,
+	gfc_check_cshift,gfc_check_dcmplx,gfc_check_dot_product,gfc_check_dprod,
+	gfc_check_eoshift,gfc_check_fn_rc2008,gfc_check_index,gfc_check_kind,
+	gfc_check_matmul,gfc_check_minloc_maxloc,check_reduction,gfc_check_null,
+	gfc_check_present,gfc_check_reshape,gfc_check_same_type_as,
+	gfc_check_spread,gfc_check_unpack,gfc_check_random_seed,
+	gfc_check_getarg,gfc_check_and,gfc_check_storage_size): Add reference
+	to 'name' field.
+
+2010-08-10  Daniel Kraft  <d@domob.eu>
+
+	* gfortran.texi (Interoperability with C): Fix ordering in menu
+	and add new subsection about pointers.
+	(Interoperable Subroutines and Functions): Split off the pointer part.
+	(working with Pointers): New subsection with extended discussion
+	of pointers (especially procedure pointers).
+
+2010-08-09  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/44235
+	* array.c (gfc_ref_dimen_size):  Add end argument.
+	If end is non-NULL, calculate it.
+	(ref_size):  Adjust call to gfc_ref_dimen_size.
+	(gfc_array_dimen_size):  Likewise.
+	(gfc_array_res_shape):  Likewise.
+	* gfortran.h:  Adjust prototype for gfc_ref_dimen_size.
+	* resolve.c (resolve_array_ref):  For stride not equal to -1,
+	fill in the lowest possible end.
+
+2010-08-09  Janus Weil  <janus@gcc.gnu.org>
+
+	* intrinsic.texi: Correct documentation of ASINH, ACOSH and ATANH.
+
+2010-08-07  Nathan Froyd  <froydnj@codesourcery.com>
+
+	* interface.c (compare_actual_formal): Use XALLOCAVEC instead of
+	alloca.
+	(check_some_aliasing): Likewise.
+	* trans-intrinsic.c (gfc_conv_intrinsic_conversion): Likewise.
+	(gfc_conv_intrinsic_int): Likewise.
+	(gfc_conv_intrinsic_lib_function): Likewise.
+	(gfc_conv_intrinsic_cmplx): Likewise.
+	(gfc_conv_intrinsic_ctime): Likewise.
+	(gfc_conv_intrinsic_fdate): Likewise.
+	(gfc_conv_intrinsic_ttynam): Likewise.
+	(gfc_conv_intrinsic_minmax): Likewise.
+	(gfc_conv_intrinsic_minmax_char): Likewise.
+	(gfc_conv_intrinsic_ishftc): Likewise.
+	(gfc_conv_intrinsic_index_scan_verify): Likewise.
+	(gfc_conv_intrinsic_merge): Likewise.
+	(gfc_conv_intrinsic_trim): Likewise.
+	* trans.c (gfc_trans_runtime_error_vararg): Likewise.
+
+2010-08-06  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/45159
+	* dependency.c (check_section_vs_section):  Handle cases where
+	the start expression coincides with the lower or upper
+	bound of the array.
+
+2010-08-04  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42207
+	PR fortran/44064
+	PR fortran/44065
+	* class.c (gfc_find_derived_vtab): Do not generate vtabs for class
+	container types. Do not artificially increase refs. Commit symbols one
+	by one.
+	* interface.c (compare_parameter): Make sure vtabs are present before
+	generating module variables.
+	* resolve.c (resolve_allocate_expr): Ditto.
+
+2010-08-04  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/45183
+	PR fortran/44857
+	* resolve.c (resolve_structure_cons): Fix
+	freeing of charlen.
+
+2010-08-04  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/42051
+	PR fortran/44064
+	* symbol.c (changed_syms): Made static again.
+	(gfc_symbol_state): Don't conditionalize on GFC_DEBUG.
+	Changed conditional internal error into assert.
+	Rename function to ...
+	(gfc_enforce_clean_symbol_state): ... this.
+	* gfortran.h (gfc_symbol_state, gfc_enforce_clean_symbol_state):
+	Rename the former to the latter.
+	* parse.c (decode_statement, decode_omp_directive,
+	decode_gcc_attribute): Update callers accordingly. Don't conditionalize
+	on GFC_DEBUG.
+	(changed_syms): Remove declaration.
+	(next_statement): Use gfc_enforce_clean_symbol_state.
+
+2010-08-04  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/44857
+	* resolve.c (resolve_structure_cons): Fix handling of
+	initialization structure constructors with character
+	elements of the wrong length.
+	* array.c (gfc_check_iter_variable): Add NULL check.
+	(gfc_resolve_character_array_constructor): Also truncate
+	character length.
+
+2010-08-04  Tobias Burnus  <burnus@net-b.de>
+
+	* trans-io.c (gfc_build_io_library_fndecls): Fix return
+	value of some libgfortran functions.
+
+2010-08-03  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/45159
+	* dependency.c (gfc_deb_compare_expr):  Remove any integer
+	conversion functions to larger types from both arguments.
+	Remove handling these functions futher down.
+
+2010-08-03  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44584
+	PR fortran/45161
+	* class.c (add_procs_to_declared_vtab1): Don't add erroneous procedures.
+	* resolve.c (resolve_tb_generic_targets): Check for errors.
+
+2010-08-02  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/45159
+	* depencency.c (gfc_dep_resolver):  Fix logic for when a loop
+	can be reversed.
+
+2010-08-02  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/36854
+	* dependency.h:  Add prototype for gfc_are_identical_variables.
+	* frontend-passes.c:  Include depencency.h.
+	(optimimize_equality):  Use gfc_are_identical_variables.
+	* dependency.c (identical_array_ref): New function.
+	(gfc_are_identical_variables):  New function.
+	(gfc_deb_compare_expr):  Use gfc_are_identical_variables.
+	* dependency.c (gfc_check_section_vs_section).  Rename gfc_
+	prefix from statc function.
+	(check_section_vs_section): Change arguments to gfc_array_ref,
+	adjust function body accordingly.
+
+2010-08-02  Mikael Morin  <mikael@gcc.gnu.org>
+	    Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42051
+	PR fortran/44064
+	PR fortran/45151
+	* intrinsic.c (gfc_get_intrinsic_sub_symbol): Commit changed symbol.
+	* symbol.c (gen_cptr_param, gen_fptr_param, gen_shape_param,
+	gfc_copy_formal_args, gfc_copy_formal_args_intr,
+	gfc_copy_formal_args_ppc, generate_isocbinding_symbol): Ditto.
+	* parse.c (parse_derived_contains, parse_spec, parse_progunit):
+	Call reject_statement in case of error.
+	(match_deferred_characteritics): Call gfc_undo_symbols in case match
+	fails.
+
+2010-08-01  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44912
+	* class.c (gfc_build_class_symbol): Make '$vptr' component private.
+	(gfc_find_derived_vtab): Make vtabs and vtypes public.
+	* module.c (read_module): When reading module files, always import
+	vtab and vtype symbols.
+
+2010-07-31  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/42051
+	PR fortran/44064
+	* symbol.c (changed_syms): Made non-static.
+	* parse.c (changed_syms): Declare new external.
+	(next_statement): Assert changed_syms is NULL at the beginning.
+
+2010-07-30  Janus Weil  <janus@gcc.gnu.org>
+	    Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/44929
+	* match.c (match_type_spec): Try to parse derived types before
+	intrinsic types.
+
+2010-07-30  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* gfortran.h (gfc_release_symbol): New prototype.
+	* symbol.c (gfc_release_symbol): New. Code taken from free_sym_tree.
+	(gfc_undo_symbols, free_sym_tree, gfc_free_finalizer):
+	Use gfc_release_symbol.
+	* parse.c (gfc_fixup_sibling_symbols): Ditto.
+	* resolve.c (resolve_symbol): Ditto.
+
+2010-07-29  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/45087
+	PR fortran/45125
+	* trans-decl.c (gfc_get_extern_function_decl): Correctly handle
+	external procedure declarations in modules.
+	(gfc_get_symbol_decl): Modify assert.
+
+2010-07-29  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44962
+	* resolve.c (resolve_fl_derived): Call gfc_resolve_array_spec.
+
+2010-07-29  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/45004
+	* trans-stmt.h (gfc_trans_class_init_assign): New prototype.
+	(gfc_trans_class_assign): Modified prototype.
+	* trans.h (gfc_conv_intrinsic_move_alloc): New prototype.
+	* trans-expr.c (gfc_trans_class_init_assign): Split off from ...
+	(gfc_trans_class_assign): ... here. Modified actual arguments.
+	* trans-intrinsic.c (gfc_conv_intrinsic_move_alloc): New function to
+	handle the MOVE_ALLOC intrinsic with scalar and class arguments.
+	* trans.c (trans_code): Call 'gfc_conv_intrinsic_move_alloc'.
+
+2010-07-29  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/42051
+	PR fortran/44064
+	* class.c (gfc_find_derived_vtab): Accept or discard newly created
+	symbols before returning.
+
+2010-07-29  Joseph Myers  <joseph@codesourcery.com>
+
+	* lang.opt (cpp): Remove Joined and Separate markers.
+	(cpp=): New internal option.
+	* lang-specs.h (F951_CPP_OPTIONS): Generate -cpp= option.
+	* cpp.c (gfc_cpp_handle_option): Handle OPT_cpp_ instead of
+	OPT_cpp.
+
+2010-07-29  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/45117
+	* array.c (resolve_array_bound): Fix error message to properly handle
+	non-variable expressions.
+
+2010-07-28  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* decl.c (free_value): Also free repeat field.
+	* data.c (gfc_assign_data_value): Always free offset before returning.
+
+2010-07-28  Daniel Kraft  <d@domob.eu>
+
+	* gfortran.h (gfc_build_intrinsic_call): New method.
+	* expr.c (gfc_build_intrinsic_call): New method.
+	* simplify.c (range_check): Ignore non-constant value.
+	(simplify_bound_dim): Handle non-variable expressions and
+	fix memory leak with non-free'ed expression.
+	(simplify_bound): Handle non-variable expressions.
+	(gfc_simplify_shape): Ditto.
+	(gfc_simplify_size): Ditto, but only in certain cases possible.
+
+2010-07-28  Joseph Myers  <joseph@codesourcery.com>
+
+	* gfortranspec.c (SWITCH_TAKES_ARG, WORD_SWITCH_TAKES_ARG):
+	Remove.
+
+2010-07-28  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/45077
+	* trans-types.c (gfc_get_derived_type): Fix DT declaration
+	from modules for whole-file mode.
+
+2010-07-27  Joseph Myers  <joseph@codesourcery.com>
+
+	* gfortran.h (gfc_handle_option): Update prototype and return
+	value type.
+	* options.c (gfc_handle_option): Update prototype and return value
+	type.
+
+2010-07-27  Joseph Myers  <joseph@codesourcery.com>
+
+	* cpp.c (gfc_cpp_init_options): Update prototype.  Use number of
+	decoded options in allocating deferred_opt.
+	* cpp.h (gfc_cpp_init_options): Update prototype.
+	* f95-lang.c (LANG_HOOKS_OPTION_LANG_MASK): Define.
+	* gfortran.h (gfc_option_lang_mask): New.
+	(gfc_init_options): Update prototype.
+	* options.c (gfc_option_lang_mask): New.
+	(gfc_init_options): Update prototype.  Pass new arguments to
+	gfc_cpp_init_options.
+
+2010-07-26  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40873
+	* trans-decl.c (gfc_get_extern_function_decl): Fix generation
+	for functions which are later in the same file.
+	(gfc_create_function_decl, build_function_decl,
+	build_entry_thunks): Add global argument.
+	* trans.c (gfc_generate_module_code): Update
+	gfc_create_function_decl call.
+	* trans.h (gfc_create_function_decl): Update prototype.
+	* resolve.c (resolve_global_procedure): Also resolve for
+	IFSRC_IFBODY.
+
+2010-07-26  Richard Henderson  <rth@redhat.com>
+
+	PR target/44132
+	* f95-lang.c (LANG_HOOKS_WRITE_GLOBALS): New.
+	(gfc_write_global_declarations): New.
+
+2010-07-26  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/45066
+	* trans-io.c (build_dt): Use NULL_TREE rather than NULL
+	for call to transfer_namelist_element.
+	* trans-decl.c (gfc_get_symbol_decl): Also set sym->backend_decl
+	for -fwhole-file.
+
+2010-07-25  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/40628
+	* Make-lang.in:  Add fortran/frontend-passes.o.
+	* gfortran.h:  Add prototype for gfc_run_passes.
+	* resolve.c (gfc_resolve):  Call gfc_run_passes.
+	* frontend-passes.c:  New file.
+
+2010-07-25  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/42852
+	* scanner.c (gfc_next_char_literal): Enable truncation warning for
+	free-form '&'.
+
+2010-07-25  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/44660
+	* gfortran.h (gfc_namespace): New field old_equiv.
+	(gfc_free_equiv_until): New prototype.
+	* match.c (gfc_free_equiv_until): New, renamed from gfc_free_equiv with
+	a parameterized stop condition.
+	(gfc_free_equiv): Use gfc_free_equiv_until.
+	* parse.c (next_statement): Save equivalence list.
+	(reject_statement): Restore equivalence list.
+
+2010-07-25  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/42852
+	* scanner.c (gfc_next_char_literal): Move check for truncation earlier
+	in the function so that it does not get missed by early exits.
+	(load_line): Add checks for quoted strings and free form comments to
+	disable warnings on comments. Add check for ampersand as first
+	character after truncation and don't warn for this case, but warn if
+	there are subsequent non-whitespace characters.
+
+2010-07-24  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40011
+	* parse.c (gfc_parse_file): Do not override
+	gfc_global_ns_list items.
+
+2010-07-24  Tobias Burnus  <burnus@net-b.de>
+
+	* options.c (gfc_init_options): Enable -fwhole-file by default.
+	* interface.c (compare_parameter): Assume a Hollerith constant is
+	compatible with all other argument types.
+
+2010-07-23  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/44945
+	* trans-decl.c (gfc_get_symbol_decl): Use module decl with
+	-fwhole-file also for derived types.
+	* trans-types.c (copy_dt_decls_ifequal): Remove static and
+	rename to gfc_copy_dt_decls_ifequal.
+	(gfc_get_derived_type): Update call.
+	* trans-types.h (gfc_copy_dt_decls_ifequal): Add prototype.
+
+2010-07-23  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/45030
+	* resolve.c (resolve_global_procedure): Properly handle ENTRY.
+
+2010-07-23  Jakub Jelinek  <jakub@redhat.com>
+
+	* trans-types.c (gfc_get_array_descriptor_base,
+	gfc_get_array_type_bounds): Set TYPE_NAMELESS.
+	* trans-decl.c (gfc_build_qualified_array): Set DECL_NAMELESS
+	instead of clearing DECL_NAME.
+	(gfc_build_dummy_array_decl): Set DECL_NAMELESS.
+
+2009-07-23  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/24524
+	* trans-array.c (gfc_init_loopinfo): Initialize the reverse
+	field.
+	gfc_trans_scalarized_loop_end: If reverse set in dimension n,
+	reverse the scalarization loop.
+	gfc_conv_resolve_dependencies: Pass the reverse field of the
+	loopinfo to gfc_dep_resolver.
+	trans-expr.c (gfc_trans_assignment_1): Enable loop reversal for
+	assignment by resetting loop.reverse.
+	gfortran.h : Add the gfc_reverse enum.
+	trans.h : Add the reverse field to gfc_loopinfo.
+	dependency.c (gfc_check_dependency): Pass null to the new arg
+	of gfc_dep_resolver.
+	(gfc_check_section_vs_section): Check for reverse dependencies.
+	(gfc_dep_resolver): Add reverse argument and deal with the loop
+	reversal logic.
+	dependency.h : Modify prototype for gfc_dep_resolver to include
+	gfc_reverse *.
+
+2010-07-23  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/44709
+	* gfortran.h (gfc_find_symtree_in_proc): New method.
+	* symbol.c (gfc_find_symtree_in_proc): New method.
+	* match.c (match_exit_cycle): Look for loop name also in parent
+	namespaces within current procedure.
+
+2010-07-22  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/45019
+	* dependency.c (gfc_check_dependency): Add argument alising check.
+	* symbol.c (gfc_symbols_could_alias): Add argument alising check.
+
+2010-07-22  Daniel Kraft  <d@domob.eu>
+
+	* trans-stmt.c (gfc_trans_return): Put back in the handling of se.post,
+	now in the correct place.
+
+2010-07-21  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/44929
+	* Revert my commit r162325.
+
+2010-07-21  Daniel Kraft  <d@domob.eu>
+
+	* trans.h (gfc_get_return_label): Removed.
+	(gfc_generate_return): New method.
+	(gfc_trans_deferred_vars): Update gfc_wrapped_block rather than
+	returning a tree directly.
+	* trans-stmt.c (gfc_trans_return): Use `gfc_generate_return'.
+	(gfc_trans_block_construct): Update for new interface to
+	`gfc_trans_deferred_vars'.
+	* trans-decl.c (current_function_return_label): Removed.
+	(current_procedure_symbol): New variable.
+	(gfc_get_return_label): Removed.
+	(gfc_trans_deferred_vars): Update gfc_wrapped_block rather than
+	returning a tree directly.
+	(get_proc_result), (gfc_generate_return): New methods.
+	(gfc_generate_function_code): Clean up and do init/cleanup here
+	also with gfc_wrapped_block.  Remove return-label but rather
+	return directly.
+
+2010-07-19  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/44929
+	* fortran/match.c (match_type_spec): Check for derived type before
+	intrinsic types.
+
+2010-07-19  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/42385
+	* interface.c (matching_typebound_op): Add argument for the
+	return of the generic name for the procedure.
+	(build_compcall_for_operator): Add an argument for the generic
+	name of an operator procedure and supply it to the expression.
+	(gfc_extend_expr, gfc_extend_assign): Use the generic name in
+	calls to the above procedures.
+	* resolve.c (resolve_typebound_function): Catch procedure
+	component calls for CLASS objects, check that the vtable is
+	complete and insert the $vptr and procedure components, to make
+	the call.
+	(resolve_typebound_function): The same.
+	* trans-decl.c (gfc_trans_deferred_vars): Do not deallocate
+	an allocatable scalar if it is a result.
+
+2010-07-19  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/44353
+	* match.c (gfc_match_iterator): Reverted.
+
+2010-07-18  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/44353
+	* match.c (gfc_match_iterator): Remove error that iterator
+	cannot be INTENT(IN).
+
+2010-07-17  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_free_ss): Don't free beyond ss rank.
+	Access subscript through the "dim" field index.
+	(gfc_trans_create_temp_array): Access ss info through the "dim" field
+	index.
+	(gfc_conv_array_index_offset): Ditto.
+	(gfc_conv_loop_setup): Ditto.
+	(gfc_conv_expr_descriptor): Ditto.
+	(gfc_conv_ss_startstride): Ditto.  Update call to
+	gfc_conv_section_startstride.
+	(gfc_conv_section_startstride): Set values along the array dimension.
+	Get array dimension directly from the argument.
+
+2010-07-15  Jakub Jelinek  <jakub@redhat.com>
+
+	* trans.h (gfc_string_to_single_character): New prototype.
+	* trans-expr.c (string_to_single_character): Renamed to ...
+	(gfc_string_to_single_character): ... this.  No longer static.
+	(gfc_conv_scalar_char_value, gfc_build_compare_string,
+	gfc_trans_string_copy): Adjust callers.
+	* config-lang.in (gtfiles): Add fortran/trans-stmt.c.
+	* trans-stmt.c: Include ggc.h and gt-fortran-trans-stmt.h.
+	(select_struct): Move to toplevel, add GTY(()).
+	(gfc_trans_character_select): Optimize SELECT CASE
+	with character length 1.
+
+2010-07-15  Nathan Froyd  <froydnj@codesourcery.com>
+
+	* f95-lang.c: Carefully replace TREE_CHAIN with DECL_CHAIN.
+	* trans-common.c: Likewise.
+	* trans-decl.c: Likewise.
+	* trans-types.c: Likewise.
+	* trans.c: Likewise.
+
+2010-07-15  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44936
+	* resolve.c (resolve_typebound_generic_call): Resolve generic
+	non-polymorphic type-bound procedure calls to the correct specific
+	procedure.
+	(resolve_typebound_subroutine): Remove superfluous code.
+
+2010-07-15  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/44709
+	* trans.h (struct gfc_wrapped_block): New struct.
+	(gfc_start_wrapped_block), (gfc_add_init_cleanup): New methods.
+	(gfc_finish_wrapped_block): New method.
+	(gfc_init_default_dt): Add new init code to block rather than
+	returning it.
+	* trans-array.h (gfc_trans_auto_array_allocation): Use gfc_wrapped_block
+	(gfc_trans_dummy_array_bias): Ditto.
+	(gfc_trans_g77_array): Ditto.
+	(gfc_trans_deferred_array): Ditto.
+	* trans.c (gfc_add_expr_to_block): Call add_expr_to_chain.
+	(add_expr_to_chain): New method based on old gfc_add_expr_to_block.
+	(gfc_start_wrapped_block), (gfc_add_init_cleanup): New methods.
+	(gfc_finish_wrapped_block): New method.
+	* trans-array.c (gfc_trans_auto_array_allocation): use gfc_wrapped_block
+	(gfc_trans_g77_array), (gfc_trans_dummy_array_bias): Ditto.
+	(gfc_trans_deferred_array): Ditto.
+	* trans-decl.c (gfc_trans_dummy_character): Ditto.
+	(gfc_trans_auto_character_variable), (gfc_trans_assign_aux_var): Ditto.
+	(init_intent_out_dt): Ditto.
+	(gfc_init_default_dt): Add new init code to block rather than
+	returning it.
+	(gfc_trans_deferred_vars): Use gfc_wrapped_block to collect all init
+	and cleanup code and put it all together.
+
+2010-07-15  Jakub Jelinek  <jakub@redhat.com>
+
+	* trans.h (gfc_build_compare_string): Add CODE argument.
+	* trans-intrinsic.c (gfc_conv_intrinsic_strcmp): Pass OP to
+	gfc_build_compare_string.
+	* trans-expr.c (gfc_conv_expr_op): Pass CODE to
+	gfc_build_compare_string.
+	(string_to_single_character): Rename len variable to length.
+	(gfc_optimize_len_trim): New function.
+	(gfc_build_compare_string): Add CODE argument.  If it is EQ_EXPR
+	or NE_EXPR and one of the strings is string literal with LEN_TRIM
+	bigger than the length of the other string, they compare unequal.
+
+	PR fortran/40206
+	* trans-stmt.c (gfc_trans_character_select): Always use NULL for high
+	in CASE_LABEL_EXPR and use NULL for low for the default case.
+
+2010-07-14  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_conv_section_upper_bound): Remove
+	(gfc_conv_section_startstride): Don't set the upper bound in the
+	vector subscript case.
+	(gfc_conv_loop_setup): Don't use gfc_conv_section_upper_bound
+
+2010-07-14  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44925
+	* gfortran.h (gfc_is_data_pointer): Remove prototype.
+	* dependency.c (gfc_is_data_pointer): Make it static.
+	* intrinsic.texi: Update documentation on C_LOC.
+	* resolve.c (gfc_iso_c_func_interface): Fix pointer and target checks
+	and add a check for polymorphic variables.
+
+2010-07-14  Jakub Jelinek  <jakub@redhat.com>
+
+	* trans-expr.c (string_to_single_character): Also optimize
+	string literals containing a single char followed only by spaces.
+	(gfc_trans_string_copy): Remove redundant string_to_single_character
+	calls.
+
+	* trans-decl.c (gfc_build_intrinsic_function_decls,
+	gfc_build_builtin_function_decls): Mark functions as
+	DECL_PURE_P or TREE_READONLY.
+
+2010-07-13  Nathan Froyd  <froydnj@codesourcery.com>
+
+	* trans-decl.c (build_entry_thunks): Call build_call_expr_loc_vec
+	instead of build_function_call_expr.
+	* trans-intrinsic.c (gfc_conv_intrinsic_sr_kind): Likewise.
+
+2010-07-13  Tobias Burnus  <burnus@net-b.de>
+	    Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/43665
+	* trans.h (gfc_build_library_function_decl_with_spec): New prototype.
+	* trans-decl.c (gfc_build_library_function_decl_with_spec): Removed
+	static.
+	* trans-io (gfc_build_io_library_fndecls): Add "fn spec" annotations.
+
+2010-07-13  Daniel Franke  <franke.daniel@gmail.com>
+	    Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/43665
+	* trans-decl.c (gfc_build_intrinsic_function_decls): Add
+	noclobber/noescape annotations to function calls.
+	(gfc_build_builtin_function_decls): Likewise.
+
+2010-07-13  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44434
+	PR fortran/44565
+	PR fortran/43945
+	PR fortran/44869
+	* gfortran.h (gfc_find_derived_vtab): Modified prototype.
+	* class.c (gfc_build_class_symbol): Modified call to
+	'gfc_find_derived_vtab'.
+	(add_proc_component): Removed, moved code into 'add_proc_comp'.
+	(add_proc_comps): Renamed to 'add_proc_comp', removed treatment of
+	generics.
+	(add_procs_to_declared_vtab1): Removed unnecessary argument 'resolved'.
+	Removed treatment of generics.
+	(copy_vtab_proc_comps): Removed unnecessary argument 'resolved'.
+	Call 'add_proc_comp' instead of duplicating code.
+	(add_procs_to_declared_vtab): Removed unnecessary arguments 'resolved'
+	and 'declared'.
+	(add_generic_specifics,add_generics_to_declared_vtab): Removed.
+	(gfc_find_derived_vtab): Removed unnecessary argument 'resolved'.
+	Removed treatment of generics.
+	* iresolve.c (gfc_resolve_extends_type_of): Modified call to
+	'gfc_find_derived_vtab'.
+	* resolve.c (resolve_typebound_function,resolve_typebound_subroutine):
+	Removed treatment of generics.
+	(resolve_select_type,resolve_fl_derived): Modified call to
+	'gfc_find_derived_vtab'.
+	* trans-decl.c (gfc_get_symbol_decl): Ditto.
+	* trans-expr.c (gfc_conv_derived_to_class,gfc_trans_class_assign):
+	Ditto.
+	* trans-stmt.c (gfc_trans_allocate): Ditto.
+
+2010-07-12  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/37077
+	* trans-io.c (build_dt): Set common.unit to flag chracter(kind=4)
+	internal unit.
+
+2010-07-12  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* expr.c (gfc_get_int_expr): Don't initialize mpfr data twice.
+	* resolve.c (build_default_init_expr): Ditto.
+
+2010-07-11  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/44702
+	* module.c (sort_iso_c_rename_list): Remove.
+	(import_iso_c_binding_module,use_iso_fortran_env_module):
+	Allow multiple imports of the same symbol.
+
+2010-07-11  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* arith.c (gfc_arith_done_1): Release mpfr internal caches.
+
+2010-07-11  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44869
+	* decl.c (build_sym,attr_decl1): Only build the class container if the
+	symbol has sufficient attributes.
+	* expr.c (gfc_check_pointer_assign): Use class_pointer instead of
+	pointer attribute for classes.
+	* match.c (gfc_match_allocate,gfc_match_deallocate): Ditto.
+	* module.c (MOD_VERSION): Bump.
+	(enum ab_attribute,attr_bits): Add AB_CLASS_POINTER.
+	(mio_symbol_attribute): Handle class_pointer attribute.
+	* parse.c (parse_derived): Use class_pointer instead of pointer
+	attribute for classes.
+	* primary.c (gfc_variable_attr,gfc_expr_attr): Ditto.
+	* resolve.c (resolve_structure_cons,resolve_deallocate_expr,
+	resolve_allocate_expr,resolve_fl_derived): Ditto.
+	(resolve_fl_var_and_proc): Check for class_ok attribute.
+
+2010-07-10  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-io.c (gfc_build_st_parameter): Update calls to
+	gfc_add_field_to_struct.
+	* trans-stmt.c (ADD_FIELD): Ditto.
+	* trans-types.c
+	(gfc_get_derived_type): Ditto. Don't create backend_decl for C_PTR's
+	C_ADDRESS field.
+	(gfc_add_field_to_struct_1): Set TYPE_FIELDS(context) instead of
+	fieldlist, remove fieldlist from argument list.
+	(gfc_add_field_to_struct): Update call to gfc_add_field_to_struct_1
+	and remove fieldlist from argument list.
+	(gfc_get_desc_dim_type, gfc_get_array_descriptor_base,
+	gfc_get_mixed_entry_union): Move setting
+	TYPE_FIELDS to gfc_add_field_to_struct_1 and update calls to it.
+	* trans-types.h (gfc_add_field_to_struct): Update prototype.
+
+2010-07-10  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/44773
+	* trans-expr.c (arrayfunc_assign_needs_temporary): No temporary
+	if the lhs has never been host associated, as well as not being
+	use associated, a pointer or a target.
+	* resolve.c (resolve_variable): Mark variables that are host
+	associated.
+	* gfortran.h: Add the host_assoc bit to the symbol_attribute
+	structure.
+
+2010-07-09  Janus Weil  <janus@gcc.gnu.org>
+
+	* intrinsic.texi: Add documentation for SAME_TYPE_AS, EXTENDS_TYPE_OF,
+	STORAGE_SIZE, C_NULL_PTR and C_NULL_FUNPTR. Modify documentation of
+	SIZEOF and C_SIZEOF.
+
+2010-07-08  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44649
+	* gfortran.h (gfc_isym_id): Add GFC_ISYM_C_SIZEOF,GFC_ISYM_STORAGE_SIZE.
+	* intrinsic.h (gfc_check_c_sizeof,gfc_check_storage_size,
+	gfc_resolve_storage_size): New prototypes.
+	* check.c (gfc_check_c_sizeof,gfc_check_storage_size): New functions.
+	* intrinsic.c (add_functions): Add STORAGE_SIZE.
+	* iresolve.c (gfc_resolve_storage_size): New function.
+	* trans-intrinsic.c (gfc_conv_intrinsic_sizeof): Handle polymorphic
+	arguments.
+	(gfc_conv_intrinsic_storage_size): New function.
+	(gfc_conv_intrinsic_function): Handle STORAGE_SIZE.
+
+2010-07-08  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/44847
+	* match.c (match_exit_cycle): Error on EXIT also from collapsed
+	!$omp do loops.  Error on CYCLE to non-innermost collapsed
+	!$omp do loops.
+
+2010-07-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* array.c (gfc_match_array_ref): Better error message for
+	coarrays with too few ranks.
+	(match_subscript): Move one diagnostic to caller.
+	* gfortran.h (gfc_get_corank): Add prottype.
+	* expr.c (gfc_get_corank): New function.
+	* iresolve.c (resolve_bound): Fix rank for cobounds.
+	(gfc_resolve_lbound,gfc_resolve_lcobound, gfc_resolve_ubound,
+	gfc_resolve_ucobound, gfc_resolve_this_image): Update
+	resolve_bound call.
+
+2010-07-06  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/44742
+	* array.c (gfc_expand_constructor): Add optional diagnostic.
+	* gfortran.h (gfc_expand_constructor): Update prototype.
+	* expr.c (gfc_simplify_expr, check_init_expr,
+	gfc_reduce_init_expr): Update gfc_expand_constructor call.
+	* resolve.c (gfc_resolve_expr): Ditto.
+
+2010-07-06  Tobias Burnus  <burnus@net-b.de>
+
+	* trans-decl.c: Include diagnostic-core.h besides toplev.h.
+	* trans-intrinsic.c: Ditto.
+	* trans-types.c: Ditto.
+	* convert.c: Include diagnostic-core.h instead of toplev.h.
+	* options.c: Ditto.
+	* trans-array.c: Ditto.
+	* trans-const.c: Ditto.
+	* trans-expr.c: Ditto.
+	* trans-io.c: Ditto.
+	* trans-openmp.c: Ditto.
+	* trans.c: Ditto.
+
+2010-07-06  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/PR44693
+	* check.c (dim_rank_check):  Also check intrinsic functions.
+	Adjust permissible rank for functions which reduce the rank of
+	their argument.  Spread is an exception, where DIM can
+	be one larger than the rank of array.
+
+2010-07-05  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/44797
+	* fortran/io.c (resolve_tag): Check EXIST tag is a default logical.
+
+2010-07-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/44596
+	* trans-types.c (gfc_get_derived_type): Derived type fields
+	with the vtype attribute must have TYPE_REF_CAN_ALIAS_ALL set
+	but build_pointer_type_for_mode must be used for this.
+
+2010-07-05  Nathan Froyd  <froydnj@codesourcery.com>
+
+	* trans.h (gfc_conv_procedure_call): Take a VEC instead of a tree.
+	* trans-intrinsic.c (gfc_conv_intrinsic_funcall): Adjust for new
+	type of gfc_conv_procedure_call.
+	(conv_generic_with_optional_char_arg): Likewise.
+	* trans-stmt.c (gfc_trans_call): Likewise.
+	* trans-expr.c (gfc_conv_function_expr): Likewise.
+	(gfc_conv_procedure_call): Use build_call_vec instead of
+	build_call_list.
+
+2010-07-04  Daniel Kraft  <d@domob.eu>
+
+	* gfc-internals.texi (gfc_code): Document BLOCK and ASSOCIATE.
+
+2010-07-04  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/44596
+	PR fortran/44745
+	* trans-types.c (gfc_get_derived_type): Derived type fields
+	with the vtype attribute must have TYPE_REF_CAN_ALIAS_ALL set.
+
+2010-07-02  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/44662
+	* decl.c (match_procedure_in_type): Clear structure before using.
+	(gfc_match_generic): Ditto.
+
+2010-07-02  Nathan Froyd  <froydnj@codesourcery.com>
+
+	* trans-types.h (gfc_add_field_to_struct): Add tree ** parameter.
+	* trans-types.c (gfc_add_field_to_struct_1): New function, most
+	of which comes from...
+	(gfc_add_field_to_struct): ...here.  Call it.  Add new parameter.
+	(gfc_get_desc_dim_type): Call gfc_add_field_to_struct_1 for
+	building fields.
+	(gfc_get_array_descriptor_base): Likewise.
+	(gfc_get_mixed_entry_union): Likewise.
+	(gfc_get_derived_type): Add extra chain parameter for
+	gfc_add_field_to_struct.
+	* trans-stmt.c (gfc_trans_character_select): Likewise.
+	* trans-io.c (gfc_build_st_parameter): Likewise.
+
+2010-06-29  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44718
+	* resolve.c (is_external_proc): Prevent procedure pointers from being
+	regarded as external procedures.
+
+2010-06-29  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44696
+	* trans-intrinsic.c (gfc_conv_associated): Handle polymorphic variables
+	passed as second argument of ASSOCIATED.
+
+2010-06-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/44582
+	* trans-expr.c (arrayfunc_assign_needs_temporary): New function
+	to determine if a function assignment can be made without a
+	temporary.
+	(gfc_trans_arrayfunc_assign): Move all the conditions that
+	suppress the direct function call to the above new functon and
+	call it.
+
+2010-06-28  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/40158
+	* interface.c (argument_rank_mismatch): New function.
+	(compare_parameter): Call new function instead of generating
+	the error directly.
+
+2010-06-28  Nathan Froyd  <froydnj@codesourcery.com>
+
+	* trans-openmp.c (dovar_init): Define.  Define VECs containing it.
+	(gfc_trans_omp_do): Use a VEC to accumulate variables and their
+	initializers.
+
+2010-06-28  Steven Bosscher  <steven@gcc.gnu.org>
+
+	* Make-lang.in: Update dependencies.
+
+2010-06-27  Nathan Froyd  <froydnj@codesourcery.com>
+
+	* gfortran.h (gfc_code): Split backend_decl field into cycle_label
+	and exit_label fields.
+	* trans-openmp.c (gfc_trans_omp_do): Assign to new fields
+	individually.
+	* trans-stmt.c (gfc_trans_simple_do): Likewise.
+	(gfc_trans_do): Likewise.
+	(gfc_trans_do_while): Likewise.
+	(gfc_trans_cycle): Use cycle_label directly.
+	(gfc_trans_exit): Use exit_label directly.
+
+2010-06-27  Daniel Kraft  <d@domob.eu>
+
+	* dump-parse-tree.c (show_symbol): Dump target-expression for
+	associate names.
+	(show_code_node): Make distinction between BLOCK and ASSOCIATE.
+	(show_namespace): Use show_level for correct indentation of
+	"inner namespaces" (contained procedures or BLOCK).
+
+2010-06-27  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/44678
+	* dump-parse-tree.c (show_code_node):  Show namespace for
+	EXEC_BLOCK.
+
+2010-06-26  Tobias Burnus  <burnus@net-b.de>
+
+	* decl.c (gfc_match_decl_type_spec): Support
+	TYPE(intrinsic-type-spec).
+
+2010-06-25  Tobias Burnus  <burnus@net-b.de>
+
+	* intrinsic.h (gfc_check_selected_real_kind,
+	gfc_simplify_selected_real_kind): Update prototypes.
+	* intrinsic.c (add_functions): Add radix support to
+	selected_real_kind.
+	* check.c (gfc_check_selected_real_kind): Ditto.
+	* simplify.c (gfc_simplify_selected_real_kind): Ditto.
+	* trans-decl.c (gfc_build_intrinsic_function_decls):
+	Change call from selected_real_kind to selected_real_kind2008.
+	* intrinsic.texi (SELECTED_REAL_KIND): Update for radix.
+	(PRECISION, RANGE, RADIX): Add cross @refs.
+
+2010-06-25  Tobias Burnus  <burnus@net-b.de>
+
+	* decl.c (gfc_match_entry): Mark ENTRY as GFC_STD_F2008_OBS.
+	* gfortran.texi (_gfortran_set_options): Update for
+	GFC_STD_F2008_OBS addition.
+	* libgfortran.h: Add GFC_STD_F2008_OBS.
+	* options.c (set_default_std_flags, gfc_handle_option): Handle
+	GFC_STD_F2008_OBS.
+	io.c (check_format): Fix allow_std check.
+
+2010-06-25  Tobias Burnus  <burnus@net-b.de>
+
+	* decl.c (gfc_match_entry): Allow END besides
+	END SUBROUTINE/END FUNCTION for contained procedures.
+
+2010-06-25  Tobias Burnus  <burnus@net-b.de>
+
+	* parse.c (next_free, next_fixed): Allow ";" as first character.
+
+2010-06-24  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/44614
+	* decl.c (variable_decl): Fix IMPORT diagnostic for CLASS.
+
+2010-06-22  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44616
+	* resolve.c (resolve_fl_derived): Avoid checking for abstract on class
+	containers.
+
+2010-06-21  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40632
+	* interface.c (compare_parameter): Add gfc_is_simply_contiguous
+	checks.
+	* symbol.c (gfc_add_contiguous): New function.
+	(gfc_copy_attr, check_conflict): Handle contiguous attribute.
+	* decl.c (match_attr_spec): Ditto.
+	(gfc_match_contiguous): New function.
+	* resolve.c (resolve_fl_derived, resolve_symbol): Handle
+	contiguous.
+	* gfortran.h (symbol_attribute): Add contiguous.
+	(gfc_is_simply_contiguous): Add prototype.
+	(gfc_add_contiguous): Add prototype.
+	* match.h (gfc_match_contiguous): Add prototype.
+	* parse.c (decode_specification_statement,
+	decode_statement): Handle contiguous attribute.
+	* expr.c (gfc_is_simply_contiguous): New function.
+	* dump-parse-tree.c (show_attr): Handle contiguous.
+	* module.c (ab_attribute, attr_bits, mio_symbol_attribute):
+	Ditto.
+	* trans-expr.c (gfc_add_interface_mapping): Copy
+	attr.contiguous.
+	* trans-array.c (gfc_conv_descriptor_stride_get,
+	gfc_conv_array_parameter): Handle contiguous arrays.
+	* trans-types.c (gfc_build_array_type, gfc_build_array_type,
+	gfc_sym_type, gfc_get_derived_type, gfc_get_array_descr_info):
+	Ditto.
+	* trans.h (gfc_array_kind): Ditto.
+	* trans-decl.c (gfc_get_symbol_decl): Ditto.
+
+2010-06-20  Joseph Myers  <joseph@codesourcery.com>
+
+	* options.c (gfc_handle_option): Don't handle N_OPTS.
+
+2010-06-19  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44584
+	* resolve.c (resolve_fl_derived): Reverse ordering of conditions
+	to avoid ICE.
+
+2010-06-18  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/44556
+	* resolve.c (resolve_allocate_deallocate): Properly check
+	part-refs in stat=/errmsg= for invalid use.
+
+2010-06-17  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44558
+	* resolve.c (resolve_typebound_function,resolve_typebound_subroutine):
+	Return directly in case of an error.
+
+2010-06-16  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44549
+	* gfortran.h (gfc_get_typebound_proc): Modified Prototype.
+	* decl.c (match_procedure_in_type): Give a unique gfc_typebound_proc
+	structure to each procedure in a procedure list.
+	* module.c (mio_typebound_proc): Add NULL argument to
+	'gfc_get_typebound_proc'.
+	* symbol.c (gfc_get_typebound_proc): Add a new argument, which is used
+	to initialize the new structure.
+
+2010-06-15  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/43388
+	* gfortran.h (gfc_expr): Add new member 'mold'.
+	* match.c (gfc_match_allocate): Implement the MOLD tag.
+	* resolve.c (resolve_allocate_expr): Ditto.
+	* trans-stmt.c (gfc_trans_allocate): Ditto.
+
+2010-06-15  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/44536
+	* trans-openmp.c (gfc_omp_predetermined_sharing): Don't return
+	OMP_CLAUSE_DEFAULT_SHARED for artificial vars with
+	GFC_DECL_SAVED_DESCRIPTOR set.
+	(gfc_omp_report_decl): New function.
+	* trans.h (gfc_omp_report_decl): New prototype.
+	* f95-lang.c (LANG_HOOKS_OMP_REPORT_DECL): Redefine.
+
+2010-06-13  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/31588
+	PR fortran/43954
+	* gfortranspec.c (lang_specific_driver): Removed deprecation
+	warning for -M.
+	* lang.opt: Add options -M, -MM, -MD, -MMD, -MF, -MG, -MP, -MT, -MQ.
+	* lang-specs.h (CPP_FORWARD_OPTIONS): Add -M* options.
+	* cpp.h (gfc_cpp_makedep): New.
+	(gfc_cpp_add_dep): New.
+	(gfc_cpp_add_target): New.
+	* cpp.c (gfc_cpp_option): Add deps* members.
+	(gfc_cpp_makedep): New.
+	(gfc_cpp_add_dep): New.
+	(gfc_cpp_add_target): New.
+	(gfc_cpp_init_options): Initialize new options.
+	(gfc_cpp_handle_option): Handle new options.
+	(gfc_cpp_post_options): Map new options to libcpp-options.
+	(gfc_cpp_init): Handle deferred -MQ and -MT options.
+	(gfc_cpp_done): If requested, write dependencies to file.
+	* module.c (gfc_dump_module): Add a module filename as target.
+	* scanner.c (open_included_file): New parameter system; add the
+	included file as dependency.
+	(gfc_open_included_file): Add the included file as dependency.
+	(gfc_open_intrinsic_module): Likewise.
+	* invoke.texi: Removed deprecation warning for -M.
+	* gfortran.texi: Removed Makefile-dependencies project.
+
+2010-06-12  Daniel Franke  <franke.daniel@gmail.com>
+
+        * resolve.c (resolve_global_procedure): Improved checking if an
+        explicit interface is required.
+
+2010-06-12  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* trans-decl.c (gfc_build_intrinsic_function_decls): Fix
+	return type.
+	* trans-intrinsic.c (gfc_conv_intrinsic_fdate): Fix argument type.
+	(gfc_conv_intrinsic_ttynam): Likewise.
+	(gfc_conv_intrinsic_trim): Likewise.
+
+2010-06-12  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40117
+	* decl.c (match_procedure_in_type): Allow procedure lists (F08).
+
+2010-06-11  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* trans-intrinsic.c (gfc_build_intrinsic_lib_fndecls): Fix comment.
+
+2010-06-11  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* mathbuiltins.def: Add builtins that do not directly correspond
+	to a Fortran intrinsic, with new macro OTHER_BUILTIN.
+	* f95-lang.c (gfc_init_builtin_functions): Define OTHER_BUILTIN.
+	* trans-intrinsic.c (gfc_intrinsic_map_t): Remove
+	code_{r,c}{4,8,10,16} fields. Add
+	{,complex}{float,double,long_double}_built_in fields.
+	(gfc_intrinsic_map): Adjust definitions of DEFINE_MATH_BUILTIN,
+	DEFINE_MATH_BUILTIN_C and LIB_FUNCTION accordingly. Add
+	definition of OTHER_BUILTIN.
+	(real_compnt_info): Remove unused struct.
+	(builtin_decl_for_precision, builtin_decl_for_float_kind): New
+	functions.
+	(build_round_expr): Call builtin_decl_for_precision instead of
+	series of if-else.
+	(gfc_conv_intrinsic_aint): Call builtin_decl_for_float_kind
+	instead of a switch.
+	(gfc_build_intrinsic_lib_fndecls): Match
+	{real,complex}{4,8,10,16}decl into the C-style built_in_decls.
+	(gfc_get_intrinsic_lib_fndecl): Do not hardcode floating-point
+	kinds.
+	(gfc_conv_intrinsic_lib_function): Go through all the extended
+	gfc_intrinsic_map.
+	(gfc_trans_same_strlen_check): Call builtin_decl_for_float_kind
+	instead of a switch.
+	(gfc_conv_intrinsic_abs): Likewise.
+	(gfc_conv_intrinsic_mod): Likewise.
+	(gfc_conv_intrinsic_sign): Likewise.
+	(gfc_conv_intrinsic_fraction): Likewise.
+	(gfc_conv_intrinsic_nearest): Likewise.
+	(gfc_conv_intrinsic_spacing): Likewise.
+	(gfc_conv_intrinsic_rrspacing): Likewise.
+	(gfc_conv_intrinsic_scale): Likewise.
+	(gfc_conv_intrinsic_set_exponent): Likewise.
+
+2010-06-11  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/42051
+	PR fortran/43896
+	* trans-expr.c (gfc_conv_derived_to_class): Handle array-valued
+	functions with CLASS formal arguments.
+
+2010-06-10  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44207
+	* resolve.c (conformable_arrays): Handle allocatable components.
+
+2010-06-10  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/38273
+	* gfortran.texi: Document that Cray pointers cannot be function
+	results.
+
+2010-06-10  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/36234
+	* gfortran.texi: Document lack of support for syntax
+	"complex FUNCTION name*16()", and existence of alternative
+	legacy syntax "complex*16 FUNCTION name()".
+
+2010-06-10  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/43032
+	* intrinsic.texi (FLUSH): Note the difference between FLUSH and
+	POSIX's fsync(), and how to call the latter from Fortran code.
+
+2010-06-10  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/44457
+	* interface.c (compare_actual_formal): Reject actual arguments with
+	array subscript passed to ASYNCHRONOUS dummys.
+
+2010-06-10  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/38936
+	* gfortran.h (enum gfc_statement): Add ST_ASSOCIATE, ST_END_ASSOCIATE.
+	(struct gfc_symbol): New field `assoc'.
+	(struct gfc_association_list): New struct.
+	(struct gfc_code): New struct `block' in union, move `ns' there
+	and add association list.
+	(gfc_free_association_list): New method.
+	(gfc_has_vector_subscript): Made public;
+	* match.h (gfc_match_associate): New method.
+	* parse.h (enum gfc_compile_state): Add COMP_ASSOCIATE.
+	* decl.c (gfc_match_end): Handle ST_END_ASSOCIATE.
+	* interface.c (gfc_has_vector_subscript): Made public.
+	(compare_actual_formal): Rename `has_vector_subscript' accordingly.
+	* match.c (gfc_match_associate): New method.
+	(gfc_match_select_type): Change reference to gfc_code's `ns' field.
+	* primary.c (match_variable): Don't allow names associated to expr here.
+	* parse.c (decode_statement): Try matching ASSOCIATE statement.
+	(case_exec_markers, case_end): Add ASSOCIATE statement.
+	(gfc_ascii_statement): Hande ST_ASSOCIATE and ST_END_ASSOCIATE.
+	(parse_associate): New method.
+	(parse_executable): Handle ST_ASSOCIATE.
+	(parse_block_construct): Change reference to gfc_code's `ns' field.
+	* resolve.c (resolve_select_type): Ditto.
+	(resolve_code): Ditto.
+	(resolve_block_construct): Ditto and add comment.
+	(resolve_select_type): Set association list in generated BLOCK to NULL.
+	(resolve_symbol): Resolve associate names.
+	* st.c (gfc_free_statement): Change reference to gfc_code's `ns' field
+	and free association list.
+	(gfc_free_association_list): New method.
+	* symbol.c (gfc_new_symbol): NULL new field `assoc'.
+	* trans-stmt.c (gfc_trans_block_construct): Change reference to
+	gfc_code's `ns' field.
+
+2010-06-10  Kai Tietz  <kai.tietz@onevision.com>
+
+	* error.c (error_print): Pre-initialize loc by NULL.
+	* openmp.c (resolve_omp_clauses): Add explicit
+	braces to avoid ambigous else.
+	* array.c (match_subscript): Pre-initialize m to MATCH_ERROR.
+
+2010-06-10  Gerald Pfeifer  <gerald@pfeifer.com>
+
+	* gfc-internals.texi: Move to GFDL 1.3.
+	* gfortran.texi: Ditto.
+	* intrinsic.texi: Ditto.
+	* invoke.texi: Ditto.
+
+2010-06-09  Daniel Franke  <franke.daniel@gmail.com>
+
+        PR fortran/44347
+        * check.c (gfc_check_selected_real_kind): Verify that the
+        actual arguments are scalar.
+
+2010-06-09  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/44359
+	* intrinsic.c (gfc_convert_type_warn): Further improve -Wconversion.
+
+2010-06-09  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44430
+	* dump-parse-tree.c (show_symbol): Avoid infinite loop.
+
+2010-06-09  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* fortran/symbol.c (check_conflict):  Remove an invalid conflict check.
+
+2010-06-09  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* fortran/intrinsic.c (add_functions): Change gfc_check_btest,
+	gfc_check_ibclr, and gfc_check_ibset to gfc_check_bitfcn.
+	* fortran/intrinsic.h: Remove prototypes for gfc_check_btest,
+	gfc_check_ibclr, and gfc_check_ibset.  Add prototype for
+	gfc_check_bitfcn.
+	* fortran/check.c (nonnegative_check, less_than_bitsize1, 
+	less_than_bitsize2): New functions.
+	(gfc_check_btest): Renamed to gfc_check_bitfcn.  Use
+	nonnegative_check and less_than_bitsize1.
+	(gfc_check_ibclr, gfc_check_ibset): Removed.
+	(gfc_check_ibits,gfc_check_mvbits): Use nonnegative_check and
+	less_than_bitsize1.
+
+2010-06-09  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44211
+	* resolve.c (resolve_typebound_function,resolve_typebound_subroutine):
+	Resolve references.
+
+2010-06-09  Kai Tietz  <kai.tietz@onevision.com>
+
+	* resolve.c (resolve_deallocate_expr): Avoid warning
+	about possible use of iunitialized sym.
+	(resolve_allocate_expr): Pre-initialize sym by NULL.
+
+2010-06-09  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/43040
+	* f95-lang.c (gfc_init_builtin_functions): Remove comment.
+
+2010-06-08  Laurynas Biveinis  <laurynas.biveinis@gmail.com>
+
+	* trans-types.c (gfc_get_nodesc_array_type): Use typed GC
+	allocation.
+	(gfc_get_array_type_bounds): Likewise.
+
+	* trans-decl.c (gfc_allocate_lang_decl): Likewise.
+	(gfc_find_module): Likewise.
+
+	* f95-lang.c (pushlevel): Likewise.
+
+	* trans.h (struct lang_type): Add variable_size GTY option.
+	(struct lang_decl): Likewise.
+
+2010-06-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/44446
+	* symbol.c (check_conflict): Move protected--external/procedure check ...
+	* resolve.c (resolve_select_type): ... to the resolution stage.
+
+2010-06-07  Tobias Burnus  <burnus@net-b.de>
+
+	* options.c (gfc_handle_option): Fix -fno-recursive.
+
+2010-06-07  Tobias Burnus  <burnus@net-b.de>
+
+	* gfc-internals.texi (copyrights-gfortran): Fix copyright year format.
+	* gfortran.texi (copyrights-gfortran): Ditto.
+
+2010-06-07  Joseph Myers  <joseph@codesourcery.com>
+
+	* lang.opt (fshort-enums): Define using Var and VarExists.
+	* options.c (gfc_handle_option): Don't set flag_short_enums here.
+
+2010-06-05  Paul Thomas  <pault@gcc.gnu.org>
+	    Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/43945
+	* resolve.c (get_declared_from_expr): Move to before
+	resolve_typebound_generic_call.  Make new_ref and class_ref
+	ignorable if set to NULL.
+	(resolve_typebound_generic_call): Once we have resolved the
+	generic call, check that the specific instance is that which
+	is bound to the declared type.
+	(resolve_typebound_function,resolve_typebound_subroutine): Avoid
+	freeing 'class_ref->next' twice.
+
+2010-06-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/43895
+	* trans-array.c (structure_alloc_comps): Dereference scalar
+	'decl' if it is a REFERENCE_TYPE. Tidy expressions containing
+	TREE_TYPE (decl).
+
+2010-06-04  Joseph Myers  <joseph@codesourcery.com>
+
+	* gfortranspec.c (append_arg, lang_specific_driver): Use
+	GCC-specific formats in diagnostics.
+
+2010-06-02  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/44360
+	* parse.c (gfc_fixup_sibling_symbols): Do not "fix" use-associated
+	symbols.
+
+2010-06-01  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/44371
+	* match.c (gfc_match_stopcode): Move gfc_match_eos call inside 
+	condition block.
+
+2010-05-31  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* fortran/gfortran.texi:  Fix typos in description of variable-format-
+	expressions.
+
+2010-05-31  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/36928
+	* dependency.c (gfc_check_section_vs_section):  Check
+	for interleaving array assignments without conflicts.
+
+2010-05-30  Janus Weil  <janus@gcc.gnu.org>
+
+	* gcc/fortran/gfortran.h (CLASS_DATA): New macro for accessing the
+	$data component of a class container.
+	* gcc/fortran/decl.c (attr_decl1): Use macro CLASS_DATA.
+	* gcc/fortran/expr.c (gfc_check_pointer_assign,gfc_check_assign_symbol,
+	gfc_has_ultimate_allocatable,gfc_has_ultimate_pointer): Ditto.
+	* gcc/fortran/interface.c (matching_typebound_op): Ditto.
+	* gcc/fortran/match.c (gfc_match_allocate, gfc_match_deallocate): Ditto.
+	* gcc/fortran/parse.c (parse_derived): Ditto.
+	* gcc/fortran/primary.c (gfc_match_varspec, gfc_variable_attr,
+	gfc_expr_attr): Ditto.
+	* gcc/fortran/resolve.c (resolve_structure_cons, find_array_spec,
+	resolve_deallocate_expr, resolve_allocate_expr, resolve_select_type,
+	resolve_fl_var_and_proc, resolve_typebound_procedure,
+	resolve_fl_derived): Ditto.
+	* gcc/fortran/symbol.c (gfc_type_compatible): Restructured.
+	* gcc/fortran/trans-array.c (structure_alloc_comps): Use macro
+	CLASS_DATA.
+	* gcc/fortran/trans-decl.c (gfc_get_symbol_decl,
+	gfc_trans_deferred_vars): Ditto.
+	* gcc/fortran/trans-stmt.c (gfc_trans_allocate): Ditto.
+
+2010-05-28  Tobias Burnus  <burnus@net-b.de>
+
+	* options.c (gfc_handle_option): Fix handling of -fno-whole-file.
+
+2010-05-28  Joseph Myers  <joseph@codesourcery.com>
+
+	* gfortranspec.c (append_arg, lang_specific_driver): Use
+	fatal_error instead of fatal.  Use warning instead of fprintf for
+	warnings.
+
+2010-05-28  Joseph Myers  <joseph@codesourcery.com>
+
+	* cpp.c (gfc_cpp_init_0): Use xstrerror instead of strerror.
+	* module.c (write_char, gfc_dump_module, gfc_use_module): Use
+	xstrerror instead of strerror.
+
+2010-05-26  Joseph Myers  <joseph@codesourcery.com>
+
+	* cpp.c (cb_cpp_error): Save and restore
+	global_dc->warn_system_headers, not variable warn_system_headers.
+
+2010-05-26  Steven Bosscher  <steven@gcc.gnu.org>
+
+	* fortran/f95-lang.c: Do not include libfuncs.h, expr.h, and except.h.
+
+2010-05-26  Steven Bosscher  <steven@gcc.gnu.org>
+
+	* trans-common.c: Do not include rtl.h, include output.h instead.
+	* trans-decl.c: Likewise.
+
+2010-05-26  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/40011
+	* resolve.c (resolve_global_procedure): Resolve the gsymbol's
+	namespace before trying to reorder the gsymbols.
+
+2010-05-25  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/30668
+	PR fortran/31346
+	PR fortran/34260
+	* resolve.c (resolve_global_procedure): Add check for global
+	procedures with implicit interfaces and assumed-shape or optional
+	dummy arguments. Verify that function return type, kind and string
+	lengths match.
+
+2010-05-21  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.h: Do not include system.h.
+	* bbt.c: Include system.h.
+	* data.c: Ditto.
+	* dependency.c: Ditto.
+	* dump-parse-tree.c: Ditto.
+	* arith.h: Do not include gfortran.h.
+	* constructor.h: Do not include gfortran.h and splay-tree.h.
+	* match.h: Do not include gfortran.h.
+	* parse.h: Ditto.
+	* target-memory.h: Ditto.
+	* openmp.c: Do not include toplev.h and target.h.
+	* trans-stmt.c: Ditto not include toplev.h.
+	* primary.c: Ditto.
+	* trans-common.c: Tell why toplev.h is needed. And
+	do not include target.h.
+	* trans-expr.c: Tell why toplev.h is needed.
+	* trans-array.c: Ditto.
+	* trans-openmp.c: Ditto.
+	* trans-const.c: Ditto.
+	* trans.c: Ditto.
+	* trans-types.c: Ditto.
+	* trans-io.c: Ditto.
+	* trans-decl.c: Ditto.
+	* scanner.c: Ditto.
+	* convert.c: Ditto.
+	* trans-intrinsic.c: Ditto.
+	* options.c: Ditto.
+
+2010-05-22 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+	PR fortran/43851
+	* match.c (gfc_match_stopcode): Use gfc_match_init_expr. Go to cleanup
+	before returning MATCH_ERROR. Add check for scalar. Add check for
+	default integer kind.
+
+2010-05-22  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44212
+	* match.c (gfc_match_select_type): On error jump back out of the local
+	namespace.
+	* parse.c (parse_derived): Defer creation of vtab symbols to resolution
+	stage, more precisely to ...
+	* resolve.c (resolve_fl_derived): ... this place.
+
+2010-05-22  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44213
+	* resolve.c (ensure_not_abstract): Allow abstract types with
+	non-abstract ancestors.
+
+2010-05-21  Steven Bosscher  <steven@gcc.gnu.org>
+
+	* trans-const.c: Include realmpfr.h.
+	* Make-lang.in: Update dependencies.
+
+2010-05-21  Steven Bosscher  <steven@gcc.gnu.org>
+
+	* trans-const.c, trans-types.c, trans-intrinsic.c:
+	Clean up redundant includes.
+
+2010-05-20  Daniel Franke  <franke.daniel@gmail.com>
+
+        PR fortran/38407
+        * lang.opt (Wunused-dummy-argument): New option.
+        * gfortran.h (gfc_option_t): Add warn_unused_dummy_argument.
+        * options.c (gfc_init_options): Disable warn_unused_dummy_argument.
+        (set_Wall): Enable warn_unused_dummy_argument.
+        (gfc_handle_option): Set warn_unused_dummy_argument according to
+        command line.
+        * trans-decl.c (generate_local_decl): Separate warnings about
+        unused variables and unused dummy arguments.
+        * invoke.texi: Documented new option.
+
+2010-05-20  Steven Bosscher  <steven@gcc.gnu.org>
+
+	* trans-expr.c: Do not include convert.h, ggc.h, real.h, and gimple.h.
+	(gfc_conv_string_tmp): Do not assert type comparibilty.
+	*  trans-array.c: Do not include gimple.h, ggc.h, and real.h.
+	(gfc_conv_expr_descriptor): Remove assert.
+	* trans-common.c: Clarify why rtl.h and tm.h are included.
+	* trans-openmp.c: Do not include ggc.h and real.h.
+	Explain why gimple.h is included.
+	* trans-const.c: Do not include ggc.h.
+	* trans-stmt.c: Do not include gimple.h, ggc.h, and real.h.
+	* trans.c: Do not include ggc.h and real.h.
+	Explain why gimple.h is included.
+	* trans-types.c: Do not include tm.h.  Explain why langhooks.h
+	and dwarf2out.h are included.
+	* trans-io.c: Do not include gimple.h and real.h.
+	* trans-decl.c: Explain why gimple.h, tm.h, and rtl.h are included.
+	* trans-intrinsic.c: Do not include gimple.h.  Explain why tm.h
+	is included.
+
+2010-05-20  Tobias Burnus  <burnus@net-b.de>
+
+	* options.c (gfc_init_options,gfc_post_options): Enable
+	flag_associative_math by default.
+
+2010-05-19 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+	PR fortran/43851
+	* trans-stmt.c (gfc_trans_stop): Add generation of call to
+	gfortran_error_stop_numeric. Fix up some whitespace. Use stop_string for
+	blank STOP, handling a null expression. (gfc_trans_pause): Use
+	pause_string for blank PAUSE.
+	* trans.h: Add external function declaration for error_stop_numeric.
+	* trans-decl.c (gfc_build_builtin_function_decls): Add the building of
+	the declaration for the library call. Adjust whitespaces.
+	* match.c (gfc_match_stopcode): Remove use of the actual stop code to
+	signal no stop code. Match the expression following the stop and pass
+	that to the translators. Remove the old use of digit matching.  Add
+	checks that the stop_code expression is INTEGER or CHARACTER, constant,
+	and if CHARACTER, default character KIND.
+
+2010-05-19  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/44055
+	* lang.opt (Wconversion-extra): New option.
+	* gfortran.h (gfc_option_t): Add warn_conversion_extra.
+	* options.c (gfc_init_options): Disable -Wconversion-extra by default.
+	(set_Wall): Enable -Wconversion.
+	(gfc_handle_option): Set warn_conversion_extra.
+	* intrinsic.c (gfc_convert_type_warn): Ignore kind conditions
+	introduced for -Wconversion if -Wconversion-extra is present.
+	* invoke.texi: Add -Wconversion to -Wall; document new behaviour of
+	-Wconversion; document -Wconversion-extra.
+
+2010-05-19  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/42360
+	* gfortran.h (gfc_has_default_initializer): New.
+	* expr.c (gfc_has_default_initializer): New.
+	* resolve.c (has_default_initializer): Removed, use
+	gfc_has_default_initializer() instead. Updated all callers.
+	* trans-array.c (has_default_initializer): Removed, use
+	gfc_has_default_initializer() instead. Updated all callers.
+	* trans-decl.c (generate_local_decl): Do not check the
+	first component only to check for initializers, but use
+	gfc_has_default_initializer() instead.
+
+2010-05-19  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/38404
+	* primary.c (match_string_constant): Move start_locus just inside 
+	the string.
+	* data.c (create_character_intializer): Clarified truncation warning.
+
+2010-05-19  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/34505
+	* intrinsic.h (gfc_check_float): New prototype.
+	(gfc_check_sngl): New prototype.
+	* check.c (gfc_check_float): New.
+	(gfc_check_sngl): New.
+	* intrinsic.c (add_functions): Moved DFLOAT from aliasing DBLE
+	to be a specific for REAL. Added check routines for FLOAT, DFLOAT
+	and SNGL.
+	* intrinsic.texi: Removed individual nodes of FLOAT, DFLOAT and SNGL,
+	added them to the list of specifics of REAL instead.
+
+2010-05-17  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/43990
+	* trans-expr.c (gfc_conv_structure): Remove unneeded and buggy code.
+	This is now handled via 'gfc_class_null_initializer'.
+
+2010-05-17  Janus Weil  <janus@gcc.gnu.org>
+
+	* class.c (gfc_add_component_ref,gfc_class_null_initializer,
+	gfc_build_class_symbol,add_proc_component,add_proc_comps, 
+	add_procs_to_declared_vtab1,copy_vtab_proc_comps,
+	add_procs_to_declared_vtab,add_generic_specifics, 
+	add_generics_to_declared_vtab,gfc_find_derived_vtab,
+	find_typebound_proc_uop,gfc_find_typebound_proc,
+	gfc_find_typebound_user_op,gfc_find_typebound_intrinsic_op, 
+	gfc_get_tbp_symtree): Moved here from other places.
+	* expr.c (gfc_add_component_ref,gfc_class_null_initializer): Move to
+	class.c.
+	* gfortran.h (gfc_build_class_symbol,gfc_find_derived_vtab,
+	gfc_find_typebound_proc,gfc_find_typebound_user_op,
+	gfc_find_typebound_intrinsic_op,gfc_get_tbp_symtree,
+	gfc_add_component_ref, gfc_class_null_initializer): Moved to class.c.
+	* Make-lang.in: Add class.o.
+	* symbol.c (gfc_build_class_symbol,add_proc_component,add_proc_comps,
+	add_procs_to_declared_vtab1,copy_vtab_proc_comps,
+	add_procs_to_declared_vtab,add_generic_specifics,
+	add_generics_to_declared_vtab,gfc_find_derived_vtab,
+	find_typebound_proc_uop,gfc_find_typebound_proc,
+	gfc_find_typebound_user_op,gfc_find_typebound_intrinsic_op,
+	gfc_get_tbp_symtree): Move to class.c.
+
+2010-05-17  Nathan Froyd  <froydnj@codesourcery.com>
+
+	* trans-types.c (gfc_init_types): Use build_function_type_list.
+	(gfc_get_ppc_type): Likewise.
+	* trans-decl.c (gfc_generate_constructors): Likewise.
+	* f95-lang.c (build_builtin_fntypes): Likewise.
+	(gfc_init_builtin_functions): Likewise.
+	(DEF_FUNCTION_TYPE_0): Likewise.
+	(DEF_FUNCTION_TYPE_1): Likewise.
+	(DEF_FUNCTION_TYPE_2): Likewise.
+	(DEF_FUNCTION_TYPE_3): Likewise.
+	(DEF_FUNCTION_TYPE_4): Likewise.
+	(DEF_FUNCTION_TYPE_5): Likewise.
+	(DEF_FUNCTION_TYPE_6): Likewise.
+	(DEF_FUNCTION_TYPE_7): Likewise.  Use ARG7.
+	(DEF_FUNCTION_TYPE_VAR_0): Use build_varags_function_type_list.
+ 
+2010-05-17  Nathan Froyd  <froydnj@codesourcery.com>
+
+	* trans-array.c (gfc_trans_array_constructor_value): Use
+	build_constructor instead of build_constructor_from_list.
+	(gfc_build_constant_array_constructor): Likewise.
+	* trans-decl.c (create_main_function): Likewise.
+	* trans-stmt.c (gfc_trans_character_select): Likewise.
+
+2010-05-17  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44044
+	* resolve.c (resolve_fl_var_and_proc): Move error messages here from ...
+	(resolve_fl_variable_derived): ... this place.
+	(resolve_symbol): Make sure function symbols (and their result
+	variables) are not resolved twice.
+
+2010-05-16  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/35779
+	* array.c (match_array_list): Revert change from 2010-05-13.
+
+2010-05-16  Richard Guenther  <rguenther@suse.de>
+
+	* trans-decl.c (module_htab_decls_hash): Revert last change.
+
+2010-05-16  Richard Guenther  <rguenther@suse.de>
+
+	* trans-decl.c (module_htab_decls_hash): Use IDENTIFIER_HASH_VALUE.
+
+2010-05-16  Manuel López-Ibáñez  <manu@gcc.gnu.org>
+
+	* options.c (set_Wall): Remove special logic for Wuninitialized
+	without -O.
+
+2010-05-15  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44154
+	PR fortran/42647
+	* trans-decl.c (gfc_trans_deferred_vars): Modify ordering of
+	if branches.
+
+2010-05-15  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/43207
+	PR fortran/43969
+	* gfortran.h (gfc_class_null_initializer): New prototype.
+	* expr.c (gfc_class_null_initializer): New function to build a NULL
+	initializer for CLASS pointers.
+	* symbol.c (gfc_build_class_symbol): Modify internal naming of class
+	containers. Remove default NULL initialization of $data component.
+	* trans.c (gfc_allocate_array_with_status): Fix wording of an error 
+	message.
+	* trans-expr.c (gfc_conv_initializer,gfc_trans_subcomponent_assign):
+	Use new function 'gfc_class_null_initializer'.
+	* trans-intrinsic.c (gfc_conv_allocated): Handle allocatable scalar
+	class variables.
+
+2010-05-14  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/44135
+	* fortran/interface.c (get_sym_storage_size): Use signed instead of
+	unsigned mpz_get_?i routines.
+
+2010-05-14  Jakub Jelinek  <jakub@redhat.com>
+
+	* trans.c (trans_code): Set backend locus early.
+	* trans-decl.c (gfc_get_fake_result_decl): Use source location
+	of the function instead of current input_location.
+
+2010-05-13  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/35779
+	* intrinsic.c (gfc_init_expr): Renamed to gfc_init_expr_flag.
+	Updated all usages.
+	* expr.c (init_flag): Removed; use gfc_init_expr_flag everywhere.
+	* array.c (match_array_list): Pass on gfc_init_expr_flag when matching
+	iterators.
+
+2010-05-13  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/44036
+	* openmp.c (resolve_omp_clauses): Allow procedure pointers in clause
+	variable lists.
+	* trans-openmp.c (gfc_omp_privatize_by_reference): Don't privatize
+	by reference dummy procedures or non-dummy procedure pointers.
+	(gfc_omp_predetermined_sharing): Return
+	OMP_CLAUSE_DEFAULT_FIRSTPRIVATE for dummy procedures.
+
+2010-05-11  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/43711
+	* openmp.c (gfc_match_omp_taskwait): Report unexpected characters
+	after OMP statement.
+	(gfc_match_omp_critical): Likewise.
+	(gfc_match_omp_flush): Likewise.
+	(gfc_match_omp_workshare): Likewise.
+	(gfc_match_omp_master): Likewise.
+	(gfc_match_omp_ordered): Likewise.
+	(gfc_match_omp_atomic): Likewise.
+	(gfc_match_omp_barrier): Likewise.
+	(gfc_match_omp_end_nowait): Likewise.
+
+2010-05-11  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/31820
+	* resolve.c (validate_case_label_expr): Removed FIXME.
+	(resolve_select): Raise default warning on case labels out of range
+	of the case expression.
+
+2010-05-10  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/27866
+	PR fortran/35003
+	PR fortran/42809
+	* intrinsic.c (gfc_convert_type_warn): Be more discriminative
+	about conversion warnings.
+
+2010-05-10  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44044
+	* match.c (gfc_match_select_type): Move error message to
+	resolve_select_type.
+	* resolve.c (resolve_select_type): Error message moved here from
+	gfc_match_select_type. Correctly set type of temporary.
+
+2010-05-10  Richard Guenther  <rguenther@suse.de>
+
+	* trans-decl.c (gfc_build_library_function_decl): Split out
+	worker to ...
+	(build_library_function_decl_1): ... this new function.
+	Set a fnspec attribute if a specification was provided.
+	(gfc_build_library_function_decl_with_spec): New function.
+	(gfc_build_intrinsic_function_decls): Annotate internal_pack
+	and internal_unpack.
+
+2010-05-07  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/40728
+	* intrinc.c (gfc_is_intrinsic): Do not prematurely mark symbol
+	as external.
+
+2010-05-07  Jason Merrill  <jason@redhat.com>
+
+	* trans-expr.c (gfc_conv_procedure_call): Rename nullptr to null_ptr
+	to avoid -Wc++-compat warning.
+
+2010-05-06  Manuel López-Ibáñez  <manu@gcc.gnu.org>
+
+	PR 40989
+	* options.c (gfc_handle_option): Add argument kind.
+	* gfortran.h (gfc_handle_option): Update declaration.
+
+2010-05-06  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/43985
+	* trans-types.c (gfc_sym_type): Mark Cray pointees as
+	GFC_POINTER_TYPE_P.
+
+2010-05-05  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/32331
+	* resolve.c (traverse_data_list): Rephrase error message for
+	non-constant bounds in data-implied-do.
+
+2010-05-05  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/24978
+	* gfortran.h: Removed repeat count from constructor, removed
+	all usages.
+	* data.h (gfc_assign_data_value_range): Changed return value from
+	void to gfc_try.
+	* data.c (gfc_assign_data_value): Add location to constructor element.
+	(gfc_assign_data_value_range): Call gfc_assign_data_value()
+	for each element in range. Return early if an error was generated.
+	* resolve.c (check_data_variable): Stop early if range assignment
+	generated an error.
+
+2010-05-05  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/43696
+	* resolve.c (resolve_fl_derived): Some fixes for class variables.
+	* symbol.c (gfc_build_class_symbol): Add separate class container for
+	class pointers.
+
+2010-05-03  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/43592
+	* fortran/parse.c (parse_interface): Do not dereference a NULL pointer.
+
+2010-05-02  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* intrinsic.c (add_functions): Fix GFC_STD and add gfc_resolve_ calls
+	for lcobound, ucobound, image_index and this_image.
+	* intrinsic.h (gfc_resolve_lcobound, gfc_resolve_this_image,
+	gfc_resolve_image_index, gfc_resolve_ucobound): New prototypes.
+	* iresolve.c (gfc_resolve_lcobound, gfc_resolve_this_image,
+	gfc_resolve_image_index, gfc_resolve_ucobound, resolve_bound): New
+	functions.
+	(gfc_resolve_lbound, gfc_resolve_ubound): Use resolve_bound.
+
+2010-04-30  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	PR fortran/43931
+	*  trans-types.c (gfc_get_array_descriptor_base): Fix index
+	calculation for array descriptor types.
+
+2010-04-29  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/43896
+	* symbol.c (add_proc_component,copy_vtab_proc_comps): Remove
+	initializers for PPC members of the vtabs.
+
+2010-04-29  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42274
+	* symbol.c (add_proc_component,add_proc_comps): Correctly set the 'ppc'
+	attribute for all PPC members of the vtypes.
+	(copy_vtab_proc_comps): Copy the correct interface.
+	* trans.h (gfc_trans_assign_vtab_procs): Modified prototype.
+	* trans-expr.c (gfc_trans_assign_vtab_procs): Pass the derived type as
+	a dummy argument and make sure all PPC members of the vtab are
+	initialized correctly.
+	(gfc_conv_derived_to_class,gfc_trans_class_assign): Additional argument
+	in call to gfc_trans_assign_vtab_procs.
+	* trans-stmt.c (gfc_trans_allocate): Ditto.
+
+2010-04-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/43326
+	* resolve.c (resolve_typebound_function): Renamed
+	resolve_class_compcall.Do all the detection of class references
+	here.
+	(resolve_typebound_subroutine): resolve_class_typebound_call
+	renamed. Otherwise same as resolve_typebound_function.
+	(gfc_resolve_expr): Call resolve_typebound_function.
+	(resolve_code): Call resolve_typebound_subroutine.
+
+2010-04-29  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/43492
+	* resolve.c (resolve_typebound_generic_call): For CLASS methods
+	pass back the specific symtree name, rather than the target
+	name.
+
+2010-04-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/42353
+	* resolve.c (resolve_structure_cons): Make the initializer of
+	the vtab component 'extends' the same type as the component.
+
+2010-04-29  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/42680
+	* interface.c (check_interface1): Pass symbol name rather than NULL to
+	gfc_compare_interfaces.(gfc_compare_interfaces): Add assert to
+	trap MULL. (gfc_compare_derived_types): Revert previous change
+	incorporated incorrectly during merge from trunk, r155778.
+	* resolve.c (check_generic_tbp_ambiguity): Pass symbol name rather
+	than NULL to gfc_compare_interfaces.
+	* symbol.c (add_generic_specifics): Likewise.
+
+2010-02-29  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42353
+	* interface.c (gfc_compare_derived_types): Add condition for vtype.
+	* symbol.c (gfc_find_derived_vtab): Sey access to private.
+	(gfc_find_derived_vtab): Likewise.
+	* module.c (ab_attribute): Add enumerator AB_VTAB.
+	(mio_symbol_attribute): Use new attribute, AB_VTAB.
+	(check_for_ambiguous): Likewise.
+
+2010-04-29  Paul Thomas  <pault@gcc.gnu.org>
+	    Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41829
+	* trans-expr.c (select_class_proc): Remove function.
+	(conv_function_val): Delete reference to previous.
+	(gfc_conv_derived_to_class): Add second argument to the call to
+	gfc_find_derived_vtab.
+	(gfc_conv_structure): Exclude proc_pointer components when
+	accessing $data field of class objects.
+	(gfc_trans_assign_vtab_procs): New function.
+	(gfc_trans_class_assign): Add second argument to the call to
+	gfc_find_derived_vtab.
+	* symbol.c (gfc_build_class_symbol): Add delayed_vtab arg and
+	implement holding off searching for the vptr derived type.
+	(add_proc_component): New function.
+	(add_proc_comps): New function.
+	(add_procs_to_declared_vtab1): New function.
+	(copy_vtab_proc_comps): New function.
+	(add_procs_to_declared_vtab): New function.
+	(void add_generic_specifics): New function.
+	(add_generics_to_declared_vtab): New function.
+	(gfc_find_derived_vtab): Add second argument to the call to
+	gfc_find_derived_vtab. Add the calls to
+	add_procs_to_declared_vtab and add_generics_to_declared_vtab.
+	* decl.c (build_sym, build_struct): Use new arg in calls to
+	gfc_build_class_symbol.
+	* gfortran.h : Add vtype bitfield to symbol_attr. Remove the
+	definition of struct gfc_class_esym_list. Modify prototypes
+	of gfc_build_class_symbol and gfc_find_derived_vtab.
+	* trans-stmt.c (gfc_trans_allocate): Add second argument to the
+	call to gfc_find_derived_vtab.
+	* module.c : Add the vtype attribute.
+	* trans.h : Add prototype for gfc_trans_assign_vtab_procs.
+	* resolve.c (resolve_typebound_generic_call): Add second arg
+	to pass along the generic name for class methods.
+	(resolve_typebound_call): The same.
+	(resolve_compcall): Use the second arg to carry the generic
+	name from the above. Remove the reference to class_esym.
+	(check_members, check_class_members, resolve_class_esym,
+	hash_value_expr): Remove functions.
+	(resolve_class_compcall, resolve_class_typebound_call): Modify
+	to use vtable rather than member by member calls.
+	(gfc_resolve_expr): Modify second arg in call to
+	resolve_compcall.
+	(resolve_select_type): Add second arg in call to
+	gfc_find_derived_vtab.
+	(resolve_code): Add second arg in call resolve_typebound_call.
+	(resolve_fl_derived): Exclude vtypes from check for late
+	procedure definitions. Likewise for checking of explicit
+	interface and checking of pass arg.
+	* iresolve.c (gfc_resolve_extends_type_of): Add second arg in
+	calls to gfc_find_derived_vtab.
+	* match.c (select_type_set_tmp): Use new arg in call to
+	gfc_build_class_symbol.
+	* trans-decl.c (gfc_get_symbol_decl): Complete vtable if
+	necessary.
+	* parse.c (endType): Finish incomplete classes.
+
+2010-04-28  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	PR fortran/43919
+	* simplify.c (simplify_cobound): Handle scalar coarrays.
+
+2010-04-27  Tobias Burnus  <burnus@net-b.de>
+
+	* gfc-internals.texi: Update copyright year.
+	* gfortran.texi: Ditto.
+	* invoke.texi: Ditto.
+
+2010-04-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* resolve.c (resolve_allocate_expr): Allow array coarrays.
+	* trans-types.h (gfc_get_array_type_bounds): Update prototype.
+	* trans-types.c (gfc_get_array_type_bounds,
+	gfc_get_array_descriptor_base): Add corank argument.
+	* trans-array.c (gfc_array_init_size): Handle corank.
+	(gfc_trans_create_temp_array, gfc_array_allocate,
+	gfc_conv_expr_descriptor): Add corank argument to call.
+	* trans-stmt.c (gfc_trans_pointer_assign_need_temp): Ditto.
+
+2010-04-24  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/30073
+	PR fortran/43793
+	* trans-array.c (gfc_trans_array_bound_check): Use TREE_CODE instead
+	of mucking with a tree directly.
+
+2010-04-24  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/43832
+	* io.c (gfc_match_open): Remove branch to syntax error. Add call to
+	gfc_error with new error message.
+
+2010-04-24  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/43841
+	PR fortran/43843
+	* trans-expr.c (gfc_conv_expr): Supply an address expression for
+	GFC_SS_REFERENCE.
+	(gfc_conv_expr_reference): Call gfc_conv_expr and return for
+	GFC_SS_REFERENCE.
+	* trans-array.c (gfc_add_loop_ss_code): Store the value rather
+	than the address of a GFC_SS_REFERENCE.
+	* trans.h : Change comment on GFC_SS_REFERENCE. 
+
+2010-04-22  Richard Guenther  <rguenther@suse.de>
+
+	PR fortran/43829
+	* resolve.c (gfc_resolve_index): Wrap around ...
+	(gfc_resolve_index_1): ... this.  Add parameter to allow
+	any integer kind index type.
+	(resolve_array_ref): Allow any integer kind for the start
+	index of an array ref.
+
+2010-04-21  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/43836
+	* f95-lang.c (gfc_define_builtin): Set TREE_NOTHROW on
+	the decl.
+
+2010-04-20  Harald Anlauf  <anlauf@gmx.de>
+
+	* intrinsic.c (sort_actual): Remove 'is' in error message.
+
+2010-04-20  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/43227
+	* resolve.c (resolve_fl_derived): If a component character
+	length has not been resolved, do so now.
+	(resolve_symbol): The same as above for a symbol character
+	length.
+	* trans-decl.c (gfc_create_module_variable): A 'length' decl is
+	not needed for a character valued, procedure pointer.
+
+	PR fortran/43266
+	* resolve.c (ensure_not_abstract_walker): If 'overriding' is
+	not found, return FAILURE rather than ICEing.
+
+2010-04-19  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/43339
+	* openmp.c (gfc_resolve_do_iterator): Only make iteration vars for
+	sequential loops private in the innermost containing task region.
+
+2010-04-18  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* f95-lang.c (gfc_init_decl_processing): Remove second argument in call
+	to build_common_tree_nodes.
+
+2010-04-17  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/31538
+	* fortran/trans-array.c (gfc_conv_ss_startstride): Remove the use of
+	gfc_msg_bounds by using 'Array bound mismatch' directly.
+	(gfc_trans_dummy_array_bias):  Remove the use of gfc_msg_bounds.  Reword
+	error message to include the mismatch in the extent of array bound.
+	* fortran/trans.c: Remove gfc_msg_bounds.  It is only used in one place.
+	* fortran/trans.h: Remove extern definition of gfc_msg_bounds.
+
+2010-04-17  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	* gfortran.texi: Update information on temporary file locations.
+
+2010-04-16  Jakub Jelinek  <jakub@redhat.com>
+
+	* trans-decl.c (gfc_build_qualified_array): Ensure
+	ubound.N and lbound.N artificial variable names don't appear
+	in debug info.
+
+2010-04-15  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/30073
+	* trans-array.c (gfc_trans_array_bound_check): Eliminate a redundant
+	block of code.  Set name to the variable associated with the descriptor.
+
+2010-04-15  Jakub Jelinek  <jakub@redhat.com>
+
+	* trans-decl.c (gfc_build_qualified_array): Clear DECL_IGNORED_P
+	on VAR_DECL LBOUND and/or UBOUND, even for -O1.
+
+2010-04-14  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* intrinsic.texi: Add the missing specific name of intrinsic
+	procedure where the specific name is identical to the generic name.
+	Fix inconsistent or mismatch in the argument names in intrinsic
+	procedure descriptions.  Add the SCALAR allocatable description to
+	ALLOCATED.
+
+2010-04-14  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* array.c (gfc_find_array_ref): Handle codimensions.
+	(gfc_match_array_spec,gfc_match_array_ref): Use gfc_fatal_error.
+	* check.c (is_coarray, dim_corank_check, gfc_check_lcobound,
+	gfc_check_image_index, gfc_check_this_image, gfc_check_ucobound):
+	New functions.
+	* gfortran.h (gfc_isym_id): Add GFC_ISYM_IMAGE_INDEX,
+	GFC_ISYM_LCOBOUND, GFC_ISYM_THIS_IMAGE,
+	GFC_ISYM_UCOBOUND.
+	* intrinsic.h (add_functions): Add this_image, image_index,
+	lcobound and ucobound intrinsics.
+	* intrinsic.c (gfc_check_lcobound,gfc_check_ucobound,
+	gfc_check_image_index, gfc_check_this_image,
+	gfc_simplify_image_index, gfc_simplify_lcobound,
+	gfc_simplify_this_image, gfc_simplify_ucobound):
+	New function prototypes.
+	* intrinsic.texi (IMAGE_INDEX, LCOBOUND, THIS_IMAGE
+	IMAGE_INDEX): Document new intrinsic functions.
+	* match.c (gfc_match_critical, sync_statement): Make -fcoarray=none
+	error fatal.
+	* simplify.c (simplify_bound_dim): Handle coarrays.
+	(simplify_bound): Update simplify_bound_dim call.
+	(gfc_simplify_num_images): Add -fcoarray=none check.
+	(simplify_cobound, gfc_simplify_lcobound, gfc_simplify_ucobound,
+	gfc_simplify_ucobound, gfc_simplify_ucobound): New functions.
+
+2010-04-14  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/43747
+	* constructor.c: Fix typo in comment.
+	* expr.c (find_array_section): Add check for max array limit.
+
+2010-04-13  Iain Sandoe  <iains@gcc.gnu.org>
+
+	PR bootstrap/31400
+	* gfortranspec.c (lookup_option): Check for -static and return
+	OPTION_static.
+	(lang_specific_driver): Break when OPTION_static is discovered.
+
+2010-04-12  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	* array.c (extract_element): Restore function from trunk.
+	(gfc_get_array_element): Restore function from trunk.
+	(gfc_expand_constructor): Restore check against
+	flag_max_array_constructor.
+	* constructor.c (node_copy_and_append): Delete unused.
+	* gfortran.h: Delete comment and extra include.
+	* constructor.h: Bump copyright and clean up TODO comments.
+	* resolve.c: Whitespace.
+
+2010-04-12  Daniel Franke  <franke.daniel@gmail.com>
+
+	* simplify.c (compute_dot_product): Replaced usage of ADVANCE macro
+	with direct access access to elements. Adjusted prototype, fixed all
+	callers.
+	(gfc_simplify_dot_product): Removed duplicate check for zero-sized
+	array.
+	(gfc_simplify_matmul): Removed usage of ADVANCE macro.
+	(gfc_simplify_spread): Removed workaround, directly insert elements
+	at a given array position.
+	(gfc_simplify_transpose): Likewise.
+	(gfc_simplify_pack): Replaced usage of ADVANCE macro with corresponding
+	function calls.
+	(gfc_simplify_unpack): Likewise.
+
+2010-04-12  Daniel Franke  <franke.daniel@gmail.com>
+
+	* simplify.c (only_convert_cmplx_boz): Renamed to ...
+	(convert_boz): ... this and moved to start of file.
+	(gfc_simplify_abs): Whitespace fix.
+	(gfc_simplify_acos): Whitespace fix.
+	(gfc_simplify_acosh): Whitespace fix.
+	(gfc_simplify_aint): Whitespace fix.
+	(gfc_simplify_dint): Whitespace fix.
+	(gfc_simplify_anint): Whitespace fix.
+	(gfc_simplify_and): Replaced if-gate by more common switch-over-type.
+	(gfc_simplify_dnint): Whitespace fix.
+	(gfc_simplify_asin): Whitespace fix.
+	(gfc_simplify_asinh): Moved creation of result-expr out of switch.
+	(gfc_simplify_atan): Likewise.
+	(gfc_simplify_atanh): Whitespace fix.
+	(gfc_simplify_atan2): Whitespace fix.
+	(gfc_simplify_bessel_j0): Removed ATTRIBUTE_UNUSED.
+	(gfc_simplify_bessel_j1): Likewise.
+	(gfc_simplify_bessel_jn): Likewise.
+	(gfc_simplify_bessel_y0): Likewise.
+	(gfc_simplify_bessel_y1): Likewise.
+	(gfc_simplify_bessel_yn): Likewise.
+	(gfc_simplify_ceiling): Reorderd statements.
+	(simplify_cmplx): Use convert_boz(), check for constant arguments.
+	Whitespace fix.
+	(gfc_simplify_cmplx): Use correct default kind. Removed check for
+	constant arguments.
+	(gfc_simplify_complex): Replaced if-gate. Removed check for
+	constant arguments.
+	(gfc_simplify_conjg): Whitespace fix.
+	(gfc_simplify_cos): Whitespace fix.
+	(gfc_simplify_cosh): Replaced if-gate by more common switch-over-type.
+	(gfc_simplify_dcmplx): Removed check for constant arguments.
+	(gfc_simplify_dble): Use convert_boz() and gfc_convert_constant().
+	(gfc_simplify_digits): Whitespace fix.
+	(gfc_simplify_dim): Whitespace fix.
+	(gfc_simplify_dprod): Reordered statements.
+	(gfc_simplify_erf): Whitespace fix.
+	(gfc_simplify_erfc): Whitespace fix.
+	(gfc_simplify_epsilon): Whitespace fix.
+	(gfc_simplify_exp): Whitespace fix.
+	(gfc_simplify_exponent): Use convert_boz().
+	(gfc_simplify_floor): Reorderd statements.
+	(gfc_simplify_gamma): Whitespace fix.
+	(gfc_simplify_huge): Whitespace fix.
+	(gfc_simplify_iand): Whitespace fix.
+	(gfc_simplify_ieor): Whitespace fix.
+	(simplify_intconv): Use gfc_convert_constant().
+	(gfc_simplify_int): Use simplify_intconv().
+	(gfc_simplify_int2): Reorderd statements.
+	(gfc_simplify_idint): Reorderd statements.
+	(gfc_simplify_ior): Whitespace fix.
+	(gfc_simplify_ishftc): Removed duplicate type check.
+	(gfc_simplify_len): Use range_check() instead of manual range check.
+	(gfc_simplify_lgamma): Removed ATTRIBUTE_UNUSED. Whitespace fix.
+	(gfc_simplify_log): Whitespace fix.
+	(gfc_simplify_log10): Whitespace fix.
+	(gfc_simplify_minval): Whitespace fix.
+	(gfc_simplify_maxval): Whitespace fix.
+	(gfc_simplify_mod): Whitespace fix.
+	(gfc_simplify_modulo): Whitespace fix.
+	(simplify_nint): Reorderd statements.
+	(gfc_simplify_not): Whitespace fix.
+	(gfc_simplify_or): Replaced if-gate by more common switch-over-type.
+	(gfc_simplify_radix): Removed unused result-variable. Whitespace fix.
+	(gfc_simplify_range): Removed unused result-variable. Whitespace fix.
+	(gfc_simplify_real): Use convert_boz() and gfc_convert_constant().
+	(gfc_simplify_realpart): Whitespace fix.
+	(gfc_simplify_selected_char_kind): Removed unused result-variable.
+	(gfc_simplify_selected_int_kind): Removed unused result-variable.
+	(gfc_simplify_selected_real_kind): Removed unused result-variable.
+	(gfc_simplify_sign): Whitespace fix.
+	(gfc_simplify_sin): Whitespace fix.
+	(gfc_simplify_sinh): Replaced if-gate by more common switch-over-type.
+	(gfc_simplify_sqrt): Avoided goto by inlining check. Whitespace fix.
+	(gfc_simplify_tan): Replaced if-gate by more common switch-over-type.
+	(gfc_simplify_tanh): Replaced if-gate by more common switch-over-type.
+	(gfc_simplify_xor): Replaced if-gate by more common switch-over-type.
+
+2010-04-12  Daniel Franke  <franke.daniel@gmail.com>
+
+	* gfortran.h (gfc_start_constructor): Removed.
+	(gfc_get_array_element): Removed.
+	* array.c (gfc_start_constructor): Removed, use gfc_get_array_expr 
+	instead. Fixed all callers.
+	(extract_element): Removed.
+	(gfc_expand_constructor): Temporarily removed check for
+	max-array-constructor. Will be re-introduced later if still required.
+	(gfc_get_array_element): Removed, use gfc_constructor_lookup_expr
+	instead. Fixed all callers.
+	* expr.c (find_array_section): Replaced manual lookup of elements
+	by gfc_constructor_lookup.
+
+2010-04-12  Daniel Franke  <franke.daniel@gmail.com>
+
+	* gfortran.h (gfc_get_null_expr): New prototype.
+	(gfc_get_operator_expr): New prototype.
+	(gfc_get_character_expr): New prototype.
+	(gfc_get_iokind_expr): New prototype.
+	* expr.c (gfc_get_null_expr): New.
+	(gfc_get_character_expr): New.
+	(gfc_get_iokind_expr): New.
+	(gfc_get_operator_expr): Moved here from matchexp.c (build_node).
+	* matchexp.c (build_node): Renamed and moved to
+	expr.c (gfc_get_operator_expr). Reordered arguments to match 
+	other functions. Fixed all callers.
+	(gfc_get_parentheses): Use specific function to build expr.
+	* array.c (gfc_match_array_constructor): Likewise.
+	* arith.c (eval_intrinsic): Likewise.
+	(gfc_hollerith2int): Likewise.
+	(gfc_hollerith2real): Likewise.
+	(gfc_hollerith2complex): Likewise.
+	(gfc_hollerith2logical): Likewise.
+	* data.c (create_character_intializer): Likewise.
+	* decl.c (gfc_match_null): Likewise.
+	(enum_initializer): Likewise.
+	* io.c (gfc_match_format): Likewise.
+	(match_io): Likewise.
+	* match.c (gfc_match_nullify): Likewise.
+	* primary.c (match_string_constant): Likewise.
+	(match_logical_constant): Likewise.
+	(build_actual_constructor): Likewise.
+	* resolve.c (build_default_init_expr): Likewise.
+	* symbol.c (generate_isocbinding_symbol): Likewise.
+	(gfc_build_class_symbol): Likewise.
+	(gfc_find_derived_vtab): Likewise.
+	* simplify.c (simplify_achar_char): Likewise.
+	(gfc_simplify_adjustl): Likewise.
+	(gfc_simplify_adjustr): Likewise.
+	(gfc_simplify_and): Likewise.
+	(gfc_simplify_bit_size): Likewise.
+	(gfc_simplify_is_iostat_end): Likewise.
+	(gfc_simplify_is_iostat_eor): Likewise.
+	(gfc_simplify_isnan): Likewise.
+	(simplify_bound): Likewise.
+	(gfc_simplify_leadz): Likewise.
+	(gfc_simplify_len_trim): Likewise.
+	(gfc_simplify_logical): Likewise.
+	(gfc_simplify_maxexponent): Likewise.
+	(gfc_simplify_minexponent): Likewise.
+	(gfc_simplify_new_line): Likewise.
+	(gfc_simplify_null): Likewise.
+	(gfc_simplify_or): Likewise.
+	(gfc_simplify_precision): Likewise.
+	(gfc_simplify_repeat): Likewise.
+	(gfc_simplify_scan): Likewise.
+	(gfc_simplify_size): Likewise.
+	(gfc_simplify_trailz): Likewise.
+	(gfc_simplify_trim): Likewise.
+	(gfc_simplify_verify): Likewise.
+	(gfc_simplify_xor): Likewise.
+	* trans-io.c (build_dt): Likewise.
+	(gfc_new_nml_name_expr): Removed.
+
+2010-04-12  Daniel Franke  <franke.daniel@gmail.com>
+
+	* arith.h (gfc_constant_result): Removed prototype.
+	* constructor.h (gfc_build_array_expr): Removed prototype.
+	(gfc_build_structure_constructor_expr): Removed prototype.
+	* gfortran.h (gfc_int_expr): Removed prototype.
+	(gfc_logical_expr): Removed prototype.
+	(gfc_get_array_expr): New prototype.
+	(gfc_get_structure_constructor_expr): New prototype.
+	(gfc_get_constant_expr): New prototype.
+	(gfc_get_int_expr): New prototype.
+	(gfc_get_logical_expr): New prototype.
+	* arith.c (gfc_constant_result): Moved and renamed to
+	expr.c (gfc_get_constant_expr). Fixed all callers.
+	* constructor.c (gfc_build_array_expr): Moved and renamed to
+	expr.c (gfc_get_array_expr). Split gfc_typespec argument to type
+	and kind. Fixed all callers.
+	(gfc_build_structure_constructor_expr): Moved and renamed to
+	expr.c (gfc_get_structure_constructor_expr). Split gfc_typespec argument
+	to type and kind. Fixed all callers.
+	* expr.c (gfc_logical_expr): Renamed to ...
+	(gfc_get_logical_expr): ... this. Added kind argument. Fixed all callers.
+	(gfc_int_expr): Renamed to ...
+	(gfc_get_int_expr): ... this. Added kind and where arguments. Fixed all
+	callers.
+	(gfc_get_constant_expr): New.
+	(gfc_get_array_expr): New.
+	(gfc_get_structure_constructor_expr): New.
+	* simplify.c (int_expr_with_kind): Removed, callers use gfc_get_int_expr
+	instead.
+
+2010-04-12  Daniel Franke  <franke.daniel@gmail.com>
+
+	* constructor.h: New.
+	* constructor.c: New.
+	* Make-lang.in: Add new files to F95_PARSER_OBJS.
+	* arith.c (reducy_unary): Use constructor API.
+	(reduce_binary_ac): Likewise.
+	(reduce_binary_ca): Likewise.
+	(reduce_binary_aa): Likewise.
+	* check.c (gfc_check_pack): Likewise.
+	(gfc_check_reshape): Likewise.
+	(gfc_check_unpack): Likewise.
+	* decl.c (add_init_expr_to_sym): Likewise.
+	(build_struct): Likewise.
+	* dependency.c (gfc_check_dependency): Likewise.
+	(contains_forall_index_p): Likewise.
+	* dump-parse-tree.c (show_constructor): Likewise.
+	* expr.c (free_expr0): Likewise.
+	(gfc_copy_expr): Likewise.
+	(gfc_is_constant_expr): Likewise.
+	(simplify_constructor): Likewise.
+	(find_array_element): Likewise.
+	(find_component_ref): Likewise.
+	(find_array_section): Likewise.
+	(find_substring_ref): Likewise.
+	(simplify_const_ref): Likewise.
+	(scalarize_intrinsic_call): Likewise.
+	(check_alloc_comp_init): Likewise.
+	(gfc_default_initializer): Likewise.
+	(gfc_traverse_expr): Likewise.
+	* iresolve.c (check_charlen_present): Likewise.
+	(gfc_resolve_reshape): Likewise.
+	(gfc_resolve_transfer): Likewise.
+	* module.c (mio_constructor): Likewise.
+	* primary.c (build_actual_constructor): Likewise.
+	(gfc_match_structure_constructor): Likewise.
+	* resolve.c (resolve_structure_cons): Likewise.
+	* simplify.c (is_constant_array_expr): Likewise.
+	(init_result_expr): Likewise.
+	(transformational_result): Likewise.
+	(simplify_transformation_to_scalar): Likewise.
+	(simplify_transformation_to_array): Likewise.
+	(gfc_simplify_dot_product): Likewise.
+	(simplify_bound): Likewise.
+	(simplify_matmul): Likewise.
+	(simplify_minval_maxval): Likewise.
+	(gfc_simplify_pack): Likewise.
+	(gfc_simplify_reshape): Likewise.
+	(gfc_simplify_shape): Likewise.
+	(gfc_simplify_spread): Likewise.
+	(gfc_simplify_transpose): Likewise.
+	(gfc_simplify_unpack): Likewise.q
+	(gfc_convert_constant): Likewise.
+	(gfc_convert_char_constant): Likewise.
+	* target-memory.c (size_array): Likewise.
+	(encode_array): Likewise.
+	(encode_derived): Likewise.
+	(interpret_array): Likewise.
+	(gfc_interpret_derived): Likewise.
+	(expr_to_char): Likewise.
+	(gfc_merge_initializers): Likewise.
+	* trans-array.c (gfc_get_array_constructor_size): Likewise.
+	(gfc_trans_array_constructor_value): Likewise.
+	(get_array_ctor_strlen): Likewise.
+	(gfc_constant_array_constructor_p): Likewise.
+	(gfc_build_constant_array_constructor): Likewise.
+	(gfc_trans_array_constructor): Likewise.
+	(gfc_conv_array_initializer): Likewise.
+	* trans-decl.c (check_constant_initializer): Likewise.
+	* trans-expr.c (flatten_array_ctors_without_strlen): Likewise.
+	(gfc_apply_interface_mapping_to_cons): Likewise.
+	(gfc_trans_structure_assign): Likewise.
+	(gfc_conv_structure): Likewise.
+	* array.c (check_duplicate_iterator): Likewise.
+	(match_array_list): Likewise.
+	(match_array_cons_element): Likewise.
+	(gfc_match_array_constructor): Likewise.
+	(check_constructor_type): Likewise.
+	(check_constructor): Likewise.
+	(expand): Likewise.
+	(expand_constructor): Likewise.
+	(extract_element): Likewise.
+	(gfc_expanded_ac): Likewise.
+	(resolve_array_list): Likewise.
+	(gfc_resolve_character_array_constructor): Likewise.
+	(copy_iterator): Renamed to ...
+	(gfc_copy_iterator): ... this.
+	(gfc_append_constructor): Removed.
+	(gfc_insert_constructor): Removed unused function.
+	(gfc_get_constructor): Removed.
+	(gfc_free_constructor): Removed.
+	(qgfc_copy_constructor): Removed.
+	* gfortran.h (struct gfc_expr): Removed member 'con_by_offset'.
+	Removed all references. Replaced constructor list by splay-tree.
+	(struct gfc_constructor): Removed member 'next', moved 'offset' from
+	the inner struct, added member 'base'.
+	(gfc_append_constructor): Removed prototype.
+	(gfc_insert_constructor): Removed prototype.
+	(gfc_get_constructor): Removed prototype.
+	(gfc_free_constructor): Removed prototype.
+	(qgfc_copy_constructor): Removed prototype.
+	(gfc_copy_iterator): New prototype.
+	* trans-array.h (gfc_constant_array_constructor_p): Adjusted prototype.
+
+2010-04-10  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/43591
+	* expr.c (gfc_is_constant_expr, gfc_traverse_expr): Handle
+	proc-pointers and type-bound procedures.
+	(gfc_specification_expr): Check proc-pointers for pureness.
+
+2010-04-09  Iain Sandoe  <iains@gcc.gnu.org>
+
+	PR bootstrap/43684
+	* gfortranspec.c (lang_specific_driver): Do not expose vars 
+	only used by HAVE_LD_STATIC_DYNAMIC targets unless compiling
+	for such.
+
+2010-04-09  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* decl.c (variable_decl, match_attr_spec): Fix setting the array
+	spec.
+	* array.c (match_subscript,gfc_match_array_ref): Add coarray support.
+	* data.c (gfc_assign_data_value): Ditto.
+	* expr.c (gfc_check_pointer_assign): Add check for coarray constraint.
+	(gfc_traverse_expr): Traverse also through codimension expressions.
+	(gfc_is_coindexed, gfc_has_ultimate_allocatable,
+	gfc_has_ultimate_pointer): New functions.
+	* gfortran.h (gfc_array_ref_dimen_type): Add DIMEN_STAR for coarrays.
+	(gfc_array_ref): Add codimen.
+	(gfc_array_ref): Add in_allocate.
+	(gfc_is_coindexed, gfc_has_ultimate_allocatable,
+	gfc_has_ultimate_pointer): Add prototypes.
+	* interface.c (compare_parameter, compare_actual_formal,
+	check_intents): Add coarray constraints.
+	* match.c (gfc_match_iterator): Add coarray constraint.
+	* match.h (gfc_match_array_ref): Update interface.
+	* primary.c (gfc_match_varspec): Handle codimensions.
+	* resolve.c (coarray_alloc, inquiry_argument): New static variables.
+	(check_class_members): Return gfc_try instead for error recovery.
+	(resolve_typebound_function,resolve_typebound_subroutine,
+	check_members): Handle return value of check_class_members.
+	(resolve_structure_cons, resolve_actual_arglist, resolve_function,
+	check_dimension, compare_spec_to_ref, resolve_array_ref,
+	resolve_ref, resolve_variable, gfc_resolve_expr, conformable_arrays,
+	resolve_allocate_expr, resolve_ordinary_assign): Add coarray
+	support.
+	* trans-array.c (gfc_conv_array_ref, gfc_walk_variable_expr):
+	Skip over coarray refs.
+	(gfc_array_allocate) Add support for references containing coindexes.
+	* trans-expr.c (gfc_add_interface_mapping): Copy coarray attribute.
+	(gfc_map_intrinsic_function): Ignore codimensions.
+
+2010-04-08  Bud Davis  <bdavis9659@sbcglobal.net>
+
+	PR fortran/28039
+	* io.c (check_format_string):  Added check for additional non 
+	blank characters after the format string was successfully 
+	parsed.
+	* io.c (check_format): Changed the error messages for positive
+	int required and period required to drop through the error logic
+	and report with gfc_error instead of gfc_error_now.  Corrected
+	format postion for hollerith strings.
+
+2010-04-08  Tobias Burnus  <burnus@net-b.de>
+
+	* module.c (use_iso_fortran_env_module): Fix standard check.
+
+2010-04-07  Jakub Jelinek  <jakub@redhat.com>
+
+	* parse.c (parse_derived, parse_enum): Avoid set but not used
+	warning.
+
+2010-04-07  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	PR fortran/40539
+	* gfortran.texi: Add section about representation of
+	LOGICAL variables.
+
+2010-04-07  Simon Baldwin  <simonb@google.com>
+
+	* cpp.c (cb_cpp_error): Add warning reason argument, set a value
+	for diagnostic_override_option_index if CPP_W_WARNING_DIRECTIVE.
+
+2010-04-07  Richard Guenther  <rguenther@suse.de>
+
+	* options.c (gfc_init_options): Do not set.
+
+2010-04-06  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* array.c (gfc_match_array_spec): Add error for -fcoarray=none.
+	* match.c (gfc_match_critical, sync_statement): Ditto.
+	* gfortran.h (gfc_fcoarray): New enum.
+	(gfc_option_t): Use it.
+	* lang.opt (fcoarray): Add new flag.
+	* invoke.texi (fcoarray): Document it.
+	* options.c (gfc_init_options,gfc_handle_option): Handle -fcoarray=.
+	(gfc_handle_coarray_option): New function.
+
+2010-04-06  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* gfortran.h (gfc_array_spec): Add cotype.
+	* array.c (gfc_match_array_spec,gfc_set_array_spec): Use it
+	and defer error diagnostic.
+	* resolve.c (resolve_fl_derived): Add missing check.
+	(resolve_symbol): Add cotype/type check.
+	* parse.c (parse_derived): Fix setting of coarray_comp.
+
+2010-04-06  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* array.c (gfc_free_array_spec,gfc_resolve_array_spec,
+	match_array_element_spec,gfc_copy_array_spec,
+	gfc_compare_array_spec): Include corank.
+	(match_array_element_spec,gfc_set_array_spec): Support codimension.
+	* decl.c (build_sym,build_struct,variable_decl,
+	match_attr_spec,attr_decl1,cray_pointer_decl,
+	gfc_match_volatile): Add codimension.
+	(gfc_match_codimension): New function.
+	* dump-parse-tree.c (show_array_spec,show_attr): Support codimension.
+	* gfortran.h (symbol_attribute,gfc_array_spec): Ditto.
+	(gfc_add_codimension): New function prototype.
+	* match.h (gfc_match_codimension): New function prototype.
+	(gfc_match_array_spec): Update prototype
+	* match.c (gfc_match_common): Update gfc_match_array_spec call.
+	* module.c (MOD_VERSION): Bump.
+	(mio_symbol_attribute): Support coarray attributes.
+	(mio_array_spec): Add corank support.
+	* parse.c (decode_specification_statement,decode_statement,
+	parse_derived): Add coarray support.
+	* resolve.c (resolve_formal_arglist, was_declared,
+	is_non_constant_shape_array, resolve_fl_variable,
+	resolve_fl_derived, resolve_symbol): Add coarray support.
+	* symbol.c (check_conflict, gfc_add_volatile, gfc_copy_attr,
+	gfc_build_class_symbol): Add coarray support.
+	(gfc_add_codimension): New function.
+
+2010-04-06  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* iso-fortran-env.def: Add the integer parameters atomic_int_kind,
+	atomic_logical_kind, iostat_inquire_internal_unit, stat_locked,
+	stat_locked_other_image, stat_stopped_image and stat_unlocked of
+	Fortran 2008.
+	* intrinsic.texi (iso_fortran_env): Ditto.
+	* libgfortran.h (libgfortran_stat_codes): New enum.
+	* module.c (use_iso_fortran_env_module): Honour -std= when loading
+	constants from the intrinsic module.
+
+2010-04-06  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/39997
+	* intrinsic.c (add_functions): Add num_images.
+	* decl.c (gfc_match_end): Handle END CRITICAL.
+	* intrinsic.h (gfc_simplify_num_images): Add prototype.
+	* dump-parse-tree.c (show_code_node): Dump CRITICAL, ERROR STOP,
+	and SYNC.
+	* gfortran.h (gfc_statement): Add enum items for those.
+	(gfc_exec_op) Ditto.
+	(gfc_isym_id): Add num_images.
+	* trans-stmt.c (gfc_trans_stop): Handle ERROR STOP.
+	(gfc_trans_sync,gfc_trans_critical): New functions.
+	* trans-stmt.h (gfc_trans_stop,gfc_trans_sync,
+	gfc_trans_critical): Add/update prototypes.
+	* trans.c (gfc_trans_code): Handle CRITICAL, ERROR STOP,
+	and SYNC statements.
+	* trans.h (gfor_fndecl_error_stop_string) Add variable.
+	* resolve.c (resolve_sync): Add function.
+	(gfc_resolve_blocks): Handle CRITICAL.
+	(resolve_code): Handle CRITICAL, ERROR STOP,
+	(resolve_branch): Add CRITICAL constraint check.
+	and SYNC statements.
+	* st.c (gfc_free_statement): Add new statements.
+	* trans-decl.c (gfor_fndecl_error_stop_string): Global variable.
+	(gfc_build_builtin_function_decls): Initialize it.
+	* match.c (gfc_match_if): Handle ERROR STOP and SYNC.
+	(gfc_match_critical, gfc_match_error_stop, sync_statement,
+	gfc_match_sync_all, gfc_match_sync_images, gfc_match_sync_memory):
+	New functions.
+	(match_exit_cycle): Handle CRITICAL constraint.
+	(gfc_match_stopcode): Handle ERROR STOP.
+	* match.h (gfc_match_critical, gfc_match_error_stop,
+	gfc_match_sync_all, gfc_match_sync_images,
+	gfc_match_sync_memory): Add prototype.
+	* parse.c (decode_statement, gfc_ascii_statement,
+	parse_executable): Handle new statements.
+	(parse_critical_block): New function.
+	* parse.h (gfc_compile_state): Add COMP_CRITICAL.
+	* intrinsic.texi (num_images): Document new function.
+	* simplify.c (gfc_simplify_num_images): Add function.
+
+2010-04-06  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/43178
+	* trans-array.c (gfc_conv_expr_descriptor): Update
+	gfc_trans_scalar_assign call.
+	(has_default_initializer): New function.
+	(gfc_trans_deferred_array): Nullify less often.
+	* trans-expr.c (gfc_conv_subref_array_arg,
+	gfc_trans_subcomponent_assign): Update call to
+	gfc_trans_scalar_assign.
+	(gfc_trans_scalar_assign): Add parameter and pass it on.
+	(gfc_trans_assignment_1): Optionally, do not dealloc before
+	assignment.
+	* trans-openmp.c (gfc_trans_omp_array_reduction): Update
+	call to gfc_trans_scalar_assign.
+	* trans-decl.c (gfc_get_symbol_decl): Do not always apply
+	initializer to static variables.
+	(gfc_init_default_dt): Add dealloc parameter and pass it on.
+	* trans-stmt.c (forall_make_variable_temp,
+	generate_loop_for_temp_to_lhs, generate_loop_for_rhs_to_temp,
+	gfc_trans_forall_1, gfc_trans_where_assign, gfc_trans_where_3
+	gfc_trans_allocate): Update gfc_trans_assignment call.
+	* trans.h (gfc_trans_scalar_assign, gfc_init_default_dt,
+	gfc_init_default_dt, gfc_trans_assignment): Add bool dealloc
+	parameter to prototype.
+
+2010-03-31  Paul Thomas  <pault@gcc.gnu.org>
+
+	* ioparm.def : Update copyright.
+	* lang.opt : ditto
+	* trans-array.c : ditto
+	* trans-array.h : ditto
+	* expr.c: ditto
+	* trans-types.c: ditto
+	* dependency.c : ditto
+	* gfortran.h : ditto
+	* options.c : ditto
+	* trans-io.c : ditto
+	* trans-intrinsic.c : ditto
+	* libgfortran.h : ditto
+	* invoke.texi : ditto
+	* intrinsic.texi : ditto
+	* trans.c : ditto
+	* trans.h : ditto
+	* intrinsic.c : ditto
+	* interface.c : ditto
+	* iresolve.c : ditto
+	* trans-stmt.c : ditto
+	* trans-stmt.h : ditto
+	* parse,c : ditto
+	* match.h : ditto
+	* error.c : ditto
+
+2010-03-20  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/43450
+	* trans-decl.c (gfc_create_module_variable): With -fwhole-file
+	do not assert the context of derived types.
+
+2010-03-20  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/43409
+	* ioparm.def: Change inquire size variable to type pointer to
+	GFC_IO_INT type.
+
+2010-03-18  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/43039
+	* trans-expr.c (conv_parent_component_references): Ensure that
+	'dt' has a backend_decl.
+
+	PR fortran/43043
+	* trans-expr.c (gfc_conv_structure): Ensure that the derived
+	type has a backend_decl.
+
+	PR fortran/43044
+	* resolve.c (resolve_global_procedure): Check that the 'cl'
+	structure is not NULL.
+
+2010-03-18  Shujing Zhao  <pearly.zhao@oracle.com>
+
+	* lang.opt (-ffixed-line-length-, ffree-line-length-): Remove
+	redundant tab.
+
+2010-03-17  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/43331
+	* trans-array.c (gfc_conv_array_index_offset,gfc_conv_array_ref,
+	gfc_conv_ss_startstride): Remove no-longer-needed cp_was_assumed
+	check.
+	* decl.c (gfc_match_derived_decl): Don't mark assumed-size Cray
+	pointees as having explizit size.
+	* expr.c (gfc_check_assign): Remove now unreachable Cray pointee
+	check.
+	* trans-types.c (gfc_is_nodesc_array): Add cp_was_assumed to assert.
+	(gfc_sym_type): Don't mark Cray pointees as restricted pointers.
+	* resolve.c (resolve_symbol): Handle cp_was_assumed.
+	* trans-decl.c (gfc_trans_deferred_vars): Ditto.
+	(gfc_finish_var_decl): Don't mark Cray pointees as restricted
+	pointers.
+
+2010-03-14  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/43362
+	* resolve.c (resolve_structure_cons): Add missing PURE constraint.
+	(resolve_ordinary_assign): Add check to avoid segfault.
+
+2010-03-12  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/43291
+	PR fortran/43326
+	* resolve.c (resolve_compcall): Add new boolean dummy argument
+	'class_members'. Only resolve expression at end if false.
+	Remove redundant, static variable 'class_object'.
+	(check_class_members): Add extra argument to call of
+	resolve_compcall.
+	(resolve_typebound_function): Renamed resolve_class_compcall.
+	Do all the detection of class references here. Correct calls to
+	resolve_compcall for extra argument.
+	(resolve_typebound_subroutine): resolve_class_typebound_call
+	renamed. Otherwise same as resolve_typebound_function.
+	(gfc_resolve_expr): Call resolve_typebound_function.
+	(resolve_code): Call resolve_typebound_subroutine.
+
+2010-03-10  Tobias Burnus  <burnus@net-b.de
+
+	PR fortran/43303
+	* symbol.c (get_iso_c_sym): Set sym->result.
+
+2010-03-08  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/43256
+	* resolve.c (resolve_compcall): Don't set 'value.function.name' here
+	for TBPs, otherwise they will not be resolved properly.
+	(resolve_function): Use 'value.function.esym' instead of
+	'value.function.name' to check if we're dealing with a TBP.
+	(check_class_members): Set correct type of passed object for all TBPs,
+	not only generic ones, except if the type is abstract.
+
+2010-03-04  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/43244
+	* decl.c (gfc_match_final_decl): Make sure variable names starting with
+	'final...' are not misinterpreted as FINAL statements.
+
+2010-03-03  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/43243
+	* trans-array.c (gfc_conv_array_parameter): Contiguous refs to
+	allocatable ultimate components do not need temporaries, whilst
+	ultimate pointer components do.
+
+2010-03-03  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/43169
+	* resolve.c (resolve_code): Correctly set gfc_current_ns for
+	EXEC_SELECT_TYPE.
+	(gfc_impure_variable): Make it work with sub-namespaces (BLOCK etc).
+	(gfc_pure): Ditto.
+
+2010-03-02  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/43180
+	* trans-array.c (gfc_conv_array_parameter): A full array of
+	derived type need not be restricted to a symbol without an
+	array spec to use the call to gfc_conv_expr_descriptor.
+
+	PR fortran/43173
+	* trans-array.c (gfc_conv_array_parameter): Contiguous refs to
+	allocatable arrays do not need temporaries.
+
+2010-03-01  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/43199
+	* resolve.c (find_array_spec): Handle REF_COMPONENT with
+	CLASS components.
+
+2010-02-28  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/43205
+	* trans-expr.c (is_zero_initializer_p): Move up in the file.
+	(gfc_conv_initializer): Handle zero initializer as special case.
+
+2010-02-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/43185
+	* resolve.c (resolve_fl_variable_derived): Imply SAVE
+	for module variables for Fortran 2008.
+
+2010-02-25  Jakub Jelinek  <jakub@redhat.com>
+
+	PR debug/43166
+	* trans-common.c (build_common_decl): Also update DECL_MODE,
+	and DECL_SIZE when encountering a larger common block and call
+	layout_decl.
+
+2010-02-24  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/43042
+	* trans-expr.c (gfc_conv_initializer): Call directly
+	gfc_conv_constant for C_NULL_(FUN)PTR.
+
+2010-02-22  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/43072
+	* dependency.c (gfc_full_array_ref_p): Check for contiguous by
+	checking the rest of the dimensions for elements.
+
+2010-02-21  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/35259
+	* gfortran.h (gfc_option_t): New flag -fprotect-parens.
+	* lang.opt: Ditto.
+	* option.c (gfc_init_options,gfc_handle_option): Ditto.
+	* trans-expr.c (gfc_conv_expr_op): Use the flag.
+	* invoke.texi: Document new -fno-protect-parens flag.
+
+2010-02-20  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/36932
+	PR fortran/36933
+	PR fortran/43072
+	PR fortran/43111
+	* dependency.c (gfc_check_argument_var_dependency): Use enum
+	value instead of arithmetic vaue for 'elemental'.
+	(check_data_pointer_types): New function.
+	(gfc_check_dependency): Call check_data_pointer_types.
+	* trans-array.h : Change fourth argument of
+	gfc_conv_array_parameter to boolean.
+	* trans-array.c (gfc_conv_array_parameter): A contiguous array
+	can be a dummy but it must not be assumed shape or deferred.
+	Change fourth argument to boolean. Array constructor exprs will
+	always be contiguous and do not need packing and unpacking.
+	* trans-expr.c (gfc_conv_procedure_call): Clean up some white
+	space and change fourth argument of gfc_conv_array_parameter
+	to boolean.
+	(gfc_trans_arrayfunc_assign): Change fourth argument of
+	gfc_conv_array_parameter to boolean.
+	* trans-io.c (gfc_convert_array_to_string): The same.
+	* trans-intrinsic.c (gfc_conv_intrinsic_loc): The same.
+
+2010-02-20  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/42958
+	* libgfortran.h: Add GFC_RTCHECK_MEM.
+	* invoke.texi (-fcheck=): Document -fcheck=mem.
+	* tranc.c (gfc_call_malloc): Remove negative-size run-time error
+	and enable malloc-success check only with -fcheck=mem.
+	* option.c (gfc_handle_runtime_check_option): Add -fcheck=mem.
+
+2010-02-16  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/43040
+	* gfortran.h (gfc_isym_id): Rename GFS_ISYM_GAMMA to GFS_ISYM_TGAMMA.
+	* intrinsic.c (add_functions): Ditto.
+	* iresolve.c (gfc_resolve_gamma): Call tgamma instead of gamma.
+	* mathbuiltins.def: Use TGAMMA instead of GAMMA with "tgamma".
+
+2010-02-14  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/32382
+	* trans-stmt.h: Add prototype for gfc_trans_code_cond. Add tree cond to
+	gfc_trans_do prototype.
+	* trans-stmt.c (gfc_trans_simple_do): Add optional argument to pass in
+	a loop exit condition.  If exit condition is given, build the loop exit
+	code, checking IO results of implied do loops in READ and WRITE.
+	(gfc_trans_do): Likewise.
+	* trans.c (trans_code): New static work function, previously
+	gfc_trans_code. Passes exit condition to gfc_trans_do.
+	(gfc_trans_code): Calls trans_code with NULL_TREE condition.
+	(gfc_trans_code_cond): Calls trans_code with loop exit condition.
+	* trans-io.c (build_dt): Build an exit condition to allow checking IO
+	result status bits in the dtparm structure. Use this condition in call
+	to gfc_trans_code_cond.
+
+2010-02-13  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/41113
+	PR fortran/41117
+	* trans-array.c (gfc_conv_array_parameter): Use
+	gfc_full_array_ref_p to detect full and contiguous variable
+	arrays. Full array components and contiguous arrays do not need
+	internal_pack and internal_unpack.
+
+2010-02-11  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/43030
+	* resolve.c (gfc_resolve_dim_arg): Call gfc_clear_ts.
+
+	PR fortran/43029
+	* decl.c (enumerator_decl): Don't call gfc_free_enum_history
+	here.
+	(gfc_match_enumerator_def): But here whenever enumerator_decl returns
+	MATCH_ERROR.
+
+2010-02-10  Joost VandeVondele <jv244@cam.ac.uk>
+	    Tobias Burnus <burnus@net-b.de>
+
+	PR fortran/40823
+	* decl.c (gfc_match_subroutine): Explicitly set sym->declared_at.
+
+2010-02-10  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/43015
+	* trans-decl.c (gfc_generate_function_code): Only check
+	actual-vs.-dummy character bounds if not bind(C).
+
+2010-02-10  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/42309
+	* trans-expr.c (gfc_conv_subref_array_arg): Avoid accessing
+	info->dimen after info has been freed.
+
+2010-02-09  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/42999
+	* array.c (gfc_constant_ac): Do not prevent expansion of constructors
+	with iterators.
+
+2010-02-09  Jakub Jelinek  <jakub@redhat.com>
+
+	* module.c (fix_mio_expr): Declare sym.
+
+2010-02-09  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/41869
+	* module.c (fix_mio_expr): Fix for private generic procedures.
+
+2010-02-09  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/39171
+	* resolve.c (resolve_charlen): Change warning about negative CHARACTER
+	length to be correct and issue only with -Wsurprising.
+	* invoke.texi (Wsurprising): Mention this new warning that is
+	turned on by -Wsurprising.
+
+2010-02-09  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/41507
+	* intrinsic.texi (MAXVAL): Remove wrong claim that array argument
+	can be CHARACTER type.
+	(MINVAL), (MAXLOC), (MINLOC): Ditto.
+
+2010-02-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/42309
+	* trans-expr.c (gfc_conv_subref_array_arg): Add new argument
+	'formal_ptr'. If this is true, give returned descriptor unity
+	lbounds, in all dimensions, and the appropriate offset.
+	(gfc_conv_procedure_call); If formal is a pointer, set the last
+	argument of gfc_conv_subref_array_arg to true.
+	* trans.h : Add last argument for gfc_conv_subref_array_arg.
+	* trans-io.c (set_internal_unit, gfc_trans_transfer): Set the
+	new arg of gfc_conv_subref_array_arg to false.
+	* trans-stmt.c (forall_make_variable_temp): The same.
+
+2010-02-03  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/42936
+	* interface.c (compare_parameter): Disable rank-checking
+	for NULL().
+
+2010-02-02  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/42650
+	* parse.c (decode_specification_statement): Use sym->result not sym.
+
+2010-02-01  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/42922
+	* decl.c (variable_decl): Allow default initializer in
+	TYPE declarations in PURE functions.
+
+2010-01-31  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42888
+	* resolve.c (resolve_allocate_expr): Move default initialization code
+	here from gfc_trans_allocate.
+	* trans.c (gfc_trans_code): Call gfc_trans_class_assign also for
+	EXEC_INIT_ASSIGN.
+	* trans-expr.c (gfc_trans_class_assign): Handle default initialization
+	of CLASS variables via memcpy.
+	* trans-stmt.c (gfc_trans_allocate): Move default initialization code
+	to resolve_allocate_expr.
+
+2010-01-31  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/38324
+	* expr.c (gfc_get_full_arrayspec_from_expr): New function.
+	* gfortran.h : Add prototype for above.
+	* trans-expr.c (gfc_trans_alloc_subarray_assign): New function.
+	(gfc_trans_subcomponent_assign): Call new function to replace
+	the code to deal with allocatable components.
+	* trans-intrinsic.c (gfc_conv_intrinsic_bound): Call
+	gfc_get_full_arrayspec_from_expr to replace existing code.
+
+2010-01-25  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/42858
+	* array.c (gfc_array_dimen_size): Fix intrinsic procedure
+	check.
+
+2010-01-24  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/41044
+	PR fortran/41167
+	* expr.c (remove_subobject_ref): If the constructor is NULL use
+	the expression as the source.
+	(simplify_const_ref): Change the type of expression if
+	there are component references.  Allow for substring to be at
+	the end of an arbitrarily long chain of references.  If an
+	element is found that is not in an EXPR_ARRAY, assume that this
+	is scalar initialization of array. Call remove_subobject_ref in
+	this case with NULL second argument.
+
+2010-01-24  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/39304
+	* array.c (gfc_array_dimen_size): Use correct specific
+	function in the check.
+
+2010-01-21  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/42736
+	* trans-stmt.c (gfc_conv_elemental_dependencies): If temporary
+	is required, turn any trailing array elements after a range
+	into ranges so that offsets can be calculated.
+
+2010-01-20  Joern Rennecke  <amylaar@spamcop.net>
+
+	* module.c (mio_f2k_derived): Use enumerator as initializer of
+	enum variable.
+
+	PR bootstrap/42812
+	* gfortran.h  (struct gfc_namespace) <resolved>: Change to signed
+	bitfield of width 2.
+
+2010-01-19  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42804
+	* resolve.c (extract_compcall_passed_object): Set locus for
+	passed-object argument.
+	(extract_ppc_passed_object): Set locus and correctly remove PPC
+	reference.
+
+2010-01-19  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/42783
+	* trans-decl.c (add_argument_checking): Do not use the backend
+	decl directly to test for the presence of an optional dummy
+	argument.  Use gfc_conv_expr_present, remembering to set the
+	symbol referenced.
+
+	PR fortran/42772
+	* trans-decl.c (gfc_generate_function_code): Small white space
+	changes. If 'recurcheckvar' is NULL do not try to reset it.
+
+2010-01-19  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42545
+	* resolve.c (resolve_fl_derived): Set the accessibility of the parent
+	component for extended types.
+	* symbol.c (gfc_find_component): Remove a wrongly-worded error message
+	and take care of parent component accessibility.
+
+2010-01-17  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42677
+	* gfortran.h (symbol_attribute): Remove 'ambiguous_interfaces'.
+	* interface.c (check_interface1): Move a warning message here from
+	resolve_fl_procedure.
+	(check_sym_interfaces): Removed 'attr.ambiguous_interfaces'.
+	* module.c (read_module): Remove call to gfc_check_interfaces, since
+	this comes too early here.
+	* resolve.c (resolve_fl_procedure): Move warning message to
+	check_interface1.
+
+2010-01-14 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+	PR fortran/42684
+	* interface.c (check_interface1): Pass symbol name rather than NULL to
+	gfc_compare_interfaces.	(gfc_compare_interfaces): Add assert to
+	trap MULL.
+	* resolve.c (check_generic_tbp_ambiguity): Pass symbol name rather
+	than NULL to gfc_compare_interfaces.
+
+2010-01-14  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/41478
+	* trans-array.c (duplicate_allocatable):  Static version of
+	gfc_duplicate_allocatable with provision to handle scalar
+	components. New boolean argument to switch off call to malloc
+	if true.
+	(gfc_duplicate_allocatable): New function to call above with
+	new argument false.
+	(gfc_copy_allocatable_data): New function to call above with
+	new argument true.
+	(structure_alloc_comps): Do not apply indirect reference to
+	scalar pointers. Add new section to copy allocatable components
+	of arrays. Extend copying of allocatable components to include
+	scalars.
+	(gfc_copy_only_alloc_comp): New function to copy allocatable
+	component derived types, without allocating the base structure.
+	* trans-array.h : Add primitive for gfc_copy_allocatable_data.
+	Add primitive for gfc_copy_only_alloc_comp.
+	* trans-expr.c (gfc_conv_procedure_call): After calls to
+	transformational functions with results that are derived types
+	with allocatable components, copy the components in the result.
+	(gfc_trans_arrayfunc_assign): Deallocate allocatable components
+	of lhs derived types before allocation.
+	
+2010-01-14  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/42481
+	* module.c (load_generic_interfaces): If a procedure that is
+	use associated but not generic is given an interface that
+	includes itself, then make it generic.
+
+2010-01-11  Joseph Myers  <joseph@codesourcery.com>
+	    Shujing Zhao  <pearly.zhao@oracle.com>
+
+	PR translation/42469
+	* lang.opt (fblas-matmul-limit=, finit-character=, finit-integer=,
+	finit-logical=, finit-real=, fmax-array-constructor=): Use tab
+	character between option name and help text.
+
+2010-01-09 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+	PR fortran/20923
+	PR fortran/32489
+	* trans-array.c (gfc_conv_array_initializer): Change call to
+	gfc_error_now to call to gfc_fatal_error.
+	* array.c (count_elements): Whitespace. (extract_element): Whitespace.
+	(is_constant_element): Changed name from constant_element.
+	(gfc_constant_ac): Only use expand_construuctor for expression
+	types of EXPR_ARRAY.  If expression type is EXPR_CONSTANT, no need to
+	call gfc_is_constant_expr.
+	* expr.c (gfc_reduce_init_expr): Adjust conditionals and delete error
+	message.
+	* resolve.c (gfc_is_expandable_expr): New function that determiners if
+	array expressions should have their constructors expanded.
+	(gfc_resolve_expr): Use new function to determine whether or not to call
+	gfc_expand_constructor.
+
+2010-01-09  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/41298
+	* trans-expr.c (gfc_trans_structure_assign): Handle
+	c_null_(fun)ptr.
+	* symbol.c (gen_special_c_interop_ptr): Add NULL_EXPR
+	to the constructor for c_null_(fun)ptr.
+	* resolve.c (resolve_structure_cons): Add special case
+	for c_null_(fun)ptr.
+
+2010-01-09  Jakub Jelinek  <jakub@redhat.com>
+
+	* gfortranspec.c (lang_specific_driver): Update copyright notice
+	dates.
+
+2010-01-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR/fortran 25829
+	* symbol.c (check_conflict, gfc_copy_attr): Add
+	ASYNCHRONOUS support.
+	(gfc_add_asynchronous): New function.
+	* decl.c (match_attr_spec): Add ASYNCHRONOUS support.
+	(gfc_match_asynchronous): New function.
+	* dump-parse-tree.c (show_attr): Add ASYNCHRONOUS support.
+	* gfortran.h (symbol_attribute): New ASYNCHRONOUS bit.
+	(gfc_add_asynchronous): New Prototype.
+	* module.c (ab_attribute, mio_symbol_attribute): Add
+	ASYNCHRONOUS support.
+	* resolve.c (was_declared): Ditto.
+	* match.h (gfc_match_asynchronous): New prototype.
+	* parse.c (decode_specification_statement,decode_statement):
+	Add ASYNCHRONOUS support.
+
+2010-01-07  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/42597
+	* trans-decl.c (get_proc_pointer_decl): Fix call to
+	gfc_conv_initializer for array-valued proc-pointer funcs.
+
+2010-01-07  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/41872
+	* trans-decl.c (gfc_trans_deferred_vars): Don't initialize
+	allocatable scalars with SAVE attribute.
+
+2010-01-05  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/42517
+	* options.c (gfc_post_options): Set -frecursion
+	when -fopenmp is used.
+
+2010-01-05  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/41872
+	* trans-expr.c (gfc_conv_procedure_call): Nullify
+	return value for allocatable-scalar character functions.
+
+2010-01-04  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/36161
+	* error.c (error_printf, gfc_warning, gfc_notify_std,
+	gfc_warning_now, gfc_error, gfc_error_now,
+	gfc_fatal_error): Change argument name from nocmsgid to
+	gmsgid to enable (x)gettext's % checking.
+
+2010-01-04  Tobias Burnus  <burnus@net-b.de>
+	
+	* trans-decl.c (gfc_trans_deferred_vars): Fix spelling.
+
+2010-01-04  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/41872
+	* trans-expr.c (gfc_conv_procedure_call): Add indirect ref
+	for functions returning allocatable scalars.
+	* trans-stmt.c (gfc_trans_allocate): Emmit error when
+	reallocating an allocatable scalar.
+	* trans.c (gfc_allocate_with_status): Fix pseudocode syntax
+	in comment.
+	* trans-decl.c (gfc_trans_deferred_vars): Nullify local
+	allocatable scalars.
+	(gfc_generate_function_code): Nullify result variable for
+	allocatable scalars.
+	
+	PR fortran/40849
+	* module.c (gfc_use_module): Fix warning string to allow
+	for translation.
+
+	PR fortran/42517
+	* invoke.texi (-fcheck=recursion): Mention that the checking
+	is also disabled for -frecursive.
+	* trans-decl.c (gfc_generate_function_code): Disable
+	-fcheck=recursion when -frecursive is used.
+
+	* intrinsic.texi (iso_c_binding): Improve wording.
+
+
+Copyright (C) 2010 Free Software Foundation, Inc.
+
+Copying and distribution of this file, with or without modification,
+are permitted in any medium without royalty provided the copyright
+notice and this notice are preserved.
diff --git a/gcc-4.9/gcc/fortran/ChangeLog-2011 b/gcc-4.9/gcc/fortran/ChangeLog-2011
new file mode 100644
index 000000000..c7ac16038
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/ChangeLog-2011
@@ -0,0 +1,4090 @@
+2011-12-31  Thomas König  <tkoenig@gcc.gnu.org>
+
+	PR fortran/51502
+	* expr.c (gfc_check_vardef_context):  When determining
+	implicit pure status, also check for variable definition
+	context.  Walk up namespaces until a procedure is
+	found to reset the implict pure attribute.
+	* resolve.c (gfc_implicit_pure):  Walk up namespaces
+	until a procedure is found.
+
+2011-12-29  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	* dependency.c (gfc_dep_compare_functions):  Document
+	new behavior for REALs and complex.  Add comment to cases
+	where only INTEGERs are handled.  Compare REAL and COMPLEX
+	constants, returning 0 and -2 only.  Add assert to make
+	sure that only integer constants are compared.
+
+2011-12-19  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51605
+	* parse.c (gfc_fixup_sibling_symbols): Regard FL_LABEL as
+	local symbol.
+
+2011-12-19  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51605
+	* match.c (gfc_match_select_type): Handle
+	scalar polymophic coarrays.
+	(select_type_set_tmp, ): Ditto; avoid segfault if !class_ok.
+	* primary.c (gfc_match_rvalue): Avoid segfault if !class_ok.
+	* resolve.c (resolve_select_type): Ditto.
+	(resolve_assoc_var): Fix setting the TARGET attribute for
+	polymorphic selectors which are pointers.
+
+2011-12-19  Tobias Burnus  <burnus@net-b.de>
+
+	* check.c (coarray_check): Add class ref if needed.
+	* resolve.c (resolve_fl_var_and_proc,
+	resolve_fl_derived0, resolve_symbol): Fix checking
+	for BT_CLASS.
+
+2011-12-15  Paul Thomas  <pault@gcc.gnu.org>
+
+	* trans-expr.c (gfc_walk_function_expr): Detect elemental
+	procedure components as well as elemental procedures.
+	* trans-array.c (gfc_conv_procedure_call): Ditto.
+	* trans-decl.c (gfc_trans_deferred_vars): Correct erroneous
+	break for class pointers to continue.
+
+2011-12-15  Toon Moene  <toon@moene.org>
+
+	PR fortran/51310
+	* resolve.c (build_default_init_expr): Allow non-allocatable,
+	non-compile-time-constant-shape arrays to have a default
+	initializer.
+	* invoke.texi: Delete the restriction on automatic arrays not
+	being initialized by -finit-<type>=<constant>.
+
+2011-12-15  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51550
+	PR fortran/47545
+	PR fortran/49050
+	PR fortran/51075	
+	* resolve.c (resolve_fl_derived0): Print not-implemented error
+	for deferred-length character components.
+
+2011-12-15  Tobias Burnus  <burnus@net-b.de>
+
+	* primary.c (gfc_match_varspec): Match array spec for
+	polymorphic coarrays.
+	(gfc_match_rvalue): If a symbol of unknown flavor has a
+	codimension, mark it as a variable.
+	* simplify.c (gfc_simplify_image_index): Directly call
+	simplify_cobound.
+	* trans-intrinsic.c (trans_this_image): Fix handling of
+	corank = 1 arrays.
+
+2011-12-15  Jakub Jelinek  <jakub@redhat.com>
+
+	PR debug/51517
+	* trans-decl.c (gfc_get_symbol_decl): Don't set DECL_INITAL on span.
+	(gfc_trans_deferred_vars): Instead add its runtime initialization
+	here.
+
+2011-12-11  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/50923
+	* trans-decl.c (generate_local_decl): Set TREE_NO_WARNING only
+	if the front end has printed a warning.
+	(gfc_generate_function_code): Fix unset-result warning.
+
+2011-12-11  Paul Thomas  <pault@gcc.gnu.org>
+	Tobias Burnus  <burnus@gcc.gnu.org>
+
+	PR fortran/41539
+	PR fortran/43214
+	PR fortran/43969
+	PR fortran/44568
+	PR fortran/46356
+	PR fortran/46990
+	PR fortran/49074
+	* interface.c (symbol_rank): Return the rank of the _data
+	component of class objects.
+	(compare_parameter): Also compare the derived type of the class
+	_data component for type mismatch.  Similarly, return 1 if the
+	formal and _data ranks match.
+	(compare_actual_formal): Do not compare storage sizes for class
+	expressions. It is an error if an actual class array, passed to
+	a formal class array is not full.
+	* trans-expr.c (gfc_class_data_get, gfc_class_vptr_get,
+	gfc_vtable_field_get, gfc_vtable_hash_get, gfc_vtable_size_get,
+	gfc_vtable_extends_get, gfc_vtable_def_init_get,
+	gfc_vtable_copy_get): New functions for class API.
+	(gfc_conv_derived_to_class): For an array reference in an
+	elemental procedure call retain the ss to provide the
+	scalarized array reference. Moved in file.
+	(gfc_conv_class_to_class): New function.
+	(gfc_conv_subref_array_arg): Use the type of the
+	class _data component as a basetype.
+	(gfc_conv_procedure_call): Ensure that class array expressions
+	have both the _data reference and an array reference. Use 
+	gfc_conv_class_to_class to handle class arrays for elemental
+	functions in scalarized loops, class array elements and full
+	class arrays. Use a call to gfc_conv_subref_array_arg in order
+	that the copy-in/copy-out for passing class arrays to derived
+	type arrays occurs correctly.
+	(gfc_conv_expr): If it is missing, add the _data component
+	between a class object or component and an array reference.
+	(gfc_trans_class_array_init_assign): New function.
+	(gfc_trans_class_init_assign): Call it for array expressions.
+	* trans-array.c (gfc_add_loop_ss_code): Do not use a temp for
+	class scalars since their size will depend on the dynamic type.
+	(build_class_array_ref): New function.
+	(gfc_conv_scalarized_array_ref): Call build_class_array_ref.
+	(gfc_array_init_size): Add extra argument, expr3, that represents
+	the SOURCE argument. If present,use this for the element size.
+	(gfc_array_allocate): Also add argument expr3 and use it when
+	calling gfc_array_init_size.
+	(structure_alloc_comps): Enable class arrays.
+	* class.c (gfc_add_component_ref): Carry over the derived type
+	of the _data component.
+	(gfc_add_class_array_ref): New function.
+	(class_array_ref_detected): New static function.
+	(gfc_is_class_array_ref): New function that calls previous.
+	(gfc_is_class_scalar_expr): New function.
+	(gfc_build_class_symbol): Throw not implemented error for
+	assumed size class arrays.  Remove error that prevents
+	CLASS arrays.
+	(gfc_build_class_symbol): Prevent pointer/allocatable conflict.
+	Also unset codimension.
+	(gfc_find_derived_vtab): Make 'copy' elemental and set the
+	intent of the arguments accordingly.: 
+	* trans-array.h: Update prototype for gfc_array_allocate.
+	* array.c (gfc_array_dimen_size): Return failure if class expr.
+	(gfc_array_size): Likewise.
+	* gfortran.h: New prototypes for gfc_add_class_array_ref,
+	gfc_is_class_array_ref and gfc_is_class_scalar_expr.
+	* trans-stmt.c (trans_associate_var): Exclude class targets
+	from test. Move the allocation of the _vptr to an earlier time
+	for class objects.
+	(trans_associate_var): Assign the descriptor directly for class
+	arrays.
+	(gfc_trans_allocate): Add expr3 to gfc_array_allocate arguments.
+	Convert array element references into sections. Do not invoke
+	gfc_conv_procedure_call, use gfc_trans_call instead.
+	* expr.c (gfc_get_corank): Fix for BT_CLASS.
+	(gfc_is_simply_contiguous): Exclude class from test.
+	* trans.c (gfc_build_array_ref): Include class array refs.
+	* trans.h: Include prototypes for class API functions that are
+	new in trans-expr. Define GFC_DECL_CLASS(node).
+	* resolve.c (check_typebound_baseobject ): Remove error for
+	non-scalar base object.
+	(resolve_allocate_expr): Ensure that class _data component is
+	present. If array, call gfc_expr_to_intialize.
+	(resolve_select): Remove scalar error for SELECT statement as a
+	temporary measure.
+	(resolve_assoc_var): Update 'target' (aka 'selector') as
+	needed. Ensure that the target expression has the right rank.
+	(resolve_select_type): Ensure that target expressions have a
+	valid locus.
+	(resolve_allocate_expr, resolve_fl_derived0): Fix for BT_CLASS.
+	* trans-decl.c (gfc_get_symbol_decl): Set GFC_DECL_CLASS, where
+	appropriate.
+	(gfc_trans_deferred_vars): Get class arrays right.
+	* match.c(select_type_set_tmp): Add array spec to temporary.
+	(gfc_match_select_type): Allow class arrays.
+	* check.c (array_check): Ensure that class arrays have refs.
+	(dim_corank_check, dim_rank_check): Retrun success if class.
+	* primary.c (gfc_match_varspec): Fix for class arrays and
+	co-arrays. Make sure that class _data is present.
+	(gfc_match_rvalue): Handle class arrays.
+	*trans-intrinsic.c (gfc_conv_intrinsic_size): Add class array
+	reference.
+	(gfc_conv_allocated): Add _data component to class expressions.
+	(gfc_add_intrinsic_ss_code): ditto.
+	* simplify.c (simplify_cobound): Fix for BT_CLASS.
+	(simplify_bound): Return NULL for class arrays.
+	(simplify_cobound): Obtain correct array_spec. Use cotype as
+	appropriate. Use arrayspec for bounds.
+
+2011-12-11  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/50690
+	* frontend-passes.c (in_omp_workshare):  New variable.
+	(cfe_expr_0):  Don't eliminiate common function if it would put
+	the variable immediately into a WORKSHARE construct.
+	(optimize_namespace):  Set in_omp_workshare.
+	(gfc_code_walker):  Keep track of OMP PARALLEL and OMP WORKSHARE
+	constructs.
+
+2011-12-10  Tobias Burnus  <burnus@net-b.de>
+
+	* trans-decl.c (add_argument_checking): Fix syntax.
+
+2011-12-10  Tobias Burnus  <burnus@net-b.de>
+	    Kai Tietz  <ktietz@redhat.com>
+
+	* trans-decl.c (add_argument_checking): Check ts.deferred earlier.
+	* trans-intrinsic.c (gfc_conv_intrinsic_repeat): Use %ld with long.
+
+2011-12-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/50815
+	* trans-decl.c (add_argument_checking): Skip bound checking
+	for deferred-length strings.
+
+2011-12-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51378
+	* symbol.c (gfc_find_component): Fix access check of parent
+	components.
+
+2011-12-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51407
+	* io/transfer.c (require_numeric_type): New function.
+	(formatted_transfer_scalar_read, formatted_transfer_scalar_write):
+	Use it, allow BOZ edit descriptors with F2008.
+
+2011-12-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51448
+	* fortran/trans-array.c (get_std_lbound): Fix handling of
+	conversion functions.
+
+2011-12-08  Toon Moene  <toon@moene.org>
+
+	PR fortran/51310
+	* invoke.texi: Itemize the cases for which
+	-finit-<type>=<constant> doesn't work.
+
+2011-12-06  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51435
+	* expr.c (gfc_has_default_initializer): Fix handling of
+	DT with initialized pointer components.
+
+2011-12-05  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/51338
+	* dependency.c (are_identical_variables):  Handle case where
+	end fields of substring references are NULL.
+
+2011-12-04  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51383
+	* resolve.c (find_array_spec): Use ref->u.c.component
+	directly without starting from ts.u.derived.
+
+2011-12-03  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/48887
+	* match.c (select_type_set_tmp): Don't set allocatable/pointer
+	attribute.
+	* class.c (gfc_build_class_symbol): Handle
+	attr.select_type_temporary.
+
+2011-12-03  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/50684
+	* check.c (variable_check): Fix intent(in) check.
+
+2011-12-03  Tobias Burnus  <burnus@net-b.de>
+
+	* check.c (gfc_check_move_alloc): Allow nonpolymorphic
+	FROM with polymorphic TO.
+	* trans-intrinsic.c (conv_intrinsic_move_alloc): Handle
+	nonpolymorphic FROM with polymorphic TO.
+
+2011-12-01  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	* module.c (dt_lower_string): Make static.
+	(dt_upper_string): Likewise.
+
+2011-12-01  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	PR fortran/25708
+	* module.c (parse_string): Read string into resizable array
+	instead of parsing twice and seeking.
+	(peek_atom): New implementation avoiding seeks.
+	(require_atom): Save and set column and line explicitly for error
+	handling.
+
+2011-12-01  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	* misc.c (gfc_open_file): Don't call stat.
+
+2011-11-29  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/40958
+	* module.c (prev_module_line):  New variable.
+	(prev_module_column):  New variable.
+	(prev_character):  New variable.
+	(module_char):  Update the new variables.
+	(module_unget_char):  New function.
+	(parse_string):  Use module_unget_char.
+	(parse_integer):  Likewise.
+	(parse_name):  Likewise.
+
+2011-11-29  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51306
+	PR fortran/48700
+	* check.c (gfc_check_move_alloc): Make sure that from/to
+	are both polymorphic or neither.
+	* trans-intrinsic.c (conv_intrinsic_move_alloc): Cleanup,
+	generate inline code.
+
+2011-11-28  Tobias Burnus  <burnus@net-b.de>
+	    Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/51308
+	* symbol.c (check_conflict): Ignore BIND(C) + PARAMETER
+	conflicts for ISO_C_BINDING variables.
+	(gen_special_c_interop_ptr): Don't mark c_ptr_null/c_funptr_null
+	as SAVE.
+
+2011-11-25  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (set_loop_bounds): Remove dead conditions.
+
+2011-11-25  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/51250
+	PR fortran/43829
+	* trans-array.c (gfc_trans_create_temp_array): Get dimension from
+	the right gfc_ss struct.
+
+2011-11-25  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/50408
+	* trans-decl.c (gfc_get_module_backend_decl): Also copy
+	ts.u.derived from the gsym if the ts.type is BT_CLASS.
+	(gfc_get_extern_function_decl): Copy also the backend_decl
+	for the symbol's ts.u.{derived,cl} from the gsym.
+	* trans-types.c (gfc_copy_dt_decls_ifequal): Directly
+	return if "from" and "to" are the same.
+
+2011-11-25  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51302
+	* trans-stmt.c (gfc_trans_simple_do): Add a fold_convert.
+
+2011-11-24  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51218
+	* resolve.c (pure_subroutine): If called subroutine is
+	impure, unset implicit_pure.
+	(resolve_function): Move impure check to simplify code.
+
+2011-11-19  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51207
+	* class.c (gfc_find_derived_vtab): Mark __def_init as PARAMETER
+	and hence as TREE_READONLY; add subroutine attribute to
+	__copy_ procedure.
+
+	PR fortran/50640
+	* trans.h (GFC_DECL_PUSH_TOPLEVEL): New DECL_LANG_FLAG_7.
+	* trans-decl.c (gfc_get_symbol_decl): Mark __def_init and vtab as
+	GFC_DECL_PUSH_TOPLEVEL.
+	(gfc_generate_function_code): If GFC_DECL_PUSH_TOPLEVEL, push it there.
+	(build_function_decl): Push __copy_ procedure to the toplevel.
+
+2011-11-16  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/39427
+	PR fortran/37829
+	* decl.c (match_data_constant, match_data_constant, variable_decl,
+	gfc_match_decl_type_spec, access_attr_decl,
+	check_extended_derived_type, gfc_match_derived_decl,
+	gfc_match_derived_decl, gfc_match_derived_decl) Modified to deal
+	with DT constructors.
+	* gfortran.h (gfc_find_dt_in_generic,
+	gfc_convert_to_structure_constructor): New function prototypes.
+	* interface.c (check_interface0, check_interface1,
+	gfc_search_interface): Ignore DT constructors in generic list.
+	* match.h (gfc_match_structure_constructor): Update prototype.
+	* match.c (match_derived_type_spec): Ensure that one uses the DT
+	not the generic function.
+	* module.c (MOD_VERSION): Bump.
+	(dt_lower_string, dt_upper_string): New functions.
+	(find_use_name_n, find_use_operator, compare_true_names,
+	find_true_name, add_true_name, fix_mio_expr, load_needed,
+	read_module, write_dt_extensions, write_symbol): Changes to deal with
+	different symtree vs. sym names.
+	(create_derived_type): Create also generic procedure.
+	* parse.c (gfc_fixup_sibling_symbols): Don't regard DT and generic
+	function as the same.
+	* primary.c (gfc_convert_to_structure_constructor): New function.
+	(gfc_match_structure_constructor): Restructured; calls
+	gfc_convert_to_structure_constructor.
+	(build_actual_constructor, gfc_match_rvalue): Update for DT generic
+	functions.
+	* resolve.c (resolve_formal_arglist, resolve_structure_cons,
+	is_illegal_recursion, resolve_generic_f, resolve_variable,
+	resolve_fl_variable_derived, resolve_fl_derived0,
+	resolve_symbol): Handle DT and DT generic constructors.
+	* symbol.c (gfc_use_derived, gfc_undo_symbols,
+	gen_special_c_interop_ptr, gen_cptr_param,
+	generate_isocbinding_symbol, gfc_get_derived_super_type): Handle
+	derived-types, which are hidden in the generic type.
+	(gfc_find_dt_in_generic): New function
+	* trans-array.c (gfc_conv_array_initializer): Replace FL_PARAMETER
+	expr by actual value.
+	* trans-decl.c (gfc_get_module_backend_decl, gfc_trans_use_stmts):
+	Ensure that we use the DT and not the generic function.
+	* trans-types.c (gfc_get_derived_type): Ensure that we use the DT
+	and not the generic procedure.
+
+2011-11-14  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51073
+	* trans-decl.c (generate_coarray_sym_init): Handle zero-sized arrays.
+
+2011-11-09  Tobias Burnus  <burnus@net-b.de>
+
+	* symbol.c (clear_sym_mark, traverse_ns): Remove functions.
+	(count_st_nodes, do_traverse_symtree, fill_st_vector): New functions.
+	(gfc_traverse_symtree, gfc_traverse_ns): Call do_traverse_symtree.
+
+2011-11-09  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	PR libfortran/50016
+	* gfortran.texi (Data consistency and durability): New section.
+
+2011-11-09  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/50540
+	* resolve.c (resolve_forall_iterators): Transform internal errors
+	to normal errors.
+
+2011-11-09  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/50960
+	* class.c (gfc_find_derived_vtab): Make the vtab symbols FL_PARAMETER.
+	* expr.c (gfc_simplify_expr): Prevent vtabs from being replaced with
+	their value.
+	* resolve.c (resolve_values): Use-associated symbols do not need to
+	be resolved again.
+	(resolve_fl_parameter): Make sure the symbol has a value.
+
+2011-11-09  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/38718
+	* intrinsic.c (add_functions): Allow dreal simplification.
+	* intrinsic.h (gfc_simplify_dreal): New prototype.
+	* simplify.c (gfc_simplify_dreal): New function.
+
+2011-11-09  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/21881
+	* trans-types.c (gfc_get_dtype): Issue a fatal error instead of
+	an internal error.
+
+2011-11-08  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/50404
+	* io.c (gfc_resolve_close): CLOSE requires a UNIT.
+
+2011-11-08  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/50409
+	* expr.c (gfc_simplify_expr): Substrings can't have negative
+	length.
+
+2011-11-08  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/50334
+	* invoke.texi (-finit-*): Document interaction with
+	-Wuninitialized.
+
+2011-11-07  François-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR libfortran/49188
+	PR libfortran/49336
+	* invoke.texi: Fix documentation of fsign-zero option. Remove
+	contractions.
+	* intrinsic.texi: Fix ATAN2 documentation for signed zeros.
+	Remove contractions.
+	* gfortran.texi: Remove contractions.
+
+2011-11-07  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/50919
+	* class.c (add_proc_comp): Don't add non-overridable procedures to the
+	vtable.
+	* resolve.c (resolve_typebound_function,resolve_typebound_subroutine):
+	Don't generate a dynamic _vptr call for non-overridable procedures.
+
+2011-11-07  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	* intrinsic.texi (MCLOCK, MCLOCK8, TIME, TIME8): Functions clock
+	and time are part of the C standard library.
+
+2011-11-06  Janus Weil  <janus@gcc.gnu.org>
+
+	* gfortran.h (gfc_extend_expr): Modified prototype.
+	* interface.c (gfc_extend_expr): Return 'match' instead of 'gfc_try'.
+	Remove argument 'real_error'.
+	* resolve.c (resolve_operator): Modified call to 'gfc_extend_expr'.
+
+2011-11-06  Andrew MacLeod  <amacleod@redhat.com>
+	    Aldy Hernandez  <aldyh@redhat.com>
+
+	Merged from cxx-mem-model.
+
+	* types.def: (BT_SIZE, BT_CONST_VOLATILE_PTR, BT_FN_VOID_INT,
+	BT_FN_I{1,2,4,8,16}_CONST_VPTR_INT, BT_FN_VOID_VPTR_INT,
+	BT_FN_BOOL_VPTR_INT, BT_FN_BOOL_SIZE_CONST_VPTR,
+	BT_FN_VOID_VPTR_I{1,2,4,8,16}_INT, BT_FN_VOID_SIZE_VPTR_PTR_INT,
+	BT_FN_VOID_SIZE_CONST_VPTR_PTR_INT, BT_FN_VOID_SIZE_VPTR_PTR_PTR_INT,
+	BT_FN_BOOL_VPTR_PTR_I{1,2,4,8,16}_BOOL_INT_INT,
+	BT_FN_I{1,2,4,8,16}_VPTR_I{1,2,4,8,16}_INT): New types.
+
+2011-11-04  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/43829
+	* trans-array.c (gfc_conv_expr_descriptor): Accept the inline intrinsic
+	case in the assertion.
+	* trans-intrinsic (enter_nested_loop): New function.
+	(gfc_conv_intrinsic_arith): Support non-scalar cases.
+	(nest_loop_dimension, walk_inline_intrinsic_arith): New functions.
+	(walk_inline_intrinsic_function): Handle sum and product.
+	(gfc_inline_intrinsic_function_p): Ditto.
+	* trans.h (gfc_get_loopinfo): New macro.
+
+2011-11-04  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-intrinsic.c (gfc_conv_intrinsic_arith): Introduce parent
+	expression variable.  Use it.
+
+2011-11-04  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-intrinsic.c (gfc_conv_intrinsic.c): Introduce current loop
+	pointer.  Use it.
+
+2011-11-04  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-intrinsic.c (gfc_conv_intrinsic_arith): Small argument handling
+	cleanup.
+
+2011-11-04  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-intrinsic.c (gfc_conv_intrinsic_arith): Update conditions.
+
+2011-11-04  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* frontend-passes.c (cfe_register_funcs): Return early in the case
+	of an inline intrinsic function.
+	(optimize_binop_array_assignment): Skip optimization in the case of
+	an inline intrinsic function.
+
+2011-11-04  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* array.c (match_subscript): Skip whitespaces before setting locus.
+	* matchexp.c (match_level_1): Ditto.
+
+2011-11-04  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-intrinsic.c (gfc_conv_intrinsic_minmaxval): Set loop's
+	temporary rank to the loop rank. Mark ss chains for multiple loop
+	if necessary.  Use gfc_trans_scalarized_loop_boundary to end one loop
+	and start another.
+
+2011-11-04  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-intrinsic.c (gfc_conv_intrinsic_minmaxloc): Set loop's
+	temporary rank to the loop rank. Mark ss chains for multiple loop
+	if necessary.  Use gfc_trans_scalarized_loop_boundary to end one loop
+	and start another.
+
+2011-11-04  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-intrinsic.c (gfc_conv_intrinsic_minmaxloc): Don't calculate
+	offset twice in generated code.
+
+2011-11-04  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-expr.c (gfc_conv_procedure_call): Handle temporaries for
+	arguments to elemental calls.
+	* trans-stmt.c (replace_ss): New function.
+	(gfc_conv_elemental_dependencies): Remove temporary loop handling.
+	Create a new ss for the temporary and replace the original one with it.
+	Remove fake array references. Recalculate all offsets.
+
+2011-11-04  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.h (gfc_free_ss, gfc_set_delta): New prototypes.
+	* trans-array.c (gfc_free_ss): Remove forward declaration.
+	Make non-static.
+	(set_delta, gfc_set_delta): Remove forward declaration.
+	Make non-static and rename the former to the later. Update uses.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans.h (gfc_inline_intrinsic_function_p): Move prototype...
+	* gfortran.h (gfc_inline_intrinsic_function_p): ... here.
+	* dependency.c (gfc_check_argument_var_dependency): Check dependencies
+	of inline intrinsics' arguments.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_trans_preloop_setup): New pointers to outer
+	dimension's ss and loop. Use them.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (outermost_loop): New function.
+	(gfc_trans_array_constructor, gfc_set_vector_loop_bounds,
+	gfc_add_loop_ss_code): Put generated code out of the outermost loop.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (constant_array_constructor_loop_size):
+	Handle multiple loops.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (get_rank, get_loop_upper_bound_for_array):
+	New functions.
+	(gfc_trans_array_constructor): Handle multiple loops.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans.h (struct gfc_loopinfo): New field parent.
+	* trans-array.c (gfc_cleanup_loop): Free nested loops.
+	(gfc_add_ss_to_loop): Set nested_loop's parent loop.
+	(gfc_trans_array_constructor): Update assertion.
+	(gfc_conv_loop_setup): Ditto.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_add_loop_ss_code): Skip non-nestedmost ss.
+	Call recursively gfc_add_loop_ss_code for all the nested loops.
+	(gfc_conv_ss_startstride): Only get the descriptor for the outermost
+	ss. Call recursively gfc_conv_ss_startstride for all the nested loops.
+	(set_loop_bounds): Call recursively for all the nested loops.
+	(set_delta): Ditto.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans.h (struct gfc_loopinfo): New fields nested and next.
+	* trans-array.c (gfc_add_ss_to_loop): Update list of nested list if
+	ss has non-null nested_ss field.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_trans_create_temp_array): Loop over the parents.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (get_array_ref_dim, get_scalarizer_dim_for_array_dim): 
+	Rename the former to the latter and loop over the parents.
+	(innermost_ss): New function.
+	(get_array_ref_dim_for_loop_dim): New function.
+	(gfc_trans_create_temp_array): Use get_scalarizer_dim_for_array_dim.
+	(set_loop_bounds): Use get_array_dim_for_loop_dim).
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans.h (struct gfc_ss): New field nested_ss.
+	* trans-expr.c (gfc_advance_se_ss_chain): Update assertion.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (set_vector_loop_bounds): Loop over the parents.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_trans_array_constructor): Loop over the parents.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_set_loop_bounds_from_array_spec): Loop over the
+	parents.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans.h (struct gfc_ss): New field parent.
+	* trans-array.c (gfc_trans_scalarizing_loops): Skip clearing if a
+	parent exists.
+	* trans-expr.c (gfc_advance_se_ss_chain): Move to parent ss at the
+	end of the chain.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.h (gfc_trans_create_temp_array): Remove loop argument.
+	* trans-array.c (gfc_trans_create_temp_array): Ditto.  Get loop from ss.
+	Update reference to loop.  Remove loop argument.
+	(gfc_trans_array_constructor, gfc_conv_loop_setup): Update calls to
+	gfc_trans_create_temp_array.
+	* trans-expr.c (gfc_conv_procedure_call): Ditto.
+	* trans-intrinsic.c (gfc_conv_intrinsic_transfer): Ditto.
+	* trans-stmt.c (gfc_conv_elemental_dependencies): Ditto.
+	Set loop before calling gfc_trans_create_temp_array.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_trans_create_temp_array): New variable total_dim.
+	Set total_dim to loop's rank. Replace usages of loop's rank.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_trans_array_constructor, trans_array_constructor):
+	Rename the former to the later.  Get loop from ss.
+	Remove loop argument.
+	(gfc_add_loop_ss_code): Update call.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_set_vector_loop_bounds): Get loop from ss.
+	Remove loop argument.
+	(gfc_add_loop_ss_code): Update call.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans.h (struct gfc_ss): New field loop.
+	* trans-array.c (set_ss_loop): New function.
+	(gfc_add_ss_to_loop): Call set_ss_loop.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans.h (struct gfc_ss_info): New field refcount.
+	* trans-array.c (free_ss_info): Decrement refcount. Return early if
+	still non-zero.
+	(gfc_get_array_ss, gfc_get_temp_ss, gfc_get_scalar_ss): Increment
+	refcount.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_trans_create_temp_array): Move invariant condition
+	out of the containing loop. 
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_conv_loop_setup, gfc_trans_create_temp_array):
+	Move specloop arrays clearing from the former to the latter.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (set_loop_bounds): Separate the beginning of
+	gfc_conv_loop_setup into a function of its own.
+	(set_delta): Separate the end of gfc_conv_loop_setup into a function
+	of its own.
+	(gfc_conv_loop_setup): Call set_loop_bounds and set delta.
+	(set_loop_bounds, set_delta, gfc_conv_loop_setup): Make loopspec a
+	pointer to the specloop field from the loop struct.
+
+2011-11-03  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/50933
+	* interface.c (gfc_compare_derived_types): Fix check for BIND(C).
+
+2011-11-03  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/50960
+	* trans-decl.c (gfc_finish_var_decl): Mark PARAMETER as TREE_READONLY.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans.h (struct gfc_ss, struct gfc_ss_info): Move field
+	gfc_ss::where into gfc_ss_info.
+	* trans-array.c (gfc_add_loop_ss_code):
+	Update reference chains.
+	* trans-stmt.c (gfc_trans_where_assign, gfc_trans_where_3): Ditto.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans.h (struct gfc_ss, struct gfc_ss_info): Move field
+	gfc_ss::useflags into gfc_ss_info.
+	* trans-array.c (gfc_mark_ss_chain_used, gfc_trans_preloop_setup,
+	gfc_trans_scalarizing_loops, gfc_trans_scalarized_boundary):
+	Update reference chains.
+	* trans-expr.c (gfc_conv_procedure_call): Ditto.
+	* trans-intrinsic.c (gfc_conv_intrinsic_function): Ditto.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans.h (struct gfc_ss, struct gfc_ss_info): Move field
+	gfc_ss::data::info into gfc_ss_info::data and remove empty union
+	gfc_ss::data.
+	* trans-array.c (gfc_free_ss, gfc_trans_create_temp_array,
+	gfc_trans_constant_array_constructor, gfc_trans_array_constructor,
+	gfc_set_vector_loop_bounds, gfc_add_loop_ss_code,
+	gfc_conv_ss_descriptor, gfc_trans_array_bound_check,
+	gfc_conv_array_index_offset, gfc_conv_scalarized_array_ref,
+	add_array_offset, gfc_trans_preloop_setup,
+	gfc_trans_scalarized_boundary, gfc_conv_section_startstride,
+	gfc_conv_ss_startstride, gfc_could_be_alias,
+	gfc_conv_loop_setup, gfc_conv_expr_descriptor,
+	gfc_alloc_allocatable_for_assignment, gfc_walk_array_ref):
+	Update reference chains and factor them where possible.
+	* trans-expr.c (gfc_conv_variable, gfc_conv_subref_array_arg,
+	gfc_conv_procedure_call, gfc_trans_subarray_assign): Updata reference
+	chains.
+	* trans-intrinsic.c (gfc_conv_intrinsic_transfer): Ditto.
+	* trans-io.c (transfer_array_component): Ditto.
+	* trans-stmt.c (gfc_conv_elemental_dependencies,
+	gfc_trans_pointer_assign_need_temp): Ditto.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans.h (struct gfc_ss, struct gfc_ss_info): Move member struct
+	gfc_ss::data::temp into gfc_ss_info::data.
+	* trans-array.c (gfc_get_temp_ss, gfc_conv_loop_setup): Update reference
+	chains.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans.h (struct gfc_ss, struct gfc_ss_info): Move member struct
+	gfc_ss::data::scalar into newly created union gfc_ss_info::data,
+	and rename subfield expr to value.
+	* trans-array.c (gfc_add_loop_ss_code, gfc_conv_array_index_offset,
+	gfc_conv_expr_descriptor): Update reference chains.
+	* trans-const.c (gfc_conv_constant): Ditto.
+	* trans-expr.c (gfc_conv_expr): Ditto.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans.h (struct gfc_ss, struct gfc_ss_info): Move field
+	string_length from the former struct to the latter.
+	* trans-array.c
+	(gfc_get_temp_ss, gfc_trans_array_constructor, gfc_add_loop_ss_code,
+	gfc_conv_ss_descriptor, gfc_conv_scalarized_array_ref,
+	gfc_conv_resolve_dependencies, gfc_conv_loop_setup,
+	gfc_conv_expr_descriptor): Update references to string_length and
+	factor common reference chains where possible.
+	* trans-const.c (gfc_conv_constant): Ditto.
+	* trans-expr.c (gfc_conv_variable, gfc_conv_subref_array_arg,
+	gfc_conv_expr): Ditto.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans.h (struct gfc_ss, struct gfc_ss_info): Move field expr from
+	the former struct to the latter.
+	* trans-array.c
+	(gfc_get_array_ss, gfc_get_scalar_ss,
+	gfc_trans_constant_array_constructor, gfc_trans_array_constructor,
+	gfc_add_loop_ss_code, gfc_conv_ss_descriptor,
+	gfc_trans_array_bound_check, gfc_conv_array_index_offset,
+	gfc_conv_scalarized_array_ref, gfc_conv_ss_startstride,
+	gfc_could_be_alias, gfc_conv_resolve_dependencies,
+	gfc_conv_loop_setup, gfc_conv_expr_descriptor,
+	gfc_alloc_allocatable_for_assignment): Update references to expr and
+	factor common reference chains where possible.
+	* trans-const.c (gfc_conv_constant): Ditto.
+	* trans-expr.c (gfc_conv_variable, gfc_conv_procedure_call,
+	gfc_conv_array_constructor_expr, gfc_conv_expr,
+	gfc_conv_expr_reference): Ditto.
+	* trans-intrinsic.c (trans_this_image, gfc_conv_intrinsic_bound,
+	gfc_conv_intrinsic_cobound, gfc_conv_intrinsic_funcall,
+	gfc_add_intrinsic_ss_code): Ditto.
+	* trans-stmt.c (gfc_conv_elemental_dependencies): Ditto.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans.h (struct gfc_ss_info): New struct.
+	(gfc_get_ss_info): New macro.
+	(struct gfc_ss): Move type field to struct gfc_ss_info.
+	Add an info field of type gfc_ss_info.
+	* trans-array.c (free_ss_info): New function.
+	(gfc_free_ss): Call free_ss_info.
+	(gfc_get_array_ss, gfc_get_temp_ss, gfc_get_scalar_ss):
+	Allocate gfc_ss_info field.
+	(gfc_get_array_ss, gfc_get_temp_ss, gfc_get_scalar_ss,
+	gfc_set_vector_loop_bounds, gfc_add_loop_ss_code,
+	gfc_conv_array_index_offset, gfc_trans_preloop_setup,
+	gfc_trans_scalarized_loop_boundary, gfc_conv_section_startstride,
+	gfc_conv_ss_startstride, gfc_conv_resolve_dependencies,
+	gfc_conv_loop_setup, transposed_dims, gfc_conv_expr_descriptor,
+	gfc_walk_elemental_function_args): Update references to type.
+	* trans-const.c (gfc_conv_constant): Factor common reference chains
+	and update reference to type.
+	* trans-expr.c (gfc_conv_procedure_call, gfc_trans_assignment_1):
+	Update reference to type.
+	(gfc_conv_array_constructor_expr, gfc_conv_expr,
+	gfc_conv_expr_reference): Ditto. Factor common reference chains.
+	* trans-intrinsic.c (walk_inline_intrinsic_transpose): Update references
+	to type
+	* trans-stmt.c (gfc_trans_where_assign): Ditto.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans.h (struct gfc_ss, struct gfc_array_info): Move shape field
+	from the former struct to the latter.
+	* trans-array.c (gfc_conv_ss_startstride, gfc_conv_loop_setup):
+	Update field references.
+	* trans-expr.c (gfc_trans_subarray_assign): Update field references
+	and factor common reference chains.
+	* trans-io.c (transfer_array_component): Ditto.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans.h (struct gfc_array_info): Move dim and dimen fields...
+	(struct gfc_ss): ... here.  Remove gfc_ss::data::temp::dimen field.
+	* trans-array.c (gfc_conv_loop_setup): Remove temp_ss dim array
+	initialization.
+	(gfc_get_temp_ss): Initialize dim and dimen.
+	(gfc_free_ss, gfc_get_array_ss, gfc_get_temp_ss,
+	gfc_set_loop_bounds_from_array_spec, get_array_ref_dim,
+	gfc_trans_create_temp_array, gfc_trans_constant_array_constructor,
+	gfc_set_vector_loop_bounds, gfc_conv_scalarized_array_ref,
+	gfc_trans_preloop_setup, gfc_conv_ss_startstride,
+	gfc_conv_resolve_dependencies, gfc_conv_loop_setup, transposed_dims,
+	gfc_conv_expr_descriptor, gfc_alloc_allocatable_for_assignment,
+	gfc_walk_array_ref): Update field references.
+	* trans-expr.c (gfc_conv_subref_array_arg, gfc_conv_procedure_call):
+	Ditto.
+	* trans-intrinsic.c (walk_inline_intrinsic_transpose): Ditto.
+	* trans-stmt.c (gfc_conv_elemental_dependencies): Ditto.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans.h (struct gfc_ss_info, struct gfc_array_info):
+	Rename the former to the latter.
+	* trans-array.c (gfc_get_array_ss, gfc_trans_allocate_array_storage,
+	get_array_ref_dim, gfc_trans_create_temp_array,
+	gfc_trans_constant_array_constructor, gfc_set_vector_loop_bounds,
+	gfc_conv_array_index_offset, gfc_conv_scalarized_array_ref,
+	add_array_offset, gfc_trans_preloop_setup, gfc_conv_section_startstride,
+	gfc_conv_ss_startstride, gfc_conv_loop_setup, transposed_dims,
+	gfc_conv_expr_descriptor): Update all uses.
+	* trans-expr.c (gfc_conv_subref_array_arg, gfc_conv_procedure_call):
+	Ditto.
+	* trans-intrinsic.c (gfc_conv_intrinsic_transfer,
+	walk_inline_intrinsic_transpose): Ditto.
+	* trans-stmt.c (gfc_conv_elemental_dependencies,
+	gfc_trans_pointer_assign_need_temp): Ditto.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (dim_ok, transposed_dims): Rename the former to the
+	latter.  Change argument type.  Invert return value.
+	(gfc_conv_expr_descriptor): Update calls.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (get_array_ref_dim): Change argument type and name.
+	Obtain previous argument from the new argument in the body.
+	(gfc_trans_create_temp_arry, gfc_conv_loop_setup): Update calls.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_set_vector_loop_bounds, set_vector_loop_bounds):
+	Rename the former to the latter.  Change type and name of argument.
+	Get previous argument from the new one.
+	(gfc_add_loop_ss_code): Update call.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.h (gfc_trans_create_temp_array): Replace info argument
+	with ss argument.
+	* trans-array.c (gfc_trans_create_temp_array): Ditto. Get info from ss.
+	(gfc_trans_array_constructor, gfc_conv_loop_setup): Update call to
+	gfc_trans_create_temp_array.
+	* trans-expr.c (gfc_conv_procedure_call): Ditto.
+	* trans-intrinsic.c (gfc_conv_intrinsic_transfer): Ditto.
+	* trans-stmt.c (gfc_conv_elemental_dependencies): Ditto.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_trans_array_bound_check): Use ss argument
+	to get name.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_trans_array_bound_check,
+	trans_array_bound_check): Rename the former to the latter.
+	Replace descriptor argument with ss argument.  Get descriptor from ss.
+	(gfc_conv_array_index_offset, conv_array_index_offset): Rename the
+	former to the latter.  Update call to trans_array_bound_check.
+	Replace info argument with ss argument.  Get info from ss.
+	(gfc_conv_scalarized_array_ref): Update call to conv_array_index_offset.
+	(add_array_offset): Ditto
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_trans_constant_array_constructor,
+	trans_constant_array_constructor): Rename the former to the latter.
+	Don't set the rank of the temporary for the loop.  Remove then unused
+	loop argument.
+	(gfc_trans_array_constructor): Update call.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_trans_scalarizing_loops): Stop loop before end
+	marker, not after it.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_conv_loop_setup): Also skip temporary arrays.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_conv_ss_startstride): Access array bounds along
+	array dimensions instead of loop dimensions.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_trans_preloop_setup): Assertify one condition.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_walk_array_ref): Skip coarray dimensions.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (get_array_ref_dim): Remove redundant condition.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_trans_preloop_setup): Move common code...
+	(add_array_offset): ...into that new function.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_trans_preloop_setup): Use loop's dimension instead
+	of array's dimention. Check that it is indeed the same.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_trans_preloop_setup): Remove redundant assertion.
+	Special case outermost loop.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_trans_preloop_setup): Factor loop index
+	initialization.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_trans_preloop_setup): Move code earlier.
+
+2011-11-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_trans_preloop_setup): Move array reference
+	initialisation earlier. Factor subsequent array references.
+
+2011-11-02  Rainer Orth  <ro@CeBiTec.Uni-Bielefeld.DE>
+
+	* Makef-lang.in (gfortranspec.o): Pass SHLIB instead of SHLIB_LINK.
+
+2011-10-30  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/50573
+	* check.c (gfc_check_dshift): Update argument checking for BOZ.
+	Update checking SHIFT against BITSIZE of I or J.
+	* intrinsic.texi: Update docs for DSHIFTL and DSHIFTR.
+
+2011-10-28  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* check.c (gfc_check_atan_2): Typo in comment.
+	(gfc_check_nearest): If 's' is constant, check that it is not 0.
+	* simplify.c (simplify_dshift, gfc_simplify_ibclr, gfc_simplify_ibits,
+	gfc_simplify_ibset, simplify_shift, gfc_simplify_ishftc,
+	gfc_simplify_nearest): Remove dead code.
+
+2011-10-23  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* simplify.c (simplify_transformation_to_array): Fix memory leak.
+
+2011-10-20  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/50821
+	* check.c (gfc_check_ishftc): Check args are constant before 
+	extracting the integer.
+
+2011-10-20  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/50514
+	* check.c (less_than_bitsize1): Check |shift| <= bit_size(i).
+	(gfc_check_ishftc):  Check |shift| <= bit_size(i) and check
+	that size is positive.
+
+2011-10-20  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/50524
+	* resolve.c (resolve_ref): Check return value of resolve_substring().
+
+2011-10-20  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* io.c (match_dt_format): Match a user-defined operator or a kind
+	type prefixed string.
+
+2011-10-19  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47023
+	* check.c (gfc_check_sizeof): Reject procedures as argument of SIZEOF.
+	* intrinsinc.texi (SIZEOF): Document it.
+	(STORAGE_SIZE): Fix special characters. Fix line breaks.
+
+2011-10-18  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/50420
+	* trans.c (gfc_build_array_ref): If type is not an array, check that
+	there is nothing to do, and do nothing.
+
+2011-10-18  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/50420
+	* trans-types.c (gfc_build_array_type): Don't force lower bound to one
+	in the deferred case.
+
+2011-10-18  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/50420
+	* simplify.c (simplify_cobound): Accept non-last-in-ref-chain coarrays.
+	Don't set already set array ref.
+
+2011-10-18  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* array.c (gfc_find_array_ref): Remove coarray-specific handling.
+
+2011-10-18  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/50420
+	* check.c (dim_corank_check): Use gfc_get_corank to get corank.
+
+2011-10-18  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/50420
+	* trans-intrinsic.c (walk_coarray): Change AR_ELEMENT to AR_SECTION.
+
+	PR fortran/50420
+	* trans-intrinsic.c (walk_coarray): Use gfc_walk_array_ref for
+	the scalarization chain initialization. 
+
+2011-10-18  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/50420
+	* trans-intrinsic.c (walk_coarray): Allow subreferences after a
+	coarray object reference.
+
+2011-10-18  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/50420
+	* trans-array.c (gfc_walk_array_ref): Allow zero rank arrays
+	if they are coarrays.
+
+2011-10-18  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.h (gfc_walk_array_ref): New prototype.
+	* trans-array.c (gfc_walk_array_ref): New function, containing
+	all but the beginning of gfc_walk_variable_expr's code.
+	(gfc_walk_variable_expr): Use gfc_walk_array_ref.
+
+2011-10-18  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/50420
+	* trans-array.c (gfc_conv_expr_descriptor): Use loop.dimen instead of
+	ndim for the descriptor's rank.
+
+2011-10-18  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/50420
+	* trans-array.c (gfc_conv_expr_descriptor): Count codimensions starting
+	from zero, and add then the relevant offset (either ndim or loop.dimen)
+	depending on context.
+
+2011-10-18  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_conv_expr_descriptor): Save some horizontal space.
+
+2011-10-18  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_conv_expr_descriptor): Move ndim initialization
+	earlier.
+
+2011-10-18  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47023
+	* decl.c (verify_c_interop_param): Renamed to
+	'gfc_verify_c_interop_param'. Add error message for polymorphic
+	arguments.
+	(verify_c_interop): Renamed to 'gfc_verify_c_interop'. Reject
+	polymorphic variables.
+	(verify_bind_c_sym): Renamed 'verify_c_interop'.
+	* gfortran.h (verify_c_interop,verify_c_interop_param): Renamed.
+	* check.c (gfc_check_sizeof): Ditto.
+	* resolve.c (gfc_iso_c_func_interface,resolve_fl_procedure): Ditto.
+	* symbol.c (verify_bind_c_derived_type): Ditto.
+
+2011-10-15  Tom Tromey  <tromey@redhat.com>
+	    Dodji Seketeli  <dodji@redhat.com>
+
+	* cpp.c (print_line, cb_define): Adjust to avoid using internals
+	of struct line_map.  Use the public API instead.
+
+2011-10-17  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47023
+	PR fortran/50752
+	* primary.c (match_kind_param): Avoid segfault.
+
+2011-10-16  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	* frontend-passes.c (current_ns):  Make static.
+	(create_var):  Note parent of newly created namespace.
+	(optimize_namespace):  Don't wak sibling namespaces
+	if they are EXEC_BLOCK because this is handled...
+	(gfc_code_walker):  ... here.  Also walk ASSOCIATE lists.
+
+2011-10-16  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47023
+	* primary.c (match_kind_param): Detect ISO_C_BINDING kinds.
+	(get_kind): Pass on 'is_iso_c' flag.
+	(match_integer_constant,match_real_constant,match_logical_constant):
+	Set 'ts.is_c_interop'.
+
+2011-10-16  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/50547
+	* resolve.c (resolve_formal_arglist): Remove unneeded error message.
+	Some reshuffling.
+
+2011-10-15  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.texi (Fortran 2008 status, TS 29113 status,
+	Further Interoperability of Fortran with C): Update implementation
+	status, change references from TR 29113 to TS 29113.
+	* intrinsic.texi (RANK): Change TR 29113 to TS 29113.
+	* invoke.text (-std=): Ditto, change -std=f2008tr to -std=f2008ts.
+	* lang.opt (std=): Ditto.
+	* options.c (gfc_handle_option, set_default_std_flags): Ditto and
+	change GFC_STD_F2008_TR to GFC_STD_F2008_TS.
+	* libgfortran.h: Ditto.
+	* intrinsic.c (add_functions, gfc_check_intrinsic_standard): Ditto.
+	* decl.c (verify_c_interop_param): Ditto.
+
+2011-10-14  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/50570
+	* expr.c (gfc_check_vardef_context): Don't throw an error on
+	non-pointer assignments involving an intent(in) pointer dummy.
+
+2011-10-14  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/50718
+	* trans-expr.c (gfc_conv_procedure_call): Fix -fcheck=pointer
+	for dummy arguments with VALUE attribute.
+
+2011-10-11  Tobias Burnus  <burnus@net-b.de>
+	    Janus Weil  <janus@gcc.gnu.org>
+
+	* invoke.texi (-fwhole-file): Update wording since -fwhole-file
+	is now enabled by default.
+
+2011-10-11  Michael Meissner  <meissner@linux.vnet.ibm.com>
+
+	* trans-expr.c (gfc_conv_power_op): Delete old interface with two
+	parallel arrays to hold standard builtin declarations, and replace
+	it with a function based interface that can support creating
+	builtins on the fly in the future.  Change all uses, and poison
+	the old names.  Make sure 0 is not a legitimate builtin index.
+	(fill_with_spaces): Ditto.
+	(gfc_trans_string_copy): Ditto.
+	(gfc_trans_zero_assign): Ditto.
+	(gfc_build_memcpy_call): Ditto.
+	(alloc_scalar_allocatable_for_assignment): Ditto.
+	* trans-array.c (gfc_trans_array_constructor_value): Ditto.
+	(duplicate_allocatable): Ditto.
+	(gfc_alloc_allocatable_for_assignment): Ditto.
+	* trans-openmp.c (gfc_omp_clause_copy_ctor): Ditto.
+	(gfc_omp_clause_assign_op): Ditto.
+	(gfc_trans_omp_atomic): Ditto.
+	(gfc_trans_omp_do): Ditto.
+	(gfc_trans_omp_task): Ditto.
+	* trans-stmt.c (gfc_trans_stop): Ditto.
+	(gfc_trans_sync): Ditto.
+	(gfc_trans_allocate): Ditto.
+	(gfc_trans_deallocate): Ditto.
+	* trans.c (gfc_call_malloc): Ditto.
+	(gfc_allocate_using_malloc): Ditto.
+	(gfc_call_free): Ditto.
+	(gfc_deallocate_with_status): Ditto.
+	(gfc_deallocate_scalar_with_status): Ditto.
+	* f95-lang.c (gfc_define_builtin): Ditto.
+	(gfc_init_builtin_functions): Ditto.
+	* trans-decl.c (create_main_function): Ditto.
+	* trans-intrinsic.c (builtin_decl_for_precision): Ditto.
+
+2011-10-10  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/50564
+	* frontend-passes (forall_level):  New variable.
+	(cfe_register_funcs):  Don't register functions if we
+	are within a forall loop.
+	(optimize_namespace):  Set forall_level to 0 before entry.
+	(gfc_code_walker):  Increase/decrease forall_level.
+
+2011-10-09  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/50273
+	* trans-common.c (translate_common): Fix -Walign-commons check.
+
+2011-10-09  Mikael Morin  <mikael.morin@sfr.fr>
+
+	* interface.c (check_dummy_characteristics): Count dimensions starting
+	from one in diagnostic.
+
+2011-10-09  Tobias Burnus  <burnus@net-b.de>
+
+	* Make-lang.in (F95_PARSER_OBJS, GFORTRAN_TRANS_DEPS): Add
+	dependency on iso-c-binding.def and iso-fortran-env.def.
+	* module.c (import_iso_c_binding_module): Add error when
+	explicitly importing a nonstandard symbol; extend standard-
+	depending loading.
+	* iso-c-binding.def: Add c_float128 and c_float128_complex
+	integer parameters (for -std=gnu).
+	* intrinsic.texi (ISO_C_Binding): Document them.
+	* symbol.c (generate_isocbinding_symbol): Change macros
+	to ignore GFC_STD_* data.
+	* trans-types.c (gfc_init_c_interop_kinds): Ditto; make
+	nonstatic and renamed from "init_c_interop_kinds".
+	(gfc_init_kinds): Don't call it
+	* trans-types.h (gfc_init_c_interop_kinds): Add prototype.
+	* f95-lang.c (gfc_init_decl_processing): Call it.
+
+2011-10-09  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/50659
+	* expr.c (replace_symbol): Only do replacement if the symbol is a dummy.
+
+2011-10-08  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/47844
+	* trans-array.c (gfc_conv_array_index_offset): Use descriptor
+	stride for pointer function results.
+
+2011-10-07  Mikael Morin  <mikael.morin@sfr.fr>
+
+	* trans-array.c	(gfc_conv_expr_descriptor): Remove trailing whitespace.
+
+2011-10-07  Mikael Morin  <mikael.morin@sfr.fr>
+
+	* trans-array.c	(gfc_conv_ss_startstride): Merge two switch cases.
+
+2011-10-07  Mikael Morin  <mikael.morin@sfr.fr>
+
+	* trans-array.c (gfc_conv_section_startstride): Remove coarray argument.
+	Remove conditions on coarray.
+	(gfc_conv_ss_startstride): Update call to gfc_conv_section_startstride.
+	(gfc_conv_expr_descriptor): Ditto. Add assertions before the call.
+
+2011-10-07  Mikael Morin  <mikael.morin@sfr.fr>
+
+	* trans-array.c (gfc_conv_section_startstride): Remove coarray_last
+	argument. Remove condition on coarray_last.
+	(gfc_conv_ss_startstride): Update call to gfc_conv_section_startstride.
+	(gfc_conv_expr_descriptor): Ditto.
+
+2011-10-07  Mikael Morin  <mikael.morin@sfr.fr>
+
+	* trans-array.c (gfc_walk_variable_expr): Remove scalar coarray
+	handling.  Don't reset array ref's corank and codimensions' types
+	in the full array ref case.  Update loop upper limit.
+	Remove DIMEN_THIS_IMAGE case.  Remove unnecessary conditions.
+
+2011-10-07  Mikael Morin  <mikael.morin@sfr.fr>
+
+	* trans.h (gfc_ss_info): Remove codimen field.
+	* trans-array.c (gfc_get_array_ss): Don't set codimen field.
+	(gfc_trans_create_temp_array): Don't set descriptor's cobounds.
+	(gfc_trans_constant_array_constructor): Update loop upper limit.
+	(gfc_conv_ss_startstride): Don't set codimen field.
+	Don't get descriptor's cobounds.
+	(gfc_walk_variable_expr): Update dimension index.
+	* trans-intrinsic.c (trans_this_image, trans_image_index,
+	conv_intrinsic_cobound): Don't set codimen field
+
+2011-10-07  Mikael Morin  <mikael.morin@sfr.fr>
+
+	* trans.h (gfc_loopinfo): Remove codimen field.
+	* trans-array.c (gfc_set_vector_loop_bounds,
+	gfc_trans_scalarizing_loops, gfc_conv_loop_setup): Update loop upper
+	limit.
+	(gfc_set_loop_bounds_from_array_spec): Ditto. Remove skip on last
+	codimension.
+	(gfc_start_scalarized_body): Update loop lower limit.
+	(gfc_conv_ss_startstride): Don't set loop's codimen field.
+	(gfc_conv_loop_setup): Remove unnecessary condition.
+	(gfc_conv_expr_descriptor): Don't use loop's codimen field as corank.
+
+2011-10-07  Mikael Morin  <mikael.morin@sfr.fr>
+
+	* trans.h (gfc_ss): Remove data.temp.codimen field.
+	* trans-array.c (gfc_conv_resolve_dependencies,
+	gfc_conv_expr_descriptor): Don't set temp's codimen field.
+
+2011-10-07  Mikael Morin  <mikael.morin@sfr.fr>
+
+	* resolve.c (resolve_array_ref): Set array_ref's dimen field (and the
+	associated dimen_type) in the full array ref case.
+
+2011-10-07  Mikael Morin  <mikael.morin@sfr.fr>
+
+	* trans-intrinsic.c (walk_coarray): New function.
+	(convert_element_to_coarray_ref): Move code to walk_coarray. Remove.
+	(trans-this_image, trans_image_index, conv_intrinsic_cobound):
+	Use walk_coarray.
+
+2011-10-07  Mikael Morin  <mikael.morin@sfr.fr>
+
+	* trans-array.c (gfc_conv_expr_descriptor): Add out-of-the-scalarizer
+	cobounds evaluation.
+
+2011-10-07  Mikael Morin  <mikael.morin@sfr.fr>
+
+	* trans-array.c (gfc_conv_ss_startstride): Support zero rank loop.
+
+2011-10-07  Mikael Morin  <mikael.morin@sfr.fr>
+
+	* trans-array.c (gfc_conv_section_startstride): Move code to
+	evaluate_bound.  Use evaluate_bound.
+	(evaluate_bound): New function.
+
+2011-10-07  Mikael Morin  <mikael.morin@sfr.fr>
+
+	* trans-array.c (gfc_conv_section_startstride): Update assertion to
+	also accept coarrays.
+
+2011-10-07  Mikael Morin  <mikael.morin@sfr.fr>
+
+	* trans-array.c (gfc_conv_section_startstride): Factor common
+	array ref references.
+
+2011-10-07  Mikael Morin  <mikael.morin@sfr.fr>
+
+	* trans-array.c (gfc_conv_expr_descriptor): Use codim instead of
+	loop.codimen as argument to gfc_get_array_type_bounds.
+
+2011-10-07  Mikael Morin  <mikael.morin@sfr.fr>
+
+	* trans-array.h (struct gfc_se): New flag want_coarray.
+	* trans-intrinsic.c (trans_this_image, trans_image_index,
+	conv_intrinsic_cobound): Set want_coarray.
+	* trans_array.c (gfc_conv_expr_descriptor): Evaluate codimension
+	earlier and without relying on the scalarizer.
+
+2011-10-07  Mikael Morin  <mikael.morin@sfr.fr>
+
+	* expr.c (gfc_get_corank): Return 0 if input expression is not a
+	coarray.
+
+2011-10-07  Mikael Morin  <mikael.morin@sfr.fr>
+
+	* trans-array.c (gfc_conv_expr_descriptor): Simplify coarray
+	descriptor setup code.
+
+2011-10-07  Mikael Morin  <mikael.morin@sfr.fr>
+
+	* resolve.c (compare_spec_to_ref): Move coarray ref initialization
+	code...
+	(resolve_array_ref): ... here.
+
+2011-10-07  Mikael Morin  <mikael.morin@sfr.fr>
+
+	* check.c (is_coarray): Remove.
+	(coarray_check): Use gfc_is_coarray.
+
+2011-10-07  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/50625
+	* class.c (gfc_build_class_symbol): Fix whitespace.
+	* module.c (mio_symbol): Set 'class_ok' attribute.
+	* trans-decl.c (gfc_get_symbol_decl): Make sure the backend_decl has
+	been built for class symbols.
+
+2011-10-04  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/35831
+	* interface.c (check_dummy_characteristics): Check the array shape.
+
+2011-10-01  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/50585
+	* interface.c (get_expr_storage_size): Check if 'length' component is
+	associated.
+
+2011-09-29  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/50547
+	* resolve.c (resolve_formal_arglist): Fix pureness check for dummy
+	functions.
+
+	PR fortran/50553
+	* symbol.c (check_conflict): Forbid TARGET attribute for statement
+	functions.
+
+2011-09-27  Jakub Jelinek  <jakub@redhat.com>
+
+	* trans-types.c (gfc_type_for_size): Return wider type
+	if no suitable narrower type has been found.
+	(gfc_type_for_mode): Return NULL_TREE if gfc_type_for_size
+	returned type doesn't have expected TYPE_MODE.
+
+2011-09-26  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/50515
+	* resolve.c (resolve_common_blocks): Check for EXTERNAL attribute.
+
+	PR fortran/50517
+	* interface.c (gfc_compare_interfaces): Bugfix in check for result type.
+
+2011-09-22  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41733
+	* expr.c (gfc_check_pointer_assign): Check for nonintrinsic elemental
+	procedures.
+	* interface.c (gfc_compare_interfaces): Rename 'intent_flag'. Check
+	for PURE and ELEMENTAL attributes.
+	(compare_actual_formal): Remove pureness check here.
+
+2011-09-20  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* check.c (gfc_check_c_sizeof): Remove redundant word.
+
+2011-09-20  Simon Baldwin  <simonb@google.com>
+
+	* module.c (gfc_dump_module): Omit timestamp from output.
+
+2011-09-17  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/50403
+	* symbol.c (gfc_use_derived): Fix coding style.
+
+2011-09-15  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/50401
+	* resolve.c (resolve_transfer): Check if component 'ref' is defined.
+
+	PR fortran/50403
+	* symbol.c (gfc_use_derived): Check if argument 'sym' is defined.
+
+2011-09-14  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34547
+	PR fortran/50375
+	* check.c (gfc_check_null): Allow allocatables as MOLD to NULL.
+	* resolve.c (resolve_transfer): Reject NULL without MOLD.
+	* interface.c (gfc_procedure_use): Reject NULL without MOLD
+	if no explicit interface is known.
+	(gfc_search_interface): Reject NULL without MOLD if it would
+	lead to ambiguity.
+
+2011-09-13  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/50379
+	* symbol.c (check_conflict): Check conflict between GENERIC and RESULT
+	attributes.
+
+2011-09-11  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/50327
+	* frontend-passes.c (dummy_expr_callback):  New function.
+	(convert_do_while):  New function.
+	(optimize_namespace):  Call code walker to convert do while loops.
+
+2011-09-11  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/35831
+	PR fortran/47978
+	* interface.c (check_dummy_characteristics): New function to check the
+	characteristics of dummy arguments.
+	(gfc_compare_interfaces,gfc_check_typebound_override): Call it here.
+
+2011-09-08  Mikael Morin  <mikael.morin@sfr.fr>
+
+	* trans-array.c (gfc_trans_constant_array_constructor): Remove
+	superfluous initialisation of DIM field.
+	(gfc_trans_array_constructor): Assert that DIMEN field is properly set.
+	(gfc_conv_expr_descriptor): Ditto.
+	* trans-expr.c (gfc_conv_procedure_call): Ditto.
+
+2011-09-08  Mikael Morin  <mikael.morin@sfr.fr>
+
+	* trans-array.h (gfc_get_scalar_ss): New prototype.
+	* trans-array.c (gfc_get_scalar_ss): New function.
+	(gfc_walk_variable_expr, gfc_walk_op_expr,
+	gfc_walk_elemental_function_args): Re-use gfc_get_scalar_ss.
+	* trans-expr.c (gfc_trans_subarray_assign): Ditto.
+	(gfc_trans_assignment_1): Ditto.
+	* trans-stmt.c (compute_inner_temp_size, gfc_trans_where_assign,
+	gfc_trans_where_3): Ditto.
+
+2011-09-08  Mikael Morin  <mikael.morin@sfr.fr>
+
+	* trans-array.h (gfc_get_temp_ss): New prototype.
+	* trans-array.c (gfc_get_temp_ss): New function.
+	(gfc_conv_resolve_dependencies): Re-use gfc_get_temp_ss.
+	(gfc_conv_expr_descriptor): Ditto.
+	* trans-expr.c (gfc_conv_subref_array_arg): Ditto.
+
+2011-09-08  Mikael Morin  <mikael.morin@sfr.fr>
+
+	* trans-array.h (gfc_get_array_ss): New prototype.
+	* trans-array.c (gfc_get_array_ss): New function.
+	(gfc_walk_variable_expr, gfc_walk_function_expr,
+	gfc_walk_array_constructor): Re-use gfc_get_array_ss.
+	* trans-expr.c (gfc_trans_subarray_assign): Ditto.
+	* trans-intrinsic.c (gfc_walk_intrinsic_bound,
+	gfc_walk_intrinsic_libfunc): Ditto.
+	* trans-io.c (transfer_array_component): Ditto.
+
+2011-09-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/44646
+	* decl.c (gfc_match_entry, gfc_match_end): Handle COMP_DO_CONCURRENT.
+	* dump-parse-tree.c (show_code_node): Handle EXEC_DO_CONCURRENT.
+	* gfortran.h (gfc_exec_op): Add EXEC_DO_CONCURRENT.
+	* match.c (gfc_match_critical, match_exit_cycle, gfc_match_stopcode,
+	lock_unlock_statement, sync_statement, gfc_match_allocate,
+	gfc_match_deallocate, gfc_match_return): Add DO CONCURRENT diagnostic.
+	(gfc_match_do): Match DO CONCURRENT.
+	(match_derived_type_spec, match_type_spec, gfc_free_forall_iterator,
+	match_forall_iterator, match_forall_header, match_simple_forall,
+	gfc_match_forall): Move up in the file.
+	* parse.c (check_do_closure, parse_do_block): Handle do concurrent.
+	* parse.h (gfc_compile_state): Add COMP_DO_CONCURRENT.
+	* resolve.c (do_concurrent_flag): New global variable.
+	(resolve_function, pure_subroutine, resolve_branch,
+	gfc_resolve_blocks, resolve_code, resolve_types): Add do concurrent
+	diagnostic.
+	* st.c (gfc_free_statement): Handle EXEC_DO_CONCURRENT.
+	* trans-stmt.c (gfc_trans_do_concurrent): New function.
+	(gfc_trans_forall_1): Handle do concurrent.
+	* trans-stmt.h (gfc_trans_do_concurrent): New function prototype.
+	* trans.c (trans_code): Call it.
+	* frontend-passes.c (gfc_code_walker): Handle EXEC_DO_CONCURRENT.
+
+2011-09-07  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/48095
+	* primary.c (gfc_match_structure_constructor): Handle parsing of
+	procedure pointers components in structure constructors.
+	* resolve.c (resolve_structure_cons): Check interface of procedure
+	pointer components. Changed wording of some error messages.
+
+2011-09-04  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/50227
+	* trans-types.c (gfc_sym_type): Check for proc_name.
+
+2011-08-30  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/45044
+	* trans-common.c (build_common_decl): Warn if named common
+	block's size is not everywhere the same.
+
+2011-08-30  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/45170
+	* trans-stmt.c (gfc_trans_allocate): Evaluate the substring.
+
+2011-08-29  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/50225
+	* trans-decl.c (gfc_generate_function_code): Nullify polymorphic
+	allocatable function results.
+
+2011-08-29  Tobias Burnus  <burnus@net-b.de>
+
+	* trans-decl.c (generate_coarray_sym_init): Use
+	GFC_CAF_COARRAY_STATIC for static coarrays.
+
+2011-08-28  Dodji Seketeli  <dodji@redhat.com>
+
+	* scanner.c (load_file): Don't abuse LC_RENAME reason while
+	(indirectly) calling linemap_add.
+
+2011-08-26  Jakub Jelinek  <jakub@redhat.com>
+
+	* trans-decl.c (get_proc_pointer_decl): Set DECL_TLS_MODEL
+	if threadprivate.
+	* symbol.c (check_conflict): Allow threadprivate attribute with
+	FL_PROCEDURE if proc_pointer.
+
+2011-08-25  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/50050
+	* expr.c (gfc_free_shape): Do nothing if shape is NULL.
+	(free_expr0): Remove redundant NULL shape check.
+	* resolve.c (check_host_association): Ditto.
+	* trans-expr.c (gfc_trans_subarray_assign): Assert that shape is
+	non-NULL.
+	* trans-io.c (transfer_array_component): Ditto.
+
+2011-08-25  Tobias Burnus  <burnus@net-b.de>
+
+	* trans-array.c (gfc_conv_descriptor_token): Add assert.
+	* trans-decl.c (gfc_build_qualified_array,
+	create_function_arglist): Handle assumed-shape arrays.
+	* trans-expr.c (gfc_conv_procedure_call): Ditto.
+	* trans-types.c (gfc_get_array_descriptor_base): Ditto, don't
+	add "caf_token" to assumed-shape descriptors, new akind argument.
+	(gfc_get_array_type_bounds): Pass akind.
+	* trans.h (lang_decl): New elements caf_offset and token.
+	(GFC_DECL_TOKEN, GFC_DECL_CAF_OFFSET): New macros.
+
+2011-08-25  Tobias Burnus  <burnus@net-b.de>
+
+	* trans-array.c (structure_alloc_comps): Fix for allocatable
+	scalar coarray components.
+	* trans-expr.c (gfc_conv_component_ref): Ditto.
+	* trans-type.c (gfc_get_derived_type): Ditto.
+
+2011-08-24  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/50163
+	* expr.c (check_init_expr): Return when an error occured.
+
+2011-08-24  Joseph Myers  <joseph@codesourcery.com>
+
+	* Make-lang.in (fortran/cpp.o): Remove explicit compilation rule.
+
+2011-08-23  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/31600
+	* symbol.c (gfc_add_type): Better diagnostic if redefining
+	use-associated symbol.
+	* module.c (gfc_use_module): Use module name as locus.
+
+2011-08-22  Gabriel Charette  <gchare@google.com>
+
+	* cpp.c (gfc_cpp_init): Force BUILTINS_LOCATION for tokens
+	defined in cpp_define_builtins.
+
+2011-08-22  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/50050
+	* gfortran.h (gfc_clear_shape, gfc_free_shape): New prototypes.
+	* expr.c (gfc_clear_shape, gfc_free_shape): New functions.
+	(free_expr0): Re-use gfc_free_shape.
+	* trans-expr.c (gfc_trans_subarray_assign): Ditto.
+	* trans-io.c (transfer_array_component): Ditto.
+	* resolve.c (check_host_association): Ditto.
+	(gfc_expr_to_initialize): Don't force the rank value and free the shape
+	after updating the expression. Recalculate shape and rank.
+	(resolve_where_shape): Re-use gfc_clear_shape.
+	* array.c (gfc_array_ref_shape): Ditto.
+
+2011-08-21  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/47659
+	* expr.c (gfc_check_assign): Check for type conversions when the
+	right-hand side is a constant REAL/COMPLEX contstant the left-hand
+	side is also REAL/COMPLEX.  Don't warn when a narrowing conversion
+	for REAL does not change the value of the constant.
+
+2011-08-21  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/50130
+	* resolve.c (resolve_array_ref):  Don't calculate upper bound
+	if the stride is zero.
+
+2011-08-20  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/49638
+	* dependency.c (gfc_dep_compare_expr): Add new result value "-3".
+	(gfc_check_element_vs_section,gfc_check_element_vs_element): Handle
+	result value "-3".
+	* frontend-passes.c (optimize_comparison): Ditto.
+	* interface.c (gfc_check_typebound_override): Ditto.
+
+2011-08-19  Mikael Morin  <mikael.morin@sfr.fr>
+
+	PR fortran/50129
+	* parse.c (parse_where): Undo changes after emitting an error. 
+
+2011-08-19  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/49792
+	* trans-expr.c (gfc_trans_assignment_1): Set OMPWS_SCALARIZER_WS
+	bit in ompws_flags only if loop.temp_ss is NULL, and clear it if
+	lhs needs reallocation.
+	* trans-openmp.c (gfc_trans_omp_workshare): Don't return early if
+	code is NULL, emit a barrier if workshare emitted no code at all
+	and NOWAIT clause isn't present.
+
+2011-08-19  Mikael Morin  <mikael.morin@sfr.fr>
+
+	PR fortran/50071
+	* gfortran.h (gfc_exec_op): New constant EXEC_END_NESTED_BLOCK.
+	* parse.c (check_statement_label): Accept ST_END_BLOCK and
+	ST_END_ASSOCIATE as valid branch target.
+	(accept_statement): Change EXEC_END_BLOCK to EXEC_END_NESTED_BLOCK.
+	Add EXEC_END_BLOCK code in the ST_END_BLOCK and ST_END_ASSOCIATE cases.
+	* resolve.c (find_reachable_labels): Change EXEC_END_BLOCK to
+	EXEC_END_NESTED_BLOCK.
+	(resolve_branch): Ditto.
+	(resolve_code): Add EXEC_END_NESTED_BLOCK case.
+	* st.c (gfc_free_statement): Ditto.
+	* trans.c (trans_code): Ditto.
+
+2011-08-18  Mikael Morin  <mikael.morin@sfr.fr>
+
+	PR fortran/50071
+	* symbol.c (gfc_get_st_label): Use the derived type namespace when
+	we are parsing a derived type definition.
+
+2011-08-18  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* parse.c (parse_derived): Add lock_type
+	checks, improve coarray_comp handling.
+	* resolve.c (resolve_allocate_expr,
+	resolve_lock_unlock, resolve_symbol): Fix lock_type
+	constraint checks.
+
+2011-08-17  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/31461
+	* trans-decl.c (generate_local_decl): Warn about
+	unused explicitly imported module variables/parameters.
+
+2011-08-17  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/50070
+	* resolve.c (resolve_fl_variable): Reject non-constant character lengths
+	in COMMON variables.
+
+2011-08-16  Tobias Burnus  <burnus@net-b.de>
+	    Dominique Dhumieres  <dominiq@lps.ens.fr>
+
+	PR fortran/50094
+	* resolve.c (resolve_symbol): Fix stupid typo.
+
+2011-08-15  Tobias Burnus  <burnus@net-b.de>
+
+	* resolve.c (resolve_symbol): Fix coarray result-var check.
+
+2011-08-14  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* module.c (use_iso_fortran_env_module):  Spell 'referrenced' correctly.
+
+2011-08-14  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/50073
+	* decl.c (check_function_name): New function, separated off from
+	'variable_decl' and slightly extended.
+	(variable_decl,attr_decl1): Call it.
+
+2011-08-08  Rainer Orth  <ro@CeBiTec.Uni-Bielefeld.DE>
+
+	* Make-lang.in (gfortran$(exeext)): Add $(EXTRA_GCC_LIBS).
+
+2011-08-07  Janus Weil  <janus@gcc.gnu.org>
+	    Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/49638
+	* dependency.c (are_identical_variables): For dummy arguments only
+	check for equal names, not equal symbols.
+	* interface.c (gfc_check_typebound_override): Add checking for rank
+	and character length.
+
+2011-08-07  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/49638
+	* dependency.h (gfc_is_same_range,gfc_are_identical_variables): Remove
+	two prototypes.
+	* dependency.c (gfc_are_identical_variables,are_identical_variables):
+	Renamed the former to the latter and made static.
+	(gfc_dep_compare_expr): Renamed 'gfc_are_identical_variables', handle
+	commutativity of multiplication.
+	(gfc_is_same_range,is_same_range): Renamed the former to the latter,
+	made static and removed argument 'def'.
+	(check_section_vs_section): Renamed 'gfc_is_same_range'.
+	* gfortran.h (gfc_check_typebound_override): New prototype.
+	* interface.c (gfc_check_typebound_override): Moved here from ...
+	* resolve.c (check_typebound_override): ... here (and renamed).
+	(resolve_typebound_procedure): Renamed 'check_typebound_override'.
+
+2011-08-06  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/50004
+	* target-memory.c (gfc_target_expr-size): Don't clobber typespec
+	for derived types.
+	* simplify.c (gfc_simplify_transfer): Don't calculate source_size
+	twice.
+
+2011-08-05  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/37211
+	* gfortran.h (gfc_calculate_transfer_sizes):  Add prototype.
+	* target-memory.h (gfc_target_interpret_expr):  Add boolean
+	argument wether to convert wide characters.
+	* target-memory.c (gfc_target_expr_size):  Also return length
+	of characters for non-constant expressions if these can be
+	determined from the cl.
+	(interpret_array):  Add argument for gfc_target_interpret_expr.
+	(gfc_interpret_derived):  Likewise.
+	(gfc_target_interpret_expr):  Likewise.
+	* check.c:  Include target-memory.h.
+	(gfc_calculate_transfer_sizes):  New function.
+	(gfc_check_transfer):  When -Wsurprising is in force, calculate
+	sizes and warn if result is larger than size (check moved from
+	gfc_simplify_transfer).
+	* simplify.c (gfc_simplify_transfer):  Use
+	gfc_calculate_transfer_sizes.  Remove warning.
+
+2011-08-04  Richard Guenther  <rguenther@suse.de>
+
+	PR fortran/49957
+	* trans-array.c (add_to_offset): New function.
+	(gfc_conv_array_ref): Build the array index expression in optimally
+	associated order.
+	(gfc_walk_variable_expr): Adjust for the backward walk.
+
+2011-08-02  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/49885
+	* trans-array.c (gfc_trans_auto_array_allocation): Change
+	gfc_start_block to gfc_init_block to avoid spurious extra-scope.
+
+2011-08-02  Tobias Burnus  <burnus@net-b.de>
+
+	* trans-array.c (gfc_array_allocate): Pass token to
+	  gfc_allocate_allocatable for -fcoarray=lib.
+	* trans-stmt.c (gfc_trans_allocate): Update
+	gfc_allocate_allocatable call.
+	* trans.h (gfc_allocate_allocatable): Update prototype.
+	(gfc_allocate_using_lib): Remove.
+	* trans.c (gfc_allocate_using_lib): Make static, handle token.
+	(gfc_allocate_allocatable): Ditto.
+
+2011-08-02  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/46752
+	* cpp.c (cpp_define_builtins): Change _OPENMP to 201107.
+	* openmp.c (gfc_free_omp_clauses): Free also final_expr.
+	(OMP_CLAUSE_FINAL, OMP_CLAUSE_MERGEABLE): Define.
+	(gfc_match_omp_clauses): Handle parsing final and mergeable
+	clauses.
+	(OMP_TASK_CLAUSES): Allow final and mergeable clauses.
+	(gfc_match_omp_taskyield): New function.
+	(resolve_omp_clauses): Resolve final clause.  Allow POINTERs and
+	Cray pointers in clauses other than REDUCTION.
+	(gfc_match_omp_atomic): Match optional
+	read/write/update/capture keywords after !$omp atomic.
+	(resolve_omp_atomic): Handle all OpenMP 3.1 atomic forms.
+	* dump-parse-tree.c (show_omp_node): Handle EXEC_OMP_TASKYIELD,
+	print final and mergeable clauses.
+	(show_code_node): Handle EXEC_OMP_TASKYIELD.
+	* trans-openmp.c (gfc_trans_omp_clauses): Handle final and
+	mergeable clauses.
+	(gfc_trans_omp_taskyield): New function.
+	(gfc_trans_omp_directive): Handle EXEC_OMP_TASKYIELD.
+	(gfc_trans_omp_atomic): Handle all OpenMP 3.1 atomic forms.
+	(gfc_omp_clause_copy_ctor): Handle non-allocated allocatable.
+	(gfc_omp_predetermined_sharing): Adjust comment.
+	* gfortran.h (gfc_statement): Add ST_OMP_TASKYIELD and
+	ST_OMP_END_ATOMIC.
+	(gfc_omp_clauses): Add final_expr and mergeable fields.
+	(gfc_exec_op): Add EXEC_OMP_TASKYIELD.
+	(gfc_omp_atomic_op): New enum typedef.
+	(struct gfc_code): Add ext.omp_atomic.
+	* trans.c (trans_code): Handle EXEC_OMP_TASKYIELD.
+	* frontend-passes.c (gfc_code_walker): Also walk final_expr.
+	* resolve.c (gfc_resolve_blocks, resolve_code): Handle
+	EXEC_OMP_TASKYIELD.
+	* st.c (gfc_free_statement): Likewise.
+	* match.h (gfc_match_omp_taskyield): New prototype.
+	* parse.c (decode_omp_directive): Handle taskyield directive.
+	Handle !$omp end atomic.
+	(case_executable): Add ST_OMP_TASKYIELD case.
+	(gfc_ascii_statement): Handle ST_OMP_TASKYIELD.
+	(parse_omp_atomic): Return gfc_statement instead of void.
+	For !$omp atomic capture parse two assignments instead of
+	just one and require !$omp end atomic afterwards, for
+	other !$omp atomic forms just allow !$omp end atomic at the
+	end.
+	(parse_omp_structured_block, parse_executable): Adjust
+	parse_omp_atomic callers.
+
+2011-08-02  Tobias Burnus  <burnus@net-b.de>
+
+	* intrinsic.c (OMP_LIB): Updated openmp_version's
+	value to 201107.
+	* gfortran.texi (OpenMP): Update ref to OpenMP 3.1.
+	* intrinsic.texi (OpenMP Modules): Update ref to OpenMP 3.1;
+	remove deleted omp_integer_kind and omp_logical_kind constants.
+
+2011-07-31  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/49112
+	* resolve.c (resolve_structure_cons): Don't do the full dt resolution,
+	only call 'resolve_fl_derived0'.
+	(resolve_typebound_procedures): Resolve typebound procedures of
+	parent type.
+	(resolve_fl_derived0): New function, which does a part of the work
+	for 'resolve_fl_derived'.
+	(resolve_fl_derived): Call 'resolve_fl_derived0' and do some additional
+	things.
+
+2011-07-30  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/48876
+	* expr.c (gfc_simplify_expr):  If end of a string is less
+	than zero, set it to zero.
+
+2011-07-28  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/31067
+	* frontend-passes.c (optimize_minmaxloc): New function.
+	(optimize_expr): Call it.
+
+2011-07-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/45586
+	* trans-types.c (gfc_get_derived_type): Ensure that pointer
+	component types are marked as nonrestricted.
+
+2011-07-27  Daniel Carrera  <dcarrera@gmail.com>
+
+	PR fortran/49755
+	* trans.c (gfc_allocate_using_malloc): Change function signature.
+	Return nothing. New parameter "pointer". Eliminate temorary variables. 
+	(gfc_allocate_using_lib): Ditto.
+	(gfc_allocate_allocatable): Ditto. Update call to gfc_allocate_using_lib
+	and gfc_allocate_using_malloc. Do not free and then reallocate a
+	variable that is already allocated.
+	(gfc_likely): New function. Basedon gfc_unlikely.
+	* trans-array.c (gfc_array_init_size): New parameter "descriptor_block".
+	Instructions to modify the array descriptor are stored in this block
+	while other instructions continue to be stored in "pblock".
+	(gfc_array_allocate): Update call to gfc_array_init_size. Move the
+	descriptor_block so that the array descriptor is only updated if
+	the array was allocated successfully.
+	Update calls to gfc_allocate_allocatable and gfc_allocate_using_malloc.
+	* trans.h (gfc_allocate_allocatable): Change function signature.
+	Function now returns void.
+	(gfc_allocate_using_lib): Ditto, and new function parameter.
+	(gfc_allocate_using_malloc): Ditto.
+	* trans-openmp.c (gfc_omp_clause_default_ctor,
+	gfc_omp_clause_copy_ctor,gfc_trans_omp_array_reduction): Replace a call
+	to gfc_allocate_allocatable with gfc_allocate_using_malloc.
+	* trans-stmt.c (gfc_trans_allocate): Update function calls for
+	gfc_allocate_allocatable and gfc_allocate_using_malloc.
+
+2011-07-26  Tobias Burnus  <burnus@net-b.de>
+
+	* trans-array.c (CAF_TOKEN_FIELD): New macro constant.
+	(gfc_conv_descriptor_token): New function.
+	* trans-array.h (gfc_conv_descriptor_token): New prototype.
+	* trans-types.c (gfc_get_array_descriptor_base): For coarrays
+	with -fcoarray=lib, append "void *token" to the array descriptor.
+	(gfc_array_descriptor_base_caf): New static variable.
+	* trans-expr.c (gfc_conv_procedure_call): Handle token and offset
+	when passing a descriptor coarray to a nondescriptor dummy. 
+
+2011-07-23  Tobias Burnus  <burnus@net-b.de>
+
+	* resolve.c (resolve_symbol): Fix coarray var decl check.
+
+2011-07-21  Daniel Carrera  <dcarrera@gmail.com>
+
+	* trans.c (gfc_allocate_with_status): Split into two functions
+	gfc_allocate_using_malloc and gfc_allocate_usig_lib.
+	(gfc_allocate_using_malloc): The status parameter is now the
+	actual status rather than a pointer. Code cleanup.
+	(gfc_allocate_using_lib): Ditto. Add new parametrs errmsg and
+	errlen. Pass these to the coarray lib.
+	* trans-openmp.c (gfc_omp_clause_default_ctor): Update calls to
+	gfc_allocate_allocatable.
+	(gfc_omp_clause_copy_ctor): Ditto.
+	(gfc_trans_omp_array_reduction): Ditto.
+	* trans-stmt.c (gfc_trans_allocate): Ditto. Update call to
+	gfc_allocate_using_malloc. Pass stat rather than pstat to the allocate
+	fuctions. If using coarray lib, pass errmsg and errlen to the allocate
+	functions. Move error checking outside the if (!gfc_array_allocate)
+	block so that it also affects trees produced by gfc_array_allocate.
+	* trans-array.c (gfc_array_allocate): Add new parameters errmsg
+	and errlen. Replace parameter pstat by status. Code cleanup. Update
+	calls to gfc_allocate_allocatable and gfc_allocate_using_malloc.
+	* trans-array.h (gfc_array_allocate): Update signature of
+	gfc_array_allocate.
+
+2011-07-21  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* gfortran.texi: Remove a duplicate word.
+
+2011-07-21  Tobias Burnus  <burnus@net-b.de>
+
+	* check.c (gfc_check_present): Allow coarrays.
+	* trans-array.c (gfc_conv_array_ref): Avoid casting
+	when a pointer is wanted.
+	* trans-decl.c (create_function_arglist): For -fcoarray=lib,
+	handle hidden token and offset arguments for nondescriptor
+	coarrays.
+	* trans-expr.c (get_tree_for_caf_expr): New function.
+	(gfc_conv_procedure_call): For -fcoarray=lib pass the
+	token and offset for nondescriptor coarray dummies.
+	* trans.h (lang_type): Add caf_offset tree.
+	(GFC_TYPE_ARRAY_CAF_OFFSET): New macro.
+
+2011-07-19  Tobias Burnus  <burnus@net-b.de>
+
+	* expr.c (gfc_is_coarray): New function.
+	* gfortran.h (gfc_is_coarray): New prototype.
+	* interface.c (compare_parameter): Use it.
+
+2011-07-19  Richard Guenther  <rguenther@suse.de>
+
+	* trans-expr.c (fill_with_spaces): Use fold_build_pointer_plus.
+	(gfc_trans_string_copy): Likewise.
+	* trans-intrinsic.c (gfc_conv_intrinsic_repeat): Likewise.
+	* trans-types.c (gfc_get_array_descr_info): Likewise.
+	* trans.c (gfc_build_array_ref): Likewise.
+
+2011-07-19  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/49708
+	* resolve.c (resolve_allocate_expr): Fix diagnostics for pointers.
+
+2011-07-18  Tobias Burnus  <burnus@net-b.de>
+
+	* trans-decl.c (gfc_build_qualified_array): Make coarray's
+	token TYPE_QUAL_RESTRICT.
+
+2011-07-18  Tobias Burnus  <burnus@net-b.de>
+
+	* resolve.c (resolve_transfer): Mention defined I/O
+	in the diagnostic for alloc_comp/pointer_comp.
+
+2011-07-17  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34657
+	* module.c (check_for_ambiguous): Check whether the name is matches
+	the current program unit.
+
+2011-07-17  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/49624
+	* expr.c (gfc_check_pointer_assign): Fix checking for invalid
+	pointer bounds.
+
+2011-07-16  Tobias Burnus  <burnus@net-b.de>
+	
+	* expr.c (gfc_ref_this_image): New function.
+	(gfc_is_coindexed): Use it.
+	* gfortran.h (gfc_ref_this_image): New prototype.
+	* resolve.c (resolve_deallocate_expr,
+	resolve_allocate_expr): Support alloc scalar coarrays.
+	* trans-array.c (gfc_conv_array_ref, gfc_array_init_size,
+	gfc_conv_descriptor_cosize, gfc_array_allocate,
+	gfc_trans_deferred_array): Ditto.
+	* trans-expr.c (gfc_conv_variable) Ditto.:
+	* trans-stmt.c (gfc_trans_deallocate): Ditto.
+	* trans-types.c (gfc_get_element_type, gfc_get_array_type_bounds
+	gfc_get_array_descr_info): Ditto.
+	* trans-decl.c (gfc_get_symbol_decl): Ditto.
+
+2011-07-11  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/49698
+	* trans-stmt.c (gfc_trans_pointer_assign_need_temp): Initialize
+	inner_size to gfc_index_one_node instead of integer_one_node.
+
+2011-07-10  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/49690
+	* intrinsic.c (add_functions): Use BT_VOID for 2nd argument of SIGNAL.
+
+2011-07-09  Uros Bizjak  <ubizjak@gmail.com>
+
+	PR fortran/48926
+	* expr.c (gfc_get_corank): Change return value to int.
+	* gfortran.h (gfc_get_corank): Update function prototype.
+
+2011-07-07  Mikael Morin  <mikael.morin@sfr.fr>
+
+	PR fortran/49648
+	* resolve.c (resolve_symbol): Force resolution of function result's
+	array specification.
+
+2011-07-07  Tobias Burnus  <burnus@net-b.de>
+
+	* trans.c (gfc_allocate_with_status): Call _gfortran_caf_register
+	with NULL arguments for (new) stat=/errmsg= arguments.
+
+2011-07-06  Daniel Carrera  <dcarrera@gmail.com>
+
+	* trans-array.c (gfc_array_allocate): Rename allocatable_array to
+	allocatable. Rename function gfc_allocate_array_with_status to
+	gfc_allocate_allocatable_with_status. Update function call for
+	gfc_allocate_with_status.
+	* trans-opemp.c (gfc_omp_clause_default_ctor): Rename function
+	gfc_allocate_array_with_status to gfc_allocate_allocatable_with_status.
+	* trans-stmt.c (gfc_trans_allocate): Update function call for
+	gfc_allocate_with_status. Rename function gfc_allocate_array_with_status
+	to gfc_allocate_allocatable_with_status.
+	* trans.c (gfc_call_malloc): Add new parameter gfc_allocate_with_status
+	so it uses the library for memory allocation when -fcoarray=lib.
+	(gfc_allocate_allocatable_with_status): Renamed from
+	gfc_allocate_array_with_status.
+	(gfc_allocate_allocatable_with_status): Update function call for
+	gfc_allocate_with_status.
+	* trans.h (gfc_coarray_type): New enum.
+	(gfc_allocate_with_status): Update prototype.
+	(gfc_allocate_allocatable_with_status): Renamed from
+	gfc_allocate_array_with_status.
+	* trans-decl.c (generate_coarray_sym_init): Use the new constant
+	GFC_CAF_COARRAY_ALLOC in the call to gfor_fndecl_caf_register.
+
+2011-07-06  Richard Guenther  <rguenther@suse.de>
+
+	* f95-lang.c (gfc_init_decl_processing):
+	Merge calls to build_common_tree_nodes and build_common_tree_nodes_2.
+
+2011-07-04  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/49623
+	* gfortranspec.c (lang_specific_driver): Ignore options with
+	CL_ERR_MISSING_ARG errors.
+
+2011-07-02  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/49562
+	* expr.c (gfc_check_vardef_context): Handle type-bound procedures.
+
+2011-06-30  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/49540
+	* gfortran.h (gfc_constructor): Add repeat field.
+	* trans-array.c (gfc_conv_array_initializer): Handle repeat > 1.
+	* array.c (current_expand): Add repeat field.
+	(expand_constructor): Copy repeat.
+	* constructor.c (node_free, node_copy, gfc_constructor_get,
+	gfc_constructor_lookup): Handle repeat field.
+	(gfc_constructor_lookup_next, gfc_constructor_remove): New functions.
+	* data.h (gfc_assign_data_value): Add mpz_t * argument.
+	(gfc_assign_data_value_range): Removed.
+	* constructor.h (gfc_constructor_advance): Removed.
+	(gfc_constructor_lookup_next, gfc_constructor_remove): New prototypes.
+	* data.c (gfc_assign_data_value): Add REPEAT argument, handle it and
+	also handle overwriting a range with a single entry.
+	(gfc_assign_data_value_range): Removed.
+	* resolve.c (check_data_variable): Adjust gfc_assign_data_value
+	call.  Use gfc_assign_data_value instead of
+	gfc_assign_data_value_expr.
+
+2011-06-27  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/49466
+	* trans-array.c (structure_alloc_comps): Make sure sub-components
+	and extended types are correctly deallocated.
+
+2011-06-21  Andrew MacLeod  <amacleod@redhat.com>
+
+	* trans-openmp.c: Add sync_ or SYNC__ to builtin names.
+	* trans-stmt.c: Add sync_ or SYNC__ to builtin names.
+	* trans-decl.c: Add sync_ or SYNC__ to builtin names.
+
+2011-06-21  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/49112
+	* class.c (gfc_find_derived_vtab): Make vtab and default initialization
+	symbols SAVE_IMPLICIT.
+
+2011-06-20  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* gfortran.h (gfc_check_vardef_context): Update prototype.
+	(iso_fortran_env_symbol): Handle derived types.
+	(symbol_attribute): Add lock_comp.
+	* expr.c (gfc_check_vardef_context): Add LOCK_TYPE check.
+	* interface.c (compare_parameter, gfc_procedure_use): Handle
+	LOCK_TYPE.
+	(compare_actual_formal): Update
+	gfc_check_vardef_context call.
+	* check.c (gfc_check_atomic_def, gfc_check_atomic_ref): Ditto.
+	* intrinsic.c (check_arglist): Ditto.
+	* io.c (resolve_tag, gfc_resolve_dt, gfc_resolve_inquire): Ditto.
+	* iso-fortran-env.def (ISOFORTRAN_LOCK_TYPE): Add.
+	* intrinsic.texi (ISO_FORTRAN_ENV): Document LOCK_TYPE.
+	* module.c (mio_symbol_attribute): Handle lock_comp.
+	(create_derived_type): New function.
+	(use_iso_fortran_env_module): Call it to handle LOCK_TYPE.
+	* parse.c (parse_derived): Add constraint check for LOCK_TYPE.
+	* resolve.c (resolve_symbol, resolve_lock_unlock): Add constraint
+	checks for LOCK_TYPE.
+	(gfc_resolve_iterator, resolve_deallocate_expr,
+	resolve_allocate_expr, resolve_code, resolve_transfer): Update
+	gfc_check_vardef_context call.
+	* trans-stmt.h (gfc_trans_lock_unlock): New prototype.
+	* trans-stmt.c (gfc_trans_lock_unlock): New function.
+	* trans.c (trans_code): Handle LOCK and UNLOCK.
+
+2011-06-18  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/49400
+	* decl.c (gfc_match_procedure): Allow PROCEDURE declarations inside
+	BLOCK constructs.
+
+2011-06-17  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/48699
+	* check.c (gfc_check_move_alloc): If 'TO' argument is polymorphic,
+	make sure the vtab is present.
+
+2011-06-16  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/49074
+	* interface.c (gfc_extend_assign): Propagate the locus from the
+	assignment to the type-bound procedure call.
+
+2011-06-16  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/49417
+	* module.c (mio_component): Make sure the 'class_ok' attribute is set
+	for use-associated CLASS components.
+	* parse.c (parse_derived): Check for 'class_ok' attribute.
+	* resolve.c (resolve_fl_derived): Ditto.
+
+2011-06-13  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	* frontend-passes.c (remove_trim):  New function.
+	(optimize_assignment):  Use it.
+	(optimize_comparison):  Likewise.  Return correct status
+	for previous change.
+
+2011-06-12  Tobias Burnus
+
+	PR fortran/49324
+	* trans-expr.c (gfc_trans_assignment_1): Tell
+	gfc_trans_scalar_assign to also deep-copy RHS nonvariables
+	with allocatable components.
+	* trans-array.c (gfc_conv_expr_descriptor): Ditto.
+
+2011-05-11  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	* frontend-passes.c (optimize_assignment): Follow chains
+	of concatenation operators to the end for removing trailing
+	TRIMS for assignments.
+
+2011-06-10  Daniel Carrera  <dcarrera@gmail.com>
+
+	* trans-decl.c (gfc_build_builtin_function_decls):
+	Updated declaration of caf_sync_all and caf_sync_images.
+	* trans-stmt.c (gfc_trans_sync): Function
+	can now handle a "stat" variable that has an integer type
+	different from integer_type_node.
+
+2011-06-09  Richard Guenther  <rguenther@suse.de>
+
+	* trans.c (gfc_allocate_array_with_status): Mark error path
+	as unlikely.
+
+2011-06-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* gfortran.h (gfc_statement): Add ST_LOCK and ST_UNLOCK.
+	(gfc_exec_op): Add EXEC_LOCK and EXEC_UNLOCK.
+	(gfc_code): Add expr4.
+	* match.h (gfc_match_lock, gfc_match_unlock): New prototypes.
+	* match.c (gfc_match_lock, gfc_match_unlock,
+	lock_unlock_statement): New functions.
+	(sync_statement): Bug fix, avoiding double freeing.
+	(gfc_match_if): Handle LOCK/UNLOCK statement.
+	* parse.c (decode_statement, next_statement,
+	gfc_ascii_statement): Ditto.
+	* st.c (gfc_free_statement): Handle LOCK and UNLOCK.
+	* resolve.c (resolve_lock_unlock): New function.
+	(resolve_code): Call it.
+	* dump-parse-tree.c (show_code_node): Handle LOCK/UNLOCK.
+
+2011-06-07  Richard Guenther  <rguenther@suse.de>
+
+	* f95-lang.c (gfc_init_decl_processing): Do not set
+	size_type_node or call set_sizetype.
+
+2011-06-05  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/49255
+	* trans-expr.c (gfc_conv_procedure_call): Fix -fcheck=pointer
+	for F2008.
+
+2011-06-05  Andreas Schmidt  <andreas.schmidt.42@gmx.net>
+	Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	* dump-parse-tree.c (show_symbol):  Don't dump namespace
+	for ENTRY to avoid infinite recursion.
+
+2011-06-02  Asher Langton  <langton2@llnl.gov>
+
+	PR fortran/49268
+	* trans-decl.c (gfc_trans_deferred_vars): Treat assumed-size Cray
+	pointees as AS_EXPLICIT.
+
+2011-06-02  Asher Langton  <langton2@llnl.gov>
+
+	PR fortran/37039
+	* decl.c (variable_decl): Merge current_as before copying to cp_as.
+
+2011-06-02  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/49265
+	* decl.c (gfc_match_modproc):  Allow for a double colon in a module
+	procedure statement.
+	* parse.c ( decode_statement): Deal with whitespace around :: in
+	gfc_match_modproc.
+
+2011-05-31  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* intrinsic.c (klass): Add CLASS_ATOMIC.
+	(add_subroutines): Add atomic_ref/atomic_define.
+	* intrinsic.texi (ATOMIC_REF, ATOMIC_DEFINE): Document.
+	* intrinsic.h (gfc_check_atomic_def, gfc_check_atomic_ref,
+	gfc_resolve_atomic_def, gfc_resolve_atomic_ref): New prototypes.
+	* gfortran.h (gfc_isym_id): Add GFC_ISYM_ATOMIC_DEF
+	and GFC_ISYM_ATOMIC_REF.
+	(gfc_atomic_int_kind, gfc_atomic_logical_kind): New global vars.
+	* iresolve.c (gfc_resolve_atomic_def, gfc_resolve_atomic_ref): New
+	functions.
+	* check.c (gfc_check_atomic, gfc_check_atomic_def,
+	gfc_check_atomic_ref): New functions.
+	* iso-fortran-env.def (ISOFORTRANENV_FILE_ATOMIC_INT_KIND,
+	ISOFORTRANENV_FILE_ATOMIC_LOGICAL_KIND): Change kind value.
+	* trans-intrinsic.c (conv_intrinsic_atomic_def,
+	conv_intrinsic_atomic_ref, gfc_conv_intrinsic_subroutine): New
+	functions.
+	(conv_intrinsic_move_alloc) Renamed from
+	gfc_conv_intrinsic_move_alloc - and made static.
+	* trans.h (gfc_conv_intrinsic_move_alloc): Remove.
+	(gfc_conv_intrinsic_subroutine) Add prototype.
+	* trans.c (trans_code): Call gfc_conv_intrinsic_subroutine.
+	* trans-types (gfc_atomic_int_kind, gfc_atomic_logical_kind): New
+	global vars.
+	(gfc_init_kinds): Set them.
+
+2011-05-31  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* trans-array.c (gfc_trans_dummy_array_bias): Handle
+	cobounds of assumed-shape arrays.
+
+2011-05-31  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* resolve.c (resolve_fl_variable): Handle static coarrays
+	with non-constant cobounds.
+
+2011-05-29  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47601
+	* module.c (mio_component_ref): Handle components of extended types.
+	* symbol.c (gfc_find_component): Return is sym is NULL.
+
+2011-05-29  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* interface.c (compare_parameter): Add check for passing coarray
+	to allocatable noncoarray dummy.
+
+2011-05-29  Tobias Burnus  <burnus@net-b.de>
+	    Richard Guenther  <rguenther@suse.de>
+
+	PR fortran/18918
+	* trans-types.c (gfc_get_nodesc_array_type): Don't mess with
+	the type's TREE_TYPE.
+	* trans-array.c (gfc_conv_array_ref): Use TYPE_MAIN_VARIANT.
+	* trans.c (gfc_build_array_ref): Ditto.
+
+2011-05-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* check.c (gfc_check_associated, gfc_check_null): Add coindexed check.
+	* match.c (gfc_match_nullify): Ditto.
+	* resolve.c (resolve_deallocate_expr): Ditto.
+	* trans-types.c (gfc_get_nodesc_array_type): Don't set restricted
+	for nonpointers.
+
+2011-05-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/48820
+	* gfortran.h (gfc_isym_id): Add GFC_ISYM_RANK.
+	* intrinsic.c (add_functions): Add rank intrinsic.
+	(gfc_check_intrinsic_standard): Handle GFC_STD_F2008_TR.
+	* intrinsic.h (gfc_simplify_rank, gfc_check_rank): Add prototypes.
+	* simplify.c (gfc_simplify_rank): New function.
+	* intrinsic.texi (RANK): Add description for rank intrinsic.
+	* check.c (gfc_check_rank): New function.
+
+2011-05-26  Paul Thomas  <pault@gcc.gnu.org>
+	    Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/48955
+	* trans-expr.c (gfc_trans_assignment_1): GFC_REVERSE_NOT_SET
+	changed to GFC_ENABLE_REVERSE.
+	* trans-array.c (gfc_init_loopinfo): GFC_CANNOT_REVERSE changed
+	to GFC_INHIBIT_REVERSE.
+	* gfortran.h: Enum gfc_reverse is now GFC_ENABLE_REVERSE,
+	GFC_FORWARD_SET, GFC_REVERSE_SET and GFC_INHIBIT_REVERSE.
+	* dependency.c (gfc_dep_resolver): Change names for elements of
+	gfc_reverse as necessary. Change the logic so that forward
+	dependences are remembered as well as backward ones. When both
+	have appeared, force a temporary.
+
+2011-05-26  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* trans-array.c (gfc_conv_array_ref): Handle pointer coarrays.
+	* trans-decl.c (has_coarray_vars, caf_init_block,
+	gfor_fndecl_caf_register): New file-global variables.
+	(gfc_finish_var_decl): Make sure that coarrays in main are static.
+	(gfc_build_qualified_array): Generate coarray token variable.
+	(gfc_get_symbol_decl): Don't use a static initializer for coarrays.
+	(gfc_build_builtin_function_decls): Set gfor_fndecl_caf_register.
+	(gfc_trans_deferred_vars, gfc_emit_parameter_debug_info): Skip for
+	static coarrays.
+	(generate_local_decl): Check for local coarrays.
+	(create_main_function): SYNC ALL before calling MAIN.
+	(generate_coarray_sym_init): Register static coarray.
+	(generate_coarray_init): Generate CAF registering constructor
+	function.
+	(gfc_generate_function_code): Call it, if needed, do not create
+	cgraph twice.
+	(gfc_generate_module_vars, gfc_process_block_locals): Call
+	generate_coarray_init.
+	* trans-types.c (gfc_get_nodesc_array_type): Generate pointers for
+	-fcoarray=lib.
+	* trans.h (gfor_fndecl_caf_register): New variable.
+	(lang_type): New element caf_token.
+	(GFC_TYPE_ARRAY_CAF_TOKEN): New macro.
+
+2011-05-24  Joseph Myers  <joseph@codesourcery.com>
+
+	* Make-lang.in (GFORTRAN_D_OBJS): Remove prefix.o.
+	(gfortran$(exeext)): Use libcommon-target.a.
+
+2011-05-22  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	* frontend-passes.c (cfe_register_funcs):  Also register
+	character functions if their charlens are known and constant.
+	Also register allocatable functions.
+
+2011-05-21  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/48699
+	* match.c (select_type_set_tmp): Make the temporary ALLOCATABLE if the
+	selector is ALLOCATABLE.
+
+2011-05-20  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/48706
+	* module.c (write_dt_extensions): Do not write extended types which
+	are local to a subroutine.
+
+2011-05-20  Joseph Myers  <joseph@codesourcery.com>
+
+	* Make-lang.in (GFORTRAN_D_OBJS): Remove version.o and intl.o.
+
+2011-05-20  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	* gfortran.texi (set_fpe): Update documentation.
+	* invoke.texi (-ffpe-trap): Likewise.
+	* libgfortran.h (GFC_FPE_PRECISION): Rename to GFC_FPE_INEXACT.
+	* options.c (gfc_handle_fpe_trap_option): Handle inexact and make
+	precision an alias for it.
+
+2011-05-19  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* trans-types.c (gfc_get_element_type): Handle scalar coarrays.
+	(gfc_get_nodesc_array_type): Make a variant-type copy for scalar
+	coarrays.
+	* trans.c (gfc_build_array_ref): Return original type not variant
+	copy for scalar coarrays.
+	* trans-array.c (gfc_conv_array_ref): Ditto.
+
+2011-05-18  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/48700
+	* trans-intrinsic.c (gfc_conv_intrinsic_move_alloc): Deallocate 'TO'
+	argument to avoid memory leaks.
+
+2011-05-16  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.texi (_gfortran_set_options): Add GFC_STD_F2008_TR.
+	(Fortran 2008 status): Multi-image support for coarrays.
+	(TR 19113 status): New section.
+
+2011-05-15  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	actual argument is not an array; rank mismatch is diagnosted later.
+	* trans-decl.c (gfc_get_symbol_decl, gfc_trans_deferred_vars): Handle
+	scalar coarrays.
+	* trans-types.c (gfc_get_array_type_bounds): Ditto.
+
+2011-05-15  Joern Rennecke  <amylaar@spamcop.net>
+
+	PR middle-end/46500
+	* trans-types.c: Include "tm.h".
+	[0] (c_size_t_size): Remove.
+
+2011-05-15  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	PR libfortran/48915
+	* gfortran.texi (_gfortran_set_options): Even though -fbacktrace
+	is now the default, the library defaults to backtracing disabled.
+
+2011-05-14  Tobias Burnus  <burnus@net-b.de>
+
+	* lang.opt (fdump-core): Re-add as ignored option
+	for backward compatibility.
+
+2011-05-14  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	PR libfortran/48915
+	* gfortran.texi: Update mixed-language programming section
+	reflecting the removal of the fdump-core option, and that
+	-fbacktrace is now enabled by default.
+
+2011-05-14  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/22572
+	* frontend-passes.c (cfe_register_funcs):  Also register functions
+	for potential elimination if the rank is > 0, the shape is unknown
+	and reallocate on assignment is active.
+	(create_var):  For rank > 0 functions with unknown shape, create
+	an allocatable temporary.
+
+2011-05-14  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* interface.c (compare_parameter): Skip diagnostic if
+	actual argument is not an array; rank mismatch is diagnosted later.
+
+2011-05-14  Tobias Burnus  <burnus@net-b.de>
+
+	* options.c (gfc_init_options, gfc_post_options): Enable
+	-fstack-arrays by default if -Ofast is used.
+	* invoke.texi (-fstack-arrays): Document this.
+
+2011-05-14  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	PR libfortran/48915
+	* gfortran.h (gfc_option_t): Remove flag_dump_core.
+	* gfortran.texi (GFORTRAN_ERROR_DUMPCORE): Remove section.
+	(GFORTRAN_ERROR_BACKTRACE): Document that it's enabled by default.
+	* intrinsic.texi (ABORT): Remove explanation of -fdump-core.
+	* invoke.texi: Remove -fdump-core, document that -fbacktrace is
+	enabled by default.
+	* lang.opt: Remove -fdump-core.
+	* options.c (gfc_init_options): Make backtrace default to enabled,
+	remove dump_core.
+	(gfc_handle_option): Remove OPT_fdump-core.
+	* trans-decl.c: Pass a 0 to preserve ABI.
+
+2011-05-14  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	* gfortran.texi: Remove GFORTRAN_USE_STDERR documentation.
+
+2011-05-13  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/48972
+	* io.c (resolve_tag_format, resolve_tag): Make sure
+	that the string is of default kind.
+	(gfc_resolve_inquire): Also resolve decimal tag.
+
+2011-05-12  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/48972
+	* resolve.c (resolve_intrinsic): Don't resolve module
+	intrinsics multiple times.
+
+2011-05-11  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/48889
+	* expr.c (gfc_is_constant_expr): Use e->value.function.esym
+	instead of e->symtree->n.sym, if available.
+
+2011-05-07  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* f95-lang.c (global_bindings_p): Return bool and simplify.
+
+2011-05-07  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	PR fortran/48919
+	* trans.h: Move gfc_init_coarray_decl prototype ...
+	* gfortran.h: ... to here.
+	* parse.c (translate_all_program_units): Call gfc_init_coarray_decl.
+	(gfc_parse_file): Update translate_all_program_units call.
+	* trans-decl.c (gfc_init_coarray_decl): Fix variable declaration,
+	new argument whether DECL_EXTERNAL should be used.
+	(create_main_function): Update gfc_init_coarray_decl call.
+	* trans-intrinsic.c (trans_this_image, trans_image_index,
+	conv_intrinsic_cobound): Ditto.
+
+2011-05-06  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* trans-array.c (gfc_walk_variable_expr): Continue walking
+	for scalar coarrays.
+	* trans-intrinsic.c (convert_element_to_coarray_ref): New function.
+	(trans_this_image, trans_image_index, conv_intrinsic_cobound): Use it.
+	(trans_this_image): Fix algorithm.
+	* trans-types.c (gfc_get_element_type, gfc_get_array_descriptor_base,
+	gfc_sym_type): Handle scalar coarrays.
+
+2011-05-06  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/48858
+	PR fortran/48820
+	* lang.opt (std=f2008tr): New.
+	* libgfortran.h (GFC_STD_F2008_TR): New macro constant.
+	* decl.c (verify_c_interop_param): Allow OPTIONAL in BIND(C)
+	procedures for -std=f2008tr/gnu/legacy.
+	(gfc_match_import): Set sym to NULL.
+	* options.c (set_default_std_flags,gfc_handle_option): Handle
+	-std=f2008tr.
+	* invoke.texi (-std=): Document -std=f2008tr.
+
+2011-05-05  Nathan Froyd  <froydnj@codesourcery.com>
+
+	* trans-decl.c (gfc_trans_entry_master_switch): Call build_case_label.
+	* trans-io.c (add_case): Likewise.
+	* trans-stmt.c (gfc_trans_integer_select): Likewise.
+	(gfc_trans_character_select): Likewise.
+
+2011-05-05  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* trans-decl.c (trans_function_start): Do not set
+	dont_save_pending_sizes_p.
+
+2011-05-04  Nathan Froyd  <froydnj@codesourcery.com>
+
+	* trans.h (gfc_chainon_list): Delete.
+	* trans.c (gfc_chainon_list): Delete.
+
+2011-05-04  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/48864
+	* invoke.texi (fno-protect-parens): Document
+	that -Ofast implies -fno-protect-parens.
+	* options.c (gfc_init_options, gfc_post_options):
+	Make -Ofast imply -fno-protect-parens.
+
+2011-05-04  Nathan Froyd  <froydnj@codesourcery.com>
+
+	* trans-decl.c (build_library_function_decl_1): Call
+	build_function_type_vec.  Adjust argument list building accordingly.
+	* trans-intrinsic.c (gfc_get_intrinsic_lib_fndecl): Likewise.
+	* trans-types.c (gfc_get_function_type): Likewise.
+
+2011-05-04  Richard Guenther  <rguenther@suse.de>
+
+	* trans-array.c (gfc_trans_array_constructor_value): Use
+	size_int for bounds of range types.
+	(gfc_trans_array_constructor_value): Use size_type_node
+	for memcpy argument.
+	* trans-common.c (build_field): Use gfc_charlen_type_node
+	for lengths.
+	* trans-openmp.c (gfc_trans_omp_clauses): Do not pass NULL
+	as type to build_int_cst.
+	* trans-const.c (gfc_build_string_const): Use size_int
+	for bounds of range types.
+	(gfc_build_wide_string_const): Likewise.
+	* trans-stmt.c (gfc_trans_label_assign): Use gfc_charlen_type_node
+	for lengths.
+	(gfc_trans_character_select): Likewise.
+	(gfc_trans_character_select): Do not pass NULL
+	as type to build_int_cst.
+	(gfc_trans_character_select): Use size_int for bounds of range types.
+	* trans-io.c (gfc_build_io_library_fndecls): Likewise.
+	(add_case): Do not pass NULL as type to build_int_cst.
+	(transfer_expr): Likewise.
+	(transfer_array_desc): Likewise.
+	* trans-decl.c (gfc_add_assign_aux_vars): Use gfc_charlen_type_node
+	for lengths.
+	(gfc_trans_assign_aux_var): Likewise.
+	(create_main_function): Use size_int for bounds of range types.
+	* trans-intrinsic.c (gfc_conv_intrinsic_minmax_char): Do not pass
+	NULL as type to build_int_cst.
+	(gfc_conv_intrinsic_spacing): Likewise.
+	(gfc_conv_intrinsic_rrspacing): Likewise.
+	(gfc_conv_intrinsic_len): Use gfc_charlen_type_node for lengths.
+
+2011-05-04  Richard Guenther  <rguenther@suse.de>
+
+	* trans-types.c (gfc_get_array_type_bounds): Remove zero notrunc
+	argument to int_const_binop.
+
+2011-05-03  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* trans-intrinsic.c (trans_this_image): Implement version with
+	coarray argument.
+	(conv_intrinsic_cobound): Simplify code.
+	(gfc_conv_intrinsic_function): Call trans_this_image for
+	this_image(coarray) except for -fcoarray=single.
+
+2011-05-02  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/48720
+	* gfortran.texi: Document the 'Q' exponent-letter extension.
+	* invoke.texi: Document -Wreal-q-constant.
+	* lang.opt: Add -Wreal-q-constant option.
+	* gfortran.h: Add warn_real_q_constant to option struct.
+	* primary.c (match_real_constant):  Use it.  Accept 'Q' as
+	exponent-letter for REAL(16) real-literal-constant with a
+	fallback to REAL(10) or error if REAL(10) is not available.
+	* options.c (gfc_init_options, set_Wall) Set it.
+	(gfc_handle_option): Handle new option.
+
+2011-04-30  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	* dump-prase-tree.c (show_code_node):  Set the current
+	namespace to the BLOCK before displaying it; restore
+	afterwards.
+
+2011-04-30  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/48821
+	* decl.c (gfc_match_import): Don't try to find the
+	symbol if already found.
+
+2011-04-30  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/48746
+	* trans-expr.c (fcncall_realloc_result): Set the bounds and the
+	offset so that the lbounds are one.
+	(gfc_trans_arrayfunc_assign): Add rank to arguments of above.
+
+2011-04-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/48462
+	* trans-expr.c (arrayfunc_assign_needs_temporary): Deal with
+	automatic reallocation when the lhs is a target.
+
+	PR fortran/48746
+	* trans-expr.c (fcncall_realloc_result): Make sure that the
+	result dtype field is set before the function call.
+
+2011-04-29  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/48810
+	* resolve.c (resolve_typebound_generic_call): Don't check access
+	flags of the specific function.
+
+	PR fortran/48800
+	* resolve.c (resolve_formal_arglist): Don't change AS_DEFERRED
+	to AS_ASSUMED_SHAPE for function results.
+	(resolve_fl_var_and_proc): Print also for function results with
+	AS_DEFERRED an error, if they are not a pointer or allocatable.
+	(resolve_types): Make sure arguments of procedures in interface
+	blocks are resolved.
+
+2011-04-29  Michael Matz  <matz@suse.de>
+
+	* options.c (options.c): Set warn_maybe_uninitialized.
+
+2011-04-28  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/48112
+	* resolve.c (resolve_fl_var_and_proc): Print diagnostic of
+	function results only once.
+	(resolve_symbol): Always resolve function results.
+
+	PR fortran/48279
+	* expr.c (gfc_check_vardef_context): Fix handling of generic
+	EXPR_FUNCTION.
+	* interface.c (check_interface0): Reject internal functions
+	in generic interfaces, unless -std=gnu.
+
+2011-04-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/48788
+	* resolve.c (resolve_global_procedure): Error recovery -
+	avoid segfault for (non)character-returning functions.
+
+2011-04-26  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	* decl.c (gfc_match_end):  Check that the block name starts
+	with "block@".
+	* parse.c (gfc_build_block_ns):  Make block names unique by
+	numbering them.
+
+2011-04-26  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	* frontend-passes.c (inserted_block):  New variable.
+	(changed_statement):  Likewise.
+	(create_var):  Encase statement to be operated on in a BLOCK.
+	Adjust code insertion for BLOCK.
+	(cfe_code):  Set inserted_block and changed_statement to NULL.
+
+2011-04-23  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* module.c (mio_array_spec): Set as->cotype on reading.
+	* resolve.c (resolve_allocate_expr): Fix allocating coarray
+	components.
+
+2011-04-21  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/48405
+	* frontend_passes (cfe_register_funcs): Remove workaround for DO
+	loops.
+	(gfc_code_walker):  Make sure the pointer to the current
+	statement doen't change when other statements are inserted.
+
+2011-04-21  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* array.c (gfc_match_array_spec): Fix maximal rank(+corank) check.
+
+2011-04-20  Jim Meyering  <meyering@redhat.com>
+
+	* expr.c (free_expr0): Remove useless if-before-free.
+	* gfortranspec.c (lang_specific_pre_link): Likewise.
+	* interface.c (gfc_extend_expr): Likewise.
+	* trans-openmp.c (gfc_trans_omp_array_reduction): Likewise.
+
+2011-04-19  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/48588
+	PR fortran/48692
+
+	* module.c (fix_mio_expr): Commit created symbol.
+
+2011-04-19  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	* scanner.c (load_file): Use XCNEWVAR instead of xcalloc.
+
+2011-04-19  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	* frontend-passes.c (gfc_run_passes): Use XDELETEVEC instead of
+	free.
+
+2011-04-19  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	* misc.c (gfc_getmem): Remove function.
+	* gfortran.h: Remove gfc_getmem prototype. Replace gfc_getmem
+	usage with XCNEW or XCNEWVEC.
+	* expr.c (gfc_check_assign_symbol): Replace gfc_getmem usage with
+	XCNEW or XCNEWVEC.
+	* options.c (gfc_handle_module_path_options)
+	(gfc_get_option_string): Likewise.
+	* resolve.c (gfc_resolve_forall): Likewise.
+	* simplify.c (simplify_transformation_to_array): Likewise.
+	* target-memory.c (gfc_target_interpret_expr): Likewise.
+	* trans-common.c (get_segment_info, copy_equiv_list_to_ns)
+	(get_init_field): Likewise.
+	* trans-expr.c (gfc_conv_statement_function): Likewise.
+	* trans-io.c (nml_full_name): Likewise.
+	* trans-stmt.c (gfc_trans_forall_1): Likewise.
+	* scanner.c (load_file): Replace gfc_getmem usage with xcalloc.
+
+2011-04-19  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/48588
+	* parse.c (resolve_all_program_units): Skip modules.
+	(translate_all_program_units): Handle modules.
+	(gfc_parse_file): Defer code generation for modules.
+
+2011-04-19  Martin Jambor  <mjambor@suse.cz>
+
+	* trans-decl.c (gfc_generate_function_code): Call cgraph_create_node
+	instead of cgraph_get_create_node.
+
+2011-04-18  Jim Meyering  <meyering@redhat.com>
+
+	remove now-unused definition of gfc_free
+	* misc.c (gfc_free): Remove function.
+	* gfortran.h (gfc_free): Remove its prototype.
+
+2011-04-18  Jim Meyering  <meyering@redhat.com>
+
+	convert each use of gfc_free (p) to free (p)
+	Do that by running this command:
+	  perl -pi -e    's/\bgfc_free ?\(/free (/' \
+	    $(git grep -El '\bgfc_free ?\(')
+	which also corrects the few uses that lacked a space between
+	the function name and the open parenthesis.
+	Manually undo the change to the function definition itself
+	and its prototype.  They'll be removed next.
+	* array.c (gfc_free_array_spec, gfc_set_array_spec): s/gfc_free/free/
+	* constructor.c (node_free): Likewise.
+	* cpp.c (dump_queued_macros): Likewise.
+	* data.c (gfc_assign_data_value): Likewise.
+	* decl.c (free_variable, free_value, gfc_free_data): Likewise.
+	(gfc_free_data_all, match_old_style_init): Likewise.
+	(gfc_set_constant_character_len, gfc_free_enum_history, NUM_DECL):
+	Likewise.
+	(gfc_match_modproc): Likewise.
+	* dependency.c (check_section_vs_section): Likewise.
+	* error.c (gfc_pop_error, gfc_free_error): Likewise.
+	* expr.c (free_expr0, gfc_free_expr, gfc_free_actual_arglist): Likewise.
+	(gfc_free_ref_list, gfc_replace_expr, gfc_copy_ref): Likewise.
+	(find_substring_ref, gfc_simplify_expr, gfc_check_assign_symbol):
+	Likewise.
+	* frontend-passes.c (gfc_run_passes, cfe_expr_0): Likewise.
+	(strip_function_call, optimize_comparison): Likewise.
+	* interface.c (gfc_free_interface, arginfo, check_interface0): Likewise.
+	(CHECK_OS_COMPARISON, gfc_extend_assign, gfc_free_formal_arglist):
+	Likewise.
+	* intrinsic.c (gfc_intrinsic_done_1, gfc_convert_type_warn): Likewise.
+	(gfc_convert_chartype): Likewise.
+	* io.c (gfc_free_open, compare_to_allowed_values, gfc_free_close):
+	Likewise.
+	(gfc_free_filepos, gfc_free_dt, gfc_free_inquire): Likewise.
+	* match.c (gfc_free_iterator, gfc_match_associate): Likewise.
+	(gfc_free_alloc_list, gfc_free_namelist, gfc_free_equiv_until):
+	Likewise.
+	(free_case, gfc_free_forall_iterator): Likewise.
+	* misc.c: Likewise.
+	* module.c (free_pi_tree, resolve_fixups, free_rename): Likewise.
+	(free_true_name, peek_atom, mio_allocated_wide_string): Likewise.
+	(mio_pool_string, mio_internal_string, mio_gmp_integer): Likewise.
+	(mio_gmp_real, mio_expr, mio_typebound_proc): Likewise.
+	(mio_full_typebound_tree, skip_list, load_equiv): Likewise.
+	(free_written_common, gfc_use_module, gfc_free_use_stmts): Likewise.
+	* openmp.c (gfc_free_omp_clauses): Likewise.
+	* options.c (gfc_post_options): Likewise.
+	* parse.c (select_type_pop, parse_omp_structured_block): Likewise.
+	* primary.c (gfc_free_structure_ctor_component): Likewise.
+	* resolve.c (resolve_structure_cons, check_host_association): Likewise.
+	(gfc_resolve_forall, resolve_equivalence): Likewise.
+	* scanner.c (gfc_scanner_done_1, gfc_release_include_path): Likewise.
+	(gfc_define_undef_line, preprocessor_line, include_line): Likewise.
+	(load_file, gfc_read_orig_filename): Likewise.
+	* simplify.c (simplify_transformation_to_array): Likewise.
+	(gfc_simplify_ibits, simplify_shift, gfc_simplify_ishftc, STRING):
+	Likewise.
+	(gfc_simplify_compiler_options): Likewise.
+	* st.c (gfc_free_statement, gfc_free_statements): Likewise.
+	(gfc_free_association_list): Likewise.
+	* symbol.c (free_components, gfc_free_st_label, free_st_labels):
+	Likewise.
+	(gfc_delete_symtree, gfc_free_symbol, gfc_undo_symbols): Likewise.
+	(free_old_symbol, gfc_commit_symbols, free_tb_tree): Likewise.
+	(free_common_tree, free_uop_tree, free_sym_tree): Likewise.
+	(gfc_free_dt_list, gfc_free_equiv_infos, gfc_free_equiv_lists):
+	Likewise.
+	(gfc_free_finalizer, gfc_free_charlen, free_entry_list): Likewise.
+	(gfc_free_namespace): Likewise.
+	* trans-array.c (gfc_free_ss, gfc_trans_array_bound_check): Likewise.
+	(gfc_conv_array_ref, gfc_conv_ss_startstride): Likewise.
+	(gfc_trans_dummy_array_bias, gfc_conv_array_parameter): Likewise.
+	* trans-common.c (get_init_field, create_common): Likewise.
+	* trans-const.c (gfc_build_wide_string_const): Likewise.
+	(gfc_conv_string_init): Likewise.
+	* trans-decl.c (gfc_generate_function_code): Likewise.
+	* trans-expr.c (gfc_conv_substring, gfc_free_interface_mapping):
+	Likewise.
+	(SCALAR_POINTER, gfc_conv_statement_function): Likewise.
+	(gfc_trans_subarray_assign): Likewise.
+	* trans-intrinsic.c (conv_generic_with_optional_char_arg): Likewise.
+	* trans-io.c (gfc_trans_io_runtime_check, set_string): Likewise.
+	(transfer_namelist_element, transfer_array_component): Likewise.
+	* trans-openmp.c (gfc_trans_omp_array_reduction): Likewise.
+	* trans-stmt.c (cleanup_forall_symtrees, gfc_trans_forall_1): Likewise.
+	* trans.c (trans_runtime_error_vararg, gfc_restore_backend_locus):
+	Likewise.
+
+2011-04-15  Jim Meyering  <meyering@redhat.com>
+
+	gfortran: remove cpp definition of free, ...
+	in preparation for the s/gfc_free/free/ transformation.
+	* gfortran.h (free): Remove macro definition that would otherwise
+	prevent direct use of the function.
+
+2011-04-18  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* array.c (gfc_match_array_ref): Check for too many codimensions.
+	* check.c (gfc_check_image_index): Check number of elements
+	in SUB argument.
+	* simplify.c (gfc_simplify_image_index): Remove unreachable checks.
+
+2011-04-18  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* iresolve.c (gfc_resolve_image_index): Set ts.type.
+	* simplify.c (gfc_simplify_image_index): Don't abort if the bounds
+	are not known at compile time and handle -fcoarray=lib.
+	* trans-intrinsics.c (gfc_conv_intrinsic_function): Handle
+	IMAGE_INDEX.
+	(conv_intrinsic_cobound): Fix comment typo.
+	(trans_this_image): New function.
+	* trans-array.c (gfc_unlikely): Move to trans.c.
+	* trans.c (gfc_unlikely): Function moved from trans-array.c.
+	(gfc_trans_runtime_check): Use it.
+	* trans-io.c (gfc_trans_io_runtime_check): Ditto.
+	* trans.h (gfc_unlikely): Add prototype.
+
+2011-04-18  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/48462
+	* trans-expr.c (fcncall_realloc_result): Renamed version of
+	realloc_lhs_bounds_for_intrinsic_call that does not touch the
+	descriptor bounds anymore but makes a temporary descriptor to
+	hold the result.
+	(gfc_trans_arrayfunc_assign): Modify the reference to above
+	renamed function.
+
+2011-05-17  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/48624
+	* trans-decl.c (gfc_get_extern_function_decl): Fix decl
+	for external procedures with proc arguments.
+
+2011-04-15  Michael Matz  <matz@suse.de>
+
+	* trans-array.c (toplevel): Include gimple.h.
+	(gfc_trans_allocate_array_storage): Check flag_stack_arrays,
+	properly expand variable length arrays.
+	(gfc_trans_auto_array_allocation): If flag_stack_arrays create
+	variable length decls and associate them with their scope.
+	* gfortran.h (gfc_option_t): Add flag_stack_arrays member.
+	* options.c (gfc_init_options): Handle -fstack_arrays option.
+	* lang.opt (fstack-arrays): Add option.
+	* invoke.texi (Code Gen Options): Document it.
+	* Make-lang.in (trans-array.o): Depend on GIMPLE_H.
+
+2011-04-15  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* trans-intrinsic.c (conv_intrinsic_cobound): Remove unused
+	code which is also causing an ICE.
+
+2011-04-14  Nathan Froyd  <froydnj@codesourcery.com>
+
+	* f95-lang.c (poplevel): Use BLOCK_CHAIN and block_chainon.
+
+2011-04-12  Nathan Froyd  <froydnj@codesourcery.com>
+
+	* f95-lang.c (union lang_tree_node): Check for TS_COMMON before
+	calling TREE_CHAIN.
+
+2011-04-12  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/48360
+	PR fortran/48456
+	* trans-array.c (get_std_lbound): For derived type variables
+	return array valued component lbound.
+
+2011-04-12  Martin Jambor  <mjambor@suse.cz>
+
+	* trans-decl.c (gfc_generate_function_code): Call
+	cgraph_get_create_node instead of cgraph_node.
+
+2011-04-11  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* simplify.c (simplify_bound_dim): Exit for
+	ucobound's last dimension unless -fcoarray=single.
+	* trans-array (gfc_conv_descriptor_size_1): Renamed from
+	gfc_conv_descriptor_size, made static, has now from_dim and
+	to_dim arguments.
+	(gfc_conv_descriptor_size): Call gfc_conv_descriptor_size.
+	(gfc_conv_descriptor_cosize): New function.
+	* trans-array.h (gfc_conv_descriptor_cosize): New prototype.
+	* trans-intrinsic.c (conv_intrinsic_cobound): Add input_location
+	and handle last codim of ucobound for when -fcoarray is not "single".
+
+2011-04-08  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/48448
+	* gfortran.h (gfc_option_t):  Add warn_function_elimination and
+	flag_frontend_optimize.
+	* lang.opt (Wfunction-elimination):  Add.
+	(ffrontend-optimize):  Add.
+	* invoke.texi:  Add documentation for -Wfunction-elimination
+	and -ffrontend-optimize.  Add -faggressive-function-elimination
+	to list of code generation options.
+	* frontend-passes.c (gfc_run_passes):  Run optimizations if
+	flag_frontend_optimize is set.
+	(warn_function_elimination):  New function.
+	(cfe_expr_0):  Call it if requested to do so.
+	* options.c (gfc_init_options):  Initiate warn_function_elimination
+	and flag_frontend_optimize.
+	(gfc_post_options):  Set flag_frontend_optimize if not specified
+	by user, depending on the optimization level.
+	(gfc_handle_option):  Handle -Wfunction-elimination and
+	-ffrontend-optimize.
+
+2011-04-06  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* trans-intrinsic.c (gfc_conv_intrinsic_function): Fix
+	call for this_image.
+
+2011-04-05  Nathan Froyd  <froydnj@codesourcery.com>
+
+	* trans-intrinsic.c (gfc_build_intrinsic_lib_fndecls): Use
+	build_function_type_list instead of build_function_type.  Correct
+	argument order for func_frexp and func_scalbn.
+
+2011-04-05  Duncan Sands  <baldrick@free.fr>
+
+	* f95-lang.c (build_builtin_fntypes): Swap frexp parameter types.
+
+2011-04-04  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	* frontend-passes: (optimize_lexical_comparison): New function.
+	(optimize_expr): Call it.
+	(optimize_comparison): Also handle lexical comparison functions.
+	Return false instad of -2 for unequal comparison.
+
+2011-04-04  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/48412
+	* frontend-passes (cfe_expr_0):  Reverse the order of going
+	through the loops.
+
+2011-04-04  Tobias Burnus  <burnus@net-b.de>
+	    Mikael Morin  <mikael.morin@sfr.fr>
+
+	PR fortran/18918
+	* check.c (is_coarray): Update - because of DIMEN_THIS_IMAGE.
+	* expr.c (gfc_is_coindexed): Ditto.
+	* gfortran.h (gfc_array_ref_dimen_type): Add DIMEN_THIS_IMAGE.
+	* interface.c (compare_parameter): Use gfc_expr_attr and
+	gfc_is_coindexed.
+	* resolve.c (check_dimension, compare_spec_to_ref,
+	resolve_allocate_expr, check_data_variable): Update for
+	DIMEN_THIS_IMAGE.
+	* simplify.c (gfc_simplify_lcobound, gfc_simplify_this_image,
+	gfc_simplify_ucobound): Allow non-constant bounds.
+	* trans-array.c (gfc_set_loop_bounds_from_array_spec,
+	gfc_trans_create_temp_array, gfc_trans_constant_array_constructor,
+	gfc_set_vector_loop_bounds, gfc_conv_array_index_offset,
+	gfc_start_scalarized_body, gfc_trans_scalarizing_loops,
+	gfc_trans_scalarized_loop_boundary, gfc_conv_section_startstride,
+	gfc_conv_ss_startstride, gfc_conv_loop_setup,
+	gfc_trans_array_bounds, gfc_conv_expr_descriptor,
+	gfc_walk_variable_expr): Handle codimen.
+	* trans-decl.c (gfc_build_qualified_array): Save cobounds.
+	* trans-intrinsic.c (gfc_conv_intrinsic_bound): Use arg2.
+	(conv_intrinsic_cobound): New function.
+	(gfc_conv_intrinsic_function): Call it.
+	(gfc_walk_intrinsic_function, gfc_add_intrinsic_ss_code): Handle
+	ucobound, lcobound, this_image.
+	* fortran/trans-types.c (gfc_build_array_type): Save cobounds.
+	(gfc_get_dtype): Honour corank.
+	(gfc_get_nodesc_array_type): Save corank and codimensions.
+	(gfc_get_array_type_bounds): Save cobound.
+	* fortran/trans.h (gfc_ss_info,gfc_loopinfo): Add codimen item.
+	(gfc_array_kind): Add corank item.
+	(GFC_TYPE_ARRAY_CORANK): New macro.
+
+2011-04-03  Kai Tietz  <ktietz@redhat.com>
+
+	PR middle-end/48422
+	* Make-lang.in (f95-lang.o): Add some missing dependencies.
+
+2011-04-01  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/48352
+	* frontend-passes (cfe_register_funcs):  Don't
+	register functions if they appear as iterators in DO loops.
+
+2011-03-30  Michael Matz  <matz@suse.de>
+
+	PR fortran/47516
+	* trans-expr.c (realloc_lhs_loop_for_fcn_call): Take loop as parameter,
+	don't use local variable.
+	(gfc_trans_arrayfunc_assign): Adjust caller.
+
+2011-03-29  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/48095
+	* decl.c (match_procedure_decl,match_ppc_decl): Set flavor of interface.
+	* module.c (MOD_VERSION): Bump.
+	(mio_typespec): Read/write 'interface' field.
+	* primary.c (match_string_constant,match_logical_constant): Remove
+	unneeded code.
+	(match_complex_constant): Make sure to clear the typespec.
+
+2011-03-29  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	* frontend-passes.c (create_var):  Warn about creating an
+	array temporary if requested.
+
+2011-03-27  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/47065
+	* frontend-passes.c (optimize_trim): Also follow references, except
+	when they are substring references or array references.
+
+2011-03-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* gfortran.h (gfc_isym_id): Rename GFC_ISYM_NUMIMAGES to
+	GFC_ISYM_NUM_IMAGES.
+	(gfc_fcoarray): Add GFC_FCOARRAY_LIB.
+	* intrinsic.c (add_functions): Update due to GFC_ISYM_NUM_IMAGES
+	rename.
+	* invoke.texi (-fcoarray=): Document "lib" argument.
+	* iresolve.c (gfc_resolve_this_image): Fix THIS IMAGE().
+	* libgfortran.h (libgfortran_stat_codes): Add comments.
+	* options.c (gfc_handle_coarray_option): Add -fcoarray=lib.
+	* simplify.c (gfc_simplify_num_images, gfc_simplify_this_image):
+	Handle GFC_FCOARRAY_LIB.
+	* trans.h (gfc_init_coarray_decl): New prototype.
+	(gfor_fndecl_caf_init, gfor_fndecl_caf_finalize,
+	gfor_fndecl_caf_critical, gfor_fndecl_caf_end_critical,
+	gfor_fndecl_caf_sync_all, gfor_fndecl_caf_sync_images,
+	gfor_fndecl_caf_error_stop, gfor_fndecl_caf_error_stop_str,
+	gfort_gvar_caf_num_images, gfort_gvar_caf_this_image):
+	New global variables.
+	* trans-decl.c: Declare several CAF functions (cf. above).
+	(gfc_build_builtin_function_decls): Initialize those.
+	(gfc_init_coarray_decl): New function.
+	(create_main_function): Call CAF init/finalize functions.
+	* trans-intrinsic.c (trans_this_image, trans_num_images): New.
+	(gfc_conv_intrinsic_function): Call those.
+	* trans-stmt.c (gfc_trans_stop, gfc_trans_sync, gfc_trans_critical):
+	Add code for GFC_FCOARRAY_LIB.
+
+2011-03-26  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/48291
+	* class.c (get_unique_hashed_string): Adjust maximum allowable length
+	for unique type string.
+
+2011-03-25  Kai Tietz  <ktietz@redhat.com>
+
+	* scanner.c (preprocessor_line): Use filename_cmp
+	instead of strcmp.
+
+2011-03-25  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/48174
+	PR fortran/45304
+	* trans-types.c (gfc_get_function_type): Don't use varargs if the
+	procedure is known to have no arguments.
+
+2011-03-21  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/22572
+	* gfortran.h (gfc_option_t): Add
+	flag_aggressive_function_elimination.
+	(gfc_dep_compare_functions):  Add prototype.
+	* lang.opt: Add faggressive-function-elimination.
+	* invoke.texi: Document -faggressive-function-elimination.
+	* frontend_passes (expr_array):  New static variable.
+	(expr_size):  Likewise.
+	(expr_count):  Likewise.
+	(current_code):  Likewise.
+	(current_ns):  Likewise.
+	(gfc_run_passes):  Allocate and free space for expressions.
+	(cfe_register_funcs):  New function.
+	(create_var):  New function.
+	(cfc_expr_0):  New function.
+	(cfe_code):  New function.
+	(optimize_namespace):  Invoke gfc_code_walker with cfe_code
+	and cfe_expr_0.
+	* dependency.c (gfc_dep_compare_functions):  New function.
+	(gfc_dep_compare_expr):  Use it.
+	* options.c (gfc_init_options):  Handle
+	flag_aggressive_function_elimination.
+	(gfc_handle_option):  Likewise.
+
+2011-03-15  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* arith.c (arith_power): Plug memory leak.
+
+2011-03-12  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/48059
+	* trans-expr.c (gfc_apply_interface_mapping_to_expr): Replace base type
+	for polymorphic arguments.
+
+2011-03-12  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/48054
+	* intrinsic.texi: Clarify doc of logarithm functions.
+
+2011-03-12  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/47552
+	* trans-intrinsic.c (gfc_conv_intrinsic_ctime): Fix type of
+	the string length variable.
+
+2011-03-11  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47768
+	* module.c (ab_attribute,attr_bits): Add AB_PROC_POINTER_COMP.
+	(mio_symbol_attribute): Handle attribute 'proc_pointer_comp'.
+
+2011-03-06  Paul Thomas  <pault@gcc.gnu.org>
+	    Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/47850
+	* expr.c (gfc_is_constant_expr): Only use gfc_constant_ac if
+	the expression has an iterator.  Otherwise, iterate through the
+	array, checking for constant expressions for each element.
+
+2011-03-04  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	PR libfortran/47802
+	* intrinsic.texi: Update CTIME and FDATE documentation.
+
+2011-03-03  Ralf Wildenhues  <Ralf.Wildenhues@gmx.de>
+
+	* invoke.texi (Option Summary, Fortran Dialect Options)
+	(Preprocessing Options, Runtime Options, Code Gen Options):
+	Fix vertical list spacing by using @itemx for additinoal
+	items, empty line before @table.  Fix typos.
+
+2011-02-28  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/47894
+	* intrinsic.texi: Fix doc of the VERIFY intrinsic.
+
+2011-02-26  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/47846
+	* trans-stmt.c (gfc_trans_allocate): Fix allocation with
+	type-spec of deferred-length strings.
+
+2011-02-26  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/47886
+	* openmp.c (gfc_resolve_omp_directive): Resolve if()
+	condition of OpenMP's task.
+
+2011-02-26  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/47894
+	* intrinsic.texi: Fix doc of the VERIFY intrinsic.
+
+2011-02-24  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/47872
+	* intrinsic.texi (ALLOCATED, ATAN, BESSEL_JN, BESSEL_YN): Add
+	multitable for linebreak between different syntax variants.
+
+2011-02-24  Richard Guenther  <rguenther@suse.de>
+
+	PR fortran/47839
+	* f95-lang.c (pushdecl): For externs in non-global scope push
+	a copy of the decl into the BLOCK.
+
+2011-02-23  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/40850
+	* trans.c (gfc_prepend_expr_to_block): New function.
+	* trans.h (gfc_prepend_expr_to_block): Declare.
+	* trans-array.c (gfc_conv_array_parameter): Replace
+	gfc_add_expr_to_block with gfc_prepend_expr_to_block.
+
+2011-02-22  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/45743
+	* trans-decl.c (gfc_get_extern_function_decl): Don't use the
+	gsymbol backend_decl if the procedure has a formal argument
+	that is a procedure.
+
+2011-02-22  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/41359
+	* trans-stmt.c (gfc_trans_if_1): Use correct line for
+	expressions in the if condition.
+
+2011-02-20  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/47797
+	* trans-decl.c (gfc_trans_deferred_vars): Use gfc_set_backend_locus and
+	gfc_restore_backend_locus to have better debug locations.
+	* trans-array.c (gfc_trans_deferred_array): Ditto.
+
+2011-02-20  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/45077
+	PR fortran/44945
+	* trans-types.c (gfc_get_derived_type): Remove code that looks
+	for decls in gsym and add call to gfc_get_module_backend_decl.
+	* trans.h: Add prototype for gfc_get_module_backend_decl.
+	* trans-decl.c (gfc_get_module_backend_decl): New function.
+	(gfc_get_symbol_decl): Call it.
+
+2011-02-19  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/47348
+	* trans-array.c (get_array_ctor_all_strlen): Move up in file.
+	(get_array_ctor_var_strlen): Add block dummy and add call to
+	get_array_ctor_all_strlen instead of giving up on substrings.
+	Call gcc_unreachable for default case.
+	(get_array_ctor_strlen): Add extra argument to in call to
+	get_array_ctor_var_strlen.
+
+2011-02-18  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47789
+	* primary.c (gfc_match_structure_constructor): Handle empty parent
+	types.
+
+2011-02-18  Tobias Burnus
+
+	PR fortran/47775
+	* trans-expr.c (arrayfunc_assign_needs_temporary): Use
+	esym to check whether the specific procedure returns an
+	allocatable or pointer.
+
+2011-02-18  Michael Matz  <matz@suse.de>
+
+	PR fortran/45586
+	* gfortran.h (struct gfc_component): Add norestrict_decl member.
+	* trans.h (struct lang_type): Add nonrestricted_type member.
+	* trans-expr.c (gfc_conv_component_ref): Search fields with correct
+	parent type.
+	* trans-types.c (mirror_fields, gfc_nonrestricted_type): New.
+	(gfc_sym_type): Use it.
+
+2011-02-18  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47768
+	* resolve.c (resolve_transfer): Reject variables with procedure pointer
+	components.
+
+2011-02-18  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47767
+	* gfortran.h (gfc_check_access): Removed prototype.
+	(gfc_check_symbol_access): Added prototype.
+	* module.c (gfc_check_access): Renamed to 'check_access', made static.
+	(gfc_check_symbol_access): New function, basically a shortcut for
+	'check_access'.
+	(write_dt_extensions,write_symbol0,write_generic,write_symtree): Use
+	'gfc_check_symbol_access'.
+	(write_operator,write_module): Renamed 'gfc_check_access'.
+	* resolve.c (resolve_fl_procedure,resolve_fl_derived,
+	resolve_fl_namelist,resolve_symbol,resolve_fntype): Use
+	'gfc_check_symbol_access'.
+
+2011-02-16  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47745
+	* class.c (gfc_build_class_symbol): Set 'class_ok' attribute.
+	* decl.c (build_sym,attr_decl1): Move setting of 'class_ok' into
+	'gfc_build_class_symbol'.
+	(gfc_match_decl_type_spec): Reject unlimited polymorphism.
+	* interface.c (matching_typebound_op): Check for 'class_ok' attribute.
+	* match.c (select_type_set_tmp): Move setting of 'class_ok' into
+	'gfc_build_class_symbol'.
+	* primary.c (gfc_variable_attr): Check for 'class_ok' attribute.
+
+2011-02-15  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/47633
+	. simplify.c (gfc_simplify_compiler_version): Fix off-by-one issue.
+
+2011-02-14  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47730
+	* parse.c (gfc_build_block_ns): Commit 'block@' symbol.
+
+2011-02-14  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47728
+	* class.c (gfc_build_class_symbol): Give a fatal error on polymorphic
+	arrays.
+	* primary.c (gfc_match_varspec): Avoid ICE for invalid class
+	declaration.
+
+2011-02-14  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47349
+	* interface.c (get_expr_storage_size): Handle derived-type components.
+
+2011-02-13  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/47569
+	* interface.c (compare_parameter): Avoid ICE with
+	character components.
+
+2011-02-12  Janus Weil  <janus@gcc.gnu.org>
+
+	* class.c (gfc_build_class_symbol): Reject polymorphic arrays.
+	* decl.c (build_sym,build_struct,attr_decl1): Use return value of
+	'gfc_build_class_symbol'.
+
+2011-02-12  Michael Matz  <matz@suse.de>
+	    Janus Weil  <janus@gcc.gnu.org>
+	    Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/45586
+	* trans-expr.c (conv_parent_component_references): Avoid unintendent
+	skipping of parent compounds.
+
+2011-02-11  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/47550
+	* resolve.c (resolve_formal_arglist): PURE with VALUE
+	and no INTENT: Add -std= diagnostics.
+
+2011-02-09  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47352
+	* resolve.c (resolve_procedure_interface): If interface has a result
+	variable, copy the typespec and set result pointer to self.
+
+2011-02-09  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47463
+	* resolve.c (resolve_typebound_subroutine): Remove erroneous line.
+
+2011-02-09  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47637
+	* trans-decl.c (init_intent_out_dt): Handle CLASS arguments.
+
+2011-02-08  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	* io.c (match_io_element): Do not set dt if not inquire.
+
+2011-02-08  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/45290
+	* expr.c (gfc_check_assign_symbol): Reject pointers as pointer
+	initialization target.
+
+2011-02-07  Janne Blomqvist  <jb@gcc.gnu.org>
+	    Ralf Wildenhues  <Ralf.Wildenhues@gmx.de>
+
+	* gfortran.texi (Thread-safety): texinfo styling fixes.
+	* intrinsic.texi: Likewise.
+
+2011-02-06  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	* gfortran.texi (Compiler Characteristics): Add reference to
+	thread-safety section.
+
+2011-02-06  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	* gfortran.texi (Thread-safety): New section.
+	* intrinsic.texi (EXECUTE_COMMAND_LINE): Mention thread-safety.
+	(GETENV): Likewise.
+	(GET_ENVIRONMENT_VARIABLE): Likewise.
+	(SYSTEM): Likewise.
+
+2011-02-06  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/47592
+	* trans-stmt.c (gfc_trans_allocate): For deferred character
+	length allocations with SOURCE, store to the values and string
+	length to avoid calculating twice.  Replace gfc_start_block
+	with gfc_init_block to avoid unnecessary contexts and to keep
+	declarations of temporaries where they should be. Tidy up the
+	code a bit.
+
+2011-02-05  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	PR fortran/42434
+	* intrinsic.texi (SYSTEM_CLOCK): Update documentation.
+
+2011-02-02  Janus Weil  <janus@gcc.gnu.org>
+	    Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/47082
+	* trans-expr.c (gfc_trans_class_init_assign): Add call to
+	gfc_get_derived_type.
+	* module.c (read_cleanup): Do not use unique_symtrees for vtabs
+	or vtypes.
+
+2011-02-02  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47572
+	* resolve.c (resolve_fl_variable): Handle polymorphic allocatables.
+
+2011-02-01  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47565
+	* trans-expr.c (gfc_conv_structure): Handle constructors for procedure
+	pointer components with allocatable result.
+
+2011-01-31  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47455
+	* trans-expr.c (gfc_conv_procedure_call): Handle procedure pointers
+	with pointer or allocatable result.
+
+2011-01-31  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/47519
+	* trans-stmt.c (gfc_trans_allocate): Improve handling of
+	deferred character lengths with SOURCE.
+	* iresolve.c (gfc_resolve_repeat): Calculate character
+	length from source length and ncopies.
+	* dump-parse-tree.c (show_code_node): Show MOLD and SOURCE
+	expressions for ALLOCATE.
+
+2011-01-31  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47463
+	* resolve.c (resolve_typebound_subroutine): Bug fix for the case of
+	an argument of a typebound assignment being a component.
+
+2011-01-31  Rainer Orth  <ro@CeBiTec.Uni-Bielefeld.DE>
+
+	* gfortranspec.c (add_arg_libgfortran) [HAVE_LD_STATIC_DYNAMIC] Use
+	LD_STATIC_OPTION, LD_DYNAMIC_OPTION.
+
+2011-01-31  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/47042
+	* resolve.c (resolve_fl_procedure): Reject stmt functions
+	with pointer/allocatable attribute.
+
+2011-01-31  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/47042
+	* interface.c (gfc_procedure_use): Add explicit interface check for
+	pointer/allocatable functions.
+
+2011-01-30  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/47523
+	* trans-expr.c (gfc_trans_assignment_1): If the rhs is an op
+	expr and is assigned to a deferred character length scalar,
+	make sure that the function is called before reallocation,
+	so that the length is available. Include procedure pointer
+	and procedure pointer component rhs as well.
+
+	PR fortran/45170
+	PR fortran/35810
+	PR fortran/47350
+	* gfortran.dg/allocatable_function_5.f90: New test not added by
+	mistake on 2011-01-28.
+
+2011-01-29  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/47531
+	* check.c (gfc_check_shape): Support kind argument in SHAPE.
+	* intrinsic.c (add_functions): Ditto.
+	* resolve.c (gfc_resolve_shape): Ditto.
+	* simplify.c (gfc_simplify_shape): Ditto.
+	* intrinsic.h (gfc_check_shape, gfc_resolve_shape,
+	gfc_simplify_shape): Update prototypes.
+	* intrinisc.text (SHAPE): Document kind argument.
+
+2011-01-28  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/47507
+	* resolve.c (resolve_formal_arglist): Allow arguments with VALUE
+	attribute also without INTENT.
+
+2011-01-28  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.texi (Fortran 2003 status): Mention support for
+	nonconstant namelist variables.
+
+2011-01-28  Paul Thomas  <pault@gcc.gnu.org>
+	    Tobias Burnus  <burnus@gcc.gnu.org>
+
+	PR fortran/45170
+	PR fortran/35810
+	PR fortran/47350
+	* interface.c (compare_actual_formal): An allocatable or pointer
+	deferred length actual is only allowed if the formal argument
+	is also deferred length. Clean up whitespace.
+	* trans-expr.c (gfc_conv_procedure_call): Pass string length for
+	deferred character length formal arguments by reference. Do the
+	same for function results.
+	(gfc_trans_pointer_assignment): Do not do runtime check of lhs
+	and rhs character lengths, if deferred length lhs.  In this case
+	set the lhs character length to that of the rhs.
+	(gfc_conv_string_parameter): Remove assert that string length is
+	an integer type.
+	(is_scalar_reallocatable_lhs): New function.
+	(alloc_scalar_allocatable_for_assignment): New function.
+	(gfc_trans_assignment_1): Call above new function. If the rhs is
+	a deferred character length itself, makes ure that the function
+	is called before reallocation, so that the length is available.
+	(gfc_trans_asssignment): Remove error about assignment to
+	deferred length character variables.
+	* gfortran.texi: Update entry about (re)allocation on
+	assignment.
+	* trans-stmt.c (gfc_trans_allocate): Add code to handle deferred
+	length character variables.
+	* module.c (mio_typespec): Transfer deferred characteristic.
+	* trans-types.c (gfc_get_function_type): New code to generate
+	hidden typelist, so that those character lengths that are
+	passed by reference get the right type.
+	* resolve.c (resolve_contained_fntype): Supress error for
+	deferred character length functions.
+	(resolve_function, resolve_fl_procedure) The same.
+	(check_symbols): Remove the error that support for
+	entity with deferred type parameter is not yet implemented.
+	(resolve_fl_derived): The same.
+	match.c (alloc_opt_list): Allow MOLD for deferred length object.
+	* trans-decl.c (gfc_get_symbol_decl): For deferred character
+	length dummies, generate a local variable for string length.
+	(create_function_arglist): Hidden length can be a pointer.
+	(gfc_trans_deferred_vars): For deferred character length
+	results and dummies, assign the string length to the local
+	variable from the hidden argument on entry and the other way
+	round on exit, as appropriate.
+
+2011-01-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/47474
+	* trans-decl.c (gfc_generate_function_code): Fix init
+	of allocatable result variable with allocatable components.
+
+2011-01-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/47472
+	* options.c (gfc_handle_module_path_options): Save
+	module path without trailing slash as include path.
+
+2011-01-25  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/47448
+	* interface.c (gfc_check_operator_interface): Fix
+	defined-assignment check.
+
+2011-01-23  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/47421
+	* trans-decl.c (gfc_trans_deferred_vars): Do not nullify
+	scalar allocatable dummy arguments.
+
+2011-01-22  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/38536
+	* resolve.c (gfc_iso_c_func_interface):  For C_LOC,
+	check for array sections followed by component references
+	which are illegal.  Also check for coindexed arguments.
+
+2011-01-22  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/47399
+	* primary.c (gfc_match_varspec): Relax gcc_assert to allow for
+	PARAMETER TBP.
+
+2011-01-21  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/47394
+	* error.c (gfc_error_now, gfc_fatal_error, gfc_error_check):
+	Use defined instead of magic number exit status codes.
+	* scanner.c (include_line, gfc_new_file): Ditto.
+
+2011-01-21  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/47377
+	* expr.c (gfc_check_pointer_assign): Reject expr data-targets
+	without pointer attribute.
+
+2011-01-18  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47240
+	* resolve.c (expression_rank): Fix rank of procedure poiner components.
+	* trans-expr.c (gfc_conv_procedure_call): Take care of procedure
+	pointer components as actual arguments.
+
+2011-01-17  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/47331
+	* gfortran.h (struct gfc_omp_saved_state): New type.
+	(gfc_omp_save_and_clear_state, gfc_omp_restore_state): New prototypes.
+	* resolve.c (resolve_global_procedure): Call it around gfc_resolve
+	call.
+	* openmp.c (gfc_omp_save_and_clear_state, gfc_omp_restore_state): New
+	functions.
+
+2011-01-17  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/47327
+	* invoke.texi (Options to request or suppress errors
+	and warnings): Fix cross link.
+
+2011-01-15  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.texi: Update Fortran 2003 Status section.
+
+	PR fortran/47177
+	* invoke.texi: Add missing "-E" to the -dM example.
+
+2011-01-13  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/47268
+	* intrinsic.texi (get_command_argument, get_environment_variable):
+	Mark arguments as optional in the Arguments section.
+
+2011-01-13  Kai Tietz  <kai.tietz@onevision.com>
+	    Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/47260
+	* trans-decl.c (gfc_get_extern_function_decl,
+	build_function_decl): Set TREE_PUBLIC/TREE_EXTERNAL before
+	calling decl_attributes.
+
+2011-01-13  Tobias Burnus  <burnus@net-b.de>
+	    Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/45848
+	PR fortran/47204
+	* gfortran.h (gfc_code): Move union ext's case_list into
+	the struct block.
+	* dump-parse-tree.c (show_code_node): Adapt by prefixing case_list
+	by "block.".
+	* frontend-passes.c (gfc_code_walker): Ditto.
+	* match.c (gfc_match_goto, gfc_match_call, gfc_match_case,
+	gfc_match_type_is, gfc_match_class_is): Ditto.
+	* resolve.c (resolve_select, resolve_select_type): Ditto.
+	* st.c (gfc_free_statement): Ditto.
+	* trans-stmt.c (gfc_trans_integer_select, gfc_trans_logical_select,
+	gfc_trans_character_select): Ditto.
+	* parse.c (resolve_all_program_units): For error recovery, avoid
+	segfault is proc_name is NULL.
+
+2011-01-11  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/47051
+	* trans-array.c (gfc_alloc_allocatable_for_assignment): Change
+	to be standard compliant by testing for shape rather than size
+	before skipping reallocation. Improve comments.
+
+2011-01-09  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47224
+	* resolve.c (resolve_actual_arglist): Remove unneeded and buggy piece
+	of code.
+
+2011-01-09  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/38536
+	* resolve.c (is_scalar_expr_ptr):  For a substring reference,
+	use gfc_dep_compare_expr to compare start and end expession.
+	Add FIXME for using gfc_deb_compare_expr elsewhere.
+
+2011-01-09  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/46313
+	* class.c (get_unique_type_string): Make type name start with upper
+	case letter.
+
+2011-01-08  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/46405
+	* invoke.texi:  Mention -ffree-line-length-none and
+	-ffixed-line-length-none for preprocessing.
+
+2011-01-08  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/46896
+	* trans-expr.c (gfc_conv_procedure_call): With a non-copying
+	procedure argument (eg TRANSPOSE) use a temporary if there is
+	any chance of aliasing due to host or use association.
+	(arrayfunc_assign_needs_temporary): Correct logic for function
+	results and do not use a temporary for implicitly PURE
+	variables.  Use a temporary for Cray pointees.
+	* symbol.c (gfc_add_save): Explicit SAVE not compatible with
+	implicit pureness of containing procedure.
+	* decl.c (match_old_style_init, gfc_match_data): Where decl
+	would fail in PURE procedure, set implicit_pure to zero.
+	* gfortran.h: Add implicit_pure to structure symbol_attr and
+	add prototype for function gfc_implicit_pure.
+	* expr.c (gfc_check_pointer_assign, gfc_check_vardef_context):
+	Where decl would fail in PURE procedure, reset implicit_pure.
+	* io.c (match_vtag, gfc_match_open, gfc_match_close,
+	gfc_match_print, gfc_match_inquire, gfc_match_wait): The same.
+	* match.c (gfc_match_critical, gfc_match_stopcode,
+	sync_statement, gfc_match_allocate, gfc_match_deallocate): The
+	same.
+	* parse.c (decode_omp_directive): The same.
+	(parse_contained): If not PURE, set implicit pure attribute.
+	* resolve.c (resolve_formal_arglist, resolve_structure_cons,
+	resolve_function, resolve_ordinary_assign): The same.
+	(gfc_implicit_pure): New function.
+	* module.c (mio_symbol_attribute): Introduce AB_IMPLICIT_PURE
+	to ab_attribute enum and use it in this function.
+
+2011-01-08  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/45777
+	* symbol.c (gfc_symbols_could_alias):  Strip gfc_ prefix,
+	make static and move in front of its only caller, to ...
+	* trans-array.c (symbols_could_alias): ... here.
+	Pass information about pointer and target status as
+	arguments.  Allocatable arrays don't alias anything
+	unless they have the POINTER attribute.
+	(gfc_could_be_alias):  Keep track of pointer and target
+	status when following references.  Also check if typespecs
+	of components match those of other components or symbols.
+
+2011-01-07  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/41580
+	* class.c (gfc_build_class_symbol): Mark __vtab as attr.vtab.
+	* intrinsic.c (add_functions): Use simplify functions for
+	EXTENDS_TYPE_OF and SAME_TYPE_AS.
+	* intrinsic.h (gfc_simplify_extends_type_of,
+	gfc_simplify_same_type_as): New prototypes.
+	* simplify.c (is_last_ref_vtab, gfc_simplify_extends_type_of,
+	gfc_simplify_same_type_as): New functions.
+
+2011-01-07  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47189
+	PR fortran/47194
+	* gfortran.h (gfc_lval_expr_from_sym): Moved prototype.
+	* class.c (gfc_class_null_initializer): Initialize _vptr to declared
+	type.
+	* expr.c (gfc_lval_expr_from_sym): Moved here from symbol.c.
+	* resolve.c (resolve_deallocate_expr): _data component will be added
+	at translation stage.
+	* symbol.c (gfc_lval_expr_from_sym): Moved to expr.c.
+	* trans-stmt.c (gfc_trans_deallocate): Reset _vptr to declared type.
+
+2011-01-06  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/33117
+	PR fortran/46478
+	* parse.c (parse_interface): Remove check for procedure types.
+	* interface.c (check_interface0): Verify that procedures are
+	either all SUBROUTINEs or all FUNCTIONs.
+
+2011-01-05  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47180
+	* trans-expr.c (gfc_trans_class_assign): Bugfix for r168524 (make sure
+	'vtab' is initialized).
+
+2011-01-05  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47180
+	* trans-expr.c (gfc_trans_class_assign): For a polymorphic NULL pointer
+	assignment, set the _vptr component to the declared type.
+
+2011-01-05  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/46017
+	* resolve.c (resolve_allocate_deallocate): Follow references to
+	check for duplicate occurence of allocation/deallocation objects.
+
+2011-01-05  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47024
+	* trans-decl.c (gfc_trans_deferred_vars): Initialize the _vpr component
+	of polymorphic allocatables according to their declared type.
+
+2011-01-04  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/46448
+	* class.c (gfc_find_derived_vtab): Set the module field for the copying
+	routine to make sure it receives module name mangling.
+
+2011-01-03  Jakub Jelinek  <jakub@redhat.com>
+
+	* gfortranspec.c (lang_specific_driver): Update copyright notice
+	dates.
+
+2011-01-03  Janus Weil  <janus@gcc.gnu.org>
+
+	* intrinsic.texi (LEADZ): Fix example.
+
+2011-01-02  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/46408
+	* class.c (gfc_find_derived_vtab): Use EXEC_INIT_ASSIGN for __copy_
+	routine.
+
+
+Copyright (C) 2011 Free Software Foundation, Inc.
+
+Copying and distribution of this file, with or without modification,
+are permitted in any medium without royalty provided the copyright
+notice and this notice are preserved.
diff --git a/gcc-4.9/gcc/fortran/ChangeLog-2012 b/gcc-4.9/gcc/fortran/ChangeLog-2012
new file mode 100644
index 000000000..5045220f0
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/ChangeLog-2012
@@ -0,0 +1,2798 @@
+2012-12-28  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/55692
+	* check.c (gfc_check_associated): Remove a "gcc_assert (0)".
+
+2012-12-28  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/55763
+	* check.c (gfc_check_move_alloc): Handle unlimited polymorphic.
+	* trans-intrinsic.c (conv_intrinsic_move_alloc): Ditto.
+
+2012-12-27  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/48976
+	* gfortran.h (gfc_inquire struct): Add pointer for inquire stream.
+	* io.c (io_tag): Add tag for inquire stream. (match_inquire_element):
+	Add matcher for new tag. (gfc_resolve_inquire): Resolve new tag.
+	* ioparm.def: Add new parameter for inquire stream.
+	* trans-io.c (gfc_trans_inquire): Add tranlste code for inquire
+	stream.
+
+2012-12-23  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54884
+	* module.c (write_symbol1_recursion): Set attr.public_use.
+	* interface.c (check_sym_interfaces, check_uop_interfaces,
+	gfc_check_interfaces): Remove attr.public_use code.
+	* resolve.c (resolve_function, resolve_variable,
+	resolve_typebound_procedure): Ditto.
+
+2012-12-22  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/55763
+	* module.c (mio_component): Don't skip _hash's initializer.
+	* resolve.c (resolve_select_type): Add an assert.
+	* trans-expr.c (gfc_conv_procedure_call): Handle
+	INTENT(OUT) for UNLIMIT_POLY.
+
+2012-12-21  Richard Biener  <rguenther@suse.de>
+
+	PR bootstrap/54659
+	* gfortran.h: Do not include gmp.h here.
+
+2012-12-21  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/55763
+	* match.c (select_type_set_tmp): Return is a derived type or
+	class typespec has no derived type.
+	* resolve.c (resolve_fl_var_and_proc): Exclude select type
+	temporaries from 'pointer'.
+	(resolve_symbol): Exclude select type temporaries from tests
+	for assumed size and assumed rank.
+
+2012-12-20  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/36044
+	* gfortran.h (gfc_isym_id): Add GFC_ISYM_BACKTRACE.
+	* intrinsic.c (add_subroutines): Add "backtrace".
+	* intrinsic.texi (BACKTRACE): Document BACKTRACE intrinsic.
+
+2012-12-20  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54818
+	* trans-intrinsic.c (gfc_conv_intrinsic_transfer): Ensure that
+	the string length is of type gfc_charlen_type_node.
+
+2012-12-19  Paul Thomas  <pault@gcc.gnu.org>
+
+	* array.c (resolve_array_list): Apply C4106.
+	* check.c (gfc_check_same_type_as): Exclude polymorphic
+	entities from check for extensible types. Improved error
+	for disallowed argument types to name the offending type.
+	* class.c : Update copyright date.
+	(gfc_class_null_initializer): Add argument for initialization
+	expression and deal with unlimited polymorphic typespecs.
+	(get_unique_type_string): Give unlimited polymorphic
+	entities a type string.
+	(gfc_intrinsic_hash_value): New function.
+	(gfc_build_class_symbol): Incorporate unlimited polymorphic
+	entities.
+	(gfc_find_derived_vtab): Deal with unlimited polymorphic
+	entities.
+	(gfc_find_intrinsic_vtab): New function.
+	* decl.c (gfc_match_decl_type_spec): Match typespec for
+	unlimited polymorphic type.
+	(gfc_match_data_decl): Skip to 'ok' if unlimited polymorphic.
+	expr.c (gfc_check_pointer_assign): Apply C717.  If unlimited
+	polymorphic lvalue, find rvalue vtable for all typespecs,
+	except unlimited polymorphic expressions.
+	(gfc_check_vardef_context): Handle unlimited polymorphic
+	entities.
+	* gfortran.h : Add unlimited polymorphic attribute. Add
+	second arg to gfc_class_null_initializer primitive and
+	primitive for gfc_find_intrinsic_vtab.  Add UNLIMITED_POLY
+	to detect unlimited polymorphic expressions.
+	* interface.c (gfc_compare_types): If expr1 is unlimited
+	polymorphic, always return 1. If expr2 is unlimited polymorphic
+	enforce C717.
+	(gfc_compare_interfaces): Skip past conditions that do not
+	apply for unlimited polymorphic entities.
+	(compare_parameter): Make sure that an unlimited polymorphic,
+	allocatable or pointer, formal argument is matched by an
+	unlimited polymorphic actual argument.
+	(compare_actual_formal): Ensure that an intrinsic vtable exists
+	to match an unlimited polymorphic formal argument.
+	* match.c (gfc_match_allocate): Type kind parameter does not
+	need to match an unlimited polymorphic allocate-object.
+	(alloc_opt_list): An unlimited polymorphic allocate-object
+	requires a typespec or a SOURCE tag.
+	(select_intrinsic_set_tmp): New function.
+	(select_type_set_tmp): Call new function.  If it returns NULL,
+	build a derived type or class temporary instead.
+	(gfc_match_type_is): Remove restriction to derived types only.
+	Bind(C) or sequence derived types not permitted.
+	* misc (gfc_typename):  Printed CLASS(*) for unlimited
+	polymorphism.
+	* module.c : Add AB_UNLIMITED_POLY to pass unlimited
+	polymorphic attribute to and from modules.
+	* resolve.c (resolve_common_vars): Unlimited polymorphic
+	entities cannot appear in common blocks.
+	(resolve_deallocate_expr): Deallocate unlimited polymorphic
+	enities.
+	(resolve_allocate_expr): Likewise for allocation.  Make sure
+	vtable exists.
+	(gfc_type_is_extensible): Unlimited polymorphic entities are
+	not extensible.
+	(resolve_select_type): Handle unlimited polymorphic selectors.
+	Ensure that length type parameters are assumed and that names
+	for intrinsic types are generated.
+	(resolve_fl_var_and_proc): Exclude select type temporaries
+	from test of extensibility of type.
+	(resolve_fl_variable): Likewise for test that assumed character
+	length must be a dummy or a parameter.
+	(resolve_fl_derived0): Return SUCCESS unconditionally for
+	unlimited polymorphic entities. Also, allow unlimited
+	polymorphic components.
+	(resolve_fl_derived): Return SUCCESS unconditionally for
+	unlimited polymorphic entities.
+	(resolve_symbol): Return early with unlimited polymorphic
+	entities.
+	* simplifiy.c : Update copyright year.
+	(gfc_simplify_extends_type_of): No simplification possible
+	for unlimited polymorphic arguments.
+	* symbol.c (gfc_use_derived): Nothing to do for unlimited
+	polymorphic "derived type".
+	(gfc_type_compatible): Return unity if ts1 is unlimited
+	polymorphic.
+	* trans-decl.c (create_function_arglist) Formal arguments
+	without a character length should be treated in the same way
+	as passed lengths.
+	(gfc_trans_deferred_vars): Nullify the vptr of unlimited
+	polymorphic pointers. Avoid unlimited polymorphic entities
+	triggering gcc_unreachable.
+	* trans-expr.c (gfc_conv_intrinsic_to_class): New function.
+	(gfc_trans_class_init_assign): Make indirect reference of
+	src.expr.
+	(gfc_trans_class_assign): Expression NULL of unknown type
+	should set NULL vptr on lhs. Treat C717 cases where lhs is
+	a derived type and the rhs is unlimited polymorphic.
+	(gfc_conv_procedure_call): Handle the conversion of a non-class
+	actual argument to match an unlimited polymorphic formal
+	argument.  Suppress the passing of a character string length
+	in this case.  Make sure that calls to the character __copy
+	function have two character string length arguments.
+	(gfc_conv_initializer): Pass the initialization expression to
+	gfc_class_null_initializer.
+	(gfc_trans_subcomponent_assign): Ditto.
+	(gfc_conv_structure): Move handling of _size component.
+	trans-intrinsic.c: (gfc_conv_same_type_as): Handle conditions
+	where unlimited polymorphic arguments have null vptr.
+	* trans-stmt.c (trans_associate_var): Correctly treat array
+	temporaries associated with unlimited polymorphic selectors.
+	Recover the overwritten dtype for the descriptor. Use the _size
+	field of the vptr for character string lengths.
+	(gfc_trans_allocate): Cope with unlimited polymorphic allocate
+	objects; especially with character source tags.
+	(reset_vptr): New function.
+	(gfc_trans_deallocate): Call it.
+	* trans-types.c (gfc_get_derived_type): Detect unlimited
+	polymorphic types and deal with cases where the derived type of
+	components is null.
+	* trans.c : Update copyright year.
+	(trans_code): Call gfc_trans_class_assign for C717 cases where
+	the lhs is not unlimited polymorphic.
+
+2012-12-19  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/55733
+	* trans-decl.c (gfc_create_string_length): Avoid setting
+	TREE_STATIC for automatic variables with -fno-automatic.
+
+2012-12-19  Tobias Burnus  <burnus@net-b.de>
+	    Jakub Jelinek  <jakub@redhat.com>
+	    Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/55636
+	PR fortran/55733
+	* gfortran.h (GFC_PREFIX): Define.
+	* trans-decl.c (gfc_create_string_length): For VAR_DECLs that
+	will be TREE_STATIC, use GFC_PREFIX to mangle the names. Handle
+	-fno-automatic
+	(gfc_trans_deferred_vars): Don't free variables SAVEd via
+	-fno-automatic.
+
+2012-12-16  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/55197
+	* module.c (gfc_use_module): Free rename list only for
+	internally generated intrinsic modules.
+
+2012-12-16  Tobias Burnus  <burnus@net-b.de>
+
+	* trans-intrinsic.c (conv_intrinsic_move_alloc): Set dynamic
+	type of the FROM variable to the declared type.
+
+2012-12-16  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/55638
+	* resolve.c (resolve_formal_arglist): Allow VALUE without
+	INTENT for ELEMENTAL procedures.
+
+2012-12-10  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/52909
+	* trans-decl.c (get_proc_pointer_decl): Apply name mangling.
+
+2012-12-09  Tobias Burnus  <burnus@net-b.de>
+
+	* trans-array.c (structure_alloc_comps): Use NULL_TREE in the
+	call to gfc_deallocate_scalar_with_status.
+	* trans-decl.c (gfc_trans_deferred_vars): Pass symbol.
+	* trans-stmt.c (gfc_trans_deallocate): Pass polymorphic variable.
+
+2012-12-09  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/55593
+	* frontend-passes.c (doloop_code):  Use resolved_sym
+	instead of n.sym->formal for formal argument list
+	to get the correct version for all generic subroutines.
+
+2012-12-05  Tobias Burnus  <burnus@net-b.de>
+
+	* resolve.c (generate_component_assignments): Fix memleak.
+
+2012-12-03  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/55548
+	* intrinsic.texi (SYSTEM_CLOCK): Update documentation of SYSTEM_CLOCK.
+
+2012-12-03  Tobias Burnus  <burnus@net-b.de>
+	    Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/37336
+	* class.c (gfc_is_finalizable): New function.
+	* gfortran.h (gfc_is_finalizable): Its prototype.
+	* module.c (mio_component): Read initializer for vtype's _final.
+	* resolve.c (resolve_fl_derived0): Call gfc_is_finalizable.
+	* trans-expr.c (gfc_vtable_final_get): New function.
+	(conv_parent_component_references): Fix comment.
+	(gfc_conv_variable): Fix for scalar coarray components.
+	* trans-intrinsic.c (conv_intrinsic_move_alloc): For BT_CLASS,
+	pass the BT_CLASS type and not the declared type to
+	gfc_deallocate_scalar_with_status.
+	* trans.h (gfc_vtable_final_get): New prototype.
+
+2012-12-03  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/55475
+	* scanner.c (gfc_next_char_literal): Fix setting locus
+	to free_line_length for the error message.
+	* error.c (show_locus): Fix potential out-of-bounds
+	read.
+
+2012-12-03  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/37336
+	* class.c (finalizer_insert_packed_call): New static function.
+	(finalize_component, generate_finalization_wrapper):
+	Fix coarray handling and packing.
+
+2012-12-02  Paul Thomas  <pault@gcc.gnu.org>
+
+	* resolve.c (resolve_allocate_deallocate,
+	resolve_typebound_intrinsic_op): Recover revisions 193568 and
+	193778, which were accidentally reverted by the previous patch.
+
+2012-12-01   Alessandro Fanfarillo <alessandro.fanfarillo@gmail.com>
+	     Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/46897
+	* gfortran.h : Add bit field 'defined_assign_comp' to
+	symbol_attribute structure.
+	Add primitive for gfc_add_full_array_ref.
+	* expr.c (gfc_add_full_array_ref): New function.
+	(gfc_lval_expr_from_sym): Call new function.
+	* resolve.c (add_comp_ref): New function.
+	(build_assignment): New function.
+	(get_temp_from_expr): New function
+	(add_code_to_chain): New function
+	(generate_component_assignments): New function that calls all
+	the above new functions.
+	(resolve_code): Call generate_component_assignments.
+	(check_defined_assignments): New function.
+	(resolve_fl_derived0): Call check_defined_assignments.
+	(gfc_resolve): Reset component_assignment_level in case it is
+	left in a bad state by errors.
+
+
+	* resolve.c (is_sym_host_assoc, resolve_procedure_interface,
+	resolve_contained_fntype, resolve_procedure_expression,
+	resolve_elemental_actual, resolve_global_procedure,
+	is_scalar_expr_ptr, gfc_iso_c_func_interface, resolve_function,
+	set_name_and_label, gfc_iso_c_sub_interface,
+	resolve_specific_s0, resolve_operator, compare_bound_mpz_t,
+	gfc_resolve_character_operator, resolve_typebound_function,
+	gfc_resolve_expr, forall_index, remove_last_array_ref,
+	conformable_arrays, resolve_allocate_expr,
+	resolve_allocate_deallocate, resolve_select_type,
+	resolve_transfer, resolve_where,
+	gfc_resolve_where_code_in_forall, gfc_resolve_forall_body,
+	gfc_count_forall_iterators, resolve_values,
+	resolve_bind_c_comms, resolve_bind_c_derived_types,
+	gfc_verify_binding_labels, apply_default_init,
+	build_default_init_expr, apply_default_init_local,
+	resolve_fl_var_and_proc, resolve_fl_procedure,
+	gfc_resolve_finalizers, check_generic_tbp_ambiguity,
+	resolve_typebound_intrinsic_op, resolve_typebound_procedure,
+	resolve_typebound_procedures, ensure_not_abstract,
+	resolve_fl_derived0, resolve_fl_parameter, resolve_symbol,
+	resolve_equivalence_derived): Remove trailing white space.
+	* gfortran.h : Remove trailing white space.
+
+2012-11-28  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52161
+	* trans-stmt.c (gfc_trans_sync): Fix bound checking
+	for -fcoarray=lib.
+
+2012-11-28  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52161
+	* trans-stmt.c (gfc_trans_sync): Fix bound checking.
+
+2012-11-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/55476
+	* expr.c (gfc_check_pointer_assign): Fix check
+	pointer-might-outlive-target check for host_assoc.
+
+2012-11-26  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* trans-decl.c (gfc_finish_var_decl): Do not set DECL_RESTRICTED_P.
+
+2012-11-26  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/54997
+	* decl.c (match_procedure_decl): Don't set 'referenced' attribute
+	for PROCEDURE declarations.
+	* parse.c (gfc_fixup_sibling_symbols,parse_contained): Don't set
+	'referenced' attribute for all contained procedures.
+	* trans-decl.c (gfc_get_symbol_decl): Allow for unreferenced procedures.
+	(build_function_decl): Set TREE_USED for referenced procedures.
+
+2012-11-26  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/54881
+	* match.c (select_derived_set_tmp,select_class_set_tmp): Removed and
+	unified into ...
+	(select_type_set_tmp): ... this one. Set POINTER argument according to
+	selector.
+	* trans-intrinsic.c (gfc_conv_associated): Use 'gfc_class_data_get'
+	instead of 'gfc_add_data_component'.
+
+2012-11-25  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/30146
+	* frontend-passes.c (doloop_warn):  New function.
+	(doloop_list):  New static variable.
+	(doloop_size):  New static variable.
+	(doloop_level):  New static variable.
+	(gfc_run_passes): Call doloop_warn.
+	(doloop_code):  New function.
+	(doloop_function):  New function.
+	(gfc_code_walker):  Keep track of DO level.
+
+2012-11-24  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/55314
+	* resolve.c (resolve_allocate_deallocate):  Compare all
+	subscripts when deciding if to reject a (de)allocate
+	statement.
+
+2012-11-21  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/55352
+	* trans-decl.c (generate_local_decl): Don't warn for explicitly imported
+	but unused module variables which are in a namelist or common block.
+
+2012-11-20  Diego Novillo  <dnovillo@google.com>
+	    Jakub Jelinek  <jakub@redhat.com>
+
+	* trans-openmp.c: Replace all vec<T, A>() initializers
+	with vNULL.
+
+2012-11-17  Diego Novillo  <dnovillo@google.com>
+
+	Adjust for new vec API (http://gcc.gnu.org/wiki/cxx-conversion/cxx-vec)
+
+	* frontend-passes.c: Use new vec API in vec.h.
+	* trans-array.c: Likewise.
+	* trans-common.c: Likewise.
+	* trans-decl.c: Likewise.
+	* trans-expr.c: Likewise.
+	* trans-intrinsic.c: Likewise.
+	* trans-openmp.c: Likewise.
+	* trans-stmt.c: Likewise.
+	* trans-types.c: Likewise.
+	* trans.h: Likewise.
+
+2012-11-17  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/55341
+	* trans-intrinsic.c (gfc_conv_intrinsic_transfer): Convert last
+	argument to memcpy to size_type_node type.
+	* trans-stmt.c (gfc_conv_elemental_dependencies): Likewise.
+	* trasn-array.c (duplicate_allocatable): Likewise.
+
+2012-11-16  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/55297
+	* resolve.c (resolve_typebound_intrinsic_op): Only add typebound
+	operators to the operator list in the namespace of the derived type.
+
+
+2012-11-12  Jan Hubicka  <jh@suse.cz>
+
+	* f95-lang.c (ATTR_NOTHROW_LEAF_MALLOC_LIST): New macro.
+	(gfc_define_builtin): Use set_call_expr_flags.
+	(gfc_init_builtin_functions): Update.
+
+2012-11-12  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/55272
+	* module.c (mio_array_spec): Correctly handle coarray
+	scalars.
+
+2012-11-07  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	PR fortran/51727
+	* module.c (sorted_pointer_info): New.
+	(gfc_get_sorted_pointer_info): New.
+	(free_sorted_pointer_info_tree): New.
+	(compare_sorted_pointer_info): New.
+	(find_symbols_to_write): New.
+	(write_symbol1_recursion): New.
+	(write_symbol1): Collect symbols that need writing, output in order.
+	(write_generic): Traverse tree in order.
+
+2012-11-07  Manuel López-Ibáñez  <manu@gcc.gnu.org>
+
+	PR c/53063
+	* options.c (set_Wall): Do not set warn_switch here.
+
+2012-11-06  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/54917
+	* target-memory.c (gfc_target_expr_size,gfc_target_interpret_expr):
+	Handle BT_CLASS.
+	* trans-intrinsic.c (gfc_conv_intrinsic_transfer): Add support for
+	polymorphic arguments.
+
+2012-11-04  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/55199
+	* primary.c (gfc_match_varspec): Clear typespec if it cannot be
+	determined at this point.
+
+2012-10-31  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/53718
+	* trans.h (GFC_DECL_PUSH_TOPLEVEL): Removed.
+	* trans-decl.c (gfc_get_symbol_decl,gfc_generate_function_code): Remove
+	GFC_DECL_PUSH_TOPLEVEL.
+	(build_function_decl): Do not push __copy procedure to toplevel.
+
+2012-10-31  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/55134
+	* trans-array.c (gfc_conv_array_parameter): Regard AS_DEFERRED as
+	array with descriptor.
+
+2012-10-28  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54958
+	* gfortran.h (gfc_resolve_iterator_expr,
+	gfc_check_vardef_context): Update prototype.
+	* expr.c (gfc_check_vardef_context): Add own_scope
+	argument and honour it.
+	* resolve.c (gfc_resolve_iterator_expr): Add own_scope
+	argument and honour it.
+	(resolve_deallocate_expr, resolve_allocate_expr,
+	resolve_data_variables, resolve_transfer
+	resolve_lock_unlock, resolve_code): Update calls.
+	* array.c (resolve_array_list): Ditto.
+	* check.c (gfc_check_atomic_def, gfc_check_atomic_ref): Ditto.
+	* interface.c (compare_actual_formal): Ditto.
+	* intrinsic.c (check_arglist): Ditto.
+	* io.c (resolve_tag, gfc_resolve_dt, gfc_resolve_inquire): Ditto.
+
+2012-10-27  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	* trans.c (gfc_allocate_allocatable):  Revert accidental
+	commit.
+
+2012-10-24  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/55037
+	* trans-expr.c (gfc_conv_procedure_call): Move a piece of code and
+	remove an assert.
+
+2012-10-21  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54725
+	* Make-lang.in (CFLAGS-cpp.o): Use TARGET_SYSTEM_ROOT_DEFINE.
+	* cpp.o (gfc_cpp_init_options): Use it for
+	setting gfc_cpp_option.sysroot.
+
+2012-10-21  Thomas König  <tkoenig@gcc.gnu.org>
+
+	PR fortran/54465
+	* lang.opt (Wextra):  Add.
+	* invoke.texi:  Document that -Wc-binding-type, -Wconversion
+	and -Wline-truncation are implied by -Wall.  Document that
+	-Wcompare-reals is implied by -Wextra.  Document -Wextra.
+	* options.c (set_Wextra):  New function.
+	(gfc_handle_option):  Handle -Wextra.
+
+2012-10-19  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/54224
+	* trans-expr.c (conv_function_val): Set TREE_USED.
+
+2012-10-18  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54884
+	* resolve.c (specification_expr): Change to bool.
+	(resolve_formal_arglist, resolve_symbol): Set
+	specification_expr to true before resolving the array spec.
+	(resolve_variable, resolve_charlen, resolve_fl_variable):
+	Properly reset specification_expr.
+	(resolve_function): Set public_use when used in
+	a specification expr.
+
+2012-10-16  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/50981
+	PR fortran/54618
+	* trans.h (gfc_conv_derived_to_class, gfc_conv_class_to_class):
+	Update prototype.
+	* trans-stmt.c (trans_associate_var,gfc_trans_allocate): Update
+	calls to those functions.
+	* trans-expr.c (gfc_conv_derived_to_class, gfc_conv_class_to_class,
+	gfc_conv_expr_present): Handle absent polymorphic arguments.
+	(class_scalar_coarray_to_class): New function.
+	(gfc_conv_procedure_call): Update calls.
+
+2012-10-12  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40453
+	* interface.c (check_dummy_characteristics): Recursively check dummy
+	procedures.
+
+2012-10-11  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/54784
+	* trans-stmt.c (gfc_trans_allocate): Correctly determine the reference
+	to the _data component for polymorphic allocation with SOURCE.
+
+2012-10-06  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/54832
+	* resolve.c (resolve_fl_derived0): Correctly copy the 'class_ok'
+	attribute for proc-ptr components with RESULT variable.
+
+2012-10-06  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/45521
+	* interface.c (generic_correspondence): Implement additional
+	distinguishability criteria of F08.
+	(compare_actual_formal): Reject data object as actual argument for
+	procedure formal argument.
+
+2012-10-04  Tobias Burnus  <burnus@net-b.de>
+
+	* expr.c (scalarize_intrinsic_call): Plug memory leak.
+	* frontend-passes.c (gcc_assert): Extend assert.
+	* interface.c (gfc_compare_derived_types): Fix comparison.
+	(gfc_check_operator_interface): Move up to make this error
+	message reachable.
+	(get_sym_storage_size): Remove always-true checks.
+	* io.c (format_lex): Add comment.
+	(gfc_free_wait): Free memory.
+	* match.c (gfc_match_select_type): Ditto.
+	* matchexpr.c (match_level_3): Ditto.
+	* primary.c (match_string_constant): Ditto.
+	(match_actual_arg): Check return value.
+	* resolve.c (gfc_resolve_substring_charlen,
+	resolve_typebound_generic_call, resolve_typebound_function,
+	resolve_typebound_subroutine): Free memory.
+	* trans-types.c (gfc_get_derived_type): Remove always-true check.
+
+2012-10-02  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/54778
+	* interface.c (matching_typebound_op): Check for 'class_ok' attribute.
+
+2012-09-30  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/54667
+	* intrinsic.texi (C_F_POINTER): Fix description.
+	* resolve.c (gfc_iso_c_sub_interface): Add a check for FPTR argument
+	of C_F_POINTER. Modify two error messages. Cleanup.
+
+2012-09-24  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54618
+	PR fortran/54690
+	* trans-expr.c (gfc_conv_procedure_call): Fix INTENT(OUT)
+	handling for allocatable BT_CLASS.
+
+2012-09-24  Lawrence Crowl  <crowl@google.com>
+
+	* trans-expr.c (gfc_conv_cst_int_power): Change to new double_int API.
+	* target-memory.c (gfc_interpret_logical): Likewise.
+
+2012-09-23  Tobias Burnus  <burnus@net-b.de>
+
+	* parse.c (parse_derived): Don't set attr.alloc_comp
+	for pointer components with allocatable subcomps.
+
+	PR fortran/54599
+	* resolve.c (resolve_fl_namelist): Remove superfluous
+	NULL check.
+	* simplify.c (simplify_min_max): Remove unreachable code.
+	* trans-array.c (gfc_trans_create_temp_array): Change
+	a condition into an assert.
+
+	PR fortran/54618
+	* trans-expr.c (gfc_trans_class_init_assign): Guard
+	re-setting of the _data by gfc_conv_expr_present.
+	(gfc_conv_procedure_call): Fix INTENT(OUT) handling
+	for allocatable BT_CLASS.
+
+2012-09-22  Thomas König  <tkoenig@gcc.gnu.org>
+
+	PR fortran/54599
+	* dependency.c (gfc_dep_compare_expr):  Clarify logic,
+	remove dead code.
+
+2012-09-20  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54599
+	* cpp.c (print_line): Properly handle extern C.
+
+2012-09-20  Martin Jambor  <mjambor@suse.cz>
+
+	* trans-decl.c (gfc_get_extern_function_decl): Push NULL cfun.  Do not
+	set and restore current_function_decl.
+	(gfc_init_coarray_decl): Do not set and restore current_function_decl.
+
+2012-09-17  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54608
+	* simplify.c (gfc_simplify_scan, gfc_simplify_verify):
+	Fix handling of BACK=variable.
+
+2012-09-17  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/54285
+	* expr.c (gfc_check_pointer_assign): Correctly handle procedure pointers
+	as function results.
+	* primary.c (gfc_match_varspec): Allow to call a PPC with proc-ptr
+	result.
+
+2012-09-17  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54603
+	* trans-expr.c (gfc_trans_subcomponent_assign): Handle
+	proc-pointer components.
+
+2012-09-17  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54599
+	* error.c (error_print): Move increment out of the assert.
+	* interface.c (gfc_compare_derived_types): Add assert.
+	(get_expr_storage_size): Remove always-true logical condition.
+	* resolve.c (resolve_allocate_expr): Fix looping logic.
+	* target-memory.c (gfc_target_expr_size): Add assert.
+
+2012-09-16  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/54594
+	* resolve.c (get_checked_tb_operator_target): Add a reference to the
+	relevant quote from the F08 standard.
+
+2012-09-16  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/54594
+	* interface.c (compare_type_rank): Handle CLASS arrays.
+
+2012-09-16  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/54387
+	* expr.c (gfc_check_pointer_assign): Check for result of embracing
+	function.
+
+2012-09-16  Tobias Burnus  <burnus@net-b.de>
+
+	* trans-decl.c (gfc_generate_function_code): Fix
+	gfc_option.coarray check.
+	* trans-stmt.c (compute_inner_temp_size): Fix handling
+	of gfc_option.rtcheck.
+
+2012-09-16  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* symbol.c (gfc_undo_symbols): Correctly undo namelists.
+
+2012-09-15  Tobias Burnus  <burnus@net-b.de>
+
+	* trans-io.c (gfc_trans_transfer): Add an assert.
+
+2012-09-15  Tobias Burnus  <burnus@net-b.de>
+
+	* arith.c (arith_power): Call gfc_free_expr in case of error.
+	* array.c (gfc_match_array_constructor): Initialize variable.
+	(gfc_resolve_character_array_constructor): Remove superfluous check.
+	(gfc_array_dimen_size): Add assert.
+	* check.c (numeric_check): Fix implicit typing.
+	* class.c (gfc_build_class_symbol): Add assert.
+	(finalize_component): Free memory.
+	* dump-parse-tree.c (show_namespace): Add assert.
+	* trans-io.c (transfer_namelist_element, transfer_expr): Avoid
+	memory leakage.
+	(gfc_trans_transfer): Add assert.
+	* trans.c (gfc_trans_runtime_check): Call va_end
+
+2012-09-15  Tobias Burnus  <burnus@net-b.de>
+
+	* match.c (lock_unlock_statement, sync_statement): Fix potential
+	double freeing.
+	(sync_statement): Remove unreachable code.
+	* simplify.c (gfc_simplify_bessel_n2): Avoid double freeing.
+	(gfc_simplify_repeat): Remove bogus code.
+	* target-memory.h (gfc_target_encode_expr): Update prototype.
+	* target-memory.c (gfc_target_encode_expr, encode_array,
+	encode_derived): Return unsigned HOST_WIDE_INT.
+	(gfc_target_interpret_expr): Add assert.
+	(gfc_merge_initializers): Fix "== 0" check for mpz_t.
+	* symbol.c (gfc_get_typebound_proc): Add assert.
+	(gfc_merge_initializers): Remove unreachable check.
+
+2012-09-13  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54556
+	* resolve.c (resolve_formal_arglist): Allow VALUE arguments
+	with implicit_pure.
+	(gfc_impure_variable): Don't check gfc_pure such that the
+	function also works for gfc_implicit_pure procedures.
+
+2012-09-12  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54225
+	PR fortran/53306
+	* array.c (match_subscript, gfc_match_array_ref): Fix
+	diagnostic of coarray's '*'.
+
+2012-09-07  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/54208
+	* simplify.c (simplify_bound_dim): Resolve array spec before
+	proceeding with simplification.
+
+2012-09-06  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54463
+	* trans-intrinsic.c (gfc_conv_intrinsic_funcall): Fix matmul
+	call to BLAS if the default-kind has been promoted.
+
+2012-09-05  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54462
+	* symbol.c (gfc_undo_symbols): Avoid NULL pointer dereference.
+
+2012-09-04  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/54435
+	PR fortran/54443
+	* match.c (gfc_match_select_type): Make sure to only access CLASS_DATA
+	for BT_CLASS.
+
+2012-09-03  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54467
+	* class.c (gfc_find_derived_vtab): Fix disabling of _final
+	by continuing to generate normal type-bound procedures.
+
+2012-09-03  Tobias Burnus  <burnus@net-b.de>
+
+	* class.c (gfc_find_derived_vtab): Disable ABI-breaking
+	generation of the "_final" subroutine for now.
+
+2012-09-03  Tobias Burnus  <burnus@net-b.de>
+
+	* class.c (finalize_component): Fixes to the comment.
+
+2012-09-03  Alessandro Fanfarillo  <fanfarillo.gcc@gmail.com>
+	    Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/37336
+	* gfortran.h (symbol_attribute): Add artificial.
+	* module.c (mio_symbol_attribute): Handle attr.artificial
+	* class.c (gfc_build_class_symbol): Defer creation of the vtab
+	if the DT has finalizers, mark generated symbols as
+	attr.artificial.
+	(has_finalizer_component, finalize_component,
+	finalization_scalarizer, generate_finalization_wrapper):
+	New static functions.
+	(gfc_find_derived_vtab): Add _final component and call
+	generate_finalization_wrapper.
+	* dump-parse-tree.c (show_f2k_derived): Use resolved
+	proc_tree->n.sym rather than unresolved proc_sym.
+	(show_attr): Handle attr.artificial.
+	* resolve.c (gfc_resolve_finalizers): Ensure that the vtab exists.
+	(resolve_fl_derived): Resolve finalizers before
+	generating the vtab.
+	(resolve_symbol): Also allow assumed-rank arrays with CONTIGUOUS;
+	skip artificial symbols.
+	(resolve_fl_derived0): Skip artificial symbols.
+
+2012-09-02  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54426
+	* symbol.c (find_common_symtree): New function.
+	(gfc_undo_symbols): Use it; free common_head if needed.
+
+2012-08-28  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54389
+	* trans-decl.c (gfc_get_extern_function_decl,
+	build_function_decl): Don't mark impure elemental
+	functions as DECL_PURE_P and honour implicit_pure.
+
+2012-08-28  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54382
+	* error.c (show_locus): Avoid out of bound access.
+
+2012-08-28  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54384
+	* decl.c (match_data_constant): Add missing gfc_free_expr.
+	(top_val_list): Remove always-true condition.
+	* data.c (get_array_index, create_character_initializer):
+	Free temporary expressions.
+	(gfc_assign_data_value): Free expression when aborting.
+
+2012-08-28  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54384
+	* symbol.c (gfc_copy_formal_args): Set also sym->formal_ns.
+
+2012-08-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54384
+	* resolve.c (gfc_resolve_character_operator): Free temporary
+	variables.
+	* trans-expr.c (gfc_conv_statement_function): Ditto.
+
+2012-08-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54384
+	* dependency.c (check_section_vs_section): Use gfc_free_expr
+	instead of free.
+	* trans-intrinsic.c (conv_generic_with_optional_char_arg): Use
+	gfc_free_symbol instead of free.
+
+2012-08-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54384
+	* trans-expr.c (gfc_trans_arrayfunc_assign): Free se.ss
+	and loop.
+
+2012-08-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/41093
+	* gfortran.h (gfc_common_head): Add "int refs".
+	* match.c (gfc_match_common): Increment refs.
+	* resolve.c (resolve_symbol): Only increment formal_ns->refs
+	if formal_ns is not sym->ns.
+	* symbol.c (gfc_free_symbol): Only free formal_ns if
+	if formal_ns is not sym->ns. Free common_block if refs is one.
+	(gfc_release_symbol): Release formal_ns only if the
+	symbol is not ENTRY of a module.
+	* decl.c (get_proc_name): Don't increment gfc_current_ns->refs.
+	* parse.c (parse_interface): Incement proc_unit->refs++ for
+	proc-pointer result variables.
+	* module.c (mio_symbol): Don't increase sym->refs for its
+	use in sym->formal_ns->proc_name.
+
+2012-08-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54370
+	* trans-stmt.c (gfc_trans_do_while): Don't change the logical
+	kind for negation of the condition.
+
+2012-08-27  Tobias Burnus  <burnus@net-b.de>
+
+	* options.c (set_Wall): Don't set for -Wcompare-reals.
+	* invoke.texi (-Wall, -Wcompare-reals): -Wall no longer
+	implies -Wcompare-reals.
+
+2012-08-24  Simon Baldwin  <simonb@google.com>
+
+	* lang.opt (-cpp=): Mark flag NoDWARFRecord.
+
+2012-08-23  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54350
+	* trans-array.c (free_ss_info): Free data.array.subscript.
+	(gfc_free_ss): No longer free data.array.subscript.
+	(walk_coarray): New function, moved from trans-intrinsic.c
+	(gfc_conv_expr_descriptor): Walk array descriptor instead
+	of taking passed "ss".
+	(get_array_ctor_all_strlen, gfc_add_loop_ss_code,
+	gfc_conv_array_parameter): Update call and cleanup ss handling.
+	* trans-array.h (gfc_conv_expr_descriptor,
+	gfc_conv_array_parameter): Update prototype.
+	* trans-expr.c (gfc_conv_derived_to_class,
+	conv_isocbinding_procedure, gfc_conv_procedure_call,
+	gfc_trans_alloc_subarray_assign, gfc_trans_subcomponent_assign,
+	gfc_trans_pointer_assignment, gfc_trans_arrayfunc_assign): Update
+	call to gfc_conv_expr_descriptor and gfc_conv_array_parameter, and
+	clean up.
+	* trans-intrinsic.c (walk_coarray): Moved to trans-array.c
+	(trans_this_image, trans_image_index, gfc_conv_intrinsic_rank
+	gfc_conv_intrinsic_bound, gfc_conv_intrinsic_cobound,
+	gfc_conv_intrinsic_len, gfc_conv_intrinsic_size,
+	gfc_conv_intrinsic_sizeof, gfc_conv_intrinsic_storage_size,
+	gfc_conv_intrinsic_transfer, gfc_conv_allocated,
+	gfc_conv_associated, gfc_conv_intrinsic_loc,
+	conv_intrinsic_move_alloc): Update calls.
+	* trans-io.c (gfc_convert_array_to_string, set_internal_unit,
+	gfc_trans_transfer): Ditto.
+	* trans-stmt.c (gfc_conv_elemental_dependencies,
+	gfc_trans_sync, trans_associate_var,
+	gfc_trans_pointer_assign_need_temp): Ditto.
+
+2012-08-23  Jakub Jelinek  <jakub@redhat.com>
+
+	* trans-decl.c (trans_function_start, generate_coarray_init,
+	create_main_function, gfc_generate_constructors): Call
+	allocate_struct_function instead of init_function_start.
+
+2012-08-22  Tobias Burnus  <burnus@net-b.de>
+
+	* trans-expr.c (gfc_copy_class_to_class,
+	gfc_trans_arrayfunc_assign): Free loop and ss data.
+	* trans-intrinsic.c (gfc_trans_arrayfunc_assign): Free ss data.
+
+2012-08-21  Tobias Burnus  <burnus@net-b.de>
+
+	* parse.c (parse_contained): Include EXEC_END_PROCEDURE
+	in ns->code to make sure the gfc_code is freed.
+
+2012-08-20  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54301
+	* expr.c (gfc_check_pointer_assign): Warn when a pointer,
+	which is a function result, might outlive its target.
+
+2012-08-20  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54301
+	* expr.c (gfc_check_pointer_assign): Warn when the pointer
+	might outlive its target.
+	* gfortran.h (struct gfc_option_t): Add warn_target_lifetime.
+	* options.c (gfc_init_options, set_wall, gfc_handle_option):
+	handle it.
+	* invoke.texi (-Wtarget-lifetime): Document it.
+	(-Wall): Implied it.
+	* lang.opt (-Wtarget-lifetime): New flag.
+
+2012-08-19  Thomas König  <tkoenig@gcc.gnu.org>
+
+	PR fortran/54298
+	* gfortran.h (struct gfc_option_t): Add warn_compare_reals.
+	* lang.opt:  Add Wcompare-reals.
+	* invoke.texi:  Document -Wcompare-reals.
+	* resolve.c (resolve_operator):  If -Wcompare-reals is in effect,
+	warn about equality/inequality comparisions for REAL and COMPLEX.
+	* options.c (gfc_init_options):  Set warn_compare_reals.
+	(set_Wall):  Include warn_compare_reals in Wall.
+	(gfc_handle_option):  Handle Wcompare_reals.
+
+2012-08-17  Jakub Jelinek  <jakub@redhat.com>
+
+	* array.c (gfc_match_array_ref): Fix up memset arguments.
+
+2012-08-16   Diego Novillo  <dnovillo@google.com>
+
+	Revert
+
+	PR bootstrap/54281
+	* gfortran.h: Do not include gmp.h.
+
+2012-08-16   Diego Novillo  <dnovillo@google.com>
+
+	PR bootstrap/54281
+	* gfortran.h: Do not include gmp.h.
+
+2012-08-15  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/54243
+	PR fortran/54244
+	* resolve.c (check_typebound_baseobject): Check for class_ok attribute.
+	(resolve_procedure_interface,resolve_fl_derived0): Copy class_ok
+	attribute.
+
+2012-08-14  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/47586
+	* trans-expr.c (expr_is_variable): Handle regular, procedure pointer,
+	and typebound functions returning a data pointer.
+
+2012-08-14  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* decl.c (match_ppc_decl): Copy the procedure interface's symbol
+	as procedure interface's result.
+
+2012-08-14  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-expr.c (gfc_trans_scalar_assign): Rename argument,
+	extend comment.
+
+2012-08-14  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* gfortran.h (gfc_get_proc_ptr_comp): New prototype.
+	(gfc_is_proc_ptr_comp): Update prototype.
+	* expr.c (gfc_get_proc_ptr_comp): New function based on the old
+	gfc_is_proc_ptr_comp.
+	(gfc_is_proc_ptr_comp): Call gfc_get_proc_ptr_comp.
+	(gfc_specification_expr, gfc_check_pointer_assign): Use
+	gfc_get_proc_ptr_comp.
+	* trans-array.c (gfc_walk_function_expr): Likewise.
+	* resolve.c (resolve_structure_cons, update_ppc_arglist,
+	resolve_ppc_call, resolve_expr_ppc): Likewise.
+	(resolve_function): Update call to gfc_is_proc_ptr_comp.
+	* dump-parse-tree.c (show_expr): Likewise.
+	* interface.c (compare_actual_formal): Likewise.
+	* match.c (gfc_match_pointer_assignment): Likewise.
+	* primary.c (gfc_match_varspec): Likewise.
+	* trans-io.c (gfc_trans_transfer): Likewise.
+	* trans-expr.c (gfc_conv_variable, conv_function_val,
+	conv_isocbinding_procedure, gfc_conv_procedure_call,
+	gfc_trans_pointer_assignment): Likewise.
+	(gfc_conv_procedure_call, gfc_trans_array_func_assign):
+	Use gfc_get_proc_ptr_comp.
+
+2012-08-14  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40881
+	* error.c (gfc_notify_std): Reset cur_error_buffer->flag flag
+	when the error/warning has been printed.
+	* gfortran.h (gfc_sl_type): Add ST_LABEL_DO_TARGET.
+	* match.c (gfc_match_do): Use ST_LABEL_DO_TARGET.
+	* parse.c (check_statement_label): Use ST_LABEL_DO_TARGET.
+	(parse_executable): Add obsolescence check for DATA.
+	* resolve.c (resolve_branch): Handle ST_LABEL_DO_TARGET.
+	* symbol.c (gfc_define_st_label, gfc_reference_st_label):
+	Add obsolescence diagnostics.
+	* trans-stmt.c (gfc_trans_label_assign): Handle ST_LABEL_DO_TARGET.
+
+2012-08-14  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54234
+	* check.c (gfc_check_cmplx): Add -Wconversion warning
+	when converting higher-precision REAL to default-precision
+	CMPLX without kind= parameter.
+
+2012-08-12  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54221
+	* trans-decl.c (gfc_finish_var_decl, build_function_decl):
+	Fix setting private module vars/procs as TREE_PUBLIC(...) = 0.
+
+2012-08-09  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54199
+	* intrinsic.c (gfc_warn_intrinsic_shadow): Better warning
+	for internal procedures.
+
+2012-08-06  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/35831
+	* interface.c (check_result_characteristics): New function, which checks
+	the characteristics of function results.
+	(gfc_compare_interfaces,gfc_check_typebound_override): Call it.
+
+2012-08-02  Thomas König  <tkoenig@gcc.gnu.org>
+
+	 PR fortran/54033
+	 * scanner.c (add_path_to_list):  New argument warn.  Don't
+	 warn if it is true.
+	 (gfc_add_include_path):  Warn if directory is missing.
+	 (gfc_add_intrinsic_modules_path):  Do not warn if directory
+	 is missing.
+	 * optinons.c (gfc_handle_option):  Do not add directory
+	 for intrinsic modules to normal include path.
+
+2012-08-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/54166
+	* trans-array.c (set_loop_bounds): Access specinfo using spec_dim.
+
+2012-08-02  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/48820
+	* trans-array.c (gfc_conv_ss_startstride): Set the intrinsic
+	result's lower and upper bounds according to the rank.
+	(set_loop_bounds): Set the loop upper bound in the intrinsic case.
+
+2012-08-02  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (set_loop_bounds): Allow non-array-section to be
+	chosen using the stride and lower bound criteria.
+
+2012-08-02  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (set_loop_bounds): Remove useless dimension check.
+	Don't update loopspec if it would loose the wanted stride criterion.
+
+2012-08-02  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.h (gfc_conv_descriptor_rank): New prototype.
+	* trans-array.c (gfc_conv_descriptor_rank): New function moved and
+	renamed ...
+	* trans-intrinsic.c (get_rank_from_desc): ... from this one.
+	(gfc_conv_intrinsic_rank, gfc_conv_intrinsic_bound,
+	gfc_conv_associated): Also rename function calls.
+
+2012-08-02  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* iresolve.c (resolve_bound, gfc_resolve_shape):
+	Don't set the shape for assumed rank arrays.
+	* simplify.c (gfc_simplify_shape): Don't try to simplify if the
+	argument is assumed rank.
+
+2012-08-02  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* array.c (gfc_copy_array_ref): Don't copy the offset field.
+	* expr.c (find_array_section): Ignore the offset field.
+	* trans-expr.c (gfc_find_interface_mapping_to_ref): Don't apply
+	any interface mapping to the offset field.
+	* gfortran.h (struct gfc_array_ref): Remove the offset field.
+
+2012-08-02  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/54147
+	* resolve.c (check_proc_interface): New routine for PROCEDURE interface
+	checks.
+	(resolve_procedure_interface,resolve_typebound_procedure,
+	resolve_fl_derived0): Call it.
+
+2012-08-01  Thomas König  <tkoenig@gcc.gnu.org>
+
+	PR fortran/54033
+	* scanner.c (add_path_to_list): Emit warning if an error occurs
+	for an include path, if it is not present or if it is not a
+	directory.  Do not add the path in these cases.
+
+2012-07-31  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42418
+	* decl.c (match_procedure_interface): Move some checks to
+	'resolve_procedure_interface'. Set flavor if appropriate.
+	* expr.c (gfc_check_pointer_assign): Cleanup of 'gfc_is_intrinsic'.
+	* intrinsic.c (gfc_is_intrinsic): Additional checks for attributes which
+	identify a procedure as being non-intrinsic.
+	* resolve.c (resolve_procedure_interface): Checks moved here from
+	'match_procedure_interface'. Minor cleanup.
+	(resolve_formal_arglist,resolve_symbol): Cleanup of
+	'resolve_procedure_interface'
+	(resolve_actual_arglist,is_external_proc): Cleanup of
+	'gfc_is_intrinsic'.
+
+2012-07-31  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/54134
+	* dependency.c (gfc_dep_compare_expr): Check if arguments are NULL.
+
+2012-07-31  Tobias Burnus  <burnus@net-b.de>
+
+	* interface.c (gfc_procedure_use): Return gfc_try instead of void.
+	* gfortran.h (gfc_procedure_use): Update prototype.
+	* resolve.c (gfc_iso_c_func_interface): Allow noninteroperable
+	procedures for c_funloc for TS29113.
+	* (gfc_iso_c_sub_interface): Ditto for c_f_procpointer. Add
+	diagnostic for c_ptr vs. c_funptr for c_f_(proc)pointer.
+
+2012-07-30  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/51081
+	* gfortran.h (gfc_resolve_intrinsic): Add prototype.
+	* expr.c (gfc_check_pointer_assign): Set INTRINSIC attribute if needed.
+	Check for invalid intrinsics.
+	* primary.c (gfc_match_rvalue): Check for intrinsics came too early.
+	Set procedure flavor if appropriate.
+	* resolve.c (resolve_intrinsic): Renamed to gfc_resolve_intrinsic.
+	(resolve_procedure_interface,resolve_procedure_expression,
+	resolve_function,resolve_fl_derived0,resolve_symbol): Ditto.
+
+2012-07-26  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/44354
+	* trans-array.c (gfc_trans_array_constructor_value):
+	Evaluate the iteration bounds before the inner variable shadows
+	the outer.
+
+2012-07-26  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/44354
+	* array.c (sought_symbol): New variable.
+	(expr_is_sought_symbol_ref, find_symbol_in_expr): New functions.
+	(resolve_array_list): Check for references to the induction
+	variable in the iteration bounds and issue a diagnostic if some
+	are found.
+
+2012-07-26  Alessandro Fanfarillo  <fanfarillo.gcc@gmail.com>
+	    Tobias Burnus  <burnus@net-b.de>
+
+	* module.c (mio_array_spec): Don't read as->lower for
+	assumed-rank arrays.
+
+2012-07-25  Tobias Burnus  <burnus@net-b.de>
+
+	* trans-types.c (gfc_real16_is_float128): Fix spelling
+	in a comment.
+	* trans.h (struct gfc_array_info): Ditto.
+	* gfortran.h (gfc_expr): Ditto.
+	* simplify.c (gfc_count): Ditto.
+	* trans-expr.c (gfc_copy_class_to_class,
+	conv_parent_component_references,
+	gfc_trans_pointer_assignment): Ditto.
+	* expr.c (check_pointer_assign): Fix diagnostic spelling.
+	* interface.c (compare_parameter): Ditto.
+	* parse.c (use_modules, parse_associate): Ditto.
+	* decl.c (match_char_length): Fix spelling of the
+	an function argument.
+
+2012-07-21  Tobias Burnus  <burnus@net-b.de>
+
+	* iso-c-binding.def (C_PTRDIFF_T): New TS29113 parameter.
+	* intrinsic.texi (ISO_C_BINDING): Document it.
+
+2012-07-21  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/48820
+	* trans-intrinsic.c (gfc_conv_intrinsic_bound): Support
+	lbound/ubound with dim= for assumed-rank arrays.
+	* array.c (gfc_set_array_spec): Reject coarrays with
+	assumed shape.
+	* decl.c (merge_array_spec): Ditto. Return gfc_try.
+	(match_attr_spec, match_attr_spec): Update call.
+
+2012-07-21  Tobias Burnus  <burnus@net-b.de>
+
+	* resolve.c (resolve_formal_arglist): Put variable
+	declaration before the first assignment.
+
+2012-07-21  Tobias Burnus  <burnus@net-b.de>
+
+	* trans-expr.c (gfc_conv_derived_to_class): Fix argument passed
+	to class_array_data_assign.
+
+2012-07-20  Tobias Burnus  <burnus@net-b.de>
+
+	* decl.c (gfc_verify_c_interop_param): Allow assumed-shape
+	with -std=f2008ts.
+
+2012-07-20  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/48820
+	* array.c (match_array_element_spec, gfc_match_array_spec,
+	spec_size, gfc_array_dimen_size): Add support for
+	assumed-rank arrays.
+	* check.c (dim_rank_check): Ditto.
+	* class.c (gfc_add_component_ref): Ditto.
+	(gfc_build_class_symbol): Regard assumed-rank arrays
+	as having GFC_MAX_DIMENSIONS. And build extra class
+	container for a scalar pointer class.
+	* decl.c (merge_array_spec): Add assert.
+	* dump-parse-tree.c (show_array_spec): Add support for
+	assumed-rank arrays.
+	* expr.c (gfc_is_simply_contiguous): Ditto.
+	* gfortran.h (array_type): Ditto.
+	(gfc_array_spec, gfc_expr): Add comment to "rank" field.
+	* interface.c (compare_type_rank, argument_rank_mismatch,
+	compare_parameter, gfc_procedure_use): Ditto.
+	(compare_actual_formal): Fix NULL() to optional-dummy
+	handling for polymorphic dummies.
+	* module.c (mio_typespec): Add support for
+	assumed-rank arrays.
+	* resolve.c (resolve_formal_arglist, resolve_actual_arglist,
+	resolve_elemental_actual, resolve_global_procedure,
+	expression_shape, resolve_variable, update_ppc_arglist,
+	check_typebound_baseobject, gfc_resolve_expr,
+	resolve_fl_var_and_proc, gfc_resolve_finalizers,
+	resolve_typebound_procedure, resolve_symbol): Ditto.
+	(assumed_type_expr_allowed): Remove static variable.
+	(actual_arg, first_actual_arg): New static variables.
+	* simplify.c (simplify_bound, gfc_simplify_range): Add
+	support for assumed-rank arrays.
+	* trans-array.c (gfc_conv_array_parameter): Ditto.
+	(gfc_get_descriptor_dimension): New function, which returns
+	the descriptor.
+	(gfc_conv_descriptor_dimension): Use it.
+	(gfc_conv_descriptor_stride_get, gfc_conv_array_parameter):
+	Handle GFC_ARRAY_ASSUMED_RANK_CONT and AS_ASSUMED_RANK.
+	* trans-array.h (gfc_get_descriptor_dimension): New prototype.
+	* trans-decl. (gfc_build_dummy_array_decl,
+	gfc_trans_deferred_vars, add_argument_checking): Add
+	support for assumed-rank arrays.
+	* trans-expr.c (gfc_conv_expr_present, gfc_conv_variable,
+	gfc_conv_procedure_call): Ditto.
+	(get_scalar_to_descriptor_type, class_array_data_assign,
+	conv_scalar_to_descriptor): New static functions.
+	(gfc_conv_derived_to_class, gfc_conv_class_to_class): Use
+	them.
+	* trans-intrinsic.c (get_rank_from_desc): New function.
+	(gfc_conv_intrinsic_rank, gfc_conv_associated): Use it.
+	* trans-types.c (gfc_array_descriptor_base_caf,
+	gfc_array_descriptor_base): Make space for scalar array.
+	(gfc_is_nodesc_array, gfc_is_nodesc_array,
+	gfc_build_array_type, gfc_get_array_descriptor_base): Add
+	support for assumed-rank arrays.
+	* trans.h (gfc_array_kind): Add GFC_ARRAY_ASSUMED_RANK and
+	GFC_ARRAY_ASSUMED_RANK_CONT.
+
+2012-07-19  Tobias Burnus  <burnus@net-b.de>
+
+	* trans-expr.c (gfc_conv_procedure_call): Fix handling
+	of polymorphic arguments.
+	* resolve.c (resolve_formal_arglist): Ditto, mark polymorphic
+	assumed-shape arrays as such.
+
+2012-07-19  Tobias Burnus  <burnus@net-b.de>
+
+	* interface.c (compare_parameter, compare_actual_formal): Fix
+	handling of polymorphic arguments.
+
+2012-07-17  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/51081
+	* error.c (gfc_notify_std): Automatically print the relevant Fortran
+	standard version.
+	* arith.c (arith_power): Remove explicit standard reference string.
+	* array.c (gfc_match_array_spec, gfc_match_array_constructor): Ditto.
+	* check.c (gfc_check_a_p, gfc_check_besn, gfc_check_count,
+	gfc_check_float, gfc_check_fn_rc2008, gfc_check_iand,
+	gfc_check_ichar_iachar, gfc_check_ieor, gfc_check_index, gfc_check_ior,
+	gfc_check_lbound, gfc_check_len_lentrim, check_rest, gfc_check_min_max,
+	gfc_check_null, gfc_check_scan, gfc_check_selected_real_kind,
+	gfc_check_shape, gfc_check_size, gfc_check_sngl, gfc_check_ubound,
+	gfc_check_verify): Ditto.
+	* data.c (gfc_assign_data_value): Ditto.
+	* decl.c (var_element, char_len_param_value, match_char_length,
+	gfc_verify_c_interop_param, match_pointer_init, variable_decl,
+	gfc_match_decl_type_spec, gfc_match_import, match_attr_spec,
+	gfc_match_prefix, gfc_match_suffix, match_ppc_decl,
+	match_procedure_in_interface, gfc_match_procedure,gfc_match_entry,
+	gfc_match_subroutine, gfc_match_end, gfc_match_codimension,
+	gfc_match_protected, gfc_match_value, gfc_match_volatile,
+	gfc_match_asynchronous, gfc_match_modproc, gfc_get_type_attr_spec,
+	gfc_match_enum, match_procedure_in_type): Ditto.
+	* expr.c (check_elemental, gfc_check_assign, gfc_check_pointer_assign):
+	Ditto.
+	* interface.c (gfc_match_abstract_interface, check_interface0): Ditto.
+	* intrinsic.c (gfc_intrinsic_func_interface): Ditto.
+	* io.c (format_lex, resolve_tag_format, resolve_tag,
+	compare_to_allowed_values, gfc_match_open, gfc_match_rewind,
+	gfc_resolve_dt, gfc_match_wait): Ditto.
+	* match.c (match_arithmetic_if, gfc_match_if, gfc_match_critical,
+	gfc_match_do, match_exit_cycle, gfc_match_pause, gfc_match_stop,
+	gfc_match_lock, sync_statement, gfc_match_assign, gfc_match_goto,
+	gfc_match_allocate, gfc_match_return, gfc_match_st_function): Ditto.
+	* module.c (gfc_match_use, gfc_use_module): Ditto.
+	* parse.c (parse_derived_contains, parse_block_construct,
+	parse_associate, parse_contained): Ditto.
+	* primary.c (match_hollerith_constant, match_boz_constant,
+	match_real_constant, match_sym_complex_part, match_arg_list_function,
+	build_actual_constructor, gfc_convert_to_structure_constructor): Ditto.
+	* resolve.c (resolve_formal_arglist, resolve_entries,
+	resolve_common_blocks, resolve_actual_arglist, gfc_resolve_index_1,
+	gfc_resolve_iterator_expr, resolve_ordinary_assign,
+	resolve_fl_var_and_proc, resolve_fl_variable_derived,
+	resolve_fl_procedure, resolve_fl_derived0, resolve_fl_derived,
+	resolve_fl_namelist, resolve_symbol, resolve_fntype): Ditto.
+	* symbol.c (check_conflict, conflict, gfc_add_is_bind_c,
+	gfc_add_extension, gfc_check_symbol_typed): Ditto.
+
+2012-07-17  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/53985
+	* decl.c (gfc_verify_c_interop_param): Make warning conditional
+	on -Wc-binding-type works and improve the wording.
+
+2012-07-17  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52101
+	* decl.c (match_char_length): Extra argument, show obsolenscent
+	warning only if *length is used after the typename.
+	(variable_decl, gfc_match_char_spec): Update call
+
+2012-07-17  Tobias Burnus  <burnus@net-b.de>
+	    Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/49265
+	* decl.c (match_procedure_in_interface): Support "::" for
+	Fortran 2008 and later.
+
+2012-07-16  Thomas König  <tkoenig@gcc.gnu.org>
+
+	PR fortran/53824
+	* resolve.c (resolve_allocate_deallocate):  If both
+	start indices are NULL, skip the test for equality.
+
+2012-07-16  Steven Bosscher  <steven@gcc.gnu.org>
+
+	* f95-lang.c: Include dumpfile.h instead of tree-dump.h.
+	* Make-lang.in: Fix dependencies.
+
+2012-07-16  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/53956
+	* gfortran.h (gfc_copy_formal_args,gfc_copy_formal_args_ppc): Modified
+	prototypes.
+	* symbol.c (gfc_copy_formal_args): New argument 'if_src'. Copy if_source
+	of dummy procedures.
+	(gfc_copy_formal_args_ppc): Ditto.
+	* resolve.c (resolve_procedure_interface): Pass IFSRC_DECL to
+	gfc_copy_formal_args.
+	(resolve_fl_derived0): Pass IFSRC_DECL to gfc_copy_formal_args_ppc.
+
+2012-07-12  Tobias Burnus  <burnus@net-b.de>
+
+	* trans-expr.c (conv_isocbinding_procedure): Generate c_f_pointer code
+	inline.
+
+2012-07-11  Steven Bosscher  <steven@gcc.gnu.org>
+
+	* trans.c: Do not include defaults.h.
+	* trans-intrinsic.c: Likewise.
+
+2012-07-08  Steven Bosscher  <steven@gcc.gnu.org>
+
+	* gfortran.h: Do not include coretypes.h here.
+	Make it an error to include this before coretypes.h
+	* openmp.c: Include coretypes.h.
+	* interface.c: Likewise.
+	* intrinsic.c: Likewise.
+	* symbol.c: Likewise.
+	* class.c: Likewise.
+	* decl.c: Likewise.
+	* matchexp.c: Likewise.
+	* dump-parse-tree.c: Likewise.
+	* array.c: Likewise.
+	* constructor.c: Likewise.
+	* error.c: Likewise.
+	* data.c: Likewise.
+	* expr.c: Likewise.
+	* module.c: Likewise.
+	* scanner.c: Likewise.
+	* bbt.c: Likewise.
+	* io.c: Likewise.
+	* frontend-passes.c: Likewise.
+	* resolve.c: Likewise.
+	* st.c: Likewise.
+	* target-memory.c: Likewise.
+	* match.c: Likewise.
+	* arith.c: Likewise.
+	* parse.c: Likewise.
+	* check.c: Likewise.
+	* dependency.c: Likewise.
+	* primary.c: Likewise.
+	* misc.c: Likewise.
+	* simplify.c: Likewise.
+
+2012-07-05  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/53732
+	* trans-array.c (gfc_add_loop_ss_code): Disable self recursive calls
+	handling nested loop(s) if the subscript flag is true.
+
+2012-07-05  Uros Bizjak  <ubizjak@gmail.com>
+
+	PR fortran/53449
+	* parse.c (gfc_parse_file): Initialize errors_before.
+
+2012-06-27  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41951
+	PR fortran/49591
+	* interface.c (check_new_interface): Rename, add 'loc' argument,
+	make non-static.
+	(gfc_add_interface): Rename 'check_new_interface'
+	* gfortran.h (gfc_check_new_interface): Add prototype.
+	* resolve.c (resolve_typebound_intrinsic_op): Add typebound operator
+	targets to non-typebound operator list.
+
+2012-06-22  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47710
+	PR fortran/53328
+	* interface.c (count_types_test, generic_correspondence,
+	gfc_compare_interfaces): Ignore PASS arguments.
+	(check_interface1, compare_parameter): Pass NULL arguments to
+	gfc_compare_interfaces.
+	* gfortran.h (gfc_compare_interfaces): Modified prototype.
+	* expr.c (gfc_check_pointer_assign): Pass NULL arguments to
+	gfc_compare_interfaces.
+	* resolve.c (resolve_structure_cons): Ditto.
+	(check_generic_tbp_ambiguity): Determine PASS arguments and pass them
+	to gfc_compare_interfaces.
+
+2012-06-21  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	PR fortran/39654
+	* iresolve.c (gfc_resolve_ftell): Fix result kind and use new
+	library function.
+
+2012-06-18  Tobias Burnus  <burnus@net-b.de>
+
+	* intrinsic.h (gfc_resolve_rank): New prototype.
+	* intrinsic.c (add_functions): Use gfc_resolve_rank.
+	* iresolve.c (add_functions): New function.
+	* trans-intrinsic.c (gfc_conv_intrinsic_rank): New function.
+	(gfc_conv_intrinsic_function): Call it.
+
+2012-06-18  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/53692
+	* trans-array.c (set_loop_bounds): Don't scalarize via absent
+	optional arrays.
+	* resolve.c (resolve_elemental_actual): Don't stop resolving after printing
+	a warning.
+
+2012-06-18  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/53526
+	* trans-intrinsic.c (conv_intrinsic_move_alloc): Handle coarrays.
+
+2012-06-18  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/53526
+	* check.c (gfc_check_move_alloc): Reject coindexed actual arguments
+	and those with different corank.
+
+2012-06-17  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/53691
+	PR fortran/53685
+	* check.c (gfc_calculate_transfer_sizes): Return if
+	SIZE= is not constant or source-size cannot be determined.
+
+2012-06-16  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/53642
+	PR fortran/45170
+	* frontend-passes.c (optimize_assignment): Don't remove RHS's
+	trim when assigning to a deferred-length string.
+	* trans-expr.c (gfc_trans_assignment_1): Ensure that the RHS string
+	length is evaluated before the deferred-length LHS is reallocated.
+
+2012-06-13  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/53643
+	* trans-decl.c (init_intent_out_dt): Fix for polymorphic arrays.
+	* trans-array.c (structure_alloc_comps): Don't loop for
+	scalar coarrays.
+
+2012-06-13  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/53597
+	* decl.c (match_attr_spec): Only mark module variables
+	as SAVE_IMPLICIT for Fortran 2008 and later.
+
+2012-06-08  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/52552
+	* match.c (gfc_match_allocate): Modify order of checks. Change wording
+	of error message. Remove FIXME note.
+	* resolve.c (resolve_allocate_expr): Add a comment.
+
+2012-06-07  Thomas König  <tkoenig@gcc.gnu.org>
+
+	PR fortran/52861
+	* frontend-passes.c (optimize_assignment):  Don't set the
+	length of an empty string for deferred-length character
+	variables.
+
+2012-06-07  Thomas König  <tkoenig@gcc.gnu.org>
+
+	PR fortran/52861
+	* frontend-passes.c (empty_string):  Add prototype.
+	(optimize_assignment):  Set the length of an empty string
+	constant to zero.
+
+2012-06-04  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/50619
+	* resolve.c (build_default_init_expr): Don't initialize
+	ASSOCIATE names.
+
+2012-06-03  Alessandro Fanfarillo  <fanfarillo.gcc@gmail.com>
+	    Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/48831
+	* gfortran.h (gfc_check_init_expr): Add prototype declaration
+	of function.
+	* check.c (kind_check): Change if condition to use
+	to gfc_check_init_expr.
+	* expr.c (check_init_expr): Remove forward declaration
+	and static keyword. Change name in gfc_check_init_expr.
+	(scalarize_intrinsic_call, check_init_expr_arguments,
+	check_inquiry, check_conversion, gfc_reduce_init_expr): Update
+	call to gfc_check_init_expr.
+
+2012-05-31  Steven Bosscher  <steven@gcc.gnu.org>
+
+	* trans-common.c: Do not include output.h.
+	* trans-decl.c: Likewise.
+
+2012-05-31  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/53521
+	* trans.c (gfc_deallocate_scalar_with_status): Properly
+	handle the case size == 0.
+
+2012-05-30  Tobias Burnus  <burnus@net-b.de>
+
+	PR c/53502
+	* decl.c (match_attr_spec): Remove "typedef".
+
+2012-05-30  Tobias Burnus  <burnus@net-b.de>
+
+	* decl.c: Fix comment typos.
+	* expr.c: Ditto.
+	* frontend-passes.c: Ditto.
+	* match.c: Ditto.
+	* resolve.c: Ditto.
+	* trans-array.c: Ditto.
+	* trans-common.c: Ditto.
+	* trans-intrinsic.c: Ditto.
+	* trans-types.c: Ditto.
+
+2012-05-23  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51055
+	PR fortran/45170
+	* match.c (gfc_match_allocate): Set length_from_typespec
+	for characters.
+	* resolve.c (resolve_charlen): If set, don't check whether
+	the len is a specification expression.
+
+2012-05-22  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/53389
+	* trans-array.c (gfc_add_loop_ss_code): Don't evaluate expression, if
+	ss->is_alloc_lhs is set.
+
+2012-05-22  Dodji Seketeli  <dodji@redhat.com>
+
+	PR c++/53322
+	* f95-lang.c (gfc_init_builtin_functions): Remove the unused
+	typedef builtin_type.
+
+2012-05-14  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	PR fortran/52428
+	* gfortran.texi: Update _gfortran_set_options documentation.
+	* invoke.texi: Remove runtime behavior description of
+	-fno-range-check.
+	* trans-decl.c (create_main_function): Don't pass the range-check
+	setting to the library.
+
+2012-05-14  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/49110
+	PR fortran/51055
+	PR fortran/53329
+	* trans-expr.c (gfc_trans_assignment_1): Fix allocation
+	handling for assignment of function results to allocatable
+	deferred-length strings.
+	* trans-decl.c (gfc_create_string_length): For deferred-length
+	module variables, include module name in the assembler name.
+	(gfc_get_symbol_decl): Don't override the assembler name.
+
+2012-05-14  Manuel López-Ibáñez  <manu@gcc.gnu.org>
+
+	PR 53063
+	* options.c (gfc_handle_option): Call lang-specific generated function.
+
+2012-05-13  Alessandro Fanfarillo  <fanfarillo.gcc@gmail.com>
+	    Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52158
+	PR fortran/45170
+	PR fortran/49430
+	* resolve.c (resolve_fl_derived0): Deferred character length
+	procedure components are supported.
+	* trans-expr.c (gfc_conv_procedure_call): Handle TBP with
+	deferred-length results.
+	(gfc_string_to_single_character): Add a new check to prevent
+	NULL read.
+	(gfc_conv_procedure_call): Remove unuseful checks on
+	symbol's attributes. Add new checks to prevent NULL read on
+	string length.
+
+2012-05-12  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/49110
+	PR fortran/52843
+	* resolve.c (resolve_fl_procedure): Don't regard
+	character(len=:) as character(*) in the diagnostic.
+
+2012-05-11  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/52537
+	* frontend-passes.c (optimize_op):  Change
+	old-style comparison operators to new-style, simplify
+	switch as a result.
+	(empty_string):  New function.
+	(get_len_trim_call):  New function.
+	(optimize_comparison):  If comparing to an empty string,
+	use comparison of len_trim to zero.
+	Use new-style comparison operators only.
+	(optimize_trim):  Use get_len_trim_call.
+
+2012-05-11  Manuel López-Ibáñez  <manu@gcc.gnu.org>
+
+	PR 53063
+	* options.c: Include diagnostics.h instead of
+	diagnostics-core.h.
+	(set_Wall): Do not see warn_unused here.
+	(gfc_handle_option): Set it here using handle_generated_option.
+
+2012-05-08  Jan Hubicka  <jh@suse.cz>
+
+	* trans-common.c (create_common): Do not fake TREE_ASM_WRITTEN.
+	* trans-decl.c (gfc_finish_cray_pointee): Likewise.
+
+2012-05-07  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/53255
+	* resolve.c (resolve_typebound_static): Fix handling
+	of overridden specific to generic operator.
+
+2012-05-06  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/41587
+	* decl.c (build_struct): Don't ignore FAILED status.
+
+2012-05-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/41600
+	* trans-array.c (build_array_ref): New static function.
+	(gfc_conv_array_ref, gfc_get_dataptr_offset): Call it.
+	* trans-expr.c (gfc_get_vptr_from_expr): New function.
+	(gfc_conv_derived_to_class): Add a new argument for a caller
+	supplied vptr and use it if it is not NULL.
+	(gfc_conv_procedure_call): Add NULL to call to above.
+	symbol.c (gfc_is_associate_pointer): Return true if symbol is
+	a class object.
+	* trans-stmt.c (trans_associate_var): Handle class associate-
+	names.
+	* expr.c (gfc_get_variable_expr): Supply the array-spec if
+	possible.
+	* trans-types.c (gfc_typenode_for_spec): Set GFC_CLASS_TYPE_P
+	for class types.
+	* trans.h : Add prototypes for gfc_get_vptr_from_expr and
+	gfc_conv_derived_to_class. Define GFC_CLASS_TYPE_P.
+	* resolve.c (resolve_variable): For class arrays, ensure that
+	the target expression has all the necessary _data references.
+	(resolve_assoc_var): Throw a "not yet implemented" error for
+	class array selectors that need a temporary.
+	* match.c (copy_ts_from_selector_to_associate,
+	select_derived_set_tmp, select_class_set_tmp): New functions.
+	(select_type_set_tmp): Call one of last two new functions.
+	(gfc_match_select_type): Copy_ts_from_selector_to_associate is
+	called if associate-name is typed.
+
+	PR fortran/53191
+	* resolve.c (resolve_ref): C614 applied to class expressions.
+
+2012-05-05  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	PR fortran/49010
+	PR fortran/24518
+	* intrinsic.texi (MOD, MODULO): Mention sign and magnitude of result.
+	* simplify.c (gfc_simplify_mod): Use mpfr_fmod.
+	(gfc_simplify_modulo): Likewise, use copysign to fix the result if
+	zero.
+	* trans-intrinsic.c (gfc_conv_intrinsic_mod): Remove fallback as
+	builtin_fmod is always available. For modulo, call copysign to fix
+	the result when signed zeros are enabled.
+
+2012-05-05  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	* gfortran.texi (GFORTRAN_TMPDIR): Rename to TMPDIR, explain
+	algorithm for choosing temp directory.
+
+2012-05-04  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/53175
+	* resolve.c (resolve_variable): Set public_used
+	if a private module variable is used in a (public)
+	specification expression.
+	* trans-decl.c (gfc_finish_var_decl): Mark those
+	TREE_PUBLIC.
+
+2012-05-04  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/53111
+	* resolve.c (resolve_fl_derived): Fix -std=f95
+	diagnostic for generic vs. DT names.
+
+2012-05-03  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52864
+	* interface.c (compare_parameter_intent): Remove.
+	(check_intents): Remove call, handle CLASS pointer.
+	(compare_actual_formal): Handle CLASS pointer.
+
+2012-04-30  Jan Hubicka  <jh@suse.cz>
+
+	* f95-lang.c (gfc_finish): Update comments.
+
+2012-04-29  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/53148
+	* frontend-passes.c (create_var):  If the statement has a label,
+	put the label around the block.
+
+2012-04-25  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52196
+	* lang.opt (Wrealloc-lhs, Wrealloc-lhs-all): New flags.
+	* gfortran.h (gfc_option_t): Add them.
+	* options.c (gfc_init_options, gfc_post_options,
+	gfc_handle_option): Handle them.
+	* invoke.texi: Document them.
+	* trans-expr.c (realloc_lhs_warning): New function.
+	(gfc_trans_arrayfunc_assign,
+	alloc_scalar_allocatable_for_assignment,
+	gfc_trans_assignment_1): Use it.
+
+2012-04-18  Steven Bosscher  <steven@gcc.gnu.org>
+
+	* trans-decl.c (gfc_trans_entry_master_switch): Build SWITCH_EXPR
+	with NULL_TREE type instead of void_type_node.
+	* trans-io.c (io_result): Likewise.
+	* trans-stmt.c (gfc_trans_integer_select,
+	gfc_trans_character_select): Likewise.
+
+2012-04-16  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52864
+	* expr.c (gfc_check_vardef_context): Fix assignment check for
+	pointer components.
+
+2012-04-16  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/52968
+	* class.c (gfc_build_class_symbol): Make sure the 'f2k_derived'
+	namespace is present.
+
+2012-04-15  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/51082
+	* trans-expr.c (gfc_conv_expr_reference): Check if the expression is a
+	simple function call (or a more involved PPC reference).
+
+2012-04-15  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52916
+	PR fortran/40973
+	* gfortran.h (symbol_attribute): Add public_used.
+	* interface.c (check_sym_interfaces, check_uop_interfaces,
+	gfc_check_interfaces): Set it.
+	* resolve.c (resolve_typebound_procedure): Ditto.
+	* trans-decl.c (build_function_decl): Use it.
+
+2012-04-11  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52729
+	* resolve.c (resolve_symbol): Fix searching for parent NS decl.
+
+2012-04-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52751
+	* trans-decl.c (gfc_finish_var_decl): Don't set TREE_PUBLIC
+	for PRIVATE module variables without C-binding label.
+
+	PR fortran/40973
+	* trans-decl.c (build_function_decl): Ditto for procedures.
+
+2012-04-07  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/52893
+	* frontend-passes.c:  Keep track of wether we are in an implicit
+	DO loop; do not do function elimination if we are.
+
+2012-04-06  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/52668
+	* module.c:  Only mark symbols as use_only if they have been
+	imported via an only list.
+
+2012-03-28  Paul Thomas  <pault@gcc.gnu.org>
+	Tobias Burnus  <burnus@gcc.gnu.org>
+
+	PR fortran/52652
+	* match.c (gfc_match_allocate, gfc_match_deallocate): Change
+	"not.. or" to "neither.. nor".
+	* parse.c (decode_specification_statement): Correct error in
+	chpice of matching function for "allocatable".
+
+2012-03-23  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	* gfortran.h (GFC_MAX_LINE): Remove unused macro.
+
+2012-03-19  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/52559
+	* error.c (gfc_widechar_display_length): Consider tabs as
+	one character wide, as they're displayed as spaces.
+	(show_locus): Move tab handling to...
+	(print_wide_char_into_buffer): ... here.
+
+2012-03-17  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52585
+	* trans-intrinsic.c (gfc_conv_associated): Fix handling of
+	procpointer dummy arguments.
+
+2012-03-16  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	* trans-intrinsic.c (build_round_expr): Don't use BUILT_IN_IROUND
+	for __float128.
+
+2012-03-15  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	* f95-lang.c (gfc_init_builtin_functions): Initialize
+	BUILT_IN_IROUND.
+	* mathbuiltins.def: Add IROUND.
+	* trans-intrinsic.c (build_round_expr): Use BUILT_IN_IROUND if
+	type size matches.
+	(gfc_build_intrinsic_lib_fndecls): Build iround functions.
+
+2012-03-12  Richard Guenther  <rguenther@suse.de>
+
+	* f95-lang.c (builtin_type_for_size): Use gfc_type_for_size.
+
+2012-03-12  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52542
+	* decl.c (match_procedure_decl): If the interface
+	is bind(C), the procedure is as well.
+
+2012-03-10  Steven Bosscher  <steven@gcc.gnu.org>
+
+	* convert.c (convert): Fold BOOLEAN_TYPE types to the proper variant.
+
+2012-03-09  Steven Bosscher  <steven@gcc.gnu.org>
+
+	* Make-lang.in (convert.o): Depend on convert.h.
+	* convert.c: Header and comment cleanups.
+	(gfc_thruthvalue_conversion): Rename static function
+	to truthvalue_conversion.  Do not use 'internal_error' from here,
+	use 'gcc_unreachable' instead.
+	(convert): Do not use 'error' for conversions to void, use
+	'gcc_unreachable' instead.  Likewise for conversions to non-scalar
+	types.  Do not hanlde ENUMERAL_TYPE, the front end never creates them.
+	Clean up #if 0 code.
+
+2012-03-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52469
+	* trans-types.c (gfc_get_function_type): Handle backend_decl
+	of a procedure pointer.
+
+2012-03-06  Steven Bosscher  <steven@gcc.gnu.org>
+
+	* f95-lang.c (yyerror, yylex): Remove.
+	(clear_binding_stack): Remove, fold into its only user.
+	(LANG_HOOKS_PRINT_IDENTIFIER): Do not re-define.
+	(ridpointers): Remove.
+	(gfc_eh_initialized_p): Make static.
+	(gfc_truthvalue_conversion): Move to convert.c.
+	(gfc_be_parse_file): Clear binding level stack when done.
+	(gfc_print_identifier): Remove.
+	(pushlevel): Remove ignored 'ignore' argument.  Update all callers.
+	(poplevel): Remove unused 'reverse' argument.  Update all callers.
+	(ggc_p): Remove.
+	(gfc_builtin_function): Make static. Do not attempt to make RTL for
+	builtin functions.
+	* convert.c (gfc_truthvalue_conversion): Moved here from f95-lang.c,
+	and made static.
+	* trans.h (pushlevel, poplevel): Adjust prototypes.
+	(gfc_truthvalue_conversion, gfc_builtin_function): Remove prototypes.
+	* trans-openmp.c: Update calls to pushlevel and poplevel.
+	* trans.c: Likewise.
+	* trans-decl.c: Likewise.
+
+2012-03-04  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/50981
+	* gfortran.h (gfc_is_class_container_ref): New prototype.
+	* class.c (gfc_is_class_container_ref): New function.
+	* trans-expr.c (gfc_conv_procedure_call): Add a "_data" component
+	reference to polymorphic actual arguments.
+
+2012-03-04  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/50981
+	* trans-expr.c (gfc_conv_procedure_call): Save se->ss's value.
+	Handle the case of unallocated arrays passed to elemental procedures.
+
+2012-03-04  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans.h (struct gfc_ss_info): Move can_be_null_ref component from
+	the data::scalar subcomponent to the toplevel.
+	* trans-expr.c (gfc_conv_expr): Update component reference.
+	* trans-array.c (gfc_add_loop_ss_code): Ditto.
+	(gfc_walk_elemental_function_args): Ditto.  Move the conditional setting
+	the field out of the scalar-only block.
+
+2012-03-04  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/36160
+	* error.c (gfc_widechar_display_length, gfc_wide_display_length):
+	New functions.
+	(print_wide_char_into_buffer): Return length written.
+	(show_locus): Fix locus displayed when wide characters are present.
+
+2012-03-04  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* module.c (gfc_use_module): Improve error message some more.
+
+2012-03-03  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/52313
+	* module.c (gfc_use_module): Improve error messages.
+
+2012-03-03  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/48820
+	* resolve.c (resolve_actual_arglist): Properly reset
+	assumed_type_expr_allowed.
+
+2012-03-03  Tobias Burnus  <burnus@net-b.de>
+
+	* lang.opt (Wc-binding-type): New flag.
+	* options.c (gfc_init_options, gfc_handle_option): Handle it.
+	* invoke.texi (Wc-binding-type): Document it.
+	* gfortran.h (gfc_option_t): Add warn_c_binding_type.
+	* decl.c (verify_bind_c_sym): Handle -Wc-binding-type.
+	* symbol.c (gfc_set_default_type, verify_bind_c_derived_type):
+	Ditto.
+
+2012-03-03  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/48820
+	* decl.c (gfc_match_decl_type_spec): Support type(*).
+	(gfc_verify_c_interop): Allow type(*).
+	* dump-parse-tree.c (show_typespec): Handle type(*).
+	* expr.c (gfc_copy_expr): Ditto.
+	* interface.c (compare_type_rank, compare_parameter,
+	compare_actual_formal, gfc_procedure_use): Ditto.
+	* libgfortran.h (bt): Add BT_ASSUMED.
+	* misc.c (gfc_basic_typename, gfc_typename): Handle type(*).
+	* module.c (bt_types): Ditto.
+	* resolve.c (assumed_type_expr_allowed): New static variable.
+	(resolve_actual_arglist, resolve_variable, resolve_symbol):
+	Handle type(*).
+	* trans-expr.c (gfc_conv_procedure_call): Ditto.
+	* trans-types.c (gfc_typenode_for_spec, gfc_get_dtype): Ditto.
+
+2012-03-02  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52325
+	* primary.c (gfc_match_varspec): Add missing ;.
+
+2012-03-02  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52325
+	* primary.c (gfc_match_varspec): Add diagnostic for % with
+	nonderived types.
+
+2012-03-02  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52270
+	* expr.c (gfc_check_vardef_context): Fix check for
+	intent-in polymorphic pointer .
+	* interface.c (compare_parameter): Allow passing TYPE to
+	intent-in polymorphic pointer.
+
+2012-03-02  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52452
+	* resolve.c (resolve_intrinsic): Don't search for a
+	function if we know that it is a subroutine.
+
+2012-02-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/52386
+	* trans-expr.c (fcncall_realloc_result): Dereference the
+	descriptor if needed.
+
+2012-02-22  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52335
+	* io.c (gfc_match_open): Remove bogus F2003 DELIM= check.
+
+2012-02-18  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52295
+	* interface.c (check_interface0): Internal procs in
+	generic interfaces are allowed in Fortran 2008.
+
+2012-02-17  Tobias Burnus  <burnus@net-b.de>
+	    Roland Stigge  <stigge@antcom.de>
+
+	PR translation/52273
+	* interface.c (compare_actual_formal): Fix typo "at at".
+
+2012-02-17  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.texi (Q exponent-letter): Fix grammar.
+
+2012-02-17  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.texi (Status): Fix typos.
+	* invoke.texi (ffixed-form, fstack-arrays): Spell Fortran with
+	a majuscule.
+
+2012-02-17  Tobias Burnus  <burnus@net-b.de>
+	    Roland Stigge  <stigge@antcom.de>
+
+	PR translation/52232
+	PR translation/52234
+	PR translation/52245
+	PR translation/52246
+	PR translation/52262
+	PR translation/52273
+	* io.c (gfc_match_open): Fix typo.
+	* interface.c (compare_actual_formal): Ditto.
+	* lang.opt (freal-4-real-8, freal-4-real-16, freal-8-real-16): Ditto.
+	* match.c (alloc_opt_list, gfc_match_nullify): Ditto.
+	* check.c (gfc_check_associated, gfc_check_null): Ditto.
+
+2012-02-12  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/50981
+	* trans-stmt.c (gfc_get_proc_ifc_for_call): New function.
+	(gfc_trans_call): Use gfc_get_proc_ifc_for_call.
+
+2012-02-12  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_walk_elemental_function_args,
+	gfc_walk_function_expr): Move call to gfc_get_proc_ifc_for_expr out
+	of gfc_walk_elemental_function_args.
+	* trans-stmt.c (gfc_trans_call): Ditto.
+	* trans-array.h (gfc_get_proc_ifc_for_expr): New prototype.
+	(gfc_walk_elemental_function_args): Update prototype.
+
+2012-02-12  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_get_proc_ifc_for_expr): New function.
+	(gfc_walk_elemental_function_args): Move code to
+	gfc_get_proc_ifc_for_expr and call it.
+
+2012-02-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52151
+	* trans-expr.c (fcncall_realloc_result): Set also the stride.
+
+2012-02-07  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51514
+	* trans-expr.c (gfc_conv_procedure_call): Add _data component
+	for calls of scalar CLASS actuals to TYPE dummies.
+
+2012-02-05  Thomas König  <tkoenig@gcc.gnu.org>
+
+	PR fortran/48847
+	* trans-decl.c:  Warn about unused dummy procedure arguments
+	if -Wunused-dummy-argument is specified.  Suppress middle-end
+	warnings about procedure arguments.
+
+2012-02-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	* trans-array.c (gfc_array_allocate): Zero memory for all class
+	array allocations.
+	* trans-stmt.c (gfc_trans_allocate): Ditto for class scalars.
+
+	PR fortran/52102
+	* trans-stmt.c (gfc_trans_allocate): Before correcting a class
+	array reference, ensure that 'dataref' points to the _data
+	component that is followed by the array reference..
+
+2012-02-02  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/41587
+	PR fortran/46356
+	PR fortran/51754
+	PR fortran/50981
+	* class.c (insert_component_ref, class_data_ref_missing,
+	gfc_fix_class_refs): New functions.
+	* gfortran.h (gfc_fix_class_refs): New prototype.
+	* trans-expr.c (gfc_conv_expr): Remove special case handling and call
+	gfc_fix_class_refs instead.
+
+2012-02-02  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/52012
+	* trans-expr.c (fcncall_realloc_result): If variable shape is
+	correct, retain the bounds, whatever they are.
+
+2012-02-02  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52093
+	* simplify.c (gfc_simplify_size): Handle INTRINSIC_PARENTHESES.
+
+2012-02-01  Thomas König  <tkoenig@gcc.gnu.org>
+
+	PR fortran/51958
+	* frontend-passes.c (convert_elseif):  New function.
+	(optimize_namespace):  Call it.
+
+2012-02-01  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52024
+	* module.c (MOD_VERSION): Bump.
+	(mio_typebound_proc): Read/write is_operator from/to the
+	.mod file.
+
+2012-02-01  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52059
+	* trans-expr.c (gfc_conv_procedure_call): Add array ref
+	only to variables.
+
+2012-01-31  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52024
+	* gfortran.h (gfc_tbp_generic): Store whether the
+	generic is an operator.
+	* decl.c (gfc_match_generic): Set that flag.
+	* resolve.c (check_generic_tbp_ambiguity): Use it in the
+	gfc_compare_interfaces check.
+
+2012-01-31  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52029
+	* class.c (gfc_find_derived_vtab): Mark _copy function as pure.
+
+2012-01-31  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52013
+	* class.c (get_unique_hashed_string): Adapt trim length.
+	(gfc_build_class_symbol) Encode also corank in the container name.
+
+2012-01-31  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/52012
+	* trans-expr.c (fcncall_realloc_result): Correct calculation of
+	result offset.
+
+2012-01-29  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	* module.c (pointer_info): Make true_name and module pointers
+	rather than arrays, order pointers before other fields.
+	(free_pi_tree): free true_name and module as well.
+	(mio_read_string): Rename to read_string.
+	(mio_write_string): Remove.
+	(load_commons): Use read_string.
+	(read_module): Use read_string rather than mio_internal_string.
+	(write_blank_common): Call write_atom directly.
+	(write_symbol): Likewise.
+
+2012-01-29  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/41600
+	* expr.c (gfc_default_initializer): Convert the values if
+	the type does not match.
+
+2012-01-29  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51972
+	* trans-array.c (structure_alloc_comps): Fix assignment of
+	polymorphic components (polymorphic deep copying).
+
+2012-01-29  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	PR fortran/51808
+	* decl.c (set_binding_label): Make binding_label argument const.
+	(curr_binding_label): Constify.
+	* gfortran.h (gfc_symbol): Constify binding_label.
+	(gfc_common_head): Likewise.
+	(get_iso_c_sym): Likewise.
+	* match.c (gfc_match_name_C): Constify buffer argument.
+	* match.h (gfc_match_name_C): Likewise.
+	* resolve.c (set_name_and_label): Constify binding_label argument.
+	(gfc_iso_c_sub_interface): Constify binding_label variable.
+	* symbol.c (get_iso_c_sym): Constify binding_label argument.
+
+2012-01-29  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	PR fortran/51808
+	* decl.c (set_binding_label): Move prototype from match.h to here.
+	(curr_binding_label): Make a pointer rather than static array.
+	(build_sym): Check sym->binding_label pointer rather than array,
+	update set_binding_label call, handle curr_binding_label changes.
+	(set_binding_label): Handle new curr_binding_label, dest_label
+	double ptr, and sym->binding_label.
+	(verify_bind_c_sym): Handle sym->binding_label being a pointer.
+	(set_verify_bind_c_sym): Check sym->binding_label pointer rather
+	than array, update set_binding_label call.
+	(gfc_match_bind_c_stmt): Handle curr_binding_label change.
+	(match_procedure_decl): Update set_binding_label call.
+	(gfc_match_bind_c): Change binding_label to pointer, update
+	gfc_match_name_C call.
+	* gfortran.h (GFC_MAX_BINDING_LABEL_LEN): Remove macro.
+	(gfc_symbol): Make binding_label a pointer.
+	(gfc_common_head): Likewise.
+	* match.c (gfc_match_name_C): Heap allocate bind(C) name.
+	* match.h (gfc_match_name_C): Change prototype argument.
+	(set_binding_label): Move prototype to decl.c.
+	* module.c (struct pointer_info): Make binding_label a pointer.
+	(free_pi_tree): Free unused binding_label.
+	(mio_read_string): New function.
+	(mio_write_string): New function.
+	(load_commons): Redo reading of binding_label.
+	(read_module): Likewise.
+	(write_common_0): Change to write empty string instead of name if
+	no binding_label.
+	(write_blank_common): Write empty string for binding label.
+	(write_symbol): Change to write empty string instead of name if no
+	binding_label.
+	* resolve.c (gfc_iso_c_func_interface): Don't set binding_label.
+	(set_name_and_label): Make binding_label double pointer, use
+	asprintf.
+	(gfc_iso_c_sub_interface): Make binding_label a pointer.
+	(resolve_bind_c_comms): Handle cases if
+	gfc_common_head->binding_label is NULL.
+	(gfc_verify_binding_labels): sym->binding_label is a pointer.
+	* symbol.c (gfc_new_symbol): Rely on XCNEW zero init for
+	binding_label.
+	(gen_special_c_interop_ptr): Don't set binding label.
+	(generate_isocbinding_symbol): Insert binding_label into symbol
+	table.
+	(get_iso_c_sym): Use pointer assignment instead of strcpy.
+	* trans-common.c (gfc_sym_mangled_common_id): Handle
+	com->binding_label being a pointer.
+	* trans-decl.c (gfc_sym_mangled_identifier): Handle
+	sym->binding_label being a pointer.
+	(gfc_sym_mangled_function_id): Likewise.
+
+2012-01-29  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52038
+	* resolve.c (symbol_as): Remove unused, accidentally
+	added function.
+
+2012-01-28  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51972
+	* trans-stmt.c (gfc_trans_allocate): Properly check whether
+	we have a BT_CLASS which needs to be memset.
+
+2012-01-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52022
+	* trans-expr.c (gfc_conv_procedure_call): Fix passing
+	of functions, which return allocatables.
+
+2012-01-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52016
+	* resolve.c (resolve_formal_arglist): Fix elemental
+	constraint checks for polymorphic dummies also for
+	pointers.
+
+2012-01-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51970
+	PR fortran/51977
+	* primary.c (gfc_match_varspec. gfc_match_rvalue): Set
+	handle array spec for BT_CLASS.
+	* expr.c (gfc_get_variable_expr, gfc_lval_expr_from_sym)
+	* frontend-passes.c (create_var): Ditto.
+	* resolve.c (resolve_actual_arglist, resolve_assoc_var): Ditto.
+	* trans-decl.c (gfc_trans_deferred_vars): Use class_pointer
+	instead of attr.pointer.
+	(gfc_generate_function_code): Use CLASS_DATA (sym) for BT_CLASS.
+	* trans-intrinsic.c (conv_intrinsic_move_alloc): Move assert.
+	* trans-stmt.c (trans_associate_var): Ask for the descriptor.
+
+2012-01-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51953
+	* match.c (gfc_match_allocate): Allow more than allocate
+	object with SOURCE=.
+
+2012-01-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52016
+	* resolve.c (resolve_formal_arglist): Fix elemental
+	constraint checks for polymorphic dummies.
+
+2012-01-27  Paul Thomas  <pault@gcc.gnu.org>
+	    Tobias Burnus <burnus@gcc.gnu.org>
+
+	PR fortran/48705
+	PR fortran/51870
+	PR fortran/51943
+	PR fortran/51946
+	* trans-array.c (gfc_array_init_size): Add two extra arguments
+	to convey the dynamic element size of a calls object and to
+	return the number of elements that have been allocated.
+	(gfc_array_allocate): Add the same arguments and use them to
+	call gfc_array_init_size.  Before the allocation dereference
+	the data pointer, if necessary. Set the allocated array to zero
+	if the class element size or expr3 are non-null.
+	* trans-expr.c (gfc_conv_class_to_class): Give this function
+	global scope.
+	(get_class_array_ref): New function.
+	(gfc_copy_class_to_class): New function.
+	* trans-array.h : Update prototype for gfc_array_allocate.
+	* trans-stmt.c (gfc_trans_allocate): For non-variable class
+	STATUS expressions extract the class object and the dynamic
+	element size. Use the latter to call gfc_array_allocate and
+	the former for setting the vptr and, via
+	gfc_copy_class_to_clasfc_cs, to copy to the allocated data.
+	* trans.h : Prototypes for gfc_get_class_array_ref,
+	gfc_copy_class_to_class and gfc_conv_class_to_class.
+
+2012-01-25  Tobias Burnus  <burnus@net-b.de>
+
+	* resolve.c (symbol_as): Check also for attr.class_ok.
+
+2012-01-25  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51995
+	* class.c (gfc_build_class_symbol): Fix invalid freeing
+	issue with fclass->f2k_derived.
+
+2012-01-25  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51995
+	* class.c (gfc_build_class_symbol): Ensure that
+	fclass->f2k_derived is set.
+
+2012-01-25  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51966
+	* resolve.c (resolve_structure_cons): Only create an
+	array constructors for nonscalars.
+
+2012-01-23  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51948
+	* check.c (variable_check): Fix checking for
+	 variables and deeply nested BLOCKs.
+
+2012-01-21  Tobias Burnus  <burnus@net-b.de>
+	    Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/50556
+	* symbol.c (check_conflict): namelist-group-name cannot have the SAVE
+	attribute.
+
+2012-01-21  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51913
+	* interface.c (compare_parameter): Fix CLASS comparison.
+
+2012-01-20  Tobias Burnus  <burnus@net-b.de>
+	    Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/51056
+	* module.c (load_needed, read_module): Don't mark __vtab etc.
+	as use_only.
+
+2012-01-19  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51904
+	* expr.c (gfc_build_intrinsic_call): Also set the symtree.
+
+2012-01-18  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/51634
+	* trans-expr.c (gfc_conv_procedure_call): Deallocate allocatable
+	components of temporary class arguments.
+
+2012-01-17  Tobias Burnus  <burnus@net-b.de>
+	    Janne Blomqvist  <jb@gcc.gnu.org>
+
+	PR fortran/51869
+	* trans-expr.c (alloc_scalar_allocatable_for_assignment): Nullify
+	LHS after allocation, if it has allocatable components.
+	* f95-lang.c (gfc_init_builtin_functions): Add BUILT_IN_CALLOC.
+
+2012-01-16  Mikael Morin  <mikael@gcc.gnu.org>
+	    Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/50981
+	* trans-array.c (gfc_walk_elemental_function_args): Fix
+	passing of deallocated allocatables/pointers as absent argument.
+
+2012-01-16  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51809
+	* class.c (gfc_find_derived_vtab): Mark __vtab and
+	__def_init as FL_VARIABLE not as FL_PARAMETER.
+	* expr.c (gfc_simplify_expr): Remove special
+	handling of __vtab.
+	* resolve.c (resolve_values): Ditto.
+	* trans-decl.c (gfc_get_symbol_decl): Mark __vtab
+	and __def_init as TREE_READONLY.
+
+2012-01-16  Zydrunas Gimbutas  <gimbutas@cims.nyu.edu>
+	Andreas Kloeckner  <kloeckner@cims.nyu.edu>
+	Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/48426
+	* gfortran.h (gfc_option_t): Add members flag_*_kind to store kind.
+	* lang.opt: Add options -freal-4-real-8, -freal-4-real-10,
+	-freal-4-real-16, -freal-8-real-4, -freal-8-real-10, -freal-8-real-16
+	and -finteger-4-integer-8. User-desired type conversion information.
+	* decl.c (gfc_match_old_kind_spec,kind_expr): Type conversions
+	in declaration parsing.
+	* trans-types.c (gfc_init_kinds): User-specified type conversion
+	checked for current backend.
+	* primary.c (match_integer_constant,match_real_constant): Implement
+	type conversion in constant parsing.
+	* options.c (gfc_init_options,gfc_handle_option): Translate input
+	options to flags in internal options data structure.
+	* invoke.texi: Document new options.  Re-order options in Options
+	summary section.
+
+2012-01-16  Paul Thomas  <pault@gcc.gnu.org>
+
+	* trans-array.c (gfc_trans_create_temp_array): In the case of a
+	class array temporary, detect a null 'eltype' on entry and use
+	'initial' to provde the class reference and so, through the
+	vtable, the element size for the dynamic type.
+	* trans-stmt.c (gfc_conv_elemental_dependencies): For class
+	expressions, set 'eltype' to null and pass the values via the
+	'initial' expression.
+
+2012-01-14  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51800
+	* resolve.c (build_default_init_expr): Also initialize
+	nonconstant-length strings with -finit-character=<n>.
+
+2011-01-14  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51816
+	* module.c (read_module): Don't make nonexisting
+	intrinsic operators as found.
+	(rename_list_remove_duplicate): New function.
+	(gfc_use_modules): Use it.
+
+2012-01-13  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/48351
+	* trans-array.c (structure_alloc_comps): Suppress interative
+	call to self, when current component is deallocated using
+	gfc_trans_dealloc_allocated.
+	* class.c (gfc_build_class_symbol): Copy the 'alloc_comp'
+	attribute from the declared type to the class structure.
+
+2012-01-13  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51842
+	* fortran/trans-types.c (gfc_init_kinds): Use PTRDIFF_TYPE
+	instead of a signed int of size POINTER_SIZE for
+	gfc_index_integer_kind.
+
+2012-01-12  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/36755
+	* intrinsic.texi (CHMOD): Extend a bit and remove statement
+	that /bin/chmod is called.
+
+2012-01-10  Gerald Pfeifer  <gerald@pfeifer.com>
+
+	* gfortran.texi (Fortran 2003 Status): Fix grammar.
+
+2012-01-10  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51652
+	* resolve.c (resolve_allocate_expr): For non-deferred char lengths,
+	check whether type-spec matches declaration.
+
+2012-01-10  Tobias Burnus  <burnus@net-b.de>
+
+	* resolve.c (resolve_ordinary_assign): Improve error wording.
+
+2012-01-09  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/51791
+	* interface.c (matching_typebound_op): Drill down through
+	possible parentheses to obtain base expression. Do not test for
+	'class_ok' but, instead for the class structure components.
+	* resolve.c (resolve_ordinary_assign): Extend error message for
+	polymorphic assignment to advise checking for specific
+	subroutine.
+
+	PR fortran/51792
+	* resolve.c (resolve_typebound_function): Restore 'static' to
+	declaration.
+
+2012-01-09  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/51758
+	* trans-array.c (gfc_walk_elemental_function_args):
+	Skip over NULL() actual arguments.
+
+2012-01-09  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.texi: Bump copyright year.
+	(Fortran 2003 Status): Update polymorphism item, add
+	item for generic interface with DT name.
+
+2012-01-09  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51578
+	* gfortran.h (gfc_use_list):
+	* match.h (gfc_use_module): Rename to ...
+	(gfc_use_modules): ... this.
+	* module.c (use_locus, specified_nonint, specified_int): Remove
+	global variable.
+	(module_name): Change type to const char*, used with gfc_get_string.
+	(module_list): New global variable.
+	(free_rename): Free argument not global var.
+	(gfc_match_use): Save match to module_list.
+	(load_generic_interfaces, read_module): Don't free symtree.
+	(write_dt_extensions, gfc_dump_module): Fix module-name I/O due to the
+	type change of module_name.
+	(write_symbol0, write_generic): Optimize due to the type change.
+	(import_iso_c_binding_module, use_iso_fortran_env_module): Use
+	locus of rename->where.
+	(gfc_use_module): Take module_list as argument.
+	(gfc_use_modules): New function.
+	(gfc_module_init_2, gfc_module_done_2): Init module_list, rename_list.
+	* parse.c (last_was_use_stmt): New global variable.
+	(use_modules): New function.
+	(decode_specification_statement, decode_statement): Move USE match up
+	and call use_modules.
+	(next_free, next_fixed): Call use_modules.
+	(accept_statement): Don't call gfc_module_use.
+
+2012-01-06  Tobias Burnus <burnus@net-b.de>
+
+	* trans-openmp.c (gfc_omp_clause_dtor, gfc_trans_omp_array_reduction):
+	Update call to gfc_trans_dealloc_allocated.
+	* trans.c (gfc_allocate_using_malloc): Fix spacing.
+	(gfc_allocate_allocatable): For gfc_allocate_using_lib, jump to
+	label_finish when an error occurs.
+	(gfc_deallocate_with_status): Call caf_deregister for -fcoarray=lib.
+	* trans.h (gfc_allocate_allocatable, gfc_deallocate_with_status):
+	Update prototype.
+	(gfor_fndecl_caf_deregister): New tree symbol.
+	* trans-expr.c (gfc_conv_procedure_call): Update
+	gfc_deallocate_with_status and gfc_trans_dealloc_allocated calls.
+	* trans-array.c (gfc_array_allocate, gfc_trans_dealloc_allocated,
+	structure_alloc_comps, gfc_trans_deferred_array): Ditto.
+	(gfc_array_deallocate): Handle coarrays with -fcoarray=lib.
+	* trans-array.h (gfc_array_deallocate, gfc_array_allocate,
+	gfc_trans_dealloc_allocated): Update prototypes.
+	* trans-stmt.c (gfc_trans_sync): Fix indentation.
+	(gfc_trans_allocate): Fix errmsg padding and label handling.
+	(gfc_trans_deallocate): Ditto and handle -fcoarray=lib.
+	* expr.c (gfc_is_coarray): Fix algorithm for BT_CLASS.
+	* libgfortran.h (GFC_STAT_STOPPED_IMAGE): Use large value
+	to avoid other stats accidentally matching this one.
+	* trans-decl.c (gfor_fndecl_caf_deregister): New global var.
+	(gfc_build_builtin_function_decls): Fix prototype decl of caf_register
+	and add decl for caf_deregister.
+	(gfc_trans_deferred_vars): Handle CAF vars with -fcoarrays=lib.
+	* trans-intrinsic.c (conv_intrinsic_move_alloc): Update call to
+	gfc_deallocate_with_status.
+
+2012-01-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/PR48946
+	* resolve.c (resolve_typebound_static): If the typebound
+	procedure is 'deferred' try to find the correct specific
+	procedure in the derived type operator space itself.
+
+2012-01-04  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/50981
+	* trans-array.h (gfc_walk_elemental_function_args): New argument.
+	* trans-intrinsic.c (gfc_walk_intrinsic_function): Update call.
+	* trans-stmt.c (gfc_trans_call): Ditto.
+	* trans-array.c (gfc_walk_function_expr): Ditto.
+	(gfc_walk_elemental_function_args): Get the dummy argument list
+	if possible.  Check that the dummy and the actual argument are both
+	optional, and set can_be_null_ref accordingly.
+
+2012-01-04  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/50981
+	* trans.h (struct gfc_ss_info): New field data::scalar::can_be_null_ref
+	* trans-array.c: If the reference can be NULL, save the reference
+	instead of the value.
+	* trans-expr.c (gfc_conv_expr): If we have saved a reference,
+	dereference it.
+
+2012-01-04  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-expr.c (gfc_conv_expr): Move address taking...
+	(gfc_conv_expr_reference): ... here.
+
+2012-01-04  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/49693
+	* trans-common.c (create_common): Update copyright years.  Mark
+	variables as used to avoid warnings about unused variables in
+	common blocks.
+
+2012-01-03  Hans-Peter Nilsson  <hp@axis.com>
+
+	* gfortran.h (struct gfc_expr): Add missing "struct"
+	qualifier for member base_expr.
+
+2012-01-02  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/51529
+	* trans-array.c (gfc_array_allocate): Null allocated memory of
+	newly allocted class arrays.
+
+	PR fortran/46262
+	PR fortran/46328
+	PR fortran/51052
+	* interface.c(build_compcall_for_operator): Add a type to the
+	expression.
+	* trans-expr.c (conv_base_obj_fcn_val): New function.
+	(gfc_conv_procedure_call): Use base_expr to detect non-variable
+	base objects and, ensuring that there is a temporary variable,
+	build up the typebound call using conv_base_obj_fcn_val.
+	(gfc_trans_class_assign): Pick out class procedure pointer
+	assignments and do the assignment with no further prcessing.
+	(gfc_trans_class_array_init_assign, gfc_trans_class_init_assign
+	gfc_trans_class_assign): Move to top of file.
+	* gfortran.h : Add 'base_expr' field to gfc_expr.
+	* resolve.c (get_declared_from_expr): Add 'types' argument to
+	switch checking of derived types on or off.
+	(resolve_typebound_generic_call): Set the new argument.
+	(resolve_typebound_function, resolve_typebound_subroutine):
+	Set 'types' argument for get_declared_from_expr appropriately.
+	Identify base expression, if not a variable, in the argument
+	list of class valued calls. Assign it to the 'base_expr' field
+	of the final expression. Strip away all references after the
+	last class reference.
+
+2012-01-02  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51682
+	* trans-intrinsic.c (trans_this_image, trans_image_index,
+	trans_num_images, conv_intrinsic_cobound): Fold_convert the
+	caf_num_images/caf_this_images variables to the correct int kind.
+
+2012-01-01  Jakub Jelinek  <jakub@redhat.com>
+
+	* gfortranspec.c (lang_specific_driver): Update copyright notice
+	dates.
+
+Copyright (C) 2012 Free Software Foundation, Inc.
+
+Copying and distribution of this file, with or without modification,
+are permitted in any medium without royalty provided the copyright
+notice and this notice are preserved.
diff --git a/gcc-4.9/gcc/fortran/ChangeLog-2013 b/gcc-4.9/gcc/fortran/ChangeLog-2013
new file mode 100644
index 000000000..6c7cea7c4
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/ChangeLog-2013
@@ -0,0 +1,2083 @@
+2013-12-30  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/58998
+	* resolve.c (resolve_symbol): Check that symbol is not only flavorless
+	but also untyped.
+
+2013-12-29  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/59612
+	* dump-parse-tree.c (show_typespec): Check for charlen.
+	* invoke.texi: Fix documentation of -fdump-fortran-optimized and
+	-fdump-parse-tree.
+
+2013-12-18  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/59493
+	* gfortran.h (gfc_find_intrinsic_vtab): Removed prototype.
+	(gfc_find_vtab): New prototype.
+	* class.c (gfc_find_intrinsic_vtab): Rename to 'find_intrinsic_vtab' and
+	make static. Minor modifications.
+	(gfc_find_vtab): New function.
+	(gfc_class_initializer): Use new function 'gfc_find_vtab'.
+	* check.c (gfc_check_move_alloc): Ditto.
+	* expr.c (gfc_check_pointer_assign): Ditto.
+	* interface.c (compare_actual_formal): Ditto.
+	* resolve.c (resolve_allocate_expr, resolve_select_type): Ditto.
+	* trans-expr.c (gfc_conv_intrinsic_to_class, gfc_trans_class_assign):
+	Ditto.
+	* trans-intrinsic.c (conv_intrinsic_move_alloc): Ditto.
+	* trans-stmt.c (gfc_trans_allocate): Ditto.
+
+2013-12-16  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/54949
+	* symbol.c (check_conflict): Forbid abstract procedure pointers.
+	(gfc_add_abstract): Check for attribute conflicts.
+
+2013-12-16  Jakub Jelinek  <jakub@redhat.com>
+
+	PR libgomp/59337
+	* openmp.c (resolve_omp_atomic): Adjust error message.
+
+2013-12-15  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/59493
+	* class.c (gfc_find_intrinsic_vtab): Handle BT_CLASS.
+
+2013-12-14  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/59502
+	* primary.c (gfc_match_varspec): Check for 'class_ok'.
+
+2013-12-14  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/59450
+	* module.c (mio_expr): Handle type-bound function expressions.
+
+2013-12-12  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/59440
+	* trans-decl.c (generate_namelist_decl): Ensure debug DIE
+	is created by setting DECL_IGNORED_P to 0.
+
+2013-12-11  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/58916
+	* resolve.c (conformable_arrays): Treat scalar 'e2'.
+	(resolve_allocate_expr): Check rank also for unlimited-polymorphic
+	variables.
+
+2013-12-10  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/35831
+	* interface.c (check_dummy_characteristics): Add checks for several
+	attributes.
+
+2013-12-10  Janus Weil  <janus@gcc.gnu.org>
+
+	* gfortran.texi: Add possible kind values (and default) for
+	DOUBLE PRECISION.
+	* invoke.texi: Correct documentation of -fdefault-integer-8,
+	-fdefault-real-8 and -fdefault-double-8.
+
+2013-12-10  Janus Weil  <janus@gcc.gnu.org>
+
+	* gfortran.texi: Modify documentation of kind type parameters.
+	* invoke.texi: Extend documentation of -fdefault-integer-8 and
+	-fdefault-real-8.
+
+2013-12-10  Janus Weil  <janus@gcc.gnu.org>
+
+	* invoke.texi: Add -freal-4-real-16. Rearrange kind promotion options.
+
+2013-12-08  Tobias Burnus  <burnus@net-b.de>
+	    Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/58099
+	PR fortran/58676
+	PR fortran/41724
+	* resolve.c (gfc_resolve_intrinsic): Set elemental/pure.
+	(resolve_fl_procedure): Reject pure dummy procedures/procedure
+	pointers.
+	(gfc_explicit_interface_required): Don't require a
+	match of ELEMENTAL for intrinsics.
+
+2013-12-07  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/59414
+	* resolve.c (resolve_specific_f0): Handle CLASS-valued functions.
+
+2013-12-04  Tobias Burnus  <burnus@net-b.de>
+
+	PR debug/37132
+	* trans-decl.c (generate_namelist_decl, create_module_nml_decl):
+	New static functions.
+	(gfc_generate_module_vars, generate_local_vars): Call them.
+	(gfc_trans_use_stmts): Handle namelists for debug genertion.
+
+2013-12-01  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/57354
+	* trans-array.c (gfc_conv_resolve_dependencies): For other than
+	SS_SECTION, do a dependency check if the lhs is liable to be
+	reallocated.
+
+2013-12-01  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/58410
+	* trans-array.c (gfc_alloc_allocatable_for_assignment): Do not
+	use the array bounds of an unallocated array but set its size
+	to zero instead.
+
+2013-12-01  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34547
+	* resolve.c (resolve_transfer): EXPR_NULL is always in an
+	invalid context in a transfer statement.
+
+2013-11-28  Sergey Ostanevich  <sergos.gnu@gmail.com>
+
+	* lang.opt (Wopenmp-simd): New.
+
+2013-11-25  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/59143
+	* interface.c (get_expr_storage_size): Handle array-valued type-bound
+	procedures.
+
+2013-11-24  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* scanner.c (gfc_open_intrinsic_module): Remove function.
+	* gfortran.h (gfc_open_intrinsic_module): Remove prototype.
+
+2013-11-23  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/59228
+	* interface.c (compare_parameter): Check for array spec.
+
+2013-11-22  Andrew MacLeod  <amacleod@redhat.com>
+
+	* trans.c: Add required include files from gimple.h.
+	* trans-expr.c: Likewise
+	* trans-openmp.c: Likewise
+
+2013-11-22  David Malcolm  <dmalcolm@redhat.com>
+
+	* trans.c (trans_runtime_error_vararg): Remove use of input_line
+	macro.
+
+2013-11-17  Andrew MacLeod  <amacleod@redhat.com>
+
+	* fortran/trans-intrinsic.c: Include tree-nested.h.
+
+2013-11-14  Andrew MacLeod  <amacleod@redhat.com>
+
+	* trans-expr.c: Include only gimplify.h and gimple.h as needed.
+	* trans-openmp.c: Likewise.
+
+2013-11-14  Diego Novillo  <dnovillo@google.com>
+
+	* decl.c: Include stringpool.h.
+	* iresolve.c: Include stringpool.h.
+	* match.c: Include stringpool.h.
+	* module.c: Include stringpool.h.
+	* target-memory.c: Include stor-layout.h.
+	* trans-common.c: Include stringpool.h.
+	Include stor-layout.h.
+	Include varasm.h.
+	* trans-const.c: Include stor-layout.h.
+	* trans-decl.c: Include stringpool.h.
+	Include stor-layout.h.
+	Include varasm.h.
+	Include attribs.h.
+	* trans-expr.c: Include stringpool.h.
+	* trans-intrinsic.c: Include stringpool.h.
+	Include tree-nested.h.
+	Include stor-layout.h.
+	* trans-io.c: Include stringpool.h.
+	Include stor-layout.h.
+	* trans-openmp.c: Include stringpool.h.
+	* trans-stmt.c: Include stringpool.h.
+	* trans-types.c: Include stor-layout.h.
+	Include stringpool.h.
+	* trans.c: Include stringpool.h.
+
+2013-11-12  Andrew MacLeod  <amacleod@redhat.com>
+
+	* f95-lang.c: Don't include gimple.h.
+	* trans-array.c: Include gimple-expr.h instead of gimple.h.
+	* trans.c: Likewise.
+	* trans-decl.c: Likewise.
+	* trans-expr.c: Include gimplify.h.
+	* trans-openmp.c: Likewise.
+
+2013-11-07  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/58471
+	* primary.c (gfc_expr_attr): Check for result symbol.
+
+2013-11-06  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* gfortran.texi: Fix typo.
+
+2013-11-05  Tobias Burnus  <burnus@net-b.de>
+
+	* lang.opt (-Wdate-time): New option
+	* cpp.c (gfc_cpp_option_data): Add warn_date_time.
+	(gfc_cpp_init_options, gfc_cpp_handle_option,
+	gfc_cpp_post_options): Handle it and pass on to libcpp.
+
+2013-11-05  Steven G. Kargl <kargl@gcc.gnu.org>
+
+	PR fortran/58989
+	* check.c (gfc_check_reshape): ensure that shape is a constant
+	expression.
+
+2013-11-05  Tobias Burnus  <burnus@net-b.de>
+
+	* lang.opt (fopenmp-simd): New option.
+	* gfortran.h (gfc_option_t): Add gfc_flag_openmp_simd.
+	* options.c (gfc_handle_option): Handle it.
+
+2013-11-04  Ian Lance Taylor  <iant@google.com>
+
+	* f95-lang.c (ATTR_LEAF_LIST): Define.
+
+2013-11-04  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/58771
+	* trans-io.c (transfer_expr): If the backend_decl for a derived
+	type is missing, build it with gfc_typenode_for_spec.
+
+2013-11-04  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/57445
+	* trans-expr.c (gfc_conv_class_to_class): Remove spurious
+	assert.
+
+2013-10-29  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/44350
+	* parse.c (parse_spec): Add C1116 constraint
+	check for BLOCK DATA.
+
+2013-10-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/58793
+	* trans-types.c (gfc_typenode_for_spec): Add typenode for
+	BT_HOLLERITH. Note that the length is incorrect but unusable.
+
+	PR fortran/58858
+	* target-memory.c (gfc_element_size): Add element sizes for
+	BT_VOID and BT_ASSUMED, using gfc_typenode_for_spec.
+
+2013-10-24  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/44646
+	* trans-stmt.c (struct forall_info): Add do_concurrent field.
+	(gfc_trans_forall_1): Set it for do concurrent.
+	(gfc_trans_forall_loop): Mark those as annot_expr_ivdep_kind.
+
+2013-10-23  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/58793
+	* interface.c (compare_parameter): Reject passing TYPE(*)
+	to CLASS(*).
+
+2013-10-22  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran 57893
+	* class.c : Include target-memory.h.
+	(gfc_find_intrinsic_vtab) Build a minimal expression so that
+	gfc_element_size can be used to obtain the storage size, rather
+	that the kind value.
+
+2013-10-21  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/58803
+	* decl.c (match_ppc_decl): Prevent later
+	double free.
+
+2013-10-17  Andrew MacLeod  <amacleod@redhat.com>
+
+	* trans-openmp.c: Include omp-low.h.
+
+2013-10-16  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/58652
+	* interface.c (compare_parameter): Accept passing CLASS(*)
+	to CLASS(*).
+
+2013-10-16  Tobias Burnus  <burnus@net-b.de>
+
+	* intrinsic.texi (OpenMP Modules): Update to OpenMPv4.
+	Document omp_proc_bind_kind.
+
+2013-10-15  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/58652
+	* trans-intrinsic.c (conv_intrinsic_move_alloc): Fix handling
+	of CLASS(*) variables.
+
+2013-10-14  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/58658
+	* expr.c (gfc_check_vardef_context): Fix pointer diagnostic
+	for CLASS(*).
+
+2013-10-11  Jakub Jelinek  <jakub@redhat.com>
+
+	* trans-openmp.c (gfc_omp_clause_default_ctor,
+	gfc_omp_clause_dtor): Return NULL for OMP_CLAUSE_REDUCTION.
+	* f95-lang.c (ATTR_NULL, DEF_FUNCTION_TYPE_8): Define.
+	* types.def (DEF_FUNCTION_TYPE_8): Document.
+	(BT_FN_VOID_OMPFN_PTR_UINT,
+	BT_FN_VOID_OMPFN_PTR_UINT_LONG_LONG_LONG,
+	BT_FN_VOID_OMPFN_PTR_UINT_LONG_LONG_LONG_LONG,
+	BT_FN_VOID_OMPFN_PTR_OMPCPYFN_LONG_LONG_BOOL_UINT): Remove.
+	(BT_FN_VOID_OMPFN_PTR_UINT_UINT_UINT,
+	BT_FN_VOID_OMPFN_PTR_UINT_LONG_LONG_LONG_UINT,
+	BT_FN_VOID_OMPFN_PTR_UINT_LONG_LONG_LONG_LONG_UINT,
+	BT_FN_BOOL_INT, BT_FN_BOOL_INT_BOOL, BT_FN_VOID_UINT_UINT,
+	BT_FN_VOID_INT_PTR_SIZE_PTR_PTR_PTR,
+	BT_FN_VOID_INT_OMPFN_PTR_SIZE_PTR_PTR_PTR,
+	BT_FN_VOID_OMPFN_PTR_OMPCPYFN_LONG_LONG_BOOL_UINT_PTR): New.
+
+2013-10-10  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/58226
+	* options.c (gfc_get_option_string): Handle zero arg case.
+
+2013-10-02  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/58593
+	* trans-expr.c (gfc_conv_string_tmp): Fix obtaining
+	the byte size of a single character.
+
+2013-10-01  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/58579
+	* trans-expr.c (gfc_conv_string_tmp): Correctly obtain
+	the byte size of a single character.
+
+2013-09-27  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	* intrinsic.texi (DATE_AND_TIME): Fix example.
+
+2013-09-25  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/58436
+	* class.c (generate_finalization_wrapper): Handle CLASS(*).
+
+2013-09-25  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57697
+	PR fortran/58469
+	* resolve.c (generate_component_assignments): Avoid double free
+	at runtime and freeing a still-being used expr.
+
+2013-09-25  Tom Tromey  <tromey@redhat.com>
+
+	* Make-lang.in (fortran_OBJS): Use fortran/gfortranspec.o.
+	(gfortranspec.o): Remove.
+	(CFLAGS-fortran/gfortranspec.o): New variable.
+	(GFORTRAN_D_OBJS): Update.
+	($(F95_PARSER_OBJS), fortran/openmp.o, GFORTRAN_TRANS_DEPS)
+	(fortran/f95-lang.o, fortran/scanner.o, fortran/convert.o)
+	(fortran/frontend-passes.o, fortran/trans.o, fortran/trans-decl.o)
+	(fortran/trans-types, fortran/trans-const.o, fortran/trans-expr.o)
+	(fortran/trans-stmt.o, fortran/trans-openmp.o, fortran/trans-io.o)
+	(fortran/trans-array.o, fortran/trans-intrinsic.o)
+	(fortran/dependency.o, fortran/trans-common.o, fortran/resolve.o)
+	(fortran/data.o, fortran/options.o, fortran/cpp.o)
+	(fortran/scanner.o, fortran/module.o): Remove.
+
+2013-09-25  Tom Tromey  <tromey@redhat.com>
+
+	* Make-lang.in (gfortranspec.o): Don't use subshell.
+
+2013-09-23  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/58355
+	* decl.c (check_extended_derived_type): Prevent segfault, modify error
+	message.
+
+2013-09-20  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/58099
+	* expr.c (gfc_check_pointer_assign): Remove second call to
+	'gfc_compare_interfaces' with swapped arguments.
+	* interface.c (gfc_compare_interfaces): Symmetrize the call to
+	'check_result_characteristics' by calling it with swapped arguments.
+
+2013-09-18  Tobias Burnus  <burnus@net-b.de>
+
+	* expr.c (gfc_check_assign_symbol): Free lvalue.ref.
+
+2013-09-18  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/43366
+	* primary.c (gfc_variable_attr): Also handle codimension.
+	* resolve.c (resolve_ordinary_assign): Add invalid-diagnostic for
+	polymorphic assignment.
+
+2013-09-16  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/58356
+	* class.c (generate_finalization_wrapper): Init proc_tree if
+	not yet resolved.
+
+2013-09-16  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57697
+	* resolve.c (generate_component_assignments): Correctly handle the
+	case that the LHS is not allocated.
+
+2013-09-15  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57697
+	* resolve.c (generate_component_assignments): Handle unallocated
+	LHS with defined assignment of components.
+
+2013-09-12  Brooks Moses  <bmoses@google.com>
+
+	PR driver/42955
+	* Make-lang.in: Do not install driver binaries in $(target)/bin.
+
+2013-09-09  Tobias Burnus  <burnus@net-b.de>
+
+	* invoke.texi (Error and Warning Options): Add hyphen.
+
+2013-09-02  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/PR56519
+	* gfortran.h:  Declare gfc_do_concurrent_flag as extern.
+	* resolve.c:  Rename do_concurrent_flag to gfc_do_concurrent_flag
+	and make non-static.
+	(resolve_function):  Use gfc_do_concurrent_flag instead of
+	do_concurrent_flag.
+	(pure_subroutine):  Likewise.
+	(resolve_code):  Likewise.
+	(resolve_types):  Likewise.
+	* intrinsic.c (gfc_intrinsic_sub_interface):  Raise error for
+	non-pure intrinsic subroutines within DO CONCURRENT.
+
+2013-08-29  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/52243
+	* trans-expr.c (is_runtime_conformable):  New function.
+	* gfc_trans_assignment_1:  Use it.
+
+2013-08-26  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/58146
+	* array.c (gfc_ref_dimen_size):  If possible, use
+	gfc_dep_difference to calculate array refrence
+	sizes.  Fall back to integer code otherwise.
+	* dependency.c (discard_nops).  Move up.
+	Also discarde widening integer conversions.
+	(gfc_dep_compare_expr):  Use discard_nops.
+
+2013-08-23  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/57798
+	* trans-array.c (gfc_conv_ss_startstride, set_loop_bounds,
+	gfc_set_delta): Generate preliminary code before the outermost loop.
+
+2013-08-23  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/57843
+	* interface.c (gfc_extend_assign): Look for type-bound assignment
+	procedures before non-typebound.
+
+2013-08-23  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.c (gfc_conv_section_startstride): Move &loop->pre access
+	to the callers.
+	(gfc_conv_ss_startstride, gfc_conv_expr_descriptor): Update callers.
+
+2013-08-22  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/58185
+	* match.c (copy_ts_from_selector_to_associate): Only build class
+	container for polymorphic selector. Some cleanup.
+
+2013-08-20  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/53655
+	* trans-decl.c (generate_local_decl): Check if type has any components.
+
+2013-08-19  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/46271
+	* openmp.c (resolve_omp_clauses): Bugfix for procedure pointers.
+
+2013-08-12  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/56666
+	* gfortran.h (gfc_option_t):  Add warn_zerotrip.
+	* invoke.texi (-Wzerotrip):  Document option.
+	* lang.opt (Wzerotrip):  Add.
+	* options.c (gfc_init_options):  Initialize warn_zerotrip.
+	(set_Wall): Add handling of warn_zerotrip.
+	(gfc_handle_option):  Handle OPT_Wzerotrip.
+	* resolve.c (gfc_resolve_iterator): Honor
+	gfc_option.warn_zerotrip; update error message to show
+	how to suppress the warning.
+
+2013-08-09  Janus Weil  <janus@gcc.gnu.org>
+
+	* gfortran.h (gfc_get_code): Modified prototype.
+	* class.c (finalize_component, finalization_scalarizer,
+	finalization_get_offset, finalizer_insert_packed_call,
+	generate_finalization_wrapper, gfc_find_derived_vtab,
+	gfc_find_intrinsic_vtab): Use 'gfc_get_code'.
+	* io.c (match_io_iterator, match_io_element, terminate_io, get_io_list,
+	gfc_match_inquire): Call 'gfc_get_code' with argument.
+	* match.c (match_simple_forall, gfc_match_forall, gfc_match_goto,
+	gfc_match_nullify, gfc_match_call, match_simple_where, gfc_match_where):
+	Ditto.
+	* parse.c (new_level): Ditto.
+	(add_statement): Use XCNEW.
+	* resolve.c (resolve_entries, resolve_allocate_expr,
+	resolve_select_type, build_assignment, build_init_assign): Call
+	'gfc_get_code' with argument.
+	* st.c (gfc_get_code): Add argument 'op'.
+	* trans-expr.c (gfc_trans_class_array_init_assign): Call 'gfc_get_code'
+	with argument.
+	* trans-stmt.c (gfc_trans_allocate): Ditto.
+
+2013-08-09  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/58058
+	* trans-intrinsic.c (gfc_conv_intrinsic_transfer): Free the temporary
+	string, if necessary.
+
+2013-08-06  Martin Jambor  <mjambor@suse.cz>
+
+	PR fortran/57987
+	* trans-decl.c (gfc_generate_function_code): Never call
+	cgraph_finalize_function on nested functions.
+
+2013-08-06  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/57306
+	* class.c (gfc_class_null_initializer): Rename to
+	'gfc_class_initializer'. Treat non-NULL init-exprs.
+	* gfortran.h (gfc_class_null_initializer): Update prototype.
+	* trans-decl.c (gfc_get_symbol_decl): Treat class variables.
+	* trans-expr.c (gfc_conv_initializer): Ditto.
+	(gfc_trans_subcomponent_assign): Renamed gfc_class_null_initializer.
+
+2013-07-30  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57530
+	* symbol.c (gfc_type_compatible): A type is type compatible with
+	a class if both have the same declared type.
+	* interface.c (compare_type): Reject CLASS/TYPE even if they
+	are type compatible.
+
+2013-07-30  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57530
+	* trans-expr.c (gfc_trans_class_assign): Handle CLASS array
+	functions.
+	(gfc_trans_pointer_assign): Ditto and support pointer assignment of
+	a polymorphic var to a nonpolymorphic var.
+
+2013-07-22  Po Chang  <pchang9@cs.wisc.edu>
+
+	* match.c (gfc_match_call): Exit loop after setting i.
+
+	* resolve.c (resolve_variable): Exit loop after setting seen.
+
+	* expr.c (gfc_check_pointer_assign): Exit loop after setting warn.
+
+	* trans-array.c (set_loop_bounds): Exit loop after setting
+	nonoptional_arr.
+
+	* trans-io.c (gfc_trans_transfer): Exit loop after setting seen_vector.
+
+2013-07-28  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/58009
+	* expr.c (gfc_check_vardef_context):  Check for same values in
+	vector expression subscripts.
+
+2013-07-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57991
+	* interface.c (check_some_aliasing): Also warn for intent OUT/OUT.
+
+2013-07-27  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/57285
+	* check.c (dim_rank_check): Re-enable this check for CLASS arrays.
+
+2013-07-25  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/57966
+	* resolve.c (resolve_typebound_function): Make sure the declared type,
+	including its type-bound procedures, is resolved before resolving the
+	actual type-bound call.
+
+2013-07-25  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/57639
+	* interface.c (compare_parameter): Check for class_ok.
+	* simplify.c (gfc_simplify_same_type_as): Ditto.
+
+2013-07-23   Ondřej Bílka  <neleai@seznam.cz>
+
+	* decl.c: Fix comment typos.
+	* interface.c: Likewise.
+	* trans-array.c: Likewise.
+	* trans.c: Likewise.
+
+2013-07-22  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57906
+	PR fortran/52052
+	* class.c (gfc_build_class_symbol): Set coarray_comp.
+	* trans-array.c (structure_alloc_comps): For coarrays,
+	directly use the data pointer address.
+
+2013-07-22  Chang  <pchang9@cs.wisc.edu>
+
+	* trans-decl.c (gfc_build_dummy_array_decl): Exit loop after
+	setting PACKED_PARTIAL.
+
+2013-07-22  Tobias Burnus  <burnus@net-b.de>
+
+	* trans-array.c (gfc_array_allocate): Correct memory-leak patch.
+
+2013-07-22  Tobias Burnus  <burnus@net-b.de>
+
+	* trans-array.c (gfc_array_allocate,
+	gfc_trans_deferred_array): Plug memory leak.
+
+2013-07-21  Ondřej Bílka  <neleai@seznam.cz>
+
+	* trans-decl.c: Fix comment typos.
+	* trans-expr.c: Ditto.
+
+2013-07-21  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/56937
+	* dependency.c (gfc_dep_resolver):  Treat identical
+	array subscripts as identical; don't unconditionally
+	return a dependency if an array subscript is found.
+
+2013-07-21  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/35862
+	* libgfortran.h (GFC_FPE_DOWNWARD, GFC_FPE_TONEAREST,
+	GFC_FPE_TOWARDZERO, GFC_FPE_UPWARD): New defines.
+
+2013-07-21  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57894
+	* check.c (min_max_args): Add keyword= check.
+
+2013-07-17  Mikael Morin  <mikael@gcc.gnu.org>
+	    Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57895
+	* match.c (gfc_match_name): Ensure that the error
+	message regarding -fdollar-ok gets printed.
+	(gfc_match_common): Avoid multiple freeing.
+
+2013-07-16  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57912
+	* trans-expr.c (gfc_trans_scalar_assign): Correct if
+	condition for caf realloc.
+
+2013-07-15  Tobias Burnus  <burnus@net-b.de>
+
+	* trans-array.h (gfc_deallocate_alloc_comp_no_caf,
+	gfc_reassign_alloc_comp_caf): New prototype.
+	* trans-array.c (enum): Add DEALLOCATE_ALLOC_COMP_NO_CAF
+	and COPY_ALLOC_COMP_CAF.
+	(structure_alloc_comps): Handle it.
+	(gfc_reassign_alloc_comp_caf,
+	gfc_deallocate_alloc_comp_no_caf): New function.
+	(gfc_alloc_allocatable_for_assignment): Call it.
+	* trans-expr.c (gfc_trans_scalar_assign,
+	gfc_trans_arrayfunc_assign, gfc_trans_assignment_1): Ditto.
+	* parse.c (parse_derived): Correctly set coarray_comp.
+	* resolve.c (resolve_symbol): Improve error wording.
+
+2013-07-15  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/37336
+	* trans.c (gfc_add_comp_finalizer_call): New function.
+	* trans.h (gfc_add_comp_finalizer_call): New prototype.
+	* trans-array.c (structure_alloc_comps): Call it.
+
+2013-07-14  Thomas Koenig  <tkoenig@gcc.gnu.org>
+	    Tobias Burnus  <burnus@gcc.gnu.org>
+
+	PR fortran/52669
+	* trans-decl.c (gfc_finish_var_decl):  Move setting of
+	PRIVATE for a module variable if the module has a private
+	default or -fmodule-private is given to...
+	(gfc_create_module_variable): here. Optionally
+	warn about private module variable which is not used.
+
+2013-07-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57834
+	* check.c (is_c_interoperable): Add special case for c_f_pointer.
+	(explicit-size, gfc_check_c_f_pointer, gfc_check_c_loc): Update
+	call.
+
+2013-07-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/50554
+	* io.c (match_inquire_element): Add missing do-var check.
+
+2013-07-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57785
+	* simplify.c (compute_dot_product): Complex conjugate for
+	dot_product.
+	(gfc_simplify_dot_product, gfc_simplify_matmul): Update call.
+
+2013-07-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57469
+	* trans-decl.c (generate_local_decl): Don't warn that
+	a dummy is unused, when it is in a namelist.
+
+2013-07-01  Dominique d'Humieres  <dominiq@lps.ens.fr>
+
+	PR fortran/54788
+	* array.c (spec_size): handle the case as==NULL.
+
+2013-06-26  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/29800
+	* trans-array.c (gfc_conv_array_ref): Improve out-of-bounds
+	diagnostic message.
+	* trans-array.c (gfc_conv_array_ref): Update prototype.
+	* trans-expr.c (gfc_conv_variable): Update call.
+
+2013-06-24  Steven G. Kargl  <sgk@troutmask.apl.washington.edu>
+	    Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+	    Dominique d'Humieres  <dominiq@lps.ens.fr>
+
+	PR fortran/52413
+	* simplify.c (gfc_simplify_fraction): Fix the sign of negative values.
+
+2013-06-21  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/37336
+	* trans-array.c (gfc_trans_deferred_array): Call the
+	finalizer for nonallocatable local variables.
+	* trans-decl.c (gfc_get_symbol_decl): Add local
+	finalizable vars to the deferred list.
+	(gfc_trans_deferred_vars): Call gfc_trans_deferred_array
+	for those.
+
+2013-06-21  Tobias Burnus  <burnus@net-b.de>
+
+	* trans-array.c (gfc_alloc_allocatable_for_assignment): Allocate
+	at least one byte.
+	* trans-expr.c (alloc_scalar_allocatable_for_assignment): Ditto.
+
+2013-06-20  Tobias Burnus  <burnus@net-b.de>
+
+	* resolve.c (get_temp_from_expr): Don't set FL_VARIABLE twice.
+
+2013-06-17  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.h (gfc_option_t): Add fpe_summary.
+	* gfortran.texi (_gfortran_set_options): Update.
+	* invoke.texi (-ffpe-summary): Add doc.
+	* lang.opt (ffpe-summary): Add flag.
+	* options.c (gfc_init_options, gfc_handle_option): Handle it.
+	(gfc_handle_fpe_option): Renamed from gfc_handle_fpe_trap_option,
+	also handle fpe_summary.
+	* trans-decl.c (create_main_function): Update
+	_gfortran_set_options call.
+
+2013-06-15  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/49074
+	PR fortran/56136
+	* dependency.c (gfc_check_argument_var_dependency): Return 0 in the
+	array constructor case.
+
+2013-06-14  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57508
+	* resolve.c (get_temp_from_expr): Don't copy function
+	result attributes to temporary.
+
+2013-06-14  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57596
+	* trans-decl.c (gfc_trans_deferred_vars): Honor OPTIONAL
+	for nullify and deferred-strings' length variable.
+
+2013-06-13  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/49074
+	* trans-expr.c (gfc_conv_variable): Don't walk the reference chain.
+	Handle NULL array references.
+	(gfc_conv_procedure_call): Remove code handling NULL array references.
+
+2013-06-11  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57535
+	* trans-array.c (build_class_array_ref): Fix ICE for
+	function result variables.
+
+2013-06-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/37336
+	* trans-decl.c (init_intent_out_dt): Call finalizer
+	when appropriate.
+
+2013-06-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57553
+	* simplify.c (gfc_simplify_storage_size): Handle literal
+	strings.
+	* trans-intrinsic.c (gfc_conv_intrinsic_storage_size):
+	Add missing fold_convert.
+
+2013-06-07  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57549
+	* array.c (gfc_match_array_constructor): Call
+	gfc_match_type_spec instead of gfc_match_decl_type_spec.
+	* match.c (gfc_match_type_spec): Renamed from match_type_spec.
+	(gfc_match_type_is, gfc_match_allocate): Update call.
+	* match.h (gfc_match_type_spec): Add prototype.
+
+2013-06-07  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57556
+	* trans.c (gfc_build_final_call): Init block before use.
+
+2013-06-06  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57542
+	* trans.c (gfc_build_final_call): Add se.pre to the block
+	and modify the assert.
+
+2013-06-04  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/37336
+	* trans.h (gfc_build_final_call): Remove prototype.
+	(gfc_add_finalizer_call): Add prototype.
+	* trans-array.c (gfc_trans_dealloc_allocated): Support finalization.
+	(structure_alloc_comps): Update caller.
+	(gfc_trans_deferred_array): Call finalizer.
+	* trans-array.h (gfc_trans_dealloc_allocated): Update prototype.
+	* trans-decl.c (gfc_trans_deferred_vars): Don't deallocate/finalize
+	variables of the main program.
+	* trans-expr.c (gfc_conv_procedure_call): Support finalization.
+	* trans-openmp.c (gfc_omp_clause_dtor,
+	gfc_trans_omp_array_reduction): Update calls.
+	* trans-stmt.c (gfc_trans_deallocate): Avoid double deallocation
+	of alloc components.
+	* trans.c (gfc_add_finalizer_call): New function.
+	(gfc_deallocate_with_status,
+	gfc_deallocate_scalar_with_status): Call it
+	(gfc_build_final_call): Fix handling of scalar coarrays,
+	move up in the file and make static.
+
+2013-06-01  Janus Weil  <janus@gcc.gnu.org>
+	    Mikael Morin  <mikael@gcc.gnu.org>
+
+	* error.c (get_terminal_width): Only limit the width if we're
+	outputting to a terminal. Try to determine width via ioctl.
+
+2013-06-01  Tobias Burnus  <burnus@net-b.de>
+
+	* decl.c (add_global_entry): Take locus.
+	(gfc_match_entry): Update call.
+	(gfc_match_end): Better error location.
+	* parse.c (parse_block_data, parse_module, add_global_procedure,
+	add_global_program): Use better locus data.
+
+2013-05-31  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57456
+	* trans-array.c (gfc_array_init_size): Use passed type spec,
+	when available.
+	(gfc_array_allocate): Pass typespec on.
+	* trans-array.h (gfc_array_allocate): Update prototype.
+	* trans-stmt.c (gfc_trans_allocate): Pass typespec on.
+
+2013-05-31  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/54190
+	PR fortran/57217
+	* gfortran.h (gfc_terminal_width): Remove prototype.
+	* error.c (get_terminal_width): Moved here from misc.c. Renamed.
+	Try to determine terminal width from environment variable.
+	* interface.c (compare_type, compare_rank): New functions. Fix assumed
+	type/rank handling.
+	(compare_type_rank, check_dummy_characteristics,
+	check_result_characteristics, gfc_compare_interfaces): Use them.
+	(symbol_rank): Slightly modified and moved.
+	* misc.c (gfc_terminal_width): Moved to error.c.
+
+2013-05-30  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/54189
+	* resolve.c (check_assumed_size_reference): Check for e->ref.
+
+2013-05-30  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57458
+	* interface.c (compare_parameter): Update C1239/C1240 constraint
+	check for assumed-rank/TS29113.
+
+2013-05-29  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/37336
+	* class.c (finalize_component): Fix coarray array refs.
+	(generate_finalization_wrapper): Only gfc_convert_type_warn
+	when the kind value is different.
+	(gfc_find_intrinsic_vtab): _copy's dst is now intent(inout).
+	(gfc_find_derived_vtab): Ditto. Enable finalization-wrapper
+	generation.
+	* module.c (MOD_VERSION): Bump.
+	(gfc_dump_module, gfc_use_module): Remove empty line in .mod.
+	* trans-array.c (gfc_conv_descriptor_token): Accept nonrestricted
+	void pointer.
+	(gfc_array_allocate, structure_alloc_comps): Don't nullify for
+	BT_CLASS allocations.
+	* trans-stmt.c (gfc_trans_allocate): Ditto.
+
+2013-05-29  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/37336
+	* resolve.c (gfc_resolve_finalizers): Remove not implemented error.
+
+2013-05-28  Tobias Burnus  <burnus@net-b.de>
+
+	* trans-expr.c (gfc_conv_procedure_call): Deallocate
+	polymorphic arrays for allocatable intent(out) dummies.
+	(gfc_reset_vptr): New function, moved from trans-stmt.c
+	and extended.
+	* trans-stmt.c (reset_vptr): Remove.
+	(gfc_trans_deallocate): Update calls.
+	* trans.h (gfc_reset_vptr): New prototype.
+
+2013-05-28  Dominique d'Humieres  <dominiq@lps.ens.fr>
+
+	PR fortran/57435
+	* module.c (check_for_ambiguous): Avoid null pointer deref.
+
+2013-05-28  Janus Weil  <janus@gcc.gnu.org>
+	    Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57217
+	* interface.c (check_dummy_characteristics): Symmetrize type check.
+
+2013-05-27  Bud Davis  <jmdavis@link.com>
+
+	PR fortran/50405
+	* resolve.c (resolve_formal_arglist): Detect error when an argument
+	has the same name as the function.
+
+2013-05-27  Tobias Burnus  <burnus@net-b.de>
+
+	* expr.c (gfc_build_intrinsic_call): Make symbol as attr.artificial.
+	* intrinsic.c (gfc_is_intrinsic): Disable std check for those.
+
+2013-05-22  Tobias Burnus  <burnus@net-b.de>
+
+	* resolve.c (get_temp_from_expr): Change mangling to
+	start always with a _.
+
+2013-05-22  Tobias Burnus  <burnus@net-b.de>
+
+	* resolve.c (get_temp_from_expr): Fix temp var mangling.
+
+2013-05-22  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57364
+	* resolve.c (get_temp_from_expr): Commit created sym.
+
+2013-05-22  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57338
+	* intrinsic.c (do_check): Move some checks to ...
+	(do_ts29113_check): ... this new function.
+	(check_specific, gfc_intrinsic_sub_interface): Call it.
+
+2013-05-22  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	* intrinsic.texi (RANDOM_SEED): Improve example.
+
+2013-05-21  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57035
+	* intrinsic.c (do_check): Add constraint check for
+	NO_ARG_CHECK, assumed rank and assumed type.
+	* gfortran.texi (NO_ARG_CHECK): Minor wording change,
+	allow PRESENT intrinsic.
+
+2013-05-20  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/48858
+	PR fortran/55465
+	* decl.c (add_global_entry): Add sym_name.
+	* parse.c (add_global_procedure): Ditto.
+	* resolve.c (resolve_bind_c_derived_types): Handle multiple decl for
+	a procedure.
+	(resolve_global_procedure): Handle gsym->ns pointing to a module.
+	* trans-decl.c (gfc_get_extern_function_decl): Ditto.
+
+2013-05-20  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/48858
+	* decl.c (add_global_entry): Use nonbinding name
+	only for F2003 or if no binding label exists.
+	(gfc_match_entry): Update calls.
+	* parse.c (gfc_global_used): Improve error message.
+	(add_global_procedure): Use nonbinding name
+	only for F2003 or if no binding label exists.
+	(gfc_parse_file): Update call.
+	* resolve.c (resolve_global_procedure): Use binding
+	name when available.
+	* trans-decl.c (gfc_get_extern_function_decl): Ditto.
+
+2013-05-20  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/48858
+	* decl.c (gfc_match_bind_c_stmt): Add gfc_notify_std.
+	* match.c (gfc_match_common): Don't add commons to gsym.
+	* resolve.c (resolve_common_blocks): Add to gsym and
+	add checks.
+	(resolve_bind_c_comms): Remove.
+	(resolve_types): Remove call to the latter.
+	* trans-common.c (gfc_common_ns): Remove static var.
+	(gfc_map_of_all_commons): Add static var.
+	(build_common_decl): Correctly handle binding label.
+
+2013-05-16  Jason Merrill  <jason@redhat.com>
+
+	* Make-lang.in (f951$(exeext)): Use link mutex.
+
+2013-05-05  Tobias Burnus  <burnus@net-b.de>
+
+	* resolve.c (conformable_arrays): Avoid segfault
+	when ar.start[i] == NULL.
+
+2013-05-05  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57141
+	* decl.c (gfc_match_null): Permit use-associated
+	NULL intrinsic.
+
+2013-05-04  Tobias Burnus  <burnus@net-b.de>
+
+	* decl.c (gfc_verify_c_interop_param): Permit allocatable
+	and pointer with -std=f2008ts.
+
+2013-05-02  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57142
+	* simplify.c (gfc_simplify_size): Renamed from
+	simplify_size; fix kind=8 handling.
+	(gfc_simplify_size): New function.
+	(gfc_simplify_shape): Add range check.
+	* resolve.c (resolve_function): Fix handling
+	for ISYM_SIZE.
+
+2013-05-01  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	* frontend-passes.c (optimize_power):  Fix typo
+	in comment.
+
+2013-04-30  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/57071
+	* frontend-passes.c (optimize_power):  Simplify
+	1**k to 1.
+
+2013-04-28  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57114
+	* intrinsic.texi (RANK): Correct syntax description and
+	expected result.
+
+2013-04-28  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57093
+	* trans-types.c (gfc_get_element_type): Fix handling
+	of scalar coarrays of type character.
+	* intrinsic.texi (PACK): Add missing ")".
+
+2013-04-28  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/57071
+	* frontend-passes (optimize_power):  New function.
+	(optimize_op):  Use it.
+
+2013-04-25  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	PR bootstrap/57028
+	* Make-lang.in (f951): Link in ZLIB.
+	(CFLAGS-fortran/module.o): Add zlib include directory.
+
+2013-04-22  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/53685
+	PR fortran/57022
+	* check.c (gfc_calculate_transfer_sizes): Fix for array-valued SOURCE
+	expressions.
+	* simplify.c (gfc_simplify_sizeof,gfc_simplify_storage_size): Get rid
+	of special treatment for EXPR_ARRAY.
+	* target-memory.h (gfc_element_size): New prototype.
+	* target-memory.c (size_array): Remove.
+	(gfc_element_size): New function.
+	(gfc_target_expr_size): Modified to always return the full size of the
+	expression.
+
+2013-04-20  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/56907
+	* trans-intrinsic.c (conv_isocbinding_function): Don't pack array
+	passed to C_LOC
+
+2013-04-19  Thomas Koenig  <tkoenig@gcc.gnu.org>
+	    Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/56872
+	* frontend-passes.c (copy_walk_reduction_arg): Change argument type
+	to gfc_constructor.  If it has an iterator, wrap the copy of its
+	expression in an array constructor with that iterator.  Don't special
+	case function expressions.
+	(callback_reduction): Update caller.  Don't return early if there is
+	an iterator.
+
+2013-04-18  Tobias Burnus  <burnus@net-b.de>
+
+	* expr.c (find_array_element): Don't copy expr.
+	* data.c (create_character_initializer): Free expr.
+	* frontend-passes.c (combine_array_constructor): Ditto.
+	* match.c (match_typebound_call, gfc_match_select_type): Ditto.
+	* resolve.c (resolve_typebound_function): Free gfc_ref.
+
+2013-04-18  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/56994
+	* invoke.texi (NEAREST): S argument is not optional.
+
+2013-04-17  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/56814
+	* interface.c (check_result_characteristics): Get result from interface
+	if present.
+
+2013-04-17  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	PR fortran/40958
+	* scanner.h: New file.
+	* Make-lang.in: Dependencies on scanner.h.
+	* scanner.c (gfc_directorylist): Move to scanner.h.
+	* module.c: Don't include md5.h, include scanner.h and zlib.h.
+	(MOD_VERSION): Add comment about backwards compatibility.
+	(module_fp): Change type to gzFile.
+	(ctx): Remove.
+	(gzopen_included_file_1): New function.
+	(gzopen_included_file): New function.
+	(gzopen_intrinsic_module): New function.
+	(write_char): Use gzputc.
+	(read_crc32_from_module_file): New function.
+	(read_md5_from_module_file): Remove.
+	(gfc_dump_module): Use gz* functions instead of stdio, check gzip
+	crc32 instead of md5.
+	(read_module_to_tmpbuf): Use gz* functions instead of stdio.
+	(gfc_use_module): Use gz* functions.
+
+2013-04-16  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/39505
+	* decl.c (ext_attr_list): Add EXT_ATTR_NO_ARG_CHECK.
+	* gfortran.h (ext_attr_id_t): Ditto.
+	* gfortran.texi (GNU Fortran Compiler Directives):
+	Document it.
+	* interface.c (compare_type_rank): Ignore rank for NO_ARG_CHECK.
+	(compare_parameter): Ditto - and regard as unlimited polymorphic.
+	* resolve.c (resolve_symbol, resolve_variable): Add same constraint
+	checks as for TYPE(*); turn dummy to TYPE(*),dimension(*).
+	(gfc_explicit_interface_required): Require explicit interface
+	for NO_ARG_CHECK.
+
+2013-04-16  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/56968
+	* expr.c (gfc_check_pointer_assign): Handle generic functions returning
+	procedure pointers.
+
+2013-04-16  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/56969
+	* intrinsic.c (gfc_intrinsic_func_interface): Don't set
+	module name to "(intrinsic)" for intrinsics from intrinsic
+	modules.
+
+2013-04-15  Tobias Burnus  <burnus@net-b.de>
+
+	* intrinsic.texi (SYSTEM_CLOCK): Recommend kind=8.
+
+2013-04-15  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	PR fortran/56919
+	* intrinsics.texi (SYSTEM_CLOCK): Update documentation.
+
+2013-04-15  Tobias Burnus  <burnus@net-b.de>
+
+	* class.c (gfc_find_intrinsic_vtab): Removed unused var.
+	* dependency.c (check_data_pointer_types): Fix check.
+	* frontend-passes.c (check_data_pointer_types): Remove
+	superfluous statement.
+	* parse.c (decode_omp_directive): Add missing break.
+	* resolve.c (resolve_typebound_subroutine: Free variable.
+	* trans-decl.c (create_function_arglist): Correct condition.
+
+2013-04-14  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/56816
+	* match.c (gfc_match_select_type): Add syntax error. Move namespace
+	allocation and cleanup...
+	* parse.c (decode_statement): ... here.
+
+2013-04-13  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/55959
+	* expr.c (gfc_simplify_expr): Branch is not unreachable.
+
+2013-04-12  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/56266
+	* primary.c (gfc_match_varspec): Turn gcc_assert into MATCH_ERROR.
+
+2013-04-12  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/56929
+	* trans-array.c (duplicate_allocatable): Fix handling
+	of scalar coarrays.
+
+2013-04-12  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/56261
+	* gfortran.h (gfc_explicit_interface_required): New prototype.
+	* expr.c (gfc_check_pointer_assign): Check if an explicit interface is
+	required in a proc-ptr assignment.
+	* interface.c (check_result_characteristics): Extra check.
+	* resolve.c (gfc_explicit_interface_required): New function.
+	(resolve_global_procedure): Use new function
+	'gfc_explicit_interface_required'. Do a full interface check.
+
+2013-04-12  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/56845
+	* trans-decl.c (gfc_trans_deferred_vars): Restrict
+	static CLASS init to SAVE and -fno-automatic.
+
+2013-04-12  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/56845
+	* trans-decl.c (gfc_trans_deferred_vars): Set _vptr for
+	allocatable static BT_CLASS.
+	* trans-expr.c (gfc_class_set_static_fields): New function.
+	* trans.h (gfc_class_set_static_fields): New prototype.
+
+2013-04-11  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	* gfortran.h: Remove enum gfc_try, replace gfc_try with bool type.
+	* arith.c: Replace gfc_try with bool type.
+	* array.c: Likewise.
+	* check.c: Likewise.
+	* class.c: Likewise.
+	* cpp.c: Likewise.
+	* cpp.h: Likewise.
+	* data.c: Likewise.
+	* data.h: Likewise.
+	* decl.c: Likewise.
+	* error.c: Likewise.
+	* expr.c: Likewise.
+	* f95-lang.c: Likewise.
+	* interface.c: Likewise.
+	* intrinsic.c: Likewise.
+	* intrinsic.h: Likewise.
+	* io.c: Likewise.
+	* match.c: Likewise.
+	* match.h: Likewise.
+	* module.c: Likewise.
+	* openmp.c: Likewise.
+	* parse.c: Likewise.
+	* parse.h: Likewise.
+	* primary.c: Likewise.
+	* resolve.c: Likewise.
+	* scanner.c: Likewise.
+	* simplify.c: Likewise.
+	* symbol.c: Likewise.
+	* trans-intrinsic.c: Likewise.
+	* trans-openmp.c: Likewise.
+	* trans-stmt.c: Likewise.
+	* trans-types.c: Likewise.
+
+2013-04-09  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.texi (KIND Type Parameters,
+	Internal representation of LOGICAL variables): Add crossrefs.
+	(Intrinsic Types): Mention issues with _Bool interop.
+	(Naming and argument-passing conventions): New section.
+
+2013-04-08  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/56782
+	* frontend-passes.c (callback_reduction):  Don't do
+	any simplification if there is only a single element
+	which has an iterator.
+
+2013-04-07  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/56849
+	* iresolve.c (gfc_resolve_reshape): Set shape also
+	with order=.
+
+2013-04-04  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40881
+	* match.c (gfc_match_return): Remove standard notification.
+	* primary.c (gfc_match_actual_arglist): Add standard notification.
+
+2013-04-04  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/50269
+	* gcc/fortran/check.c (is_c_interoperable,
+	gfc_check_c_loc): Correct c_loc array checking
+	for Fortran 2003 and Fortran 2008.
+
+2013-04-03  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/56284
+	PR fortran/40881
+	* decl.c (gfc_match_formal_arglist): Warn about alternate-return
+	arguments.
+	* interface.c (check_dummy_characteristics): Return if symbols are NULL.
+
+2013-04-01  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/56500
+	* symbol.c (gfc_set_default_type): Build class container for
+	IMPLICIT CLASS.
+
+2013-03-31  Tobias Burnus  <burnus@net-b.de>
+
+	* class.c (finalization_scalarizer, finalizer_insert_packed_call,
+	generate_finalization_wrapper): Avoid segfault with absent SIZE=
+	argument to TRANSFER and use correct result kind for SIZE.
+	* intrinsic.c (gfc_isym_id_by_intmod): Also handle ids of
+	nonmodules.
+	* trans.c (gfc_build_final_call): Handle coarrays.
+
+2013-03-30  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	* trans-expr.c (build_memcmp_call):  New function.
+	(gfc_build_compare_string):  If the strings
+	compared have constant and equal lengths and
+	the strings are kind=1, or, for kind=4 strings,
+	the test is for (in)equality, use memcmp().
+
+2013-03-29  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/35203
+	* trans-decl.c (create_function_arglist): Pass hidden argument
+	for passed-by-value optional+value dummies.
+	* trans-expr.c (gfc_conv_expr_present,
+	gfc_conv_procedure_call): Handle those.
+
+2013-03-28  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/45159
+	* gfortran.h (gfc_dep_difference):  Add prototype.
+	* dependency.c (discard_nops):  New function.
+	(gfc_dep_difference):  New function.
+	(check_section_vs_section):  Use gfc_dep_difference
+	to calculate the difference of starting indices.
+	* trans-expr.c (gfc_conv_substring):  Use
+	gfc_dep_difference to calculate the length of
+	substrings where possible.
+
+2013-03-28  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/55806
+	* frontend-passes.c (optimize_code):  Keep track of
+	current code to make code insertion possible.
+	(combine_array_constructor):  New function.
+	(optimize_op):  Call it.
+
+2013-03-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/56650
+	PR fortran/36437
+	* check.c (gfc_check_sizeof, gfc_check_c_sizeof,
+	gfc_check_storage_size): Update checks.
+	* intrinsic.texi (SIZEOF): Correct class.
+	* intrinsic.h (gfc_simplify_sizeof,
+	gfc_simplify_storage_size): New prototypes.
+	* intrinsic.c (add_functions): Use them.
+	* simplify.c (gfc_simplify_sizeof,
+	gfc_simplify_storage_size): New functions.
+
+2013-03-27  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	PR fortran/25708
+	* module.c (module_locus): Use long for position.
+	(module_content): New variable.
+	(module_pos): Likewise.
+	(prev_character): Remove.
+	(bad_module): Free data instead of closing mod file.
+	(set_module_locus): Use module_pos.
+	(get_module_locus): Likewise.
+	(module_char): use buffer rather than stdio file.
+	(module_unget_char): Likewise.
+	(read_module_to_tmpbuf): New function.
+	(gfc_use_module): Call read_module_to_tmpbuf.
+
+2013-03-26  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/56649
+	* simplify.c (gfc_simplify_merge): Simplify more.
+
+2013-03-25  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/38536
+	PR fortran/38813
+	PR fortran/38894
+	PR fortran/39288
+	PR fortran/40963
+	PR fortran/45824
+	PR fortran/47023
+	PR fortran/47034
+	PR fortran/49023
+	PR fortran/50269
+	PR fortran/50612
+	PR fortran/52426
+	PR fortran/54263
+	PR fortran/55343
+	PR fortran/55444
+	PR fortran/55574
+	PR fortran/56079
+	PR fortran/56378
+	* check.c (gfc_var_strlen): Properly handle 0-sized string.
+	(gfc_check_c_sizeof): Use is_c_interoperable, add checks.
+	(is_c_interoperable, gfc_check_c_associated, gfc_check_c_f_pointer,
+	gfc_check_c_f_procpointer, gfc_check_c_funloc, gfc_check_c_loc): New
+	functions.
+	* expr.c (check_inquiry): Add c_sizeof, compiler_version and
+	compiler_options.
+	(gfc_check_pointer_assign): Refine function result check.
+	gfortran.h (gfc_isym_id): Add GFC_ISYM_C_ASSOCIATED,
+	GFC_ISYM_C_F_POINTER, GFC_ISYM_C_F_PROCPOINTER, GFC_ISYM_C_FUNLOC,
+	GFC_ISYM_C_LOC.
+	(iso_fortran_env_symbol, iso_c_binding_symbol): Handle
+	NAMED_SUBROUTINE.
+	(generate_isocbinding_symbol): Update prototype.
+	(get_iso_c_sym): Remove.
+	(gfc_isym_id_by_intmod, gfc_isym_id_by_intmod_sym): New prototypes.
+	* intrinsic.c (gfc_intrinsic_subroutine_by_id): New function.
+	(gfc_intrinsic_sub_interface): Use it.
+	(add_functions, add_subroutines): Add missing C-binding intrinsics.
+	(gfc_intrinsic_func_interface): Add special case for c_loc.
+	gfc_isym_id_by_intmod, gfc_isym_id_by_intmod_sym): New functions.
+	(gfc_intrinsic_func_interface, gfc_intrinsic_sub_interface): Use them.
+	* intrinsic.h (gfc_check_c_associated, gfc_check_c_f_pointer,
+	gfc_check_c_f_procpointer, gfc_check_c_funloc, gfc_check_c_loc,
+	gfc_resolve_c_loc, gfc_resolve_c_funloc): New prototypes.
+	* iresolve.c (gfc_resolve_c_loc, gfc_resolve_c_funloc): New
+	functions.
+	* iso-c-binding.def: Split PROCEDURE into NAMED_SUBROUTINE and
+	NAMED_FUNCTION.
+	* iso-fortran-env.def: Add NAMED_SUBROUTINE for completeness.
+	* module.c (create_intrinsic_function): Support subroutines and
+	derived-type results.
+	(use_iso_fortran_env_module): Update calls.
+	(import_iso_c_binding_module): Ditto; update calls to
+	generate_isocbinding_symbol.
+	* resolve.c (find_arglists): Skip for intrinsic symbols.
+	(gfc_resolve_intrinsic): Find intrinsic subs via id.
+	(is_scalar_expr_ptr, gfc_iso_c_func_interface,
+	set_name_and_label, gfc_iso_c_sub_interface): Remove.
+	(resolve_function, resolve_specific_s0): Remove calls to those.
+	(resolve_structure_cons): Fix handling.
+	* symbol.c (gen_special_c_interop_ptr): Update c_ptr/c_funptr
+	generation.
+	(gen_cptr_param, gen_fptr_param, gen_shape_param,
+	build_formal_args, get_iso_c_sym): Remove.
+	(std_for_isocbinding_symbol): Handle NAMED_SUBROUTINE.
+	(generate_isocbinding_symbol): Support hidden symbols and
+	using c_ptr/c_funptr symtrees for nullptr defs.
+	* target-memory.c (gfc_target_encode_expr): Fix handling
+	of c_ptr/c_funptr.
+	* trans-expr.c (conv_isocbinding_procedure): Remove.
+	(gfc_conv_procedure_call): Remove call to it.
+	(gfc_trans_subcomponent_assign, gfc_conv_expr): Update handling
+	of c_ptr/c_funptr.
+	* trans-intrinsic.c (conv_isocbinding_function,
+	conv_isocbinding_subroutine): New.
+	(gfc_conv_intrinsic_function, gfc_conv_intrinsic_subroutine):
+	Call them.
+	* trans-io.c (transfer_expr): Fix handling of c_ptr/c_funptr.
+	* trans-types.c (gfc_typenode_for_spec,
+	gfc_get_derived_type): Ditto.
+	(gfc_init_c_interop_kinds): Handle NAMED_SUBROUTINE.
+
+2013-03-18  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.h (gfc_option_t): Remove flag_whole_file.
+	* invoke.texi (-fno-whole-file): Remove.
+	* lang.opt (fwhole-file): Change to Ignore.
+	* options.c (gfc_init_options, gfc_post_options,
+	gfc_handle_option): Remove !flag_whole_file handling
+	* parse.c (resolve_all_program_units, translate_all_program_units,
+	gfc_parse_file): Ditto.
+	* resolve.c (resolve_global_procedure): Ditto.
+	* trans-decl.c (gfc_get_symbol_decl, gfc_get_extern_function_decl,
+	gfc_create_module_variable): Ditto.
+	* trans-types.c (gfc_get_derived_type): Ditto.
+
+2013-03-15  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/56615
+	* trans-intrinsic.c (gfc_conv_intrinsic_transfer): Pack arrays
+	if they are not simply contiguous.
+
+2013-03-11  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.texi (STRUCTURE and RECORD): State more clearly how
+	to convert them into derived types.
+
+2013-03-10  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/56575
+	* expr.c (gfc_default_initializer): Check that a class declared
+	type has any components.
+	* resolve.c (resolve_fl_derived0): On failing the test for C437
+	set the type to BT_UNKNOWN to prevent repeat error messages.
+
+2013-03-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/56477
+	* expr.c (gfc_check_pointer_assign): Avoid NULL pointer dereference.
+
+2013-03-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/54730
+	* array.c (gfc_match_array_constructor): Set a checkpoint before
+	matching a typespec.  Drop it on success, restore it otherwise.
+
+2013-03-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/54730
+	* gfortran.h (struct gfc_undo_change_set): New field 'previous'.
+	(gfc_new_undo_checkpoint, gfc_drop_last_undo_checkpoint,
+	gfc_restore_last_undo_checkpoint): New prototypes.
+	* symbol.c (default_undo_chgset_var): Update initialization.
+	(single_undo_checkpoint_p, gfc_new_undo_checkpoint,
+	free_undo_change_set_data, pop_undo_change_set,
+	gfc_drop_last_undo_checkpoint, enforce_single_undo_checkpoint):
+	New functions.
+	(save_symbol_data): Handle multiple change sets.  Make sure old_symbol
+	field's previous value is not overwritten.  Clear gfc_new field.
+	(restore_old_symbol): Restore previous old_symbol field.
+	(gfc_restore_last_undo_checkpoint): New function, using body renamed
+	from gfc_undo_symbols.  Restore the previous change set as current one.
+	(gfc_undo_symbols): New body.
+	(gfc_commit_symbols, gfc_commit_symbol, gfc_enforce_clean_symbol_state):
+	Call enforce_single_undo_checkpoint.
+	(gfc_symbol_done_2): Ditto.  Free change set data.
+
+2013-03-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* symbol.c (restore_old_symbol): Fix thinko.
+
+2013-03-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* symbol.c (gfc_undo_symbols): Move code...
+	(restore_old_symbol): ... here as a new function.
+
+2013-03-03  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* Make-lang.in (F95_PARSER_OBJS): Add dependency to vec.h.
+	* gfortran.h: Include vec.h.
+	(gfc_undo_change_set): New struct.
+	* symbol.c (tentative_tbp): Remove struct.
+	(changed_syms, tentative_tbp_list): Remove variables.
+	(default_undo_chgset_var, latest_undo_chgset): New variables.
+	(save_symbol_data, gfc_get_sym_tree, gfc_undo_symbols,
+	gfc_commit_symbols, gfc_commit_symbol,
+	gfc_enforce_clean_symbol_state, gfc_get_typebound_proc):
+	Use latest_undo_chgset instead of changed_syms and tentative_tbp_list.
+
+2013-03-01  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/56491
+	* iresolve.c (resolve_bound): Use gfc_get_string instead of xstrdup.
+	* symbol.c (free_components): Free proc-pointer components.
+
+2013-03-01  Tobias Burnus  <burnus@net-b.de>
+
+	* trans-decl.c (gfc_trans_deferred_vars): Free expr after use.
+	* trans-io.c (build_dt): Ditto.
+
+2013-02-24  Joseph Myers  <joseph@codesourcery.com>
+
+	* resolve.c (generate_component_assignments): Don't use UTF-8
+	ligature in diagnostic.
+
+2013-02-21  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/56385
+	* trans-array.c (structure_alloc_comps): Handle procedure-pointer
+	components with allocatable result.
+
+2013-02-21  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/56416
+	* gfortran.texi (Part II: Language Reference, Extensions,
+	Non-Fortran Main Program): Sort @menu to match actual section order.
+	* intrinsic.texi (Intrinsic Procedures): Ditto.
+	(C_F_POINTER, PRECISION): Move to the alphabetically correct place.
+
+2013-02-15  Tobias Burnus  <burnus@net-b.de>
+	    Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/56318
+	* simplify.c (gfc_simplify_matmul): Fix result shape
+	and matmul result.
+
+2013-02-15  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/53818
+	* resolve.c (apply_default_init_local): Don't create an
+	initializer for a result variable.
+
+2013-02-14  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/56224
+	* gfortran.h (gfc_add_include_path):  Add boolean argument
+	for warn.
+	* scanner.c (gfc_add_include_path):  Pass along warn argument
+	to add_path_to_list.
+	* options.c (gfc_post_options):  Add true warn argument to
+	gfc_add_include_path.
+	(gfc_handle_module_path_options):  Likewise.
+	(gfc_handle_option): Also gfc_add_include_path for intrinsic
+	modules, without warning.
+
+2013-02-14  Paul Thomas  <pault@gcc.gnu.org>
+	    Tobias Burnus  <burnus@net-b.de>
+
+	PR testsuite/56138
+	* trans-decl.c (gfc_get_symbol_decl): Fix deferred-length
+	results for functions without extra result variable.
+
+	Revert:
+	2013-01-30  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/56138
+	* trans-decl.c (gfc_trans_deferred_vars): Fix deferred-length
+	results for functions without extra result variable.
+
+2013-02-12  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/46952
+	* resolve.c (resolve_call): Do not check deferred procedures for
+	recursiveness.
+
+2013-02-09  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/55362
+	* check.c (array_check): It is an error if a procedure is
+	passed.
+
+2013-02-08  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/54107
+	* trans-types.c (gfc_get_function_type): Change a NULL backend_decl
+	to error_mark_node on entry.  Detect recursive types.  Build a variadic
+	procedure type if the type is recursive.  Restore the initial
+	backend_decl.
+
+2013-02-07  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54339
+	* gfortran.texi (Standards): Mention TS29113.
+	(Varying Length Character): Mention deferred-length
+	strings.
+	(Fortran 2003 Status): Add unlimited polymorphic.
+	(TS 29113 Status): Add TYPE(*) and DIMENSION(..).
+	(C Interop): Update the section about TS29113.
+
+2013-02-06  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/55789
+	* trans-array.c (trans_array_constructor): Remove condition
+	'dynamic' = true if the loop ubound is a VAR_DECL.
+
+2013-02-04  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/56008
+	PR fortran/47517
+	* trans-array.c (gfc_alloc_allocatable_for_assignment): Save
+	the lhs descriptor before it is modified for reallocation. Use
+	it to deallocate allocatable components in the reallocation
+	block.  Nullify allocatable components for newly (re)allocated
+	arrays.
+
+2013-02-04  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/54195
+	* resolve.c (resolve_typebound_procedures): Recurse through
+	resolve_symbol.
+
+2013-02-04  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/54107
+	PR fortran/54195
+	* gfortran.h (struct gfc_symbol): New field 'resolved'.
+	* resolve.c (resolve_fl_var_and_proc): Don't skip result symbols.
+	(resolve_symbol): Skip duplicate calls.  Don't check the current
+	namespace.
+
+2013-02-02  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/50627
+	PR fortran/56054
+	* decl.c (gfc_match_end):  Remove half-ready namespace
+	from parent if the end of a block is missing.
+	* parse.c (parse_module):  Do not put namespace into
+	gsymbol on error.
+
+2013-01-30  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/56138
+	* trans-decl.c (gfc_trans_deferred_vars): Fix deferred-length
+	results for functions without extra result variable.
+
+2013-01-29  Janus Weil  <janus@gcc.gnu.org>
+	    Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/54107
+	* gfortran.h (gfc_component): Delete members 'formal' and 'formal_ns'.
+	(gfc_copy_formal_args,gfc_copy_formal_args_ppc,gfc_expr_replace_symbols,
+	gfc_expr_replace_comp): Delete.
+	(gfc_sym_get_dummy_args): New prototype.
+	* dependency.c (gfc_check_fncall_dependency): Use
+	'gfc_sym_get_dummy_args'.
+	* expr.c (gfc_is_constant_expr): Ditto.
+	(replace_symbol,gfc_expr_replace_symbols,replace_comp,
+	gfc_expr_replace_comp): Deleted.
+	* frontend-passes.c (doloop_code,do_function): Use
+	'gfc_sym_get_dummy_args'.
+	* interface.c (gfc_check_operator_interface,gfc_compare_interfaces,
+	gfc_procedure_use,gfc_ppc_use,gfc_arglist_matches_symbol,
+	gfc_check_typebound_override): Ditto.
+	* module.c (MOD_VERSION): Bump module version.
+	(mio_component): Do not read/write 'formal' and 'formal_ns'.
+	* resolve.c (resolve_procedure_interface,resolve_fl_derived0): Do not
+	copy formal args, but just keep a pointer to the interface.
+	(resolve_function,resolve_call,resolve_typebound_generic_call,
+	resolve_ppc_call,resolve_expr_ppc,generate_component_assignments,
+	resolve_fl_procedure,gfc_resolve_finalizers,check_generic_tbp_ambiguity,
+	resolve_typebound_procedure,check_uop_procedure): Use
+	'gfc_sym_get_dummy_args'.
+	* symbol.c (free_components): Do not free 'formal' and 'formal_ns'.
+	(gfc_copy_formal_args,gfc_copy_formal_args_ppc): Deleted.
+	(gfc_sym_get_dummy_args): New function.
+	* trans-array.c (get_array_charlen,gfc_walk_elemental_function_args):
+	Use 'gfc_sym_get_dummy_args'.
+	* trans-decl.c (build_function_decl,create_function_arglist,
+	build_entry_thunks,init_intent_out_dt,gfc_trans_deferred_vars,
+	add_argument_checking): Ditto.
+	* trans-expr.c (gfc_map_fcn_formal_to_actual,gfc_conv_procedure_call,
+	gfc_conv_statement_function): Ditto.
+	* trans-stmt.c (gfc_conv_elemental_dependencies): Ditto.
+	* trans-types.c (create_fn_spec,gfc_get_function_type): Ditto.
+
+2013-01-28  Tobias Burnus  <burnus@net-b.de>
+	    Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/53537
+	* symbol.c (gfc_find_sym_tree): Don't look for the symbol outside an
+	interface block.
+	(gfc_get_ha_symtree): Let gfc_find_sym_tree lookup the parent namespace.
+	* decl.c (gfc_match_data_decl): Ditto.
+	(variable_decl): Remove undeclared type error.
+	(gfc_match_import): Use renamed instead of original name.
+
+2013-01-27  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/55984
+	PR fortran/56047
+	* gfortran.h : Add associate_var to symbol_attr.
+	* resolve.c (resolve_assoc_var): Set associate_var attribute.
+	If the target class_ok is set, set it for the associate
+	variable.
+	* check.c (allocatable_check): Associate variables should not
+	have the allocatable attribute even if their symbols do.
+	* class.c (gfc_build_class_symbol): Symbols with associate_var
+	set will always have a good class container.
+
+2013-01-23  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/56081
+	* resolve.c (resolve_select): Add argument 'select_type', reject
+	non-scalar expressions.
+	(resolve_select_type,resolve_code): Pass new argument to
+	'resolve_select'.
+
+2013-01-23  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/56052
+	* trans-decl.c (gfc_get_symbol_decl): Set DECL_ARTIFICIAL
+	and DECL_IGNORED_P on select_type_temporary and don't set
+	DECL_BY_REFERENCE.
+
+2013-01-21  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/55919
+	* scanner.c (add_path_to_list): Copy path to temporary and strip
+	trailing directory separators before calling stat().
+
+2013-01-17  Richard Biener  <rguenther@suse.de>
+
+	* trans-stmt.c (gfc_trans_do): Conditionally compute countm1
+	dependent on sign of step, avoids repeated evaluation of
+	step sign test.  Avoid undefined overflow issues by using unsigned
+	arithmetic.
+
+2013-01-16  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/55983
+	* class.c (find_typebound_proc_uop): Check for f2k_derived instead of
+	asserting it.
+
+2013-01-16  Jakub Jelinek  <jakub@redhat.com>
+	    Tobias Burnus  <burnus@net-b.de>
+
+	PR driver/55884
+	* lang.opt (fintrinsic-modules-path): Don't accept Joined.
+	(fintrinsic-modules-path=): New.
+	* options.c (gfc_handle_option, gfc_get_option_string,
+	gfc_get_option_string): Handle the latter.
+
+2013-01-16  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/52865
+	* trans-stmt.c (gfc_trans_do): Put countm1-- before conditional
+	and use value of countm1 before the decrement in the condition.
+
+2013-01-15  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/54286
+	* expr.c (gfc_check_pointer_assign): Check for presence of
+	's2' before using it.
+
+2013-01-14  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/55806
+	* frontend-passes.c (optimize_reduction):  New function,
+	including prototype.
+	(callback_reduction):  Likewise.
+	(gfc_run_passes):  Also run optimize_reduction.
+	(copy_walk_reduction_arg):  New function.
+	(dummy_code_callback):  New function.
+
+2013-01-13  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/55935
+	* trans-expr.c (gfc_conv_structure): Call
+	unshare_expr_without_location on the ctor elements.
+
+2013-01-13  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/54286
+	* expr.c (gfc_check_pointer_assign): Ensure that both lvalue
+	and rvalue interfaces are presented to gfc_compare_interfaces.
+	Simplify references to interface names by using the symbols
+	themselves. Call gfc_compare_interfaces with s1 and s2 inter-
+	changed to overcome the asymmetry of this function. Do not
+	repeat the check for the presence of s1 and s2.
+
+2013-01-12  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/55072
+	* trans-array.c (gfc_conv_array_parameter): No packing was done for
+	full arrays of derived type.
+
+2013-01-08  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/55868
+	* class.c (get_unique_type_string): Change $tar to STAR and
+	replace sprintf by strcpy where there is no formatting.
+	* decl.c (gfc_match_decl_type_spec): Change $tar to STAR.
+
+2013-01-09  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/47203
+	* module.c (check_for_ambiguous): Get the current program unit using
+	gfc_current_ns.
+
+2013-01-09  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/55758
+	* resolve.c (resolve_symbol): Reject non-C_Bool logicals
+	in BIND(C) procedures with -std=f*.
+
+2013-01-08  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/55618
+	* trans-expr.c (gfc_conv_procedure_call): Dereference scalar
+	character function arguments to elemental procedures in
+	scalarization loops.
+
+2013-01-07  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/55763
+	* gfortran.h (gfc_check_assign_symbol): Update prototype.
+	* decl.c (add_init_expr_to_sym, do_parm): Update call.
+	* expr.c (gfc_check_assign_symbol): Handle BT_CLASS and
+	improve error location; support components.
+	(gfc_check_pointer_assign): Handle component assignments.
+	* resolve.c (resolve_fl_derived0): Call gfc_check_assign_symbol.
+	(resolve_values): Update call.
+	(resolve_structure_cons): Avoid double diagnostic.
+
+2013-01-07  Tobias Burnus  <burnus@net-b.de>
+	    Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/55852
+	* expr.c (gfc_build_intrinsic_call): Avoid clashes
+	with user's procedures.
+	* gfortran.h (gfc_build_intrinsic_call): Update prototype.
+	* simplify.c (gfc_simplify_size): Update call.
+	* class.c (finalization_scalarizer, finalization_get_offset,
+	finalizer_insert_packed_call, generate_finalization_wrapper):
+	Clean up by using gfc_build_intrinsic_call.
+
+2013-01-07  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/55763
+	* resolve.c (resolve_select_type): Reject intrinsic types for
+	a non-unlimited-polymorphic selector.
+
+2013-01-06  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/53876
+	PR fortran/54990
+	PR fortran/54992
+	* trans-array.c (build_array_ref): Check the TYPE_CANONICAL
+	to see if it is GFC_CLASS_TYPE_P.
+	* trans-expr.c (gfc_get_vptr_from_expr): The same.
+	(gfc_conv_class_to_class): If the types are not the same,
+	cast parmese->expr to the type of ctree.
+	* trans-types.c (gfc_get_derived_type): GFC_CLASS_TYPE_P of
+	CLASS components must be set.
+
+2013-01-06  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/42769
+	PR fortran/45836
+	PR fortran/45900
+	* module.c (read_module): Don't reuse local symtree if the associated
+	symbol isn't exactly the one wanted.  Don't reuse local symtree if it is
+	ambiguous.
+	* resolve.c (resolve_call): Use symtree's name instead of symbol's to
+	lookup the symtree.
+
+2013-01-05  Steven G. Kargl  <kargl@gcc.gnu.org>
+	    Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/55827
+	* class.c (gfc_fix_class_refs): Adapt ts initialization for the case
+	e->symtree == NULL.
+	* trans-expr.c (gfc_conv_function_expr): Init sym earlier. Use it.
+
+2013-01-05  Tobias Burnus  <burnus@net-b.de>
+
+	* class.c (finalize_component): Used passed offset expr.
+	(finalization_get_offset): New static function.
+	(finalizer_insert_packed_call, generate_finalization_wrapper): Use it
+	to handle noncontiguous arrays.
+
+2013-01-04  Tobias Burnus  <burnus@net-b.de>
+
+	* trans.c (gfc_build_final_call): New function.
+	* trans.h (gfc_build_final_call, gfc_conv_scalar_to_descriptor):
+	New function prototypes.
+	* trans-expr.c (gfc_conv_scalar_to_descriptor): Renamed from
+	conv_scalar_to_descriptor, removed static attribute.
+	(gfc_conv_procedure_call): Honor renaming.
+
+2013-01-04  Tobias Burnus  <burnus@net-b.de>
+
+	* intrinsic.c (add_functions): New internal intrinsic
+	function GFC_PREFIX ("stride").
+	* gfortran.h (gfc_isym_id): Add GFC_ISYM_STRIDE.
+	* intrinsic.h (gfc_resolve_stride): New prototypes.
+	* iresolve.c (gfc_resolve_stride): New function.
+	* trans-intrinsic.c (conv_intrinsic_stride): New static
+	function.
+	(gfc_conv_intrinsic_function): Use it.
+
+2013-01-04  Tobias Burnus  <burnus@net-b.de>
+
+	* class.c (gfc_find_intrinsic_vtab): Add _final
+	component.
+	* decl.c (gfc_match_null): Remove superfluous
+	variadic argument to gfc_match.
+
+2013-01-04  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/55172
+	* match.c (copy_ts_from_selector_to_associate): Remove call to
+	gfc_resolve_expr and replace it with explicit setting of the
+	array reference type.
+	* resolve.c (resolve_select_type): It is an error if the
+	selector is coindexed.
+
+2013-01-04  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/55763
+	* decl.c (gfc_match_null): Parse and reject MOLD.
+
+2013-01-04  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/55854
+	PR fortran/55763
+	* class.c (gfc_class_null_initializer): Fix finding the vtab.
+	(gfc_find_intrinsic_vtab): Use BT_VOID for some components.
+
+2013-01-03  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/55855
+	* expr.c (gfc_check_assign): Use 'gfc_expr_attr' to evaluate attributes
+	of rvalue. Correct hyphenation in error message.
+
+2013-01-03  Jakub Jelinek  <jakub@redhat.com>
+
+	* gfortranspec.c (lang_specific_driver): Update copyright notice
+	dates.
+
+Copyright (C) 2013 Free Software Foundation, Inc.
+
+Copying and distribution of this file, with or without modification,
+are permitted in any medium without royalty provided the copyright
+notice and this notice are preserved.
diff --git a/gcc-4.9/gcc/fortran/ChangeLog.ptr b/gcc-4.9/gcc/fortran/ChangeLog.ptr
new file mode 100644
index 000000000..c8d8527f9
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/ChangeLog.ptr
@@ -0,0 +1,17 @@
+2007-05-15  Andrew Pinski  <andrew_pinski@playstation.sony.com>
+
+	* trans-intrinsic.c (gfc_conv_intrinsic_repeat): Use
+	POINTER_PLUS_EXPR instead of PLUS_EXPR for pointer addition.
+
+2007-05-07  Andrew Pinski  <andrew_pinski@playstation.sony.com>
+
+	* trans-expr.c (gfc_trans_string_copy): Create
+	POINTER_PLUS_EXPR instead of a PLUS_EXPR
+	for pointer types.
+
+
+Copyright (C) 2007 Free Software Foundation, Inc.
+
+Copying and distribution of this file, with or without modification,
+are permitted in any medium without royalty provided the copyright
+notice and this notice are preserved.
diff --git a/gcc-4.9/gcc/fortran/Make-lang.in b/gcc-4.9/gcc/fortran/Make-lang.in
new file mode 100644
index 000000000..f8287bd46
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/Make-lang.in
@@ -0,0 +1,313 @@
+# -*- makefile -*-
+# Top level makefile fragment for GNU gfortran, the GNU Fortran 95 compiler.
+# Copyright (C) 2002-2014 Free Software Foundation, Inc.
+# Contributed by Paul Brook <paul@nowt.org
+# and Steven Bosscher <s.bosscher@student.tudelft.nl>
+
+#This file is part of GCC.
+
+#GCC is free software; you can redistribute it and/or modify
+#it under the terms of the GNU General Public License as published by
+#the Free Software Foundation; either version 3, or (at your option)
+#any later version.
+
+#GCC is distributed in the hope that it will be useful,
+#but WITHOUT ANY WARRANTY; without even the implied warranty of
+#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+#GNU General Public License for more details.
+
+#You should have received a copy of the GNU General Public License
+#along with GCC; see the file COPYING3.  If not see
+#<http://www.gnu.org/licenses/>.
+
+# This file provides the language dependent support in the main Makefile.
+# Each language makefile fragment must provide the following targets:
+#
+# foo.all.cross, foo.start.encap, foo.rest.encap,
+# foo.install-common, foo.install-man, foo.install-info, foo.install-pdf,
+# foo.install-html, foo.info, foo.dvi, foo.pdf, foo.html, foo.uninstall,
+# foo.mostlyclean, foo.clean, foo.distclean,
+# foo.maintainer-clean, foo.stage1, foo.stage2, foo.stage3, foo.stage4
+#
+# where `foo' is the name of the language.
+#
+# It should also provide rules for:
+#
+# - making any compiler driver (eg: gfortran)
+# - the compiler proper (eg: f951)
+# - define the names for selecting the language in LANGUAGES.
+# $(srcdir) must be set to the gcc/ source directory (*not* gcc/fortran/).
+
+# Actual name to use when installing a native compiler.
+GFORTRAN_INSTALL_NAME := $(shell echo gfortran|sed '$(program_transform_name)')
+GFORTRAN_TARGET_INSTALL_NAME := $(target_noncanonical)-$(shell echo gfortran|sed '$(program_transform_name)')
+
+#^L
+
+# Use strict warnings for this front end.
+fortran-warn = $(STRICT_WARN)
+
+# These are the groups of object files we have.  The F95_PARSER_OBJS are
+# all the front end files, the F95_OBJS are the files for the translation
+# from the parse tree to GENERIC
+
+F95_PARSER_OBJS = fortran/arith.o fortran/array.o fortran/bbt.o \
+    fortran/check.o fortran/class.o fortran/constructor.o fortran/cpp.o \
+    fortran/data.o fortran/decl.o fortran/dump-parse-tree.o fortran/error.o \
+    fortran/expr.o fortran/interface.o fortran/intrinsic.o fortran/io.o \
+    fortran/iresolve.o fortran/match.o fortran/matchexp.o fortran/misc.o \
+    fortran/module.o fortran/openmp.o fortran/options.o fortran/parse.o \
+    fortran/primary.o fortran/resolve.o fortran/scanner.o fortran/simplify.o \
+    fortran/st.o fortran/symbol.o fortran/target-memory.o
+
+F95_OBJS = $(F95_PARSER_OBJS) $(FORTRAN_TARGET_OBJS) \
+    fortran/convert.o fortran/dependency.o fortran/f95-lang.o \
+    fortran/trans.o fortran/trans-array.o fortran/trans-common.o \
+    fortran/trans-const.o fortran/trans-decl.o fortran/trans-expr.o \
+    fortran/trans-intrinsic.o fortran/trans-io.o fortran/trans-openmp.o \
+    fortran/trans-stmt.o fortran/trans-types.o fortran/frontend-passes.o
+
+fortran_OBJS = $(F95_OBJS) fortran/gfortranspec.o
+
+#
+# Define the names for selecting gfortran in LANGUAGES.
+fortran: f951$(exeext)
+
+# Tell GNU make to ignore files by these names if they exist.
+.PHONY: fortran
+
+CFLAGS-fortran/gfortranspec.o += $(DRIVER_DEFINES)
+
+# Create the compiler driver gfortran.
+GFORTRAN_D_OBJS = $(GCC_OBJS) fortran/gfortranspec.o
+gfortran$(exeext): $(GFORTRAN_D_OBJS) $(EXTRA_GCC_OBJS) libcommon-target.a \
+	$(LIBDEPS)
+	+$(LINKER) $(ALL_LINKERFLAGS) $(LDFLAGS) -o $@ \
+	  $(GFORTRAN_D_OBJS) $(EXTRA_GCC_OBJS) libcommon-target.a \
+	  $(EXTRA_GCC_LIBS) $(LIBS)
+
+# Create a version of the gfortran driver which calls the cross-compiler.
+gfortran-cross$(exeext): gfortran$(exeext)
+	-rm -f gfortran-cross$(exeext)
+	cp gfortran$(exeext) gfortran-cross$(exeext)
+
+# The compiler itself is called f951.
+f951$(exeext): $(F95_OBJS) \
+		$(BACKEND) $(LIBDEPS) attribs.o
+	+$(LLINKER) $(ALL_LINKERFLAGS) $(LDFLAGS) -o $@ \
+		$(F95_OBJS) $(BACKEND) $(ZLIB) $(LIBS) attribs.o \
+		$(BACKENDLIBS)
+
+gt-fortran-trans.h    : s-gtype; @true
+#
+# Build hooks:
+
+fortran.all.cross: gfortran-cross$(exeext)
+
+fortran.start.encap: gfortran$(exeext)
+fortran.rest.encap:
+
+fortran.srcinfo: doc/gfortran.info
+	-cp -p $^ $(srcdir)/fortran
+
+fortran.tags: force
+	cd $(srcdir)/fortran; etags -o TAGS.sub *.c *.h; \
+	etags --include TAGS.sub --include ../TAGS.sub
+
+fortran.info: doc/gfortran.info doc/gfc-internals.info
+fortran.dvi: doc/gfortran.dvi doc/gfc-internals.dvi
+
+F95_HTMLFILES = $(build_htmldir)/gfortran
+
+fortran.html: $(F95_HTMLFILES)/index.html
+
+fortran.install-html: $(F95_HTMLFILES)
+	@$(NORMAL_INSTALL)
+	test -z "$(htmldir)" || $(mkinstalldirs) "$(DESTDIR)$(htmldir)"
+	@list='$(F95_HTMLFILES)'; for p in $$list; do \
+	  if test -f "$$p" || test -d "$$p"; then d=""; else d="$(srcdir)/"; fi; \
+	  f=$(html__strip_dir) \
+	  if test -d "$$d$$p"; then \
+	    echo " $(mkinstalldirs) '$(DESTDIR)$(htmldir)/$$f'"; \
+	    $(mkinstalldirs) "$(DESTDIR)$(htmldir)/$$f" || exit 1; \
+	    echo " $(INSTALL_DATA) '$$d$$p'/* '$(DESTDIR)$(htmldir)/$$f'"; \
+	    $(INSTALL_DATA) "$$d$$p"/* "$(DESTDIR)$(htmldir)/$$f"; \
+	  else \
+	    echo " $(INSTALL_DATA) '$$d$$p' '$(DESTDIR)$(htmldir)/$$f'"; \
+	    $(INSTALL_DATA) "$$d$$p" "$(DESTDIR)$(htmldir)/$$f"; \
+	  fi; \
+	done
+
+F95_PDFFILES = doc/gfortran.pdf
+
+fortran.pdf: $(F95_PDFFILES) doc/gfc-internals.pdf
+
+fortran.install-pdf: $(F95_PDFFILES)
+	@$(NORMAL_INSTALL)
+	test -z "$(pdfdir)/gcc" || $(mkinstalldirs) "$(DESTDIR)$(pdfdir)/gcc"
+	@list='$(F95_PDFFILES)'; for p in $$list; do \
+	  if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \
+	  f=$(pdf__strip_dir) \
+	  echo " $(INSTALL_DATA) '$$d$$p' '$(DESTDIR)$(pdfdir)/gcc/$$f'"; \
+	  $(INSTALL_DATA) "$$d$$p" "$(DESTDIR)$(pdfdir)/gcc/$$f"; \
+	done
+
+F95_MANFILES = doc/gfortran.1
+
+fortran.man: $(F95_MANFILES)
+
+fortran.srcman: $(F95_MANFILES)
+	-cp -p $^ $(srcdir)/doc
+
+fortran.srcextra:
+
+check-f95 : check-gfortran
+check-fortran : check-gfortran
+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.
+check_gfortran_parallelize = dg.exp=gfortran.dg/\[adAD\]* \
+			     dg.exp=gfortran.dg/\[bcBC\]* \
+			     dg.exp=gfortran.dg/\[nopNOP\]* \
+			     dg.exp=gfortran.dg/\[isuvISUV\]* \
+			     dg.exp=gfortran.dg/\[efhkqrxzEFHKQRXZ\]* \
+			     dg.exp=gfortran.dg/\[0-9gjlmtwyGJLMTWY\]*
+
+# GFORTRAN documentation.
+GFORTRAN_TEXI = \
+  $(srcdir)/fortran/gfortran.texi \
+  $(srcdir)/fortran/intrinsic.texi \
+  $(srcdir)/fortran/invoke.texi \
+  $(srcdir)/doc/include/fdl.texi \
+  $(srcdir)/doc/include/gpl_v3.texi \
+  $(srcdir)/doc/include/funding.texi \
+  $(srcdir)/doc/include/gcc-common.texi \
+  gcc-vers.texi
+
+doc/gfortran.info: $(GFORTRAN_TEXI)
+	if [ x$(BUILD_INFO) = xinfo ]; then \
+	  rm -f doc/gfortran.info-*; \
+	  $(MAKEINFO) -I $(srcdir)/doc/include -I $(srcdir)/fortran \
+	    -o $@ $<; \
+	else true; fi
+
+doc/gfortran.dvi: $(GFORTRAN_TEXI)
+	$(TEXI2DVI) -I $(srcdir)/fortran -I $(abs_docdir)/include -o $@ $<
+
+doc/gfortran.pdf: $(GFORTRAN_TEXI)
+	$(TEXI2PDF) -I $(srcdir)/fortran -I $(abs_docdir)/include -o $@ $<
+
+$(build_htmldir)/gfortran/index.html: $(GFORTRAN_TEXI)
+	$(mkinstalldirs) $(@D)
+	rm -f $(@D)/*
+	$(TEXI2HTML) -I $(gcc_docdir)/include -I $(srcdir)/fortran -o $(@D) $<
+
+.INTERMEDIATE: gfortran.pod
+
+gfortran.pod: $(GFORTRAN_TEXI)
+	-$(TEXI2POD) -DBUGURL="$(BUGURL_TEXI)" \
+	  < $(srcdir)/fortran/invoke.texi > $@
+
+# GFORTRAN internals documentation.
+GFC_INTERNALS_TEXI = \
+  $(srcdir)/fortran/gfc-internals.texi \
+  $(srcdir)/doc/include/fdl.texi \
+  $(srcdir)/doc/include/gcc-common.texi \
+  gcc-vers.texi
+
+doc/gfc-internals.info: $(GFC_INTERNALS_TEXI)
+	if [ x$(BUILD_INFO) = xinfo ]; then \
+	  rm -f doc/gfc-internals.info-*; \
+	  $(MAKEINFO) -I $(srcdir)/doc/include -I $(srcdir)/fortran \
+	    -o $@ $<; \
+	else true; fi
+
+doc/gfc-internals.dvi: $(GFC_INTERNALS_TEXI)
+	$(TEXI2DVI) -I $(srcdir)/fortran -I $(abs_docdir)/include -o $@ $<
+
+doc/gfc-internals.pdf: $(GFC_INTERNALS_TEXI)
+	$(TEXI2PDF) -I $(srcdir)/fortran -I $(abs_docdir)/include -o $@ $<
+
+# Create or recreate the gfortran private include file directory.
+install-finclude-dir: installdirs
+	$(mkinstalldirs) -m 0755 $(DESTDIR)$(libsubdir)/finclude
+#
+# Install hooks:
+# f951 is installed elsewhere as part of $(COMPILERS).
+
+# Install the driver program as $(target)-gfortran, and also as gfortran
+# if native.
+fortran.install-common: install-finclude-dir installdirs
+	-if [ -f f951$(exeext) ] ; then \
+	  rm -f $(DESTDIR)$(bindir)/$(GFORTRAN_INSTALL_NAME)$(exeext); \
+	  $(INSTALL_PROGRAM) gfortran$(exeext) $(DESTDIR)$(bindir)/$(GFORTRAN_INSTALL_NAME)$(exeext); \
+	  chmod a+x $(DESTDIR)$(bindir)/$(GFORTRAN_INSTALL_NAME)$(exeext); \
+	  if [ ! -f gfortran-cross$(exeext) ] ; then \
+	    rm -f $(DESTDIR)$(bindir)/$(GFORTRAN_TARGET_INSTALL_NAME)$(exeext); \
+	    $(LN) $(DESTDIR)$(bindir)/$(GFORTRAN_INSTALL_NAME)$(exeext) $(DESTDIR)$(bindir)/$(GFORTRAN_TARGET_INSTALL_NAME)$(exeext); \
+	  fi ; \
+	fi
+
+fortran.install-plugin:
+
+fortran.install-info: $(DESTDIR)$(infodir)/gfortran.info
+
+fortran.install-man: $(DESTDIR)$(man1dir)/$(GFORTRAN_INSTALL_NAME)$(man1ext)
+
+$(DESTDIR)$(man1dir)/$(GFORTRAN_INSTALL_NAME)$(man1ext): doc/gfortran.1 \
+		installdirs
+	-rm -f $@
+	-$(INSTALL_DATA) $< $@
+	-chmod a-x $@
+
+fortran.uninstall:
+	if $(SHELL) -c 'install-info --version | sed 1q | fgrep -s -v -i debian' >/dev/null 2>&1; then \
+	  echo " install-info --delete --info-dir=$(DESTDIR)$(infodir) $(DESTDIR)$(infodir)/gfortran.info"; \
+	  install-info --delete --info-dir=$(DESTDIR)$(infodir) $(DESTDIR)$(infodir)/gfortran.info || : ; \
+	else : ; fi; \
+	rm -rf $(DESTDIR)$(bindir)/$(GFORTRAN_INSTALL_NAME)$(exeext); \
+	rm -rf $(DESTDIR)$(man1dir)/$(GFORTRAN_INSTALL_NAME)$(man1ext); \
+	rm -rf $(DESTDIR)$(bindir)/$(GFORTRAN_TARGET_INSTALL_NAME)$(exeext); \
+	rm -rf $(DESTDIR)$(infodir)/gfortran.info*
+
+#
+# Clean hooks:
+# A lot of the ancillary files are deleted by the main makefile.
+# We just have to delete files specific to us.
+
+fortran.mostlyclean:
+	-rm -f f951$(exeext)
+	-rm -f fortran/*.o
+
+fortran.clean:
+fortran.distclean:
+	-rm -f fortran/config.status fortran/Makefile
+
+fortran.extraclean:
+fortran.maintainer-clean:
+	-rm -f doc/gfortran.info* fortran/gfortran.*aux
+	-rm -f $(docobjdir)/gfortran.1
+
+#
+# Stage hooks:
+# The toplevel makefile has already created stage?/fortran at this point.
+
+fortran.stage1: stage1-start
+	-mv fortran/*$(objext) stage1/fortran
+fortran.stage2: stage2-start
+	-mv fortran/*$(objext) stage2/fortran
+fortran.stage3: stage3-start
+	-mv fortran/*$(objext) stage3/fortran
+fortran.stage4: stage4-start
+	-mv fortran/*$(objext) stage4/fortran
+fortran.stageprofile: stageprofile-start
+	-mv fortran/*$(objext) stageprofile/fortran
+fortran.stagefeedback: stageprofile-start
+	-mv fortran/*$(objext) stagefeedback/fortran
+
+#
+
+CFLAGS-fortran/cpp.o += $(TARGET_SYSTEM_ROOT_DEFINE)
+CFLAGS-fortran/module.o += $(ZLIBINC)
diff --git a/gcc-4.9/gcc/fortran/arith.c b/gcc-4.9/gcc/fortran/arith.c
new file mode 100644
index 000000000..053cf765e
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/arith.c
@@ -0,0 +1,2368 @@
+/* Compiler arithmetic
+   Copyright (C) 2000-2014 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+/* Since target arithmetic must be done on the host, there has to
+   be some way of evaluating arithmetic expressions as the host
+   would evaluate them.  We use the GNU MP library and the MPFR
+   library to do arithmetic, and this file provides the interface.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "flags.h"
+#include "gfortran.h"
+#include "arith.h"
+#include "target-memory.h"
+#include "constructor.h"
+
+/* MPFR does not have a direct replacement for mpz_set_f() from GMP.
+   It's easily implemented with a few calls though.  */
+
+void
+gfc_mpfr_to_mpz (mpz_t z, mpfr_t x, locus *where)
+{
+  mp_exp_t e;
+
+  if (mpfr_inf_p (x) || mpfr_nan_p (x))
+    {
+      gfc_error ("Conversion of an Infinity or Not-a-Number at %L "
+		 "to INTEGER", where);
+      mpz_set_ui (z, 0);
+      return;
+    }
+
+  e = mpfr_get_z_exp (z, x);
+
+  if (e > 0)
+    mpz_mul_2exp (z, z, e);
+  else
+    mpz_tdiv_q_2exp (z, z, -e);
+}
+
+
+/* Set the model number precision by the requested KIND.  */
+
+void
+gfc_set_model_kind (int kind)
+{
+  int index = gfc_validate_kind (BT_REAL, kind, false);
+  int base2prec;
+
+  base2prec = gfc_real_kinds[index].digits;
+  if (gfc_real_kinds[index].radix != 2)
+    base2prec *= gfc_real_kinds[index].radix / 2;
+  mpfr_set_default_prec (base2prec);
+}
+
+
+/* Set the model number precision from mpfr_t x.  */
+
+void
+gfc_set_model (mpfr_t x)
+{
+  mpfr_set_default_prec (mpfr_get_prec (x));
+}
+
+
+/* Given an arithmetic error code, return a pointer to a string that
+   explains the error.  */
+
+static const char *
+gfc_arith_error (arith code)
+{
+  const char *p;
+
+  switch (code)
+    {
+    case ARITH_OK:
+      p = _("Arithmetic OK at %L");
+      break;
+    case ARITH_OVERFLOW:
+      p = _("Arithmetic overflow at %L");
+      break;
+    case ARITH_UNDERFLOW:
+      p = _("Arithmetic underflow at %L");
+      break;
+    case ARITH_NAN:
+      p = _("Arithmetic NaN at %L");
+      break;
+    case ARITH_DIV0:
+      p = _("Division by zero at %L");
+      break;
+    case ARITH_INCOMMENSURATE:
+      p = _("Array operands are incommensurate at %L");
+      break;
+    case ARITH_ASYMMETRIC:
+      p =
+	_("Integer outside symmetric range implied by Standard Fortran at %L");
+      break;
+    default:
+      gfc_internal_error ("gfc_arith_error(): Bad error code");
+    }
+
+  return p;
+}
+
+
+/* Get things ready to do math.  */
+
+void
+gfc_arith_init_1 (void)
+{
+  gfc_integer_info *int_info;
+  gfc_real_info *real_info;
+  mpfr_t a, b;
+  int i;
+
+  mpfr_set_default_prec (128);
+  mpfr_init (a);
+
+  /* Convert the minimum and maximum values for each kind into their
+     GNU MP representation.  */
+  for (int_info = gfc_integer_kinds; int_info->kind != 0; int_info++)
+    {
+      /* Huge  */
+      mpz_init (int_info->huge);
+      mpz_set_ui (int_info->huge, int_info->radix);
+      mpz_pow_ui (int_info->huge, int_info->huge, int_info->digits);
+      mpz_sub_ui (int_info->huge, int_info->huge, 1);
+
+      /* These are the numbers that are actually representable by the
+	 target.  For bases other than two, this needs to be changed.  */
+      if (int_info->radix != 2)
+	gfc_internal_error ("Fix min_int calculation");
+
+      /* See PRs 13490 and 17912, related to integer ranges.
+	 The pedantic_min_int exists for range checking when a program
+	 is compiled with -pedantic, and reflects the belief that
+	 Standard Fortran requires integers to be symmetrical, i.e.
+	 every negative integer must have a representable positive
+	 absolute value, and vice versa.  */
+
+      mpz_init (int_info->pedantic_min_int);
+      mpz_neg (int_info->pedantic_min_int, int_info->huge);
+
+      mpz_init (int_info->min_int);
+      mpz_sub_ui (int_info->min_int, int_info->pedantic_min_int, 1);
+
+      /* Range  */
+      mpfr_set_z (a, int_info->huge, GFC_RND_MODE);
+      mpfr_log10 (a, a, GFC_RND_MODE);
+      mpfr_trunc (a, a);
+      int_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
+    }
+
+  mpfr_clear (a);
+
+  for (real_info = gfc_real_kinds; real_info->kind != 0; real_info++)
+    {
+      gfc_set_model_kind (real_info->kind);
+
+      mpfr_init (a);
+      mpfr_init (b);
+
+      /* huge(x) = (1 - b**(-p)) * b**(emax-1) * b  */
+      /* 1 - b**(-p)  */
+      mpfr_init (real_info->huge);
+      mpfr_set_ui (real_info->huge, 1, GFC_RND_MODE);
+      mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
+      mpfr_pow_si (a, a, -real_info->digits, GFC_RND_MODE);
+      mpfr_sub (real_info->huge, real_info->huge, a, GFC_RND_MODE);
+
+      /* b**(emax-1)  */
+      mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
+      mpfr_pow_ui (a, a, real_info->max_exponent - 1, GFC_RND_MODE);
+
+      /* (1 - b**(-p)) * b**(emax-1)  */
+      mpfr_mul (real_info->huge, real_info->huge, a, GFC_RND_MODE);
+
+      /* (1 - b**(-p)) * b**(emax-1) * b  */
+      mpfr_mul_ui (real_info->huge, real_info->huge, real_info->radix,
+		   GFC_RND_MODE);
+
+      /* tiny(x) = b**(emin-1)  */
+      mpfr_init (real_info->tiny);
+      mpfr_set_ui (real_info->tiny, real_info->radix, GFC_RND_MODE);
+      mpfr_pow_si (real_info->tiny, real_info->tiny,
+		   real_info->min_exponent - 1, GFC_RND_MODE);
+
+      /* subnormal (x) = b**(emin - digit)  */
+      mpfr_init (real_info->subnormal);
+      mpfr_set_ui (real_info->subnormal, real_info->radix, GFC_RND_MODE);
+      mpfr_pow_si (real_info->subnormal, real_info->subnormal,
+		   real_info->min_exponent - real_info->digits, GFC_RND_MODE);
+
+      /* epsilon(x) = b**(1-p)  */
+      mpfr_init (real_info->epsilon);
+      mpfr_set_ui (real_info->epsilon, real_info->radix, GFC_RND_MODE);
+      mpfr_pow_si (real_info->epsilon, real_info->epsilon,
+		   1 - real_info->digits, GFC_RND_MODE);
+
+      /* range(x) = int(min(log10(huge(x)), -log10(tiny))  */
+      mpfr_log10 (a, real_info->huge, GFC_RND_MODE);
+      mpfr_log10 (b, real_info->tiny, GFC_RND_MODE);
+      mpfr_neg (b, b, GFC_RND_MODE);
+
+      /* a = min(a, b)  */
+      mpfr_min (a, a, b, GFC_RND_MODE);
+      mpfr_trunc (a, a);
+      real_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
+
+      /* precision(x) = int((p - 1) * log10(b)) + k  */
+      mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
+      mpfr_log10 (a, a, GFC_RND_MODE);
+      mpfr_mul_ui (a, a, real_info->digits - 1, GFC_RND_MODE);
+      mpfr_trunc (a, a);
+      real_info->precision = (int) mpfr_get_si (a, GFC_RND_MODE);
+
+      /* If the radix is an integral power of 10, add one to the precision.  */
+      for (i = 10; i <= real_info->radix; i *= 10)
+	if (i == real_info->radix)
+	  real_info->precision++;
+
+      mpfr_clears (a, b, NULL);
+    }
+}
+
+
+/* Clean up, get rid of numeric constants.  */
+
+void
+gfc_arith_done_1 (void)
+{
+  gfc_integer_info *ip;
+  gfc_real_info *rp;
+
+  for (ip = gfc_integer_kinds; ip->kind; ip++)
+    {
+      mpz_clear (ip->min_int);
+      mpz_clear (ip->pedantic_min_int);
+      mpz_clear (ip->huge);
+    }
+
+  for (rp = gfc_real_kinds; rp->kind; rp++)
+    mpfr_clears (rp->epsilon, rp->huge, rp->tiny, rp->subnormal, NULL);
+
+  mpfr_free_cache ();
+}
+
+
+/* Given a wide character value and a character kind, determine whether
+   the character is representable for that kind.  */
+bool
+gfc_check_character_range (gfc_char_t c, int kind)
+{
+  /* As wide characters are stored as 32-bit values, they're all
+     representable in UCS=4.  */
+  if (kind == 4)
+    return true;
+
+  if (kind == 1)
+    return c <= 255 ? true : false;
+
+  gcc_unreachable ();
+}
+
+
+/* Given an integer and a kind, make sure that the integer lies within
+   the range of the kind.  Returns ARITH_OK, ARITH_ASYMMETRIC or
+   ARITH_OVERFLOW.  */
+
+arith
+gfc_check_integer_range (mpz_t p, int kind)
+{
+  arith result;
+  int i;
+
+  i = gfc_validate_kind (BT_INTEGER, kind, false);
+  result = ARITH_OK;
+
+  if (pedantic)
+    {
+      if (mpz_cmp (p, gfc_integer_kinds[i].pedantic_min_int) < 0)
+	result = ARITH_ASYMMETRIC;
+    }
+
+
+  if (gfc_option.flag_range_check == 0)
+    return result;
+
+  if (mpz_cmp (p, gfc_integer_kinds[i].min_int) < 0
+      || mpz_cmp (p, gfc_integer_kinds[i].huge) > 0)
+    result = ARITH_OVERFLOW;
+
+  return result;
+}
+
+
+/* Given a real and a kind, make sure that the real lies within the
+   range of the kind.  Returns ARITH_OK, ARITH_OVERFLOW or
+   ARITH_UNDERFLOW.  */
+
+static arith
+gfc_check_real_range (mpfr_t p, int kind)
+{
+  arith retval;
+  mpfr_t q;
+  int i;
+
+  i = gfc_validate_kind (BT_REAL, kind, false);
+
+  gfc_set_model (p);
+  mpfr_init (q);
+  mpfr_abs (q, p, GFC_RND_MODE);
+
+  retval = ARITH_OK;
+
+  if (mpfr_inf_p (p))
+    {
+      if (gfc_option.flag_range_check != 0)
+	retval = ARITH_OVERFLOW;
+    }
+  else if (mpfr_nan_p (p))
+    {
+      if (gfc_option.flag_range_check != 0)
+	retval = ARITH_NAN;
+    }
+  else if (mpfr_sgn (q) == 0)
+    {
+      mpfr_clear (q);
+      return retval;
+    }
+  else if (mpfr_cmp (q, gfc_real_kinds[i].huge) > 0)
+    {
+      if (gfc_option.flag_range_check == 0)
+	mpfr_set_inf (p, mpfr_sgn (p));
+      else
+	retval = ARITH_OVERFLOW;
+    }
+  else if (mpfr_cmp (q, gfc_real_kinds[i].subnormal) < 0)
+    {
+      if (gfc_option.flag_range_check == 0)
+	{
+	  if (mpfr_sgn (p) < 0)
+	    {
+	      mpfr_set_ui (p, 0, GFC_RND_MODE);
+	      mpfr_set_si (q, -1, GFC_RND_MODE);
+	      mpfr_copysign (p, p, q, GFC_RND_MODE);
+	    }
+	  else
+	    mpfr_set_ui (p, 0, GFC_RND_MODE);
+	}
+      else
+	retval = ARITH_UNDERFLOW;
+    }
+  else if (mpfr_cmp (q, gfc_real_kinds[i].tiny) < 0)
+    {
+      mp_exp_t emin, emax;
+      int en;
+
+      /* Save current values of emin and emax.  */
+      emin = mpfr_get_emin ();
+      emax = mpfr_get_emax ();
+
+      /* Set emin and emax for the current model number.  */
+      en = gfc_real_kinds[i].min_exponent - gfc_real_kinds[i].digits + 1;
+      mpfr_set_emin ((mp_exp_t) en);
+      mpfr_set_emax ((mp_exp_t) gfc_real_kinds[i].max_exponent);
+      mpfr_check_range (q, 0, GFC_RND_MODE);
+      mpfr_subnormalize (q, 0, GFC_RND_MODE);
+
+      /* Reset emin and emax.  */
+      mpfr_set_emin (emin);
+      mpfr_set_emax (emax);
+
+      /* Copy sign if needed.  */
+      if (mpfr_sgn (p) < 0)
+	mpfr_neg (p, q, GMP_RNDN);
+      else
+	mpfr_set (p, q, GMP_RNDN);
+    }
+
+  mpfr_clear (q);
+
+  return retval;
+}
+
+
+/* Low-level arithmetic functions.  All of these subroutines assume
+   that all operands are of the same type and return an operand of the
+   same type.  The other thing about these subroutines is that they
+   can fail in various ways -- overflow, underflow, division by zero,
+   zero raised to the zero, etc.  */
+
+static arith
+gfc_arith_not (gfc_expr *op1, gfc_expr **resultp)
+{
+  gfc_expr *result;
+
+  result = gfc_get_constant_expr (BT_LOGICAL, op1->ts.kind, &op1->where);
+  result->value.logical = !op1->value.logical;
+  *resultp = result;
+
+  return ARITH_OK;
+}
+
+
+static arith
+gfc_arith_and (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
+{
+  gfc_expr *result;
+
+  result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
+				  &op1->where);
+  result->value.logical = op1->value.logical && op2->value.logical;
+  *resultp = result;
+
+  return ARITH_OK;
+}
+
+
+static arith
+gfc_arith_or (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
+{
+  gfc_expr *result;
+
+  result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
+				  &op1->where);
+  result->value.logical = op1->value.logical || op2->value.logical;
+  *resultp = result;
+
+  return ARITH_OK;
+}
+
+
+static arith
+gfc_arith_eqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
+{
+  gfc_expr *result;
+
+  result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
+				  &op1->where);
+  result->value.logical = op1->value.logical == op2->value.logical;
+  *resultp = result;
+
+  return ARITH_OK;
+}
+
+
+static arith
+gfc_arith_neqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
+{
+  gfc_expr *result;
+
+  result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
+				  &op1->where);
+  result->value.logical = op1->value.logical != op2->value.logical;
+  *resultp = result;
+
+  return ARITH_OK;
+}
+
+
+/* Make sure a constant numeric expression is within the range for
+   its type and kind.  Note that there's also a gfc_check_range(),
+   but that one deals with the intrinsic RANGE function.  */
+
+arith
+gfc_range_check (gfc_expr *e)
+{
+  arith rc;
+  arith rc2;
+
+  switch (e->ts.type)
+    {
+    case BT_INTEGER:
+      rc = gfc_check_integer_range (e->value.integer, e->ts.kind);
+      break;
+
+    case BT_REAL:
+      rc = gfc_check_real_range (e->value.real, e->ts.kind);
+      if (rc == ARITH_UNDERFLOW)
+	mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
+      if (rc == ARITH_OVERFLOW)
+	mpfr_set_inf (e->value.real, mpfr_sgn (e->value.real));
+      if (rc == ARITH_NAN)
+	mpfr_set_nan (e->value.real);
+      break;
+
+    case BT_COMPLEX:
+      rc = gfc_check_real_range (mpc_realref (e->value.complex), e->ts.kind);
+      if (rc == ARITH_UNDERFLOW)
+	mpfr_set_ui (mpc_realref (e->value.complex), 0, GFC_RND_MODE);
+      if (rc == ARITH_OVERFLOW)
+	mpfr_set_inf (mpc_realref (e->value.complex),
+		      mpfr_sgn (mpc_realref (e->value.complex)));
+      if (rc == ARITH_NAN)
+	mpfr_set_nan (mpc_realref (e->value.complex));
+
+      rc2 = gfc_check_real_range (mpc_imagref (e->value.complex), e->ts.kind);
+      if (rc == ARITH_UNDERFLOW)
+	mpfr_set_ui (mpc_imagref (e->value.complex), 0, GFC_RND_MODE);
+      if (rc == ARITH_OVERFLOW)
+	mpfr_set_inf (mpc_imagref (e->value.complex), 
+		      mpfr_sgn (mpc_imagref (e->value.complex)));
+      if (rc == ARITH_NAN)
+	mpfr_set_nan (mpc_imagref (e->value.complex));
+
+      if (rc == ARITH_OK)
+	rc = rc2;
+      break;
+
+    default:
+      gfc_internal_error ("gfc_range_check(): Bad type");
+    }
+
+  return rc;
+}
+
+
+/* Several of the following routines use the same set of statements to
+   check the validity of the result.  Encapsulate the checking here.  */
+
+static arith
+check_result (arith rc, gfc_expr *x, gfc_expr *r, gfc_expr **rp)
+{
+  arith val = rc;
+
+  if (val == ARITH_UNDERFLOW)
+    {
+      if (gfc_option.warn_underflow)
+	gfc_warning (gfc_arith_error (val), &x->where);
+      val = ARITH_OK;
+    }
+
+  if (val == ARITH_ASYMMETRIC)
+    {
+      gfc_warning (gfc_arith_error (val), &x->where);
+      val = ARITH_OK;
+    }
+
+  if (val != ARITH_OK)
+    gfc_free_expr (r);
+  else
+    *rp = r;
+
+  return val;
+}
+
+
+/* It may seem silly to have a subroutine that actually computes the
+   unary plus of a constant, but it prevents us from making exceptions
+   in the code elsewhere.  Used for unary plus and parenthesized
+   expressions.  */
+
+static arith
+gfc_arith_identity (gfc_expr *op1, gfc_expr **resultp)
+{
+  *resultp = gfc_copy_expr (op1);
+  return ARITH_OK;
+}
+
+
+static arith
+gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp)
+{
+  gfc_expr *result;
+  arith rc;
+
+  result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
+
+  switch (op1->ts.type)
+    {
+    case BT_INTEGER:
+      mpz_neg (result->value.integer, op1->value.integer);
+      break;
+
+    case BT_REAL:
+      mpfr_neg (result->value.real, op1->value.real, GFC_RND_MODE);
+      break;
+
+    case BT_COMPLEX:
+      mpc_neg (result->value.complex, op1->value.complex, GFC_MPC_RND_MODE);
+      break;
+
+    default:
+      gfc_internal_error ("gfc_arith_uminus(): Bad basic type");
+    }
+
+  rc = gfc_range_check (result);
+
+  return check_result (rc, op1, result, resultp);
+}
+
+
+static arith
+gfc_arith_plus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
+{
+  gfc_expr *result;
+  arith rc;
+
+  result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
+
+  switch (op1->ts.type)
+    {
+    case BT_INTEGER:
+      mpz_add (result->value.integer, op1->value.integer, op2->value.integer);
+      break;
+
+    case BT_REAL:
+      mpfr_add (result->value.real, op1->value.real, op2->value.real,
+	       GFC_RND_MODE);
+      break;
+
+    case BT_COMPLEX:
+      mpc_add (result->value.complex, op1->value.complex, op2->value.complex,
+	       GFC_MPC_RND_MODE);
+      break;
+
+    default:
+      gfc_internal_error ("gfc_arith_plus(): Bad basic type");
+    }
+
+  rc = gfc_range_check (result);
+
+  return check_result (rc, op1, result, resultp);
+}
+
+
+static arith
+gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
+{
+  gfc_expr *result;
+  arith rc;
+
+  result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
+
+  switch (op1->ts.type)
+    {
+    case BT_INTEGER:
+      mpz_sub (result->value.integer, op1->value.integer, op2->value.integer);
+      break;
+
+    case BT_REAL:
+      mpfr_sub (result->value.real, op1->value.real, op2->value.real,
+		GFC_RND_MODE);
+      break;
+
+    case BT_COMPLEX:
+      mpc_sub (result->value.complex, op1->value.complex,
+	       op2->value.complex, GFC_MPC_RND_MODE);
+      break;
+
+    default:
+      gfc_internal_error ("gfc_arith_minus(): Bad basic type");
+    }
+
+  rc = gfc_range_check (result);
+
+  return check_result (rc, op1, result, resultp);
+}
+
+
+static arith
+gfc_arith_times (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
+{
+  gfc_expr *result;
+  arith rc;
+
+  result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
+
+  switch (op1->ts.type)
+    {
+    case BT_INTEGER:
+      mpz_mul (result->value.integer, op1->value.integer, op2->value.integer);
+      break;
+
+    case BT_REAL:
+      mpfr_mul (result->value.real, op1->value.real, op2->value.real,
+	       GFC_RND_MODE);
+      break;
+
+    case BT_COMPLEX:
+      gfc_set_model (mpc_realref (op1->value.complex));
+      mpc_mul (result->value.complex, op1->value.complex, op2->value.complex,
+	       GFC_MPC_RND_MODE);
+      break;
+
+    default:
+      gfc_internal_error ("gfc_arith_times(): Bad basic type");
+    }
+
+  rc = gfc_range_check (result);
+
+  return check_result (rc, op1, result, resultp);
+}
+
+
+static arith
+gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
+{
+  gfc_expr *result;
+  arith rc;
+
+  rc = ARITH_OK;
+
+  result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
+
+  switch (op1->ts.type)
+    {
+    case BT_INTEGER:
+      if (mpz_sgn (op2->value.integer) == 0)
+	{
+	  rc = ARITH_DIV0;
+	  break;
+	}
+
+      mpz_tdiv_q (result->value.integer, op1->value.integer,
+		  op2->value.integer);
+      break;
+
+    case BT_REAL:
+      if (mpfr_sgn (op2->value.real) == 0 && gfc_option.flag_range_check == 1)
+	{
+	  rc = ARITH_DIV0;
+	  break;
+	}
+
+      mpfr_div (result->value.real, op1->value.real, op2->value.real,
+	       GFC_RND_MODE);
+      break;
+
+    case BT_COMPLEX:
+      if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0
+	  && gfc_option.flag_range_check == 1)
+	{
+	  rc = ARITH_DIV0;
+	  break;
+	}
+
+      gfc_set_model (mpc_realref (op1->value.complex));
+      if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0)
+      {
+	/* In Fortran, return (NaN + NaN I) for any zero divisor.  See
+	   PR 40318. */
+	mpfr_set_nan (mpc_realref (result->value.complex));
+	mpfr_set_nan (mpc_imagref (result->value.complex));
+      }
+      else
+	mpc_div (result->value.complex, op1->value.complex, op2->value.complex,
+		 GFC_MPC_RND_MODE);
+      break;
+
+    default:
+      gfc_internal_error ("gfc_arith_divide(): Bad basic type");
+    }
+
+  if (rc == ARITH_OK)
+    rc = gfc_range_check (result);
+
+  return check_result (rc, op1, result, resultp);
+}
+
+/* Raise a number to a power.  */
+
+static arith
+arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
+{
+  int power_sign;
+  gfc_expr *result;
+  arith rc;
+
+  rc = ARITH_OK;
+  result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
+
+  switch (op2->ts.type)
+    {
+    case BT_INTEGER:
+      power_sign = mpz_sgn (op2->value.integer);
+
+      if (power_sign == 0)
+	{
+	  /* Handle something to the zeroth power.  Since we're dealing
+	     with integral exponents, there is no ambiguity in the
+	     limiting procedure used to determine the value of 0**0.  */
+	  switch (op1->ts.type)
+	    {
+	    case BT_INTEGER:
+	      mpz_set_ui (result->value.integer, 1);
+	      break;
+
+	    case BT_REAL:
+	      mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
+	      break;
+
+	    case BT_COMPLEX:
+	      mpc_set_ui (result->value.complex, 1, GFC_MPC_RND_MODE);
+	      break;
+
+	    default:
+	      gfc_internal_error ("arith_power(): Bad base");
+	    }
+	}
+      else
+	{
+	  switch (op1->ts.type)
+	    {
+	    case BT_INTEGER:
+	      {
+		int power;
+
+		/* First, we simplify the cases of op1 == 1, 0 or -1.  */
+		if (mpz_cmp_si (op1->value.integer, 1) == 0)
+		  {
+		    /* 1**op2 == 1 */
+		    mpz_set_si (result->value.integer, 1);
+		  }
+		else if (mpz_cmp_si (op1->value.integer, 0) == 0)
+		  {
+		    /* 0**op2 == 0, if op2 > 0
+	               0**op2 overflow, if op2 < 0 ; in that case, we
+		       set the result to 0 and return ARITH_DIV0.  */
+		    mpz_set_si (result->value.integer, 0);
+		    if (mpz_cmp_si (op2->value.integer, 0) < 0)
+		      rc = ARITH_DIV0;
+		  }
+		else if (mpz_cmp_si (op1->value.integer, -1) == 0)
+		  {
+		    /* (-1)**op2 == (-1)**(mod(op2,2)) */
+		    unsigned int odd = mpz_fdiv_ui (op2->value.integer, 2);
+		    if (odd)
+		      mpz_set_si (result->value.integer, -1);
+		    else
+		      mpz_set_si (result->value.integer, 1);
+		  }
+		/* Then, we take care of op2 < 0.  */
+		else if (mpz_cmp_si (op2->value.integer, 0) < 0)
+		  {
+		    /* if op2 < 0, op1**op2 == 0  because abs(op1) > 1.  */
+		    mpz_set_si (result->value.integer, 0);
+		  }
+		else if (gfc_extract_int (op2, &power) != NULL)
+		  {
+		    /* If op2 doesn't fit in an int, the exponentiation will
+		       overflow, because op2 > 0 and abs(op1) > 1.  */
+		    mpz_t max;
+		    int i;
+		    i = gfc_validate_kind (BT_INTEGER, result->ts.kind, false);
+
+		    if (gfc_option.flag_range_check)
+		      rc = ARITH_OVERFLOW;
+
+		    /* Still, we want to give the same value as the
+		       processor.  */
+		    mpz_init (max);
+		    mpz_add_ui (max, gfc_integer_kinds[i].huge, 1);
+		    mpz_mul_ui (max, max, 2);
+		    mpz_powm (result->value.integer, op1->value.integer,
+			      op2->value.integer, max);
+		    mpz_clear (max);
+		  }
+		else
+		  mpz_pow_ui (result->value.integer, op1->value.integer,
+			      power);
+	      }
+	      break;
+
+	    case BT_REAL:
+	      mpfr_pow_z (result->value.real, op1->value.real,
+			  op2->value.integer, GFC_RND_MODE);
+	      break;
+
+	    case BT_COMPLEX:
+	      mpc_pow_z (result->value.complex, op1->value.complex,
+			 op2->value.integer, GFC_MPC_RND_MODE);
+	      break;
+
+	    default:
+	      break;
+	    }
+	}
+      break;
+
+    case BT_REAL:
+
+      if (gfc_init_expr_flag)
+	{
+	  if (!gfc_notify_std (GFC_STD_F2003, "Noninteger "
+			       "exponent in an initialization "
+			       "expression at %L", &op2->where))
+	    {
+	      gfc_free_expr (result);
+	      return ARITH_PROHIBIT;
+	    }
+	}
+
+      if (mpfr_cmp_si (op1->value.real, 0) < 0)
+	{
+	  gfc_error ("Raising a negative REAL at %L to "
+		     "a REAL power is prohibited", &op1->where);
+	  gfc_free_expr (result);
+	  return ARITH_PROHIBIT;
+	}
+
+	mpfr_pow (result->value.real, op1->value.real, op2->value.real,
+		  GFC_RND_MODE);
+      break;
+
+    case BT_COMPLEX:
+      {
+	if (gfc_init_expr_flag)
+	  {
+	    if (!gfc_notify_std (GFC_STD_F2003, "Noninteger "
+				 "exponent in an initialization "
+				 "expression at %L", &op2->where))
+	      {
+		gfc_free_expr (result);
+		return ARITH_PROHIBIT;
+	      }
+	  }
+
+	mpc_pow (result->value.complex, op1->value.complex,
+		 op2->value.complex, GFC_MPC_RND_MODE);
+      }
+      break;
+    default:
+      gfc_internal_error ("arith_power(): unknown type");
+    }
+
+  if (rc == ARITH_OK)
+    rc = gfc_range_check (result);
+
+  return check_result (rc, op1, result, resultp);
+}
+
+
+/* Concatenate two string constants.  */
+
+static arith
+gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
+{
+  gfc_expr *result;
+  int len;
+
+  gcc_assert (op1->ts.kind == op2->ts.kind);
+  result = gfc_get_constant_expr (BT_CHARACTER, op1->ts.kind,
+				  &op1->where);
+
+  len = op1->value.character.length + op2->value.character.length;
+
+  result->value.character.string = gfc_get_wide_string (len + 1);
+  result->value.character.length = len;
+
+  memcpy (result->value.character.string, op1->value.character.string,
+	  op1->value.character.length * sizeof (gfc_char_t));
+
+  memcpy (&result->value.character.string[op1->value.character.length],
+	  op2->value.character.string,
+	  op2->value.character.length * sizeof (gfc_char_t));
+
+  result->value.character.string[len] = '\0';
+
+  *resultp = result;
+
+  return ARITH_OK;
+}
+
+/* Comparison between real values; returns 0 if (op1 .op. op2) is true.
+   This function mimics mpfr_cmp but takes NaN into account.  */
+
+static int
+compare_real (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
+{
+  int rc;
+  switch (op)
+    {
+      case INTRINSIC_EQ:
+	rc = mpfr_equal_p (op1->value.real, op2->value.real) ? 0 : 1;
+	break;
+      case INTRINSIC_GT:
+	rc = mpfr_greater_p (op1->value.real, op2->value.real) ? 1 : -1;
+	break;
+      case INTRINSIC_GE:
+	rc = mpfr_greaterequal_p (op1->value.real, op2->value.real) ? 1 : -1;
+	break;
+      case INTRINSIC_LT:
+	rc = mpfr_less_p (op1->value.real, op2->value.real) ? -1 : 1;
+	break;
+      case INTRINSIC_LE:
+	rc = mpfr_lessequal_p (op1->value.real, op2->value.real) ? -1 : 1;
+	break;
+      default:
+	gfc_internal_error ("compare_real(): Bad operator");
+    }
+
+  return rc;
+}
+
+/* Comparison operators.  Assumes that the two expression nodes
+   contain two constants of the same type. The op argument is
+   needed to handle NaN correctly.  */
+
+int
+gfc_compare_expr (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
+{
+  int rc;
+
+  switch (op1->ts.type)
+    {
+    case BT_INTEGER:
+      rc = mpz_cmp (op1->value.integer, op2->value.integer);
+      break;
+
+    case BT_REAL:
+      rc = compare_real (op1, op2, op);
+      break;
+
+    case BT_CHARACTER:
+      rc = gfc_compare_string (op1, op2);
+      break;
+
+    case BT_LOGICAL:
+      rc = ((!op1->value.logical && op2->value.logical)
+	    || (op1->value.logical && !op2->value.logical));
+      break;
+
+    default:
+      gfc_internal_error ("gfc_compare_expr(): Bad basic type");
+    }
+
+  return rc;
+}
+
+
+/* Compare a pair of complex numbers.  Naturally, this is only for
+   equality and inequality.  */
+
+static int
+compare_complex (gfc_expr *op1, gfc_expr *op2)
+{
+  return mpc_cmp (op1->value.complex, op2->value.complex) == 0;
+}
+
+
+/* Given two constant strings and the inverse collating sequence, compare the
+   strings.  We return -1 for a < b, 0 for a == b and 1 for a > b. 
+   We use the processor's default collating sequence.  */
+
+int
+gfc_compare_string (gfc_expr *a, gfc_expr *b)
+{
+  int len, alen, blen, i;
+  gfc_char_t ac, bc;
+
+  alen = a->value.character.length;
+  blen = b->value.character.length;
+
+  len = MAX(alen, blen);
+
+  for (i = 0; i < len; i++)
+    {
+      ac = ((i < alen) ? a->value.character.string[i] : ' ');
+      bc = ((i < blen) ? b->value.character.string[i] : ' ');
+
+      if (ac < bc)
+	return -1;
+      if (ac > bc)
+	return 1;
+    }
+
+  /* Strings are equal */
+  return 0;
+}
+
+
+int
+gfc_compare_with_Cstring (gfc_expr *a, const char *b, bool case_sensitive)
+{
+  int len, alen, blen, i;
+  gfc_char_t ac, bc;
+
+  alen = a->value.character.length;
+  blen = strlen (b);
+
+  len = MAX(alen, blen);
+
+  for (i = 0; i < len; i++)
+    {
+      ac = ((i < alen) ? a->value.character.string[i] : ' ');
+      bc = ((i < blen) ? b[i] : ' ');
+
+      if (!case_sensitive)
+	{
+	  ac = TOLOWER (ac);
+	  bc = TOLOWER (bc);
+	}
+
+      if (ac < bc)
+	return -1;
+      if (ac > bc)
+	return 1;
+    }
+
+  /* Strings are equal */
+  return 0;
+}
+
+
+/* Specific comparison subroutines.  */
+
+static arith
+gfc_arith_eq (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
+{
+  gfc_expr *result;
+
+  result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
+				  &op1->where);
+  result->value.logical = (op1->ts.type == BT_COMPLEX)
+			? compare_complex (op1, op2)
+			: (gfc_compare_expr (op1, op2, INTRINSIC_EQ) == 0);
+
+  *resultp = result;
+  return ARITH_OK;
+}
+
+
+static arith
+gfc_arith_ne (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
+{
+  gfc_expr *result;
+
+  result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
+				  &op1->where);
+  result->value.logical = (op1->ts.type == BT_COMPLEX)
+			? !compare_complex (op1, op2)
+			: (gfc_compare_expr (op1, op2, INTRINSIC_EQ) != 0);
+
+  *resultp = result;
+  return ARITH_OK;
+}
+
+
+static arith
+gfc_arith_gt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
+{
+  gfc_expr *result;
+
+  result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
+				  &op1->where);
+  result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GT) > 0);
+  *resultp = result;
+
+  return ARITH_OK;
+}
+
+
+static arith
+gfc_arith_ge (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
+{
+  gfc_expr *result;
+
+  result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
+				  &op1->where);
+  result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GE) >= 0);
+  *resultp = result;
+
+  return ARITH_OK;
+}
+
+
+static arith
+gfc_arith_lt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
+{
+  gfc_expr *result;
+
+  result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
+				  &op1->where);
+  result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LT) < 0);
+  *resultp = result;
+
+  return ARITH_OK;
+}
+
+
+static arith
+gfc_arith_le (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
+{
+  gfc_expr *result;
+
+  result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
+				  &op1->where);
+  result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LE) <= 0);
+  *resultp = result;
+
+  return ARITH_OK;
+}
+
+
+static arith
+reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op,
+	      gfc_expr **result)
+{
+  gfc_constructor_base head;
+  gfc_constructor *c;
+  gfc_expr *r;
+  arith rc;
+
+  if (op->expr_type == EXPR_CONSTANT)
+    return eval (op, result);
+
+  rc = ARITH_OK;
+  head = gfc_constructor_copy (op->value.constructor);
+  for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
+    {
+      rc = reduce_unary (eval, c->expr, &r);
+
+      if (rc != ARITH_OK)
+	break;
+
+      gfc_replace_expr (c->expr, r);
+    }
+
+  if (rc != ARITH_OK)
+    gfc_constructor_free (head);
+  else
+    {
+      gfc_constructor *c = gfc_constructor_first (head);
+      r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
+			      &op->where);
+      r->shape = gfc_copy_shape (op->shape, op->rank);
+      r->rank = op->rank;
+      r->value.constructor = head;
+      *result = r;
+    }
+
+  return rc;
+}
+
+
+static arith
+reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
+		  gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
+{
+  gfc_constructor_base head;
+  gfc_constructor *c;
+  gfc_expr *r;
+  arith rc = ARITH_OK;
+
+  head = gfc_constructor_copy (op1->value.constructor);
+  for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
+    {
+      if (c->expr->expr_type == EXPR_CONSTANT)
+        rc = eval (c->expr, op2, &r);
+      else
+	rc = reduce_binary_ac (eval, c->expr, op2, &r);
+
+      if (rc != ARITH_OK)
+	break;
+
+      gfc_replace_expr (c->expr, r);
+    }
+
+  if (rc != ARITH_OK)
+    gfc_constructor_free (head);
+  else
+    {
+      gfc_constructor *c = gfc_constructor_first (head);
+      r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
+			      &op1->where);
+      r->shape = gfc_copy_shape (op1->shape, op1->rank);
+      r->rank = op1->rank;
+      r->value.constructor = head;
+      *result = r;
+    }
+
+  return rc;
+}
+
+
+static arith
+reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
+		  gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
+{
+  gfc_constructor_base head;
+  gfc_constructor *c;
+  gfc_expr *r;
+  arith rc = ARITH_OK;
+
+  head = gfc_constructor_copy (op2->value.constructor);
+  for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
+    {
+      if (c->expr->expr_type == EXPR_CONSTANT)
+	rc = eval (op1, c->expr, &r);
+      else
+	rc = reduce_binary_ca (eval, op1, c->expr, &r);
+
+      if (rc != ARITH_OK)
+	break;
+
+      gfc_replace_expr (c->expr, r);
+    }
+
+  if (rc != ARITH_OK)
+    gfc_constructor_free (head);
+  else
+    {
+      gfc_constructor *c = gfc_constructor_first (head);
+      r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
+			      &op2->where);
+      r->shape = gfc_copy_shape (op2->shape, op2->rank);
+      r->rank = op2->rank;
+      r->value.constructor = head;
+      *result = r;
+    }
+
+  return rc;
+}
+
+
+/* We need a forward declaration of reduce_binary.  */
+static arith reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
+			    gfc_expr *op1, gfc_expr *op2, gfc_expr **result);
+
+
+static arith
+reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
+		  gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
+{
+  gfc_constructor_base head;
+  gfc_constructor *c, *d;
+  gfc_expr *r;
+  arith rc = ARITH_OK;
+
+  if (!gfc_check_conformance (op1, op2, "elemental binary operation"))
+    return ARITH_INCOMMENSURATE;
+
+  head = gfc_constructor_copy (op1->value.constructor);
+  for (c = gfc_constructor_first (head),
+       d = gfc_constructor_first (op2->value.constructor);
+       c && d;
+       c = gfc_constructor_next (c), d = gfc_constructor_next (d))
+    {
+	rc = reduce_binary (eval, c->expr, d->expr, &r);
+	if (rc != ARITH_OK)
+	  break;
+
+	gfc_replace_expr (c->expr, r);
+    }
+
+  if (c || d)
+    rc = ARITH_INCOMMENSURATE;
+
+  if (rc != ARITH_OK)
+    gfc_constructor_free (head);
+  else
+    {
+      gfc_constructor *c = gfc_constructor_first (head);
+      r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
+			      &op1->where);
+      r->shape = gfc_copy_shape (op1->shape, op1->rank);
+      r->rank = op1->rank;
+      r->value.constructor = head;
+      *result = r;
+    }
+
+  return rc;
+}
+
+
+static arith
+reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
+	       gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
+{
+  if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_CONSTANT)
+    return eval (op1, op2, result);
+
+  if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_ARRAY)
+    return reduce_binary_ca (eval, op1, op2, result);
+
+  if (op1->expr_type == EXPR_ARRAY && op2->expr_type == EXPR_CONSTANT)
+    return reduce_binary_ac (eval, op1, op2, result);
+
+  return reduce_binary_aa (eval, op1, op2, result);
+}
+
+
+typedef union
+{
+  arith (*f2)(gfc_expr *, gfc_expr **);
+  arith (*f3)(gfc_expr *, gfc_expr *, gfc_expr **);
+}
+eval_f;
+
+/* High level arithmetic subroutines.  These subroutines go into
+   eval_intrinsic(), which can do one of several things to its
+   operands.  If the operands are incompatible with the intrinsic
+   operation, we return a node pointing to the operands and hope that
+   an operator interface is found during resolution.
+
+   If the operands are compatible and are constants, then we try doing
+   the arithmetic.  We also handle the cases where either or both
+   operands are array constructors.  */
+
+static gfc_expr *
+eval_intrinsic (gfc_intrinsic_op op,
+		eval_f eval, gfc_expr *op1, gfc_expr *op2)
+{
+  gfc_expr temp, *result;
+  int unary;
+  arith rc;
+
+  gfc_clear_ts (&temp.ts);
+
+  switch (op)
+    {
+    /* Logical unary  */
+    case INTRINSIC_NOT:
+      if (op1->ts.type != BT_LOGICAL)
+	goto runtime;
+
+      temp.ts.type = BT_LOGICAL;
+      temp.ts.kind = gfc_default_logical_kind;
+      unary = 1;
+      break;
+
+    /* Logical binary operators  */
+    case INTRINSIC_OR:
+    case INTRINSIC_AND:
+    case INTRINSIC_NEQV:
+    case INTRINSIC_EQV:
+      if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
+	goto runtime;
+
+      temp.ts.type = BT_LOGICAL;
+      temp.ts.kind = gfc_default_logical_kind;
+      unary = 0;
+      break;
+
+    /* Numeric unary  */
+    case INTRINSIC_UPLUS:
+    case INTRINSIC_UMINUS:
+      if (!gfc_numeric_ts (&op1->ts))
+	goto runtime;
+
+      temp.ts = op1->ts;
+      unary = 1;
+      break;
+
+    case INTRINSIC_PARENTHESES:
+      temp.ts = op1->ts;
+      unary = 1;
+      break;
+
+    /* Additional restrictions for ordering relations.  */
+    case INTRINSIC_GE:
+    case INTRINSIC_GE_OS:
+    case INTRINSIC_LT:
+    case INTRINSIC_LT_OS:
+    case INTRINSIC_LE:
+    case INTRINSIC_LE_OS:
+    case INTRINSIC_GT:
+    case INTRINSIC_GT_OS:
+      if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
+	{
+	  temp.ts.type = BT_LOGICAL;
+	  temp.ts.kind = gfc_default_logical_kind;
+	  goto runtime;
+	}
+
+    /* Fall through  */
+    case INTRINSIC_EQ:
+    case INTRINSIC_EQ_OS:
+    case INTRINSIC_NE:
+    case INTRINSIC_NE_OS:
+      if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
+	{
+	  unary = 0;
+	  temp.ts.type = BT_LOGICAL;
+	  temp.ts.kind = gfc_default_logical_kind;
+
+	  /* If kind mismatch, exit and we'll error out later.  */
+	  if (op1->ts.kind != op2->ts.kind)
+	    goto runtime;
+
+	  break;
+	}
+
+    /* Fall through  */
+    /* Numeric binary  */
+    case INTRINSIC_PLUS:
+    case INTRINSIC_MINUS:
+    case INTRINSIC_TIMES:
+    case INTRINSIC_DIVIDE:
+    case INTRINSIC_POWER:
+      if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts))
+	goto runtime;
+
+      /* Insert any necessary type conversions to make the operands
+	 compatible.  */
+
+      temp.expr_type = EXPR_OP;
+      gfc_clear_ts (&temp.ts);
+      temp.value.op.op = op;
+
+      temp.value.op.op1 = op1;
+      temp.value.op.op2 = op2;
+
+      gfc_type_convert_binary (&temp, 0);
+
+      if (op == INTRINSIC_EQ || op == INTRINSIC_NE
+	  || op == INTRINSIC_GE || op == INTRINSIC_GT
+	  || op == INTRINSIC_LE || op == INTRINSIC_LT
+	  || op == INTRINSIC_EQ_OS || op == INTRINSIC_NE_OS
+	  || op == INTRINSIC_GE_OS || op == INTRINSIC_GT_OS
+	  || op == INTRINSIC_LE_OS || op == INTRINSIC_LT_OS)
+	{
+	  temp.ts.type = BT_LOGICAL;
+	  temp.ts.kind = gfc_default_logical_kind;
+	}
+
+      unary = 0;
+      break;
+
+    /* Character binary  */
+    case INTRINSIC_CONCAT:
+      if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
+	  || op1->ts.kind != op2->ts.kind)
+	goto runtime;
+
+      temp.ts.type = BT_CHARACTER;
+      temp.ts.kind = op1->ts.kind;
+      unary = 0;
+      break;
+
+    case INTRINSIC_USER:
+      goto runtime;
+
+    default:
+      gfc_internal_error ("eval_intrinsic(): Bad operator");
+    }
+
+  if (op1->expr_type != EXPR_CONSTANT
+      && (op1->expr_type != EXPR_ARRAY
+	  || !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1)))
+    goto runtime;
+
+  if (op2 != NULL
+      && op2->expr_type != EXPR_CONSTANT
+	 && (op2->expr_type != EXPR_ARRAY
+	     || !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2)))
+    goto runtime;
+
+  if (unary)
+    rc = reduce_unary (eval.f2, op1, &result);
+  else
+    rc = reduce_binary (eval.f3, op1, op2, &result);
+
+
+  /* Something went wrong.  */
+  if (op == INTRINSIC_POWER && rc == ARITH_PROHIBIT)
+    return NULL;
+
+  if (rc != ARITH_OK)
+    {
+      gfc_error (gfc_arith_error (rc), &op1->where);
+      return NULL;
+    }
+
+  gfc_free_expr (op1);
+  gfc_free_expr (op2);
+  return result;
+
+runtime:
+  /* Create a run-time expression.  */
+  result = gfc_get_operator_expr (&op1->where, op, op1, op2);
+  result->ts = temp.ts;
+
+  return result;
+}
+
+
+/* Modify type of expression for zero size array.  */
+
+static gfc_expr *
+eval_type_intrinsic0 (gfc_intrinsic_op iop, gfc_expr *op)
+{
+  if (op == NULL)
+    gfc_internal_error ("eval_type_intrinsic0(): op NULL");
+
+  switch (iop)
+    {
+    case INTRINSIC_GE:
+    case INTRINSIC_GE_OS:
+    case INTRINSIC_LT:
+    case INTRINSIC_LT_OS:
+    case INTRINSIC_LE:
+    case INTRINSIC_LE_OS:
+    case INTRINSIC_GT:
+    case INTRINSIC_GT_OS:
+    case INTRINSIC_EQ:
+    case INTRINSIC_EQ_OS:
+    case INTRINSIC_NE:
+    case INTRINSIC_NE_OS:
+      op->ts.type = BT_LOGICAL;
+      op->ts.kind = gfc_default_logical_kind;
+      break;
+
+    default:
+      break;
+    }
+
+  return op;
+}
+
+
+/* Return nonzero if the expression is a zero size array.  */
+
+static int
+gfc_zero_size_array (gfc_expr *e)
+{
+  if (e->expr_type != EXPR_ARRAY)
+    return 0;
+
+  return e->value.constructor == NULL;
+}
+
+
+/* Reduce a binary expression where at least one of the operands
+   involves a zero-length array.  Returns NULL if neither of the
+   operands is a zero-length array.  */
+
+static gfc_expr *
+reduce_binary0 (gfc_expr *op1, gfc_expr *op2)
+{
+  if (gfc_zero_size_array (op1))
+    {
+      gfc_free_expr (op2);
+      return op1;
+    }
+
+  if (gfc_zero_size_array (op2))
+    {
+      gfc_free_expr (op1);
+      return op2;
+    }
+
+  return NULL;
+}
+
+
+static gfc_expr *
+eval_intrinsic_f2 (gfc_intrinsic_op op,
+		   arith (*eval) (gfc_expr *, gfc_expr **),
+		   gfc_expr *op1, gfc_expr *op2)
+{
+  gfc_expr *result;
+  eval_f f;
+
+  if (op2 == NULL)
+    {
+      if (gfc_zero_size_array (op1))
+	return eval_type_intrinsic0 (op, op1);
+    }
+  else
+    {
+      result = reduce_binary0 (op1, op2);
+      if (result != NULL)
+	return eval_type_intrinsic0 (op, result);
+    }
+
+  f.f2 = eval;
+  return eval_intrinsic (op, f, op1, op2);
+}
+
+
+static gfc_expr *
+eval_intrinsic_f3 (gfc_intrinsic_op op,
+		   arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
+		   gfc_expr *op1, gfc_expr *op2)
+{
+  gfc_expr *result;
+  eval_f f;
+
+  result = reduce_binary0 (op1, op2);
+  if (result != NULL)
+    return eval_type_intrinsic0(op, result);
+
+  f.f3 = eval;
+  return eval_intrinsic (op, f, op1, op2);
+}
+
+
+gfc_expr *
+gfc_parentheses (gfc_expr *op)
+{
+  if (gfc_is_constant_expr (op))
+    return op;
+
+  return eval_intrinsic_f2 (INTRINSIC_PARENTHESES, gfc_arith_identity,
+			    op, NULL);
+}
+
+gfc_expr *
+gfc_uplus (gfc_expr *op)
+{
+  return eval_intrinsic_f2 (INTRINSIC_UPLUS, gfc_arith_identity, op, NULL);
+}
+
+
+gfc_expr *
+gfc_uminus (gfc_expr *op)
+{
+  return eval_intrinsic_f2 (INTRINSIC_UMINUS, gfc_arith_uminus, op, NULL);
+}
+
+
+gfc_expr *
+gfc_add (gfc_expr *op1, gfc_expr *op2)
+{
+  return eval_intrinsic_f3 (INTRINSIC_PLUS, gfc_arith_plus, op1, op2);
+}
+
+
+gfc_expr *
+gfc_subtract (gfc_expr *op1, gfc_expr *op2)
+{
+  return eval_intrinsic_f3 (INTRINSIC_MINUS, gfc_arith_minus, op1, op2);
+}
+
+
+gfc_expr *
+gfc_multiply (gfc_expr *op1, gfc_expr *op2)
+{
+  return eval_intrinsic_f3 (INTRINSIC_TIMES, gfc_arith_times, op1, op2);
+}
+
+
+gfc_expr *
+gfc_divide (gfc_expr *op1, gfc_expr *op2)
+{
+  return eval_intrinsic_f3 (INTRINSIC_DIVIDE, gfc_arith_divide, op1, op2);
+}
+
+
+gfc_expr *
+gfc_power (gfc_expr *op1, gfc_expr *op2)
+{
+  return eval_intrinsic_f3 (INTRINSIC_POWER, arith_power, op1, op2);
+}
+
+
+gfc_expr *
+gfc_concat (gfc_expr *op1, gfc_expr *op2)
+{
+  return eval_intrinsic_f3 (INTRINSIC_CONCAT, gfc_arith_concat, op1, op2);
+}
+
+
+gfc_expr *
+gfc_and (gfc_expr *op1, gfc_expr *op2)
+{
+  return eval_intrinsic_f3 (INTRINSIC_AND, gfc_arith_and, op1, op2);
+}
+
+
+gfc_expr *
+gfc_or (gfc_expr *op1, gfc_expr *op2)
+{
+  return eval_intrinsic_f3 (INTRINSIC_OR, gfc_arith_or, op1, op2);
+}
+
+
+gfc_expr *
+gfc_not (gfc_expr *op1)
+{
+  return eval_intrinsic_f2 (INTRINSIC_NOT, gfc_arith_not, op1, NULL);
+}
+
+
+gfc_expr *
+gfc_eqv (gfc_expr *op1, gfc_expr *op2)
+{
+  return eval_intrinsic_f3 (INTRINSIC_EQV, gfc_arith_eqv, op1, op2);
+}
+
+
+gfc_expr *
+gfc_neqv (gfc_expr *op1, gfc_expr *op2)
+{
+  return eval_intrinsic_f3 (INTRINSIC_NEQV, gfc_arith_neqv, op1, op2);
+}
+
+
+gfc_expr *
+gfc_eq (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
+{
+  return eval_intrinsic_f3 (op, gfc_arith_eq, op1, op2);
+}
+
+
+gfc_expr *
+gfc_ne (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
+{
+  return eval_intrinsic_f3 (op, gfc_arith_ne, op1, op2);
+}
+
+
+gfc_expr *
+gfc_gt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
+{
+  return eval_intrinsic_f3 (op, gfc_arith_gt, op1, op2);
+}
+
+
+gfc_expr *
+gfc_ge (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
+{
+  return eval_intrinsic_f3 (op, gfc_arith_ge, op1, op2);
+}
+
+
+gfc_expr *
+gfc_lt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
+{
+  return eval_intrinsic_f3 (op, gfc_arith_lt, op1, op2);
+}
+
+
+gfc_expr *
+gfc_le (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
+{
+  return eval_intrinsic_f3 (op, gfc_arith_le, op1, op2);
+}
+
+
+/* Convert an integer string to an expression node.  */
+
+gfc_expr *
+gfc_convert_integer (const char *buffer, int kind, int radix, locus *where)
+{
+  gfc_expr *e;
+  const char *t;
+
+  e = gfc_get_constant_expr (BT_INTEGER, kind, where);
+  /* A leading plus is allowed, but not by mpz_set_str.  */
+  if (buffer[0] == '+')
+    t = buffer + 1;
+  else
+    t = buffer;
+  mpz_set_str (e->value.integer, t, radix);
+
+  return e;
+}
+
+
+/* Convert a real string to an expression node.  */
+
+gfc_expr *
+gfc_convert_real (const char *buffer, int kind, locus *where)
+{
+  gfc_expr *e;
+
+  e = gfc_get_constant_expr (BT_REAL, kind, where);
+  mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE);
+
+  return e;
+}
+
+
+/* Convert a pair of real, constant expression nodes to a single
+   complex expression node.  */
+
+gfc_expr *
+gfc_convert_complex (gfc_expr *real, gfc_expr *imag, int kind)
+{
+  gfc_expr *e;
+
+  e = gfc_get_constant_expr (BT_COMPLEX, kind, &real->where);
+  mpc_set_fr_fr (e->value.complex, real->value.real, imag->value.real,
+		 GFC_MPC_RND_MODE);
+
+  return e;
+}
+
+
+/******* Simplification of intrinsic functions with constant arguments *****/
+
+
+/* Deal with an arithmetic error.  */
+
+static void
+arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *where)
+{
+  switch (rc)
+    {
+    case ARITH_OK:
+      gfc_error ("Arithmetic OK converting %s to %s at %L",
+		 gfc_typename (from), gfc_typename (to), where);
+      break;
+    case ARITH_OVERFLOW:
+      gfc_error ("Arithmetic overflow converting %s to %s at %L. This check "
+		 "can be disabled with the option -fno-range-check",
+		 gfc_typename (from), gfc_typename (to), where);
+      break;
+    case ARITH_UNDERFLOW:
+      gfc_error ("Arithmetic underflow converting %s to %s at %L. This check "
+		 "can be disabled with the option -fno-range-check",
+		 gfc_typename (from), gfc_typename (to), where);
+      break;
+    case ARITH_NAN:
+      gfc_error ("Arithmetic NaN converting %s to %s at %L. This check "
+		 "can be disabled with the option -fno-range-check",
+		 gfc_typename (from), gfc_typename (to), where);
+      break;
+    case ARITH_DIV0:
+      gfc_error ("Division by zero converting %s to %s at %L",
+		 gfc_typename (from), gfc_typename (to), where);
+      break;
+    case ARITH_INCOMMENSURATE:
+      gfc_error ("Array operands are incommensurate converting %s to %s at %L",
+		 gfc_typename (from), gfc_typename (to), where);
+      break;
+    case ARITH_ASYMMETRIC:
+      gfc_error ("Integer outside symmetric range implied by Standard Fortran"
+	 	 " converting %s to %s at %L",
+		 gfc_typename (from), gfc_typename (to), where);
+      break;
+    default:
+      gfc_internal_error ("gfc_arith_error(): Bad error code");
+    }
+
+  /* TODO: Do something about the error, i.e., throw exception, return
+     NaN, etc.  */
+}
+
+
+/* Convert integers to integers.  */
+
+gfc_expr *
+gfc_int2int (gfc_expr *src, int kind)
+{
+  gfc_expr *result;
+  arith rc;
+
+  result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
+
+  mpz_set (result->value.integer, src->value.integer);
+
+  if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
+    {
+      if (rc == ARITH_ASYMMETRIC)
+	{
+	  gfc_warning (gfc_arith_error (rc), &src->where);
+	}
+      else
+	{
+	  arith_error (rc, &src->ts, &result->ts, &src->where);
+	  gfc_free_expr (result);
+	  return NULL;
+	}
+    }
+
+  return result;
+}
+
+
+/* Convert integers to reals.  */
+
+gfc_expr *
+gfc_int2real (gfc_expr *src, int kind)
+{
+  gfc_expr *result;
+  arith rc;
+
+  result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
+
+  mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
+
+  if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK)
+    {
+      arith_error (rc, &src->ts, &result->ts, &src->where);
+      gfc_free_expr (result);
+      return NULL;
+    }
+
+  return result;
+}
+
+
+/* Convert default integer to default complex.  */
+
+gfc_expr *
+gfc_int2complex (gfc_expr *src, int kind)
+{
+  gfc_expr *result;
+  arith rc;
+
+  result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
+
+  mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE);
+
+  if ((rc = gfc_check_real_range (mpc_realref (result->value.complex), kind))
+      != ARITH_OK)
+    {
+      arith_error (rc, &src->ts, &result->ts, &src->where);
+      gfc_free_expr (result);
+      return NULL;
+    }
+
+  return result;
+}
+
+
+/* Convert default real to default integer.  */
+
+gfc_expr *
+gfc_real2int (gfc_expr *src, int kind)
+{
+  gfc_expr *result;
+  arith rc;
+
+  result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
+
+  gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where);
+
+  if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
+    {
+      arith_error (rc, &src->ts, &result->ts, &src->where);
+      gfc_free_expr (result);
+      return NULL;
+    }
+
+  return result;
+}
+
+
+/* Convert real to real.  */
+
+gfc_expr *
+gfc_real2real (gfc_expr *src, int kind)
+{
+  gfc_expr *result;
+  arith rc;
+
+  result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
+
+  mpfr_set (result->value.real, src->value.real, GFC_RND_MODE);
+
+  rc = gfc_check_real_range (result->value.real, kind);
+
+  if (rc == ARITH_UNDERFLOW)
+    {
+      if (gfc_option.warn_underflow)
+	gfc_warning (gfc_arith_error (rc), &src->where);
+      mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
+    }
+  else if (rc != ARITH_OK)
+    {
+      arith_error (rc, &src->ts, &result->ts, &src->where);
+      gfc_free_expr (result);
+      return NULL;
+    }
+
+  return result;
+}
+
+
+/* Convert real to complex.  */
+
+gfc_expr *
+gfc_real2complex (gfc_expr *src, int kind)
+{
+  gfc_expr *result;
+  arith rc;
+
+  result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
+
+  mpc_set_fr (result->value.complex, src->value.real, GFC_MPC_RND_MODE);
+
+  rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
+
+  if (rc == ARITH_UNDERFLOW)
+    {
+      if (gfc_option.warn_underflow)
+	gfc_warning (gfc_arith_error (rc), &src->where);
+      mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
+    }
+  else if (rc != ARITH_OK)
+    {
+      arith_error (rc, &src->ts, &result->ts, &src->where);
+      gfc_free_expr (result);
+      return NULL;
+    }
+
+  return result;
+}
+
+
+/* Convert complex to integer.  */
+
+gfc_expr *
+gfc_complex2int (gfc_expr *src, int kind)
+{
+  gfc_expr *result;
+  arith rc;
+
+  result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
+
+  gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex),
+		   &src->where);
+
+  if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
+    {
+      arith_error (rc, &src->ts, &result->ts, &src->where);
+      gfc_free_expr (result);
+      return NULL;
+    }
+
+  return result;
+}
+
+
+/* Convert complex to real.  */
+
+gfc_expr *
+gfc_complex2real (gfc_expr *src, int kind)
+{
+  gfc_expr *result;
+  arith rc;
+
+  result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
+
+  mpc_real (result->value.real, src->value.complex, GFC_RND_MODE);
+
+  rc = gfc_check_real_range (result->value.real, kind);
+
+  if (rc == ARITH_UNDERFLOW)
+    {
+      if (gfc_option.warn_underflow)
+	gfc_warning (gfc_arith_error (rc), &src->where);
+      mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
+    }
+  if (rc != ARITH_OK)
+    {
+      arith_error (rc, &src->ts, &result->ts, &src->where);
+      gfc_free_expr (result);
+      return NULL;
+    }
+
+  return result;
+}
+
+
+/* Convert complex to complex.  */
+
+gfc_expr *
+gfc_complex2complex (gfc_expr *src, int kind)
+{
+  gfc_expr *result;
+  arith rc;
+
+  result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
+
+  mpc_set (result->value.complex, src->value.complex, GFC_MPC_RND_MODE);
+
+  rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
+
+  if (rc == ARITH_UNDERFLOW)
+    {
+      if (gfc_option.warn_underflow)
+	gfc_warning (gfc_arith_error (rc), &src->where);
+      mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
+    }
+  else if (rc != ARITH_OK)
+    {
+      arith_error (rc, &src->ts, &result->ts, &src->where);
+      gfc_free_expr (result);
+      return NULL;
+    }
+
+  rc = gfc_check_real_range (mpc_imagref (result->value.complex), kind);
+
+  if (rc == ARITH_UNDERFLOW)
+    {
+      if (gfc_option.warn_underflow)
+	gfc_warning (gfc_arith_error (rc), &src->where);
+      mpfr_set_ui (mpc_imagref (result->value.complex), 0, GFC_RND_MODE);
+    }
+  else if (rc != ARITH_OK)
+    {
+      arith_error (rc, &src->ts, &result->ts, &src->where);
+      gfc_free_expr (result);
+      return NULL;
+    }
+
+  return result;
+}
+
+
+/* Logical kind conversion.  */
+
+gfc_expr *
+gfc_log2log (gfc_expr *src, int kind)
+{
+  gfc_expr *result;
+
+  result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
+  result->value.logical = src->value.logical;
+
+  return result;
+}
+
+
+/* Convert logical to integer.  */
+
+gfc_expr *
+gfc_log2int (gfc_expr *src, int kind)
+{
+  gfc_expr *result;
+
+  result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
+  mpz_set_si (result->value.integer, src->value.logical);
+
+  return result;
+}
+
+
+/* Convert integer to logical.  */
+
+gfc_expr *
+gfc_int2log (gfc_expr *src, int kind)
+{
+  gfc_expr *result;
+
+  result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
+  result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
+
+  return result;
+}
+
+
+/* Helper function to set the representation in a Hollerith conversion.  
+   This assumes that the ts.type and ts.kind of the result have already
+   been set.  */
+
+static void
+hollerith2representation (gfc_expr *result, gfc_expr *src)
+{
+  int src_len, result_len;
+
+  src_len = src->representation.length - src->ts.u.pad;
+  result_len = gfc_target_expr_size (result);
+
+  if (src_len > result_len)
+    {
+      gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
+		   &src->where, gfc_typename(&result->ts));
+    }
+
+  result->representation.string = XCNEWVEC (char, result_len + 1);
+  memcpy (result->representation.string, src->representation.string,
+	  MIN (result_len, src_len));
+
+  if (src_len < result_len)
+    memset (&result->representation.string[src_len], ' ', result_len - src_len);
+
+  result->representation.string[result_len] = '\0'; /* For debugger  */
+  result->representation.length = result_len;
+}
+
+
+/* Convert Hollerith to integer. The constant will be padded or truncated.  */
+
+gfc_expr *
+gfc_hollerith2int (gfc_expr *src, int kind)
+{
+  gfc_expr *result;
+  result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
+
+  hollerith2representation (result, src);
+  gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
+			 result->representation.length, result->value.integer);
+
+  return result;
+}
+
+
+/* Convert Hollerith to real. The constant will be padded or truncated.  */
+
+gfc_expr *
+gfc_hollerith2real (gfc_expr *src, int kind)
+{
+  gfc_expr *result;
+  result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
+
+  hollerith2representation (result, src);
+  gfc_interpret_float (kind, (unsigned char *) result->representation.string,
+		       result->representation.length, result->value.real);
+
+  return result;
+}
+
+
+/* Convert Hollerith to complex. The constant will be padded or truncated.  */
+
+gfc_expr *
+gfc_hollerith2complex (gfc_expr *src, int kind)
+{
+  gfc_expr *result;
+  result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
+
+  hollerith2representation (result, src);
+  gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
+			 result->representation.length, result->value.complex);
+
+  return result;
+}
+
+
+/* Convert Hollerith to character. */
+
+gfc_expr *
+gfc_hollerith2character (gfc_expr *src, int kind)
+{
+  gfc_expr *result;
+
+  result = gfc_copy_expr (src);
+  result->ts.type = BT_CHARACTER;
+  result->ts.kind = kind;
+
+  result->value.character.length = result->representation.length;
+  result->value.character.string
+    = gfc_char_to_widechar (result->representation.string);
+
+  return result;
+}
+
+
+/* Convert Hollerith to logical. The constant will be padded or truncated.  */
+
+gfc_expr *
+gfc_hollerith2logical (gfc_expr *src, int kind)
+{
+  gfc_expr *result;
+  result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
+
+  hollerith2representation (result, src);
+  gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
+			 result->representation.length, &result->value.logical);
+
+  return result;
+}
diff --git a/gcc-4.9/gcc/fortran/arith.h b/gcc-4.9/gcc/fortran/arith.h
new file mode 100644
index 000000000..ca99dbaeb
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/arith.h
@@ -0,0 +1,87 @@
+/* Compiler arithmetic header.
+   Copyright (C) 2000-2014 Free Software Foundation, Inc.
+   Contributed by Steven Bosscher
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+#ifndef GFC_ARITH_H
+#define GFC_ARITH_H
+
+/* MPFR also does not have the conversion of a mpfr_t to a mpz_t, so declare
+   a function for this as well.  */
+
+void gfc_mpfr_to_mpz (mpz_t, mpfr_t, locus *);
+void gfc_set_model_kind (int);
+void gfc_set_model (mpfr_t);
+
+/* Make sure a gfc_expr expression is within its allowed range.  Checks
+   for overflow and underflow.  */
+arith gfc_range_check (gfc_expr *);
+
+int gfc_compare_expr (gfc_expr *, gfc_expr *, gfc_intrinsic_op);
+int gfc_compare_string (gfc_expr *, gfc_expr *);
+int gfc_compare_with_Cstring (gfc_expr *, const char *, bool);
+
+
+/* Constant folding for gfc_expr trees.  */
+gfc_expr *gfc_parentheses (gfc_expr * op);
+gfc_expr *gfc_uplus (gfc_expr * op);
+gfc_expr *gfc_uminus (gfc_expr * op);
+gfc_expr *gfc_add (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_subtract (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_multiply (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_divide (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_power (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_concat (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_and (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_or (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_not (gfc_expr *);
+gfc_expr *gfc_eqv (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_neqv (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_eq (gfc_expr *, gfc_expr *, gfc_intrinsic_op);
+gfc_expr *gfc_ne (gfc_expr *, gfc_expr *, gfc_intrinsic_op);
+gfc_expr *gfc_gt (gfc_expr *, gfc_expr *, gfc_intrinsic_op);
+gfc_expr *gfc_ge (gfc_expr *, gfc_expr *, gfc_intrinsic_op);
+gfc_expr *gfc_lt (gfc_expr *, gfc_expr *, gfc_intrinsic_op);
+gfc_expr *gfc_le (gfc_expr *, gfc_expr *, gfc_intrinsic_op);
+
+/* Convert strings to literal constants.  */
+gfc_expr *gfc_convert_integer (const char *, int, int, locus *);
+gfc_expr *gfc_convert_real (const char *, int, locus *);
+gfc_expr *gfc_convert_complex (gfc_expr *, gfc_expr *, int);
+
+/* Convert a constant of one kind to another kind.  */
+gfc_expr *gfc_int2int (gfc_expr *, int);
+gfc_expr *gfc_int2real (gfc_expr *, int);
+gfc_expr *gfc_int2complex (gfc_expr *, int);
+gfc_expr *gfc_real2int (gfc_expr *, int);
+gfc_expr *gfc_real2real (gfc_expr *, int);
+gfc_expr *gfc_real2complex (gfc_expr *, int);
+gfc_expr *gfc_complex2int (gfc_expr *, int);
+gfc_expr *gfc_complex2real (gfc_expr *, int);
+gfc_expr *gfc_complex2complex (gfc_expr *, int);
+gfc_expr *gfc_log2log (gfc_expr *, int);
+gfc_expr *gfc_log2int (gfc_expr *, int);
+gfc_expr *gfc_int2log (gfc_expr *, int);
+gfc_expr *gfc_hollerith2int (gfc_expr *, int);
+gfc_expr *gfc_hollerith2real (gfc_expr *, int);
+gfc_expr *gfc_hollerith2complex (gfc_expr *, int);
+gfc_expr *gfc_hollerith2character (gfc_expr *, int);
+gfc_expr *gfc_hollerith2logical (gfc_expr *, int);
+
+#endif /* GFC_ARITH_H  */
+
diff --git a/gcc-4.9/gcc/fortran/array.c b/gcc-4.9/gcc/fortran/array.c
new file mode 100644
index 000000000..ef2aa69f7
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/array.c
@@ -0,0 +1,2509 @@
+/* Array things
+   Copyright (C) 2000-2014 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "gfortran.h"
+#include "match.h"
+#include "constructor.h"
+
+/**************** Array reference matching subroutines *****************/
+
+/* Copy an array reference structure.  */
+
+gfc_array_ref *
+gfc_copy_array_ref (gfc_array_ref *src)
+{
+  gfc_array_ref *dest;
+  int i;
+
+  if (src == NULL)
+    return NULL;
+
+  dest = gfc_get_array_ref ();
+
+  *dest = *src;
+
+  for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
+    {
+      dest->start[i] = gfc_copy_expr (src->start[i]);
+      dest->end[i] = gfc_copy_expr (src->end[i]);
+      dest->stride[i] = gfc_copy_expr (src->stride[i]);
+    }
+
+  return dest;
+}
+
+
+/* Match a single dimension of an array reference.  This can be a
+   single element or an array section.  Any modifications we've made
+   to the ar structure are cleaned up by the caller.  If the init
+   is set, we require the subscript to be a valid initialization
+   expression.  */
+
+static match
+match_subscript (gfc_array_ref *ar, int init, bool match_star)
+{
+  match m = MATCH_ERROR;
+  bool star = false;
+  int i;
+
+  i = ar->dimen + ar->codimen;
+
+  gfc_gobble_whitespace ();
+  ar->c_where[i] = gfc_current_locus;
+  ar->start[i] = ar->end[i] = ar->stride[i] = NULL;
+
+  /* We can't be sure of the difference between DIMEN_ELEMENT and
+     DIMEN_VECTOR until we know the type of the element itself at
+     resolution time.  */
+
+  ar->dimen_type[i] = DIMEN_UNKNOWN;
+
+  if (gfc_match_char (':') == MATCH_YES)
+    goto end_element;
+
+  /* Get start element.  */
+  if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
+    star = true;
+
+  if (!star && init)
+    m = gfc_match_init_expr (&ar->start[i]);
+  else if (!star)
+    m = gfc_match_expr (&ar->start[i]);
+
+  if (m == MATCH_NO)
+    gfc_error ("Expected array subscript at %C");
+  if (m != MATCH_YES)
+    return MATCH_ERROR;
+
+  if (gfc_match_char (':') == MATCH_NO)
+    goto matched;
+
+  if (star)
+    {
+      gfc_error ("Unexpected '*' in coarray subscript at %C");
+      return MATCH_ERROR;
+    }
+
+  /* Get an optional end element.  Because we've seen the colon, we
+     definitely have a range along this dimension.  */
+end_element:
+  ar->dimen_type[i] = DIMEN_RANGE;
+
+  if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
+    star = true;
+  else if (init)
+    m = gfc_match_init_expr (&ar->end[i]);
+  else
+    m = gfc_match_expr (&ar->end[i]);
+
+  if (m == MATCH_ERROR)
+    return MATCH_ERROR;
+
+  /* See if we have an optional stride.  */
+  if (gfc_match_char (':') == MATCH_YES)
+    {
+      if (star)
+	{
+	  gfc_error ("Strides not allowed in coarray subscript at %C");
+	  return MATCH_ERROR;
+	}
+
+      m = init ? gfc_match_init_expr (&ar->stride[i])
+	       : gfc_match_expr (&ar->stride[i]);
+
+      if (m == MATCH_NO)
+	gfc_error ("Expected array subscript stride at %C");
+      if (m != MATCH_YES)
+	return MATCH_ERROR;
+    }
+
+matched:
+  if (star)
+    ar->dimen_type[i] = DIMEN_STAR;
+
+  return MATCH_YES;
+}
+
+
+/* Match an array reference, whether it is the whole array or a
+   particular elements or a section. If init is set, the reference has
+   to consist of init expressions.  */
+
+match
+gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init,
+		     int corank)
+{
+  match m;
+  bool matched_bracket = false;
+
+  memset (ar, '\0', sizeof (*ar));
+
+  ar->where = gfc_current_locus;
+  ar->as = as;
+  ar->type = AR_UNKNOWN;
+
+  if (gfc_match_char ('[') == MATCH_YES)
+    {
+       matched_bracket = true;
+       goto coarray;
+    }
+
+  if (gfc_match_char ('(') != MATCH_YES)
+    {
+      ar->type = AR_FULL;
+      ar->dimen = 0;
+      return MATCH_YES;
+    }
+
+  for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++)
+    {
+      m = match_subscript (ar, init, false);
+      if (m == MATCH_ERROR)
+	return MATCH_ERROR;
+
+      if (gfc_match_char (')') == MATCH_YES)
+	{
+	  ar->dimen++;
+	  goto coarray;
+	}
+
+      if (gfc_match_char (',') != MATCH_YES)
+	{
+	  gfc_error ("Invalid form of array reference at %C");
+	  return MATCH_ERROR;
+	}
+    }
+
+  gfc_error ("Array reference at %C cannot have more than %d dimensions",
+	     GFC_MAX_DIMENSIONS);
+  return MATCH_ERROR;
+
+coarray:
+  if (!matched_bracket && gfc_match_char ('[') != MATCH_YES)
+    {
+      if (ar->dimen > 0)
+	return MATCH_YES;
+      else
+	return MATCH_ERROR;
+    }
+
+  if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+    {
+      gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+      return MATCH_ERROR;
+    }
+
+  if (corank == 0)
+    {
+	gfc_error ("Unexpected coarray designator at %C");
+	return MATCH_ERROR;
+    }
+
+  for (ar->codimen = 0; ar->codimen + ar->dimen < GFC_MAX_DIMENSIONS; ar->codimen++)
+    {
+      m = match_subscript (ar, init, true);
+      if (m == MATCH_ERROR)
+	return MATCH_ERROR;
+
+      if (gfc_match_char (']') == MATCH_YES)
+	{
+	  ar->codimen++;
+	  if (ar->codimen < corank)
+	    {
+	      gfc_error ("Too few codimensions at %C, expected %d not %d",
+			 corank, ar->codimen);
+	      return MATCH_ERROR;
+	    }
+	  if (ar->codimen > corank)
+	    {
+	      gfc_error ("Too many codimensions at %C, expected %d not %d",
+			 corank, ar->codimen);
+	      return MATCH_ERROR;
+	    }
+	  return MATCH_YES;
+	}
+
+      if (gfc_match_char (',') != MATCH_YES)
+	{
+	  if (gfc_match_char ('*') == MATCH_YES)
+	    gfc_error ("Unexpected '*' for codimension %d of %d at %C",
+		       ar->codimen + 1, corank);
+	  else
+	    gfc_error ("Invalid form of coarray reference at %C");
+	  return MATCH_ERROR;
+	}
+      else if (ar->dimen_type[ar->codimen + ar->dimen] == DIMEN_STAR)
+	{
+	  gfc_error ("Unexpected '*' for codimension %d of %d at %C",
+		     ar->codimen + 1, corank);
+	  return MATCH_ERROR;
+	}
+
+      if (ar->codimen >= corank)
+	{
+	  gfc_error ("Invalid codimension %d at %C, only %d codimensions exist",
+		     ar->codimen + 1, corank);
+	  return MATCH_ERROR;
+	}
+    }
+
+  gfc_error ("Array reference at %C cannot have more than %d dimensions",
+	     GFC_MAX_DIMENSIONS);
+  return MATCH_ERROR;
+
+}
+
+
+/************** Array specification matching subroutines ***************/
+
+/* Free all of the expressions associated with array bounds
+   specifications.  */
+
+void
+gfc_free_array_spec (gfc_array_spec *as)
+{
+  int i;
+
+  if (as == NULL)
+    return;
+
+  for (i = 0; i < as->rank + as->corank; i++)
+    {
+      gfc_free_expr (as->lower[i]);
+      gfc_free_expr (as->upper[i]);
+    }
+
+  free (as);
+}
+
+
+/* Take an array bound, resolves the expression, that make up the
+   shape and check associated constraints.  */
+
+static bool
+resolve_array_bound (gfc_expr *e, int check_constant)
+{
+  if (e == NULL)
+    return true;
+
+  if (!gfc_resolve_expr (e)
+      || !gfc_specification_expr (e))
+    return false;
+
+  if (check_constant && !gfc_is_constant_expr (e))
+    {
+      if (e->expr_type == EXPR_VARIABLE)
+	gfc_error ("Variable '%s' at %L in this context must be constant",
+		   e->symtree->n.sym->name, &e->where);
+      else
+	gfc_error ("Expression at %L in this context must be constant",
+		   &e->where);
+      return false;
+    }
+
+  return true;
+}
+
+
+/* Takes an array specification, resolves the expressions that make up
+   the shape and make sure everything is integral.  */
+
+bool
+gfc_resolve_array_spec (gfc_array_spec *as, int check_constant)
+{
+  gfc_expr *e;
+  int i;
+
+  if (as == NULL)
+    return true;
+
+  for (i = 0; i < as->rank + as->corank; i++)
+    {
+      e = as->lower[i];
+      if (!resolve_array_bound (e, check_constant))
+	return false;
+
+      e = as->upper[i];
+      if (!resolve_array_bound (e, check_constant))
+	return false;
+
+      if ((as->lower[i] == NULL) || (as->upper[i] == NULL))
+	continue;
+
+      /* If the size is negative in this dimension, set it to zero.  */
+      if (as->lower[i]->expr_type == EXPR_CONSTANT
+	    && as->upper[i]->expr_type == EXPR_CONSTANT
+	    && mpz_cmp (as->upper[i]->value.integer,
+			as->lower[i]->value.integer) < 0)
+	{
+	  gfc_free_expr (as->upper[i]);
+	  as->upper[i] = gfc_copy_expr (as->lower[i]);
+	  mpz_sub_ui (as->upper[i]->value.integer,
+		      as->upper[i]->value.integer, 1);
+	}
+    }
+
+  return true;
+}
+
+
+/* Match a single array element specification.  The return values as
+   well as the upper and lower bounds of the array spec are filled
+   in according to what we see on the input.  The caller makes sure
+   individual specifications make sense as a whole.
+
+
+	Parsed       Lower   Upper  Returned
+	------------------------------------
+	  :           NULL    NULL   AS_DEFERRED (*)
+	  x            1       x     AS_EXPLICIT
+	  x:           x      NULL   AS_ASSUMED_SHAPE
+	  x:y          x       y     AS_EXPLICIT
+	  x:*          x      NULL   AS_ASSUMED_SIZE
+	  *            1      NULL   AS_ASSUMED_SIZE
+
+  (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE.  This
+  is fixed during the resolution of formal interfaces.
+
+   Anything else AS_UNKNOWN.  */
+
+static array_type
+match_array_element_spec (gfc_array_spec *as)
+{
+  gfc_expr **upper, **lower;
+  match m;
+  int rank;
+
+  rank = as->rank == -1 ? 0 : as->rank;
+  lower = &as->lower[rank + as->corank - 1];
+  upper = &as->upper[rank + as->corank - 1];
+
+  if (gfc_match_char ('*') == MATCH_YES)
+    {
+      *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+      return AS_ASSUMED_SIZE;
+    }
+
+  if (gfc_match_char (':') == MATCH_YES)
+    return AS_DEFERRED;
+
+  m = gfc_match_expr (upper);
+  if (m == MATCH_NO)
+    gfc_error ("Expected expression in array specification at %C");
+  if (m != MATCH_YES)
+    return AS_UNKNOWN;
+  if (!gfc_expr_check_typed (*upper, gfc_current_ns, false))
+    return AS_UNKNOWN;
+
+  if (gfc_match_char (':') == MATCH_NO)
+    {
+      *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+      return AS_EXPLICIT;
+    }
+
+  *lower = *upper;
+  *upper = NULL;
+
+  if (gfc_match_char ('*') == MATCH_YES)
+    return AS_ASSUMED_SIZE;
+
+  m = gfc_match_expr (upper);
+  if (m == MATCH_ERROR)
+    return AS_UNKNOWN;
+  if (m == MATCH_NO)
+    return AS_ASSUMED_SHAPE;
+  if (!gfc_expr_check_typed (*upper, gfc_current_ns, false))
+    return AS_UNKNOWN;
+
+  return AS_EXPLICIT;
+}
+
+
+/* Matches an array specification, incidentally figuring out what sort
+   it is. Match either a normal array specification, or a coarray spec
+   or both. Optionally allow [:] for coarrays.  */
+
+match
+gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
+{
+  array_type current_type;
+  gfc_array_spec *as;
+  int i;
+
+  as = gfc_get_array_spec ();
+
+  if (!match_dim)
+    goto coarray;
+
+  if (gfc_match_char ('(') != MATCH_YES)
+    {
+      if (!match_codim)
+	goto done;
+      goto coarray;
+    }
+
+  if (gfc_match (" .. )") == MATCH_YES)
+    {
+      as->type = AS_ASSUMED_RANK;
+      as->rank = -1;
+
+      if (!gfc_notify_std (GFC_STD_F2008_TS, "Assumed-rank array at %C"))
+	goto cleanup;
+
+      if (!match_codim)
+	goto done;
+      goto coarray;
+    }
+
+  for (;;)
+    {
+      as->rank++;
+      current_type = match_array_element_spec (as);
+
+      /* Note that current_type == AS_ASSUMED_SIZE for both assumed-size
+	 and implied-shape specifications.  If the rank is at least 2, we can
+	 distinguish between them.  But for rank 1, we currently return
+	 ASSUMED_SIZE; this gets adjusted later when we know for sure
+	 whether the symbol parsed is a PARAMETER or not.  */
+
+      if (as->rank == 1)
+	{
+	  if (current_type == AS_UNKNOWN)
+	    goto cleanup;
+	  as->type = current_type;
+	}
+      else
+	switch (as->type)
+	  {		/* See how current spec meshes with the existing.  */
+	  case AS_UNKNOWN:
+	    goto cleanup;
+
+	  case AS_IMPLIED_SHAPE:
+	    if (current_type != AS_ASSUMED_SHAPE)
+	      {
+		gfc_error ("Bad array specification for implied-shape"
+			   " array at %C");
+		goto cleanup;
+	      }
+	    break;
+
+	  case AS_EXPLICIT:
+	    if (current_type == AS_ASSUMED_SIZE)
+	      {
+		as->type = AS_ASSUMED_SIZE;
+		break;
+	      }
+
+	    if (current_type == AS_EXPLICIT)
+	      break;
+
+	    gfc_error ("Bad array specification for an explicitly shaped "
+		       "array at %C");
+
+	    goto cleanup;
+
+	  case AS_ASSUMED_SHAPE:
+	    if ((current_type == AS_ASSUMED_SHAPE)
+		|| (current_type == AS_DEFERRED))
+	      break;
+
+	    gfc_error ("Bad array specification for assumed shape "
+		       "array at %C");
+	    goto cleanup;
+
+	  case AS_DEFERRED:
+	    if (current_type == AS_DEFERRED)
+	      break;
+
+	    if (current_type == AS_ASSUMED_SHAPE)
+	      {
+		as->type = AS_ASSUMED_SHAPE;
+		break;
+	      }
+
+	    gfc_error ("Bad specification for deferred shape array at %C");
+	    goto cleanup;
+
+	  case AS_ASSUMED_SIZE:
+	    if (as->rank == 2 && current_type == AS_ASSUMED_SIZE)
+	      {
+		as->type = AS_IMPLIED_SHAPE;
+		break;
+	      }
+
+	    gfc_error ("Bad specification for assumed size array at %C");
+	    goto cleanup;
+
+	  case AS_ASSUMED_RANK:
+	    gcc_unreachable ();
+	  }
+
+      if (gfc_match_char (')') == MATCH_YES)
+	break;
+
+      if (gfc_match_char (',') != MATCH_YES)
+	{
+	  gfc_error ("Expected another dimension in array declaration at %C");
+	  goto cleanup;
+	}
+
+      if (as->rank + as->corank >= GFC_MAX_DIMENSIONS)
+	{
+	  gfc_error ("Array specification at %C has more than %d dimensions",
+		     GFC_MAX_DIMENSIONS);
+	  goto cleanup;
+	}
+
+      if (as->corank + as->rank >= 7
+	  && !gfc_notify_std (GFC_STD_F2008, "Array specification at %C "
+			      "with more than 7 dimensions"))
+	goto cleanup;
+    }
+
+  if (!match_codim)
+    goto done;
+
+coarray:
+  if (gfc_match_char ('[')  != MATCH_YES)
+    goto done;
+
+  if (!gfc_notify_std (GFC_STD_F2008, "Coarray declaration at %C"))
+    goto cleanup;
+
+  if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+    {
+      gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+      goto cleanup;
+    }
+
+  if (as->rank >= GFC_MAX_DIMENSIONS)
+    {
+      gfc_error ("Array specification at %C has more than %d "
+		 "dimensions", GFC_MAX_DIMENSIONS);
+      goto cleanup;
+    }
+
+  for (;;)
+    {
+      as->corank++;
+      current_type = match_array_element_spec (as);
+
+      if (current_type == AS_UNKNOWN)
+	goto cleanup;
+
+      if (as->corank == 1)
+	as->cotype = current_type;
+      else
+	switch (as->cotype)
+	  { /* See how current spec meshes with the existing.  */
+	    case AS_IMPLIED_SHAPE:
+	    case AS_UNKNOWN:
+	      goto cleanup;
+
+	    case AS_EXPLICIT:
+	      if (current_type == AS_ASSUMED_SIZE)
+		{
+		  as->cotype = AS_ASSUMED_SIZE;
+		  break;
+		}
+
+	      if (current_type == AS_EXPLICIT)
+		break;
+
+	      gfc_error ("Bad array specification for an explicitly "
+			 "shaped array at %C");
+
+	      goto cleanup;
+
+	    case AS_ASSUMED_SHAPE:
+	      if ((current_type == AS_ASSUMED_SHAPE)
+		  || (current_type == AS_DEFERRED))
+		break;
+
+	      gfc_error ("Bad array specification for assumed shape "
+			 "array at %C");
+	      goto cleanup;
+
+	    case AS_DEFERRED:
+	      if (current_type == AS_DEFERRED)
+		break;
+
+	      if (current_type == AS_ASSUMED_SHAPE)
+		{
+		  as->cotype = AS_ASSUMED_SHAPE;
+		  break;
+		}
+
+	      gfc_error ("Bad specification for deferred shape array at %C");
+	      goto cleanup;
+
+	    case AS_ASSUMED_SIZE:
+	      gfc_error ("Bad specification for assumed size array at %C");
+	      goto cleanup;
+
+	    case AS_ASSUMED_RANK:
+	      gcc_unreachable ();
+	  }
+
+      if (gfc_match_char (']') == MATCH_YES)
+	break;
+
+      if (gfc_match_char (',') != MATCH_YES)
+	{
+	  gfc_error ("Expected another dimension in array declaration at %C");
+	  goto cleanup;
+	}
+
+      if (as->rank + as->corank >= GFC_MAX_DIMENSIONS)
+	{
+	  gfc_error ("Array specification at %C has more than %d "
+		     "dimensions", GFC_MAX_DIMENSIONS);
+	  goto cleanup;
+	}
+    }
+
+  if (current_type == AS_EXPLICIT)
+    {
+      gfc_error ("Upper bound of last coarray dimension must be '*' at %C");
+      goto cleanup;
+    }
+
+  if (as->cotype == AS_ASSUMED_SIZE)
+    as->cotype = AS_EXPLICIT;
+
+  if (as->rank == 0)
+    as->type = as->cotype;
+
+done:
+  if (as->rank == 0 && as->corank == 0)
+    {
+      *asp = NULL;
+      gfc_free_array_spec (as);
+      return MATCH_NO;
+    }
+
+  /* If a lower bounds of an assumed shape array is blank, put in one.  */
+  if (as->type == AS_ASSUMED_SHAPE)
+    {
+      for (i = 0; i < as->rank + as->corank; i++)
+	{
+	  if (as->lower[i] == NULL)
+	    as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+	}
+    }
+
+  *asp = as;
+
+  return MATCH_YES;
+
+cleanup:
+  /* Something went wrong.  */
+  gfc_free_array_spec (as);
+  return MATCH_ERROR;
+}
+
+
+/* Given a symbol and an array specification, modify the symbol to
+   have that array specification.  The error locus is needed in case
+   something goes wrong.  On failure, the caller must free the spec.  */
+
+bool
+gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
+{
+  int i;
+
+  if (as == NULL)
+    return true;
+
+  if (as->rank
+      && !gfc_add_dimension (&sym->attr, sym->name, error_loc))
+    return false;
+
+  if (as->corank
+      && !gfc_add_codimension (&sym->attr, sym->name, error_loc))
+    return false;
+
+  if (sym->as == NULL)
+    {
+      sym->as = as;
+      return true;
+    }
+
+  if ((sym->as->type == AS_ASSUMED_RANK && as->corank)
+      || (as->type == AS_ASSUMED_RANK && sym->as->corank))
+    {
+      gfc_error ("The assumed-rank array '%s' at %L shall not have a "
+		 "codimension", sym->name, error_loc);
+      return false;
+    }
+
+  if (as->corank)
+    {
+      /* The "sym" has no corank (checked via gfc_add_codimension). Thus
+	 the codimension is simply added.  */
+      gcc_assert (as->rank == 0 && sym->as->corank == 0);
+
+      sym->as->cotype = as->cotype;
+      sym->as->corank = as->corank;
+      for (i = 0; i < as->corank; i++)
+	{
+	  sym->as->lower[sym->as->rank + i] = as->lower[i];
+	  sym->as->upper[sym->as->rank + i] = as->upper[i];
+	}
+    }
+  else
+    {
+      /* The "sym" has no rank (checked via gfc_add_dimension). Thus
+	 the dimension is added - but first the codimensions (if existing
+	 need to be shifted to make space for the dimension.  */
+      gcc_assert (as->corank == 0 && sym->as->rank == 0);
+
+      sym->as->rank = as->rank;
+      sym->as->type = as->type;
+      sym->as->cray_pointee = as->cray_pointee;
+      sym->as->cp_was_assumed = as->cp_was_assumed;
+
+      for (i = 0; i < sym->as->corank; i++)
+	{
+	  sym->as->lower[as->rank + i] = sym->as->lower[i];
+	  sym->as->upper[as->rank + i] = sym->as->upper[i];
+	}
+      for (i = 0; i < as->rank; i++)
+	{
+	  sym->as->lower[i] = as->lower[i];
+	  sym->as->upper[i] = as->upper[i];
+	}
+    }
+
+  free (as);
+  return true;
+}
+
+
+/* Copy an array specification.  */
+
+gfc_array_spec *
+gfc_copy_array_spec (gfc_array_spec *src)
+{
+  gfc_array_spec *dest;
+  int i;
+
+  if (src == NULL)
+    return NULL;
+
+  dest = gfc_get_array_spec ();
+
+  *dest = *src;
+
+  for (i = 0; i < dest->rank + dest->corank; i++)
+    {
+      dest->lower[i] = gfc_copy_expr (dest->lower[i]);
+      dest->upper[i] = gfc_copy_expr (dest->upper[i]);
+    }
+
+  return dest;
+}
+
+
+/* Returns nonzero if the two expressions are equal.  Only handles integer
+   constants.  */
+
+static int
+compare_bounds (gfc_expr *bound1, gfc_expr *bound2)
+{
+  if (bound1 == NULL || bound2 == NULL
+      || bound1->expr_type != EXPR_CONSTANT
+      || bound2->expr_type != EXPR_CONSTANT
+      || bound1->ts.type != BT_INTEGER
+      || bound2->ts.type != BT_INTEGER)
+    gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
+
+  if (mpz_cmp (bound1->value.integer, bound2->value.integer) == 0)
+    return 1;
+  else
+    return 0;
+}
+
+
+/* Compares two array specifications.  They must be constant or deferred
+   shape.  */
+
+int
+gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
+{
+  int i;
+
+  if (as1 == NULL && as2 == NULL)
+    return 1;
+
+  if (as1 == NULL || as2 == NULL)
+    return 0;
+
+  if (as1->rank != as2->rank)
+    return 0;
+
+  if (as1->corank != as2->corank)
+    return 0;
+
+  if (as1->rank == 0)
+    return 1;
+
+  if (as1->type != as2->type)
+    return 0;
+
+  if (as1->type == AS_EXPLICIT)
+    for (i = 0; i < as1->rank + as1->corank; i++)
+      {
+	if (compare_bounds (as1->lower[i], as2->lower[i]) == 0)
+	  return 0;
+
+	if (compare_bounds (as1->upper[i], as2->upper[i]) == 0)
+	  return 0;
+      }
+
+  return 1;
+}
+
+
+/****************** Array constructor functions ******************/
+
+
+/* Given an expression node that might be an array constructor and a
+   symbol, make sure that no iterators in this or child constructors
+   use the symbol as an implied-DO iterator.  Returns nonzero if a
+   duplicate was found.  */
+
+static int
+check_duplicate_iterator (gfc_constructor_base base, gfc_symbol *master)
+{
+  gfc_constructor *c;
+  gfc_expr *e;
+
+  for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
+    {
+      e = c->expr;
+
+      if (e->expr_type == EXPR_ARRAY
+	  && check_duplicate_iterator (e->value.constructor, master))
+	return 1;
+
+      if (c->iterator == NULL)
+	continue;
+
+      if (c->iterator->var->symtree->n.sym == master)
+	{
+	  gfc_error ("DO-iterator '%s' at %L is inside iterator of the "
+		     "same name", master->name, &c->where);
+
+	  return 1;
+	}
+    }
+
+  return 0;
+}
+
+
+/* Forward declaration because these functions are mutually recursive.  */
+static match match_array_cons_element (gfc_constructor_base *);
+
+/* Match a list of array elements.  */
+
+static match
+match_array_list (gfc_constructor_base *result)
+{
+  gfc_constructor_base head;
+  gfc_constructor *p;
+  gfc_iterator iter;
+  locus old_loc;
+  gfc_expr *e;
+  match m;
+  int n;
+
+  old_loc = gfc_current_locus;
+
+  if (gfc_match_char ('(') == MATCH_NO)
+    return MATCH_NO;
+
+  memset (&iter, '\0', sizeof (gfc_iterator));
+  head = NULL;
+
+  m = match_array_cons_element (&head);
+  if (m != MATCH_YES)
+    goto cleanup;
+
+  if (gfc_match_char (',') != MATCH_YES)
+    {
+      m = MATCH_NO;
+      goto cleanup;
+    }
+
+  for (n = 1;; n++)
+    {
+      m = gfc_match_iterator (&iter, 0);
+      if (m == MATCH_YES)
+	break;
+      if (m == MATCH_ERROR)
+	goto cleanup;
+
+      m = match_array_cons_element (&head);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_NO)
+	{
+	  if (n > 2)
+	    goto syntax;
+	  m = MATCH_NO;
+	  goto cleanup;		/* Could be a complex constant */
+	}
+
+      if (gfc_match_char (',') != MATCH_YES)
+	{
+	  if (n > 2)
+	    goto syntax;
+	  m = MATCH_NO;
+	  goto cleanup;
+	}
+    }
+
+  if (gfc_match_char (')') != MATCH_YES)
+    goto syntax;
+
+  if (check_duplicate_iterator (head, iter.var->symtree->n.sym))
+    {
+      m = MATCH_ERROR;
+      goto cleanup;
+    }
+
+  e = gfc_get_array_expr (BT_UNKNOWN, 0, &old_loc);
+  e->value.constructor = head;
+
+  p = gfc_constructor_append_expr (result, e, &gfc_current_locus);
+  p->iterator = gfc_get_iterator ();
+  *p->iterator = iter;
+
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in array constructor at %C");
+  m = MATCH_ERROR;
+
+cleanup:
+  gfc_constructor_free (head);
+  gfc_free_iterator (&iter, 0);
+  gfc_current_locus = old_loc;
+  return m;
+}
+
+
+/* Match a single element of an array constructor, which can be a
+   single expression or a list of elements.  */
+
+static match
+match_array_cons_element (gfc_constructor_base *result)
+{
+  gfc_expr *expr;
+  match m;
+
+  m = match_array_list (result);
+  if (m != MATCH_NO)
+    return m;
+
+  m = gfc_match_expr (&expr);
+  if (m != MATCH_YES)
+    return m;
+
+  gfc_constructor_append_expr (result, expr, &gfc_current_locus);
+  return MATCH_YES;
+}
+
+
+/* Match an array constructor.  */
+
+match
+gfc_match_array_constructor (gfc_expr **result)
+{
+  gfc_constructor_base head, new_cons;
+  gfc_undo_change_set changed_syms;
+  gfc_expr *expr;
+  gfc_typespec ts;
+  locus where;
+  match m;
+  const char *end_delim;
+  bool seen_ts;
+
+  if (gfc_match (" (/") == MATCH_NO)
+    {
+      if (gfc_match (" [") == MATCH_NO)
+	return MATCH_NO;
+      else
+	{
+	  if (!gfc_notify_std (GFC_STD_F2003, "[...] "
+			       "style array constructors at %C"))
+	    return MATCH_ERROR;
+	  end_delim = " ]";
+	}
+    }
+  else
+    end_delim = " /)";
+
+  where = gfc_current_locus;
+  head = new_cons = NULL;
+  seen_ts = false;
+
+  /* Try to match an optional "type-spec ::"  */
+  gfc_clear_ts (&ts);
+  gfc_new_undo_checkpoint (changed_syms);
+  if (gfc_match_type_spec (&ts) == MATCH_YES)
+    {
+      seen_ts = (gfc_match (" ::") == MATCH_YES);
+
+      if (seen_ts)
+	{
+	  if (!gfc_notify_std (GFC_STD_F2003, "Array constructor "
+			       "including type specification at %C"))
+	    {
+	      gfc_restore_last_undo_checkpoint ();
+	      goto cleanup;
+	    }
+
+	  if (ts.deferred)
+	    {
+	      gfc_error ("Type-spec at %L cannot contain a deferred "
+			 "type parameter", &where);
+	      gfc_restore_last_undo_checkpoint ();
+	      goto cleanup;
+	    }
+	}
+    }
+
+  if (seen_ts)
+    gfc_drop_last_undo_checkpoint ();
+  else
+    {
+      gfc_restore_last_undo_checkpoint ();
+      gfc_current_locus = where;
+    }
+
+  if (gfc_match (end_delim) == MATCH_YES)
+    {
+      if (seen_ts)
+	goto done;
+      else
+	{
+	  gfc_error ("Empty array constructor at %C is not allowed");
+	  goto cleanup;
+	}
+    }
+
+  for (;;)
+    {
+      m = match_array_cons_element (&head);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_NO)
+	goto syntax;
+
+      if (gfc_match_char (',') == MATCH_NO)
+	break;
+    }
+
+  if (gfc_match (end_delim) == MATCH_NO)
+    goto syntax;
+
+done:
+  /* Size must be calculated at resolution time.  */
+  if (seen_ts)
+    {
+      expr = gfc_get_array_expr (ts.type, ts.kind, &where);
+      expr->ts = ts;
+    }
+  else
+    expr = gfc_get_array_expr (BT_UNKNOWN, 0, &where);
+
+  expr->value.constructor = head;
+  if (expr->ts.u.cl)
+    expr->ts.u.cl->length_from_typespec = seen_ts;
+
+  *result = expr;
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in array constructor at %C");
+
+cleanup:
+  gfc_constructor_free (head);
+  return MATCH_ERROR;
+}
+
+
+
+/************** Check array constructors for correctness **************/
+
+/* Given an expression, compare it's type with the type of the current
+   constructor.  Returns nonzero if an error was issued.  The
+   cons_state variable keeps track of whether the type of the
+   constructor being read or resolved is known to be good, bad or just
+   starting out.  */
+
+static gfc_typespec constructor_ts;
+static enum
+{ CONS_START, CONS_GOOD, CONS_BAD }
+cons_state;
+
+static int
+check_element_type (gfc_expr *expr, bool convert)
+{
+  if (cons_state == CONS_BAD)
+    return 0;			/* Suppress further errors */
+
+  if (cons_state == CONS_START)
+    {
+      if (expr->ts.type == BT_UNKNOWN)
+	cons_state = CONS_BAD;
+      else
+	{
+	  cons_state = CONS_GOOD;
+	  constructor_ts = expr->ts;
+	}
+
+      return 0;
+    }
+
+  if (gfc_compare_types (&constructor_ts, &expr->ts))
+    return 0;
+
+  if (convert)
+    return gfc_convert_type(expr, &constructor_ts, 1) ? 0 : 1;
+
+  gfc_error ("Element in %s array constructor at %L is %s",
+	     gfc_typename (&constructor_ts), &expr->where,
+	     gfc_typename (&expr->ts));
+
+  cons_state = CONS_BAD;
+  return 1;
+}
+
+
+/* Recursive work function for gfc_check_constructor_type().  */
+
+static bool
+check_constructor_type (gfc_constructor_base base, bool convert)
+{
+  gfc_constructor *c;
+  gfc_expr *e;
+
+  for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
+    {
+      e = c->expr;
+
+      if (e->expr_type == EXPR_ARRAY)
+	{
+	  if (!check_constructor_type (e->value.constructor, convert))
+	    return false;
+
+	  continue;
+	}
+
+      if (check_element_type (e, convert))
+	return false;
+    }
+
+  return true;
+}
+
+
+/* Check that all elements of an array constructor are the same type.
+   On false, an error has been generated.  */
+
+bool
+gfc_check_constructor_type (gfc_expr *e)
+{
+  bool t;
+
+  if (e->ts.type != BT_UNKNOWN)
+    {
+      cons_state = CONS_GOOD;
+      constructor_ts = e->ts;
+    }
+  else
+    {
+      cons_state = CONS_START;
+      gfc_clear_ts (&constructor_ts);
+    }
+
+  /* If e->ts.type != BT_UNKNOWN, the array constructor included a
+     typespec, and we will now convert the values on the fly.  */
+  t = check_constructor_type (e->value.constructor, e->ts.type != BT_UNKNOWN);
+  if (t && e->ts.type == BT_UNKNOWN)
+    e->ts = constructor_ts;
+
+  return t;
+}
+
+
+
+typedef struct cons_stack
+{
+  gfc_iterator *iterator;
+  struct cons_stack *previous;
+}
+cons_stack;
+
+static cons_stack *base;
+
+static bool check_constructor (gfc_constructor_base, bool (*) (gfc_expr *));
+
+/* Check an EXPR_VARIABLE expression in a constructor to make sure
+   that that variable is an iteration variables.  */
+
+bool
+gfc_check_iter_variable (gfc_expr *expr)
+{
+  gfc_symbol *sym;
+  cons_stack *c;
+
+  sym = expr->symtree->n.sym;
+
+  for (c = base; c && c->iterator; c = c->previous)
+    if (sym == c->iterator->var->symtree->n.sym)
+      return true;
+
+  return false;
+}
+
+
+/* Recursive work function for gfc_check_constructor().  This amounts
+   to calling the check function for each expression in the
+   constructor, giving variables with the names of iterators a pass.  */
+
+static bool
+check_constructor (gfc_constructor_base ctor, bool (*check_function) (gfc_expr *))
+{
+  cons_stack element;
+  gfc_expr *e;
+  bool t;
+  gfc_constructor *c;
+
+  for (c = gfc_constructor_first (ctor); c; c = gfc_constructor_next (c))
+    {
+      e = c->expr;
+
+      if (e->expr_type != EXPR_ARRAY)
+	{
+	  if (!(*check_function)(e))
+	    return false;
+	  continue;
+	}
+
+      element.previous = base;
+      element.iterator = c->iterator;
+
+      base = &element;
+      t = check_constructor (e->value.constructor, check_function);
+      base = element.previous;
+
+      if (!t)
+	return false;
+    }
+
+  /* Nothing went wrong, so all OK.  */
+  return true;
+}
+
+
+/* Checks a constructor to see if it is a particular kind of
+   expression -- specification, restricted, or initialization as
+   determined by the check_function.  */
+
+bool
+gfc_check_constructor (gfc_expr *expr, bool (*check_function) (gfc_expr *))
+{
+  cons_stack *base_save;
+  bool t;
+
+  base_save = base;
+  base = NULL;
+
+  t = check_constructor (expr->value.constructor, check_function);
+  base = base_save;
+
+  return t;
+}
+
+
+
+/**************** Simplification of array constructors ****************/
+
+iterator_stack *iter_stack;
+
+typedef struct
+{
+  gfc_constructor_base base;
+  int extract_count, extract_n;
+  gfc_expr *extracted;
+  mpz_t *count;
+
+  mpz_t *offset;
+  gfc_component *component;
+  mpz_t *repeat;
+
+  bool (*expand_work_function) (gfc_expr *);
+}
+expand_info;
+
+static expand_info current_expand;
+
+static bool expand_constructor (gfc_constructor_base);
+
+
+/* Work function that counts the number of elements present in a
+   constructor.  */
+
+static bool
+count_elements (gfc_expr *e)
+{
+  mpz_t result;
+
+  if (e->rank == 0)
+    mpz_add_ui (*current_expand.count, *current_expand.count, 1);
+  else
+    {
+      if (!gfc_array_size (e, &result))
+	{
+	  gfc_free_expr (e);
+	  return false;
+	}
+
+      mpz_add (*current_expand.count, *current_expand.count, result);
+      mpz_clear (result);
+    }
+
+  gfc_free_expr (e);
+  return true;
+}
+
+
+/* Work function that extracts a particular element from an array
+   constructor, freeing the rest.  */
+
+static bool
+extract_element (gfc_expr *e)
+{
+  if (e->rank != 0)
+    {				/* Something unextractable */
+      gfc_free_expr (e);
+      return false;
+    }
+
+  if (current_expand.extract_count == current_expand.extract_n)
+    current_expand.extracted = e;
+  else
+    gfc_free_expr (e);
+
+  current_expand.extract_count++;
+
+  return true;
+}
+
+
+/* Work function that constructs a new constructor out of the old one,
+   stringing new elements together.  */
+
+static bool
+expand (gfc_expr *e)
+{
+  gfc_constructor *c = gfc_constructor_append_expr (&current_expand.base,
+						    e, &e->where);
+
+  c->n.component = current_expand.component;
+  return true;
+}
+
+
+/* Given an initialization expression that is a variable reference,
+   substitute the current value of the iteration variable.  */
+
+void
+gfc_simplify_iterator_var (gfc_expr *e)
+{
+  iterator_stack *p;
+
+  for (p = iter_stack; p; p = p->prev)
+    if (e->symtree == p->variable)
+      break;
+
+  if (p == NULL)
+    return;		/* Variable not found */
+
+  gfc_replace_expr (e, gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
+
+  mpz_set (e->value.integer, p->value);
+
+  return;
+}
+
+
+/* Expand an expression with that is inside of a constructor,
+   recursing into other constructors if present.  */
+
+static bool
+expand_expr (gfc_expr *e)
+{
+  if (e->expr_type == EXPR_ARRAY)
+    return expand_constructor (e->value.constructor);
+
+  e = gfc_copy_expr (e);
+
+  if (!gfc_simplify_expr (e, 1))
+    {
+      gfc_free_expr (e);
+      return false;
+    }
+
+  return current_expand.expand_work_function (e);
+}
+
+
+static bool
+expand_iterator (gfc_constructor *c)
+{
+  gfc_expr *start, *end, *step;
+  iterator_stack frame;
+  mpz_t trip;
+  bool t;
+
+  end = step = NULL;
+
+  t = false;
+
+  mpz_init (trip);
+  mpz_init (frame.value);
+  frame.prev = NULL;
+
+  start = gfc_copy_expr (c->iterator->start);
+  if (!gfc_simplify_expr (start, 1))
+    goto cleanup;
+
+  if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER)
+    goto cleanup;
+
+  end = gfc_copy_expr (c->iterator->end);
+  if (!gfc_simplify_expr (end, 1))
+    goto cleanup;
+
+  if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER)
+    goto cleanup;
+
+  step = gfc_copy_expr (c->iterator->step);
+  if (!gfc_simplify_expr (step, 1))
+    goto cleanup;
+
+  if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER)
+    goto cleanup;
+
+  if (mpz_sgn (step->value.integer) == 0)
+    {
+      gfc_error ("Iterator step at %L cannot be zero", &step->where);
+      goto cleanup;
+    }
+
+  /* Calculate the trip count of the loop.  */
+  mpz_sub (trip, end->value.integer, start->value.integer);
+  mpz_add (trip, trip, step->value.integer);
+  mpz_tdiv_q (trip, trip, step->value.integer);
+
+  mpz_set (frame.value, start->value.integer);
+
+  frame.prev = iter_stack;
+  frame.variable = c->iterator->var->symtree;
+  iter_stack = &frame;
+
+  while (mpz_sgn (trip) > 0)
+    {
+      if (!expand_expr (c->expr))
+	goto cleanup;
+
+      mpz_add (frame.value, frame.value, step->value.integer);
+      mpz_sub_ui (trip, trip, 1);
+    }
+
+  t = true;
+
+cleanup:
+  gfc_free_expr (start);
+  gfc_free_expr (end);
+  gfc_free_expr (step);
+
+  mpz_clear (trip);
+  mpz_clear (frame.value);
+
+  iter_stack = frame.prev;
+
+  return t;
+}
+
+
+/* Expand a constructor into constant constructors without any
+   iterators, calling the work function for each of the expanded
+   expressions.  The work function needs to either save or free the
+   passed expression.  */
+
+static bool
+expand_constructor (gfc_constructor_base base)
+{
+  gfc_constructor *c;
+  gfc_expr *e;
+
+  for (c = gfc_constructor_first (base); c; c = gfc_constructor_next(c))
+    {
+      if (c->iterator != NULL)
+	{
+	  if (!expand_iterator (c))
+	    return false;
+	  continue;
+	}
+
+      e = c->expr;
+
+      if (e->expr_type == EXPR_ARRAY)
+	{
+	  if (!expand_constructor (e->value.constructor))
+	    return false;
+
+	  continue;
+	}
+
+      e = gfc_copy_expr (e);
+      if (!gfc_simplify_expr (e, 1))
+	{
+	  gfc_free_expr (e);
+	  return false;
+	}
+      current_expand.offset = &c->offset;
+      current_expand.repeat = &c->repeat;
+      current_expand.component = c->n.component;
+      if (!current_expand.expand_work_function(e))
+	return false;
+    }
+  return true;
+}
+
+
+/* Given an array expression and an element number (starting at zero),
+   return a pointer to the array element.  NULL is returned if the
+   size of the array has been exceeded.  The expression node returned
+   remains a part of the array and should not be freed.  Access is not
+   efficient at all, but this is another place where things do not
+   have to be particularly fast.  */
+
+static gfc_expr *
+gfc_get_array_element (gfc_expr *array, int element)
+{
+  expand_info expand_save;
+  gfc_expr *e;
+  bool rc;
+
+  expand_save = current_expand;
+  current_expand.extract_n = element;
+  current_expand.expand_work_function = extract_element;
+  current_expand.extracted = NULL;
+  current_expand.extract_count = 0;
+
+  iter_stack = NULL;
+
+  rc = expand_constructor (array->value.constructor);
+  e = current_expand.extracted;
+  current_expand = expand_save;
+
+  if (!rc)
+    return NULL;
+
+  return e;
+}
+
+
+/* Top level subroutine for expanding constructors.  We only expand
+   constructor if they are small enough.  */
+
+bool
+gfc_expand_constructor (gfc_expr *e, bool fatal)
+{
+  expand_info expand_save;
+  gfc_expr *f;
+  bool rc;
+
+  /* If we can successfully get an array element at the max array size then
+     the array is too big to expand, so we just return.  */
+  f = gfc_get_array_element (e, gfc_option.flag_max_array_constructor);
+  if (f != NULL)
+    {
+      gfc_free_expr (f);
+      if (fatal)
+	{
+	  gfc_error ("The number of elements in the array constructor "
+		     "at %L requires an increase of the allowed %d "
+		     "upper limit.   See -fmax-array-constructor "
+		     "option", &e->where,
+		     gfc_option.flag_max_array_constructor);
+	  return false;
+	}
+      return true;
+    }
+
+  /* We now know the array is not too big so go ahead and try to expand it.  */
+  expand_save = current_expand;
+  current_expand.base = NULL;
+
+  iter_stack = NULL;
+
+  current_expand.expand_work_function = expand;
+
+  if (!expand_constructor (e->value.constructor))
+    {
+      gfc_constructor_free (current_expand.base);
+      rc = false;
+      goto done;
+    }
+
+  gfc_constructor_free (e->value.constructor);
+  e->value.constructor = current_expand.base;
+
+  rc = true;
+
+done:
+  current_expand = expand_save;
+
+  return rc;
+}
+
+
+/* Work function for checking that an element of a constructor is a
+   constant, after removal of any iteration variables.  We return
+   false if not so.  */
+
+static bool
+is_constant_element (gfc_expr *e)
+{
+  int rv;
+
+  rv = gfc_is_constant_expr (e);
+  gfc_free_expr (e);
+
+  return rv ? true : false;
+}
+
+
+/* Given an array constructor, determine if the constructor is
+   constant or not by expanding it and making sure that all elements
+   are constants.  This is a bit of a hack since something like (/ (i,
+   i=1,100000000) /) will take a while as* opposed to a more clever
+   function that traverses the expression tree. FIXME.  */
+
+int
+gfc_constant_ac (gfc_expr *e)
+{
+  expand_info expand_save;
+  bool rc;
+
+  iter_stack = NULL;
+  expand_save = current_expand;
+  current_expand.expand_work_function = is_constant_element;
+
+  rc = expand_constructor (e->value.constructor);
+
+  current_expand = expand_save;
+  if (!rc)
+    return 0;
+
+  return 1;
+}
+
+
+/* Returns nonzero if an array constructor has been completely
+   expanded (no iterators) and zero if iterators are present.  */
+
+int
+gfc_expanded_ac (gfc_expr *e)
+{
+  gfc_constructor *c;
+
+  if (e->expr_type == EXPR_ARRAY)
+    for (c = gfc_constructor_first (e->value.constructor);
+	 c; c = gfc_constructor_next (c))
+      if (c->iterator != NULL || !gfc_expanded_ac (c->expr))
+	return 0;
+
+  return 1;
+}
+
+
+/*************** Type resolution of array constructors ***************/
+
+
+/* The symbol expr_is_sought_symbol_ref will try to find.  */
+static const gfc_symbol *sought_symbol = NULL;
+
+
+/* Tells whether the expression E is a variable reference to the symbol
+   in the static variable SOUGHT_SYMBOL, and sets the locus pointer WHERE
+   accordingly.
+   To be used with gfc_expr_walker: if a reference is found we don't need
+   to look further so we return 1 to skip any further walk.  */
+
+static int
+expr_is_sought_symbol_ref (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+			   void *where)
+{
+  gfc_expr *expr = *e;
+  locus *sym_loc = (locus *)where;
+
+  if (expr->expr_type == EXPR_VARIABLE
+      && expr->symtree->n.sym == sought_symbol)
+    {
+      *sym_loc = expr->where;
+      return 1;
+    }
+
+  return 0;
+}
+
+
+/* Tells whether the expression EXPR contains a reference to the symbol
+   SYM and in that case sets the position SYM_LOC where the reference is.  */
+
+static bool
+find_symbol_in_expr (gfc_symbol *sym, gfc_expr *expr, locus *sym_loc)
+{
+  int ret;
+
+  sought_symbol = sym;
+  ret = gfc_expr_walker (&expr, &expr_is_sought_symbol_ref, sym_loc);
+  sought_symbol = NULL;
+  return ret;
+}
+
+
+/* Recursive array list resolution function.  All of the elements must
+   be of the same type.  */
+
+static bool
+resolve_array_list (gfc_constructor_base base)
+{
+  bool t;
+  gfc_constructor *c;
+  gfc_iterator *iter;
+
+  t = true;
+
+  for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
+    {
+      iter = c->iterator;
+      if (iter != NULL)
+        {
+	  gfc_symbol *iter_var;
+	  locus iter_var_loc;
+
+	  if (!gfc_resolve_iterator (iter, false, true))
+	    t = false;
+
+	  /* Check for bounds referencing the iterator variable.  */
+	  gcc_assert (iter->var->expr_type == EXPR_VARIABLE);
+	  iter_var = iter->var->symtree->n.sym;
+	  if (find_symbol_in_expr (iter_var, iter->start, &iter_var_loc))
+	    {
+	      if (!gfc_notify_std (GFC_STD_LEGACY, "AC-IMPLIED-DO initial "
+				   "expression references control variable "
+				   "at %L", &iter_var_loc))
+	       t = false;
+	    }
+	  if (find_symbol_in_expr (iter_var, iter->end, &iter_var_loc))
+	    {
+	      if (!gfc_notify_std (GFC_STD_LEGACY, "AC-IMPLIED-DO final "
+				   "expression references control variable "
+				   "at %L", &iter_var_loc))
+	       t = false;
+	    }
+	  if (find_symbol_in_expr (iter_var, iter->step, &iter_var_loc))
+	    {
+	      if (!gfc_notify_std (GFC_STD_LEGACY, "AC-IMPLIED-DO step "
+				   "expression references control variable "
+				   "at %L", &iter_var_loc))
+	       t = false;
+	    }
+	}
+
+      if (!gfc_resolve_expr (c->expr))
+	t = false;
+
+      if (UNLIMITED_POLY (c->expr))
+	{
+	  gfc_error ("Array constructor value at %L shall not be unlimited "
+		     "polymorphic [F2008: C4106]", &c->expr->where);
+	  t = false;
+	}
+    }
+
+  return t;
+}
+
+/* Resolve character array constructor. If it has a specified constant character
+   length, pad/truncate the elements here; if the length is not specified and
+   all elements are of compile-time known length, emit an error as this is
+   invalid.  */
+
+bool
+gfc_resolve_character_array_constructor (gfc_expr *expr)
+{
+  gfc_constructor *p;
+  int found_length;
+
+  gcc_assert (expr->expr_type == EXPR_ARRAY);
+  gcc_assert (expr->ts.type == BT_CHARACTER);
+
+  if (expr->ts.u.cl == NULL)
+    {
+      for (p = gfc_constructor_first (expr->value.constructor);
+	   p; p = gfc_constructor_next (p))
+	if (p->expr->ts.u.cl != NULL)
+	  {
+	    /* Ensure that if there is a char_len around that it is
+	       used; otherwise the middle-end confuses them!  */
+	    expr->ts.u.cl = p->expr->ts.u.cl;
+	    goto got_charlen;
+	  }
+
+      expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+    }
+
+got_charlen:
+
+  found_length = -1;
+
+  if (expr->ts.u.cl->length == NULL)
+    {
+      /* Check that all constant string elements have the same length until
+	 we reach the end or find a variable-length one.  */
+
+      for (p = gfc_constructor_first (expr->value.constructor);
+	   p; p = gfc_constructor_next (p))
+	{
+	  int current_length = -1;
+	  gfc_ref *ref;
+	  for (ref = p->expr->ref; ref; ref = ref->next)
+	    if (ref->type == REF_SUBSTRING
+		&& ref->u.ss.start->expr_type == EXPR_CONSTANT
+		&& ref->u.ss.end->expr_type == EXPR_CONSTANT)
+	      break;
+
+	  if (p->expr->expr_type == EXPR_CONSTANT)
+	    current_length = p->expr->value.character.length;
+	  else if (ref)
+	    {
+	      long j;
+	      j = mpz_get_ui (ref->u.ss.end->value.integer)
+		- mpz_get_ui (ref->u.ss.start->value.integer) + 1;
+	      current_length = (int) j;
+	    }
+	  else if (p->expr->ts.u.cl && p->expr->ts.u.cl->length
+		   && p->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+	    {
+	      long j;
+	      j = mpz_get_si (p->expr->ts.u.cl->length->value.integer);
+	      current_length = (int) j;
+	    }
+	  else
+	    return true;
+
+	  gcc_assert (current_length != -1);
+
+	  if (found_length == -1)
+	    found_length = current_length;
+	  else if (found_length != current_length)
+	    {
+	      gfc_error ("Different CHARACTER lengths (%d/%d) in array"
+			 " constructor at %L", found_length, current_length,
+			 &p->expr->where);
+	      return false;
+	    }
+
+	  gcc_assert (found_length == current_length);
+	}
+
+      gcc_assert (found_length != -1);
+
+      /* Update the character length of the array constructor.  */
+      expr->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
+						NULL, found_length);
+    }
+  else
+    {
+      /* We've got a character length specified.  It should be an integer,
+	 otherwise an error is signalled elsewhere.  */
+      gcc_assert (expr->ts.u.cl->length);
+
+      /* If we've got a constant character length, pad according to this.
+	 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
+	 max_length only if they pass.  */
+      gfc_extract_int (expr->ts.u.cl->length, &found_length);
+
+      /* Now pad/truncate the elements accordingly to the specified character
+	 length.  This is ok inside this conditional, as in the case above
+	 (without typespec) all elements are verified to have the same length
+	 anyway.  */
+      if (found_length != -1)
+	for (p = gfc_constructor_first (expr->value.constructor);
+	     p; p = gfc_constructor_next (p))
+	  if (p->expr->expr_type == EXPR_CONSTANT)
+	    {
+	      gfc_expr *cl = NULL;
+	      int current_length = -1;
+	      bool has_ts;
+
+	      if (p->expr->ts.u.cl && p->expr->ts.u.cl->length)
+	      {
+		cl = p->expr->ts.u.cl->length;
+		gfc_extract_int (cl, &current_length);
+	      }
+
+	      /* If gfc_extract_int above set current_length, we implicitly
+		 know the type is BT_INTEGER and it's EXPR_CONSTANT.  */
+
+	      has_ts = expr->ts.u.cl->length_from_typespec;
+
+	      if (! cl
+		  || (current_length != -1 && current_length != found_length))
+		gfc_set_constant_character_len (found_length, p->expr,
+						has_ts ? -1 : found_length);
+	    }
+    }
+
+  return true;
+}
+
+
+/* Resolve all of the expressions in an array list.  */
+
+bool
+gfc_resolve_array_constructor (gfc_expr *expr)
+{
+  bool t;
+
+  t = resolve_array_list (expr->value.constructor);
+  if (t)
+    t = gfc_check_constructor_type (expr);
+
+  /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
+     the call to this function, so we don't need to call it here; if it was
+     called twice, an error message there would be duplicated.  */
+
+  return t;
+}
+
+
+/* Copy an iterator structure.  */
+
+gfc_iterator *
+gfc_copy_iterator (gfc_iterator *src)
+{
+  gfc_iterator *dest;
+
+  if (src == NULL)
+    return NULL;
+
+  dest = gfc_get_iterator ();
+
+  dest->var = gfc_copy_expr (src->var);
+  dest->start = gfc_copy_expr (src->start);
+  dest->end = gfc_copy_expr (src->end);
+  dest->step = gfc_copy_expr (src->step);
+
+  return dest;
+}
+
+
+/********* Subroutines for determining the size of an array *********/
+
+/* These are needed just to accommodate RESHAPE().  There are no
+   diagnostics here, we just return a negative number if something
+   goes wrong.  */
+
+
+/* Get the size of single dimension of an array specification.  The
+   array is guaranteed to be one dimensional.  */
+
+bool
+spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
+{
+  if (as == NULL)
+    return false;
+
+  if (dimen < 0 || dimen > as->rank - 1)
+    gfc_internal_error ("spec_dimen_size(): Bad dimension");
+
+  if (as->type != AS_EXPLICIT
+      || as->lower[dimen]->expr_type != EXPR_CONSTANT
+      || as->upper[dimen]->expr_type != EXPR_CONSTANT
+      || as->lower[dimen]->ts.type != BT_INTEGER
+      || as->upper[dimen]->ts.type != BT_INTEGER)
+    return false;
+
+  mpz_init (*result);
+
+  mpz_sub (*result, as->upper[dimen]->value.integer,
+	   as->lower[dimen]->value.integer);
+
+  mpz_add_ui (*result, *result, 1);
+
+  return true;
+}
+
+
+bool
+spec_size (gfc_array_spec *as, mpz_t *result)
+{
+  mpz_t size;
+  int d;
+
+  if (!as || as->type == AS_ASSUMED_RANK)
+    return false;
+
+  mpz_init_set_ui (*result, 1);
+
+  for (d = 0; d < as->rank; d++)
+    {
+      if (!spec_dimen_size (as, d, &size))
+	{
+	  mpz_clear (*result);
+	  return false;
+	}
+
+      mpz_mul (*result, *result, size);
+      mpz_clear (size);
+    }
+
+  return true;
+}
+
+
+/* Get the number of elements in an array section. Optionally, also supply
+   the end value.  */
+
+bool
+gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result, mpz_t *end)
+{
+  mpz_t upper, lower, stride;
+  mpz_t diff;
+  bool t;
+
+  if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
+    gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
+
+  switch (ar->dimen_type[dimen])
+    {
+    case DIMEN_ELEMENT:
+      mpz_init (*result);
+      mpz_set_ui (*result, 1);
+      t = true;
+      break;
+
+    case DIMEN_VECTOR:
+      t = gfc_array_size (ar->start[dimen], result);	/* Recurse! */
+      break;
+
+    case DIMEN_RANGE:
+
+      mpz_init (stride);
+
+      if (ar->stride[dimen] == NULL)
+	mpz_set_ui (stride, 1);
+      else
+	{
+	  if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
+	    {
+	      mpz_clear (stride);
+	      return false;
+	    }
+	  mpz_set (stride, ar->stride[dimen]->value.integer);
+	}
+
+      /* Calculate the number of elements via gfc_dep_differce, but only if
+	 start and end are both supplied in the reference or the array spec.
+	 This is to guard against strange but valid code like
+
+	 subroutine foo(a,n)
+	 real a(1:n)
+	 n = 3
+	 print *,size(a(n-1:))
+
+	 where the user changes the value of a variable.  If we have to
+	 determine end as well, we cannot do this using gfc_dep_difference.
+	 Fall back to the constants-only code then.  */
+
+      if (end == NULL)
+	{
+	  bool use_dep;
+
+	  use_dep = gfc_dep_difference (ar->end[dimen], ar->start[dimen],
+					&diff);
+	  if (!use_dep && ar->end[dimen] == NULL && ar->start[dimen] == NULL)
+	    use_dep = gfc_dep_difference (ar->as->upper[dimen],
+					    ar->as->lower[dimen], &diff);
+
+	  if (use_dep)
+	    {
+	      mpz_init (*result);
+	      mpz_add (*result, diff, stride);
+	      mpz_div (*result, *result, stride);
+	      if (mpz_cmp_ui (*result, 0) < 0)
+		mpz_set_ui (*result, 0);
+
+	      mpz_clear (stride);
+	      mpz_clear (diff);
+	      return true;
+	    }
+
+	}
+
+      /*  Constant-only code here, which covers more cases
+	  like a(:4) etc.  */
+      mpz_init (upper);
+      mpz_init (lower);
+      t = false;
+
+      if (ar->start[dimen] == NULL)
+	{
+	  if (ar->as->lower[dimen] == NULL
+	      || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
+	    goto cleanup;
+	  mpz_set (lower, ar->as->lower[dimen]->value.integer);
+	}
+      else
+	{
+	  if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
+	    goto cleanup;
+	  mpz_set (lower, ar->start[dimen]->value.integer);
+	}
+
+      if (ar->end[dimen] == NULL)
+	{
+	  if (ar->as->upper[dimen] == NULL
+	      || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT)
+	    goto cleanup;
+	  mpz_set (upper, ar->as->upper[dimen]->value.integer);
+	}
+      else
+	{
+	  if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
+	    goto cleanup;
+	  mpz_set (upper, ar->end[dimen]->value.integer);
+	}
+
+      mpz_init (*result);
+      mpz_sub (*result, upper, lower);
+      mpz_add (*result, *result, stride);
+      mpz_div (*result, *result, stride);
+
+      /* Zero stride caught earlier.  */
+      if (mpz_cmp_ui (*result, 0) < 0)
+	mpz_set_ui (*result, 0);
+      t = true;
+
+      if (end)
+	{
+	  mpz_init (*end);
+
+	  mpz_sub_ui (*end, *result, 1UL);
+	  mpz_mul (*end, *end, stride);
+	  mpz_add (*end, *end, lower);
+	}
+
+    cleanup:
+      mpz_clear (upper);
+      mpz_clear (lower);
+      mpz_clear (stride);
+      return t;
+
+    default:
+      gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
+    }
+
+  return t;
+}
+
+
+static bool
+ref_size (gfc_array_ref *ar, mpz_t *result)
+{
+  mpz_t size;
+  int d;
+
+  mpz_init_set_ui (*result, 1);
+
+  for (d = 0; d < ar->dimen; d++)
+    {
+      if (!gfc_ref_dimen_size (ar, d, &size, NULL))
+	{
+	  mpz_clear (*result);
+	  return false;
+	}
+
+      mpz_mul (*result, *result, size);
+      mpz_clear (size);
+    }
+
+  return true;
+}
+
+
+/* Given an array expression and a dimension, figure out how many
+   elements it has along that dimension.  Returns true if we were
+   able to return a result in the 'result' variable, false
+   otherwise.  */
+
+bool
+gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
+{
+  gfc_ref *ref;
+  int i;
+
+  gcc_assert (array != NULL);
+
+  if (array->ts.type == BT_CLASS)
+    return false;
+
+  if (array->rank == -1)
+    return false;
+
+  if (dimen < 0 || dimen > array->rank - 1)
+    gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
+
+  switch (array->expr_type)
+    {
+    case EXPR_VARIABLE:
+    case EXPR_FUNCTION:
+      for (ref = array->ref; ref; ref = ref->next)
+	{
+	  if (ref->type != REF_ARRAY)
+	    continue;
+
+	  if (ref->u.ar.type == AR_FULL)
+	    return spec_dimen_size (ref->u.ar.as, dimen, result);
+
+	  if (ref->u.ar.type == AR_SECTION)
+	    {
+	      for (i = 0; dimen >= 0; i++)
+		if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
+		  dimen--;
+
+	      return gfc_ref_dimen_size (&ref->u.ar, i - 1, result, NULL);
+	    }
+	}
+
+      if (array->shape && array->shape[dimen])
+	{
+	  mpz_init_set (*result, array->shape[dimen]);
+	  return true;
+	}
+
+      if (array->symtree->n.sym->attr.generic
+	  && array->value.function.esym != NULL)
+	{
+	  if (!spec_dimen_size (array->value.function.esym->as, dimen, result))
+	    return false;
+	}
+      else if (!spec_dimen_size (array->symtree->n.sym->as, dimen, result))
+	return false;
+
+      break;
+
+    case EXPR_ARRAY:
+      if (array->shape == NULL) {
+	/* Expressions with rank > 1 should have "shape" properly set */
+	if ( array->rank != 1 )
+	  gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
+	return gfc_array_size(array, result);
+      }
+
+      /* Fall through */
+    default:
+      if (array->shape == NULL)
+	return false;
+
+      mpz_init_set (*result, array->shape[dimen]);
+
+      break;
+    }
+
+  return true;
+}
+
+
+/* Given an array expression, figure out how many elements are in the
+   array.  Returns true if this is possible, and sets the 'result'
+   variable.  Otherwise returns false.  */
+
+bool
+gfc_array_size (gfc_expr *array, mpz_t *result)
+{
+  expand_info expand_save;
+  gfc_ref *ref;
+  int i;
+  bool t;
+
+  if (array->ts.type == BT_CLASS)
+    return false;
+
+  switch (array->expr_type)
+    {
+    case EXPR_ARRAY:
+      gfc_push_suppress_errors ();
+
+      expand_save = current_expand;
+
+      current_expand.count = result;
+      mpz_init_set_ui (*result, 0);
+
+      current_expand.expand_work_function = count_elements;
+      iter_stack = NULL;
+
+      t = expand_constructor (array->value.constructor);
+
+      gfc_pop_suppress_errors ();
+
+      if (!t)
+	mpz_clear (*result);
+      current_expand = expand_save;
+      return t;
+
+    case EXPR_VARIABLE:
+      for (ref = array->ref; ref; ref = ref->next)
+	{
+	  if (ref->type != REF_ARRAY)
+	    continue;
+
+	  if (ref->u.ar.type == AR_FULL)
+	    return spec_size (ref->u.ar.as, result);
+
+	  if (ref->u.ar.type == AR_SECTION)
+	    return ref_size (&ref->u.ar, result);
+	}
+
+      return spec_size (array->symtree->n.sym->as, result);
+
+
+    default:
+      if (array->rank == 0 || array->shape == NULL)
+	return false;
+
+      mpz_init_set_ui (*result, 1);
+
+      for (i = 0; i < array->rank; i++)
+	mpz_mul (*result, *result, array->shape[i]);
+
+      break;
+    }
+
+  return true;
+}
+
+
+/* Given an array reference, return the shape of the reference in an
+   array of mpz_t integers.  */
+
+bool
+gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
+{
+  int d;
+  int i;
+
+  d = 0;
+
+  switch (ar->type)
+    {
+    case AR_FULL:
+      for (; d < ar->as->rank; d++)
+	if (!spec_dimen_size (ar->as, d, &shape[d]))
+	  goto cleanup;
+
+      return true;
+
+    case AR_SECTION:
+      for (i = 0; i < ar->dimen; i++)
+	{
+	  if (ar->dimen_type[i] != DIMEN_ELEMENT)
+	    {
+	      if (!gfc_ref_dimen_size (ar, i, &shape[d], NULL))
+		goto cleanup;
+	      d++;
+	    }
+	}
+
+      return true;
+
+    default:
+      break;
+    }
+
+cleanup:
+  gfc_clear_shape (shape, d);
+  return false;
+}
+
+
+/* Given an array expression, find the array reference structure that
+   characterizes the reference.  */
+
+gfc_array_ref *
+gfc_find_array_ref (gfc_expr *e)
+{
+  gfc_ref *ref;
+
+  for (ref = e->ref; ref; ref = ref->next)
+    if (ref->type == REF_ARRAY
+	&& (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION))
+      break;
+
+  if (ref == NULL)
+    gfc_internal_error ("gfc_find_array_ref(): No ref found");
+
+  return &ref->u.ar;
+}
+
+
+/* Find out if an array shape is known at compile time.  */
+
+int
+gfc_is_compile_time_shape (gfc_array_spec *as)
+{
+  int i;
+
+  if (as->type != AS_EXPLICIT)
+    return 0;
+
+  for (i = 0; i < as->rank; i++)
+    if (!gfc_is_constant_expr (as->lower[i])
+	|| !gfc_is_constant_expr (as->upper[i]))
+      return 0;
+
+  return 1;
+}
diff --git a/gcc-4.9/gcc/fortran/bbt.c b/gcc-4.9/gcc/fortran/bbt.c
new file mode 100644
index 000000000..2f020648a
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/bbt.c
@@ -0,0 +1,198 @@
+/* Balanced binary trees using treaps.
+   Copyright (C) 2000-2014 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+/* The idea is to balance the tree using pseudorandom numbers.  The
+   main constraint on this implementation is that we have several
+   distinct structures that have to be arranged in a binary tree.
+   These structures all contain a BBT_HEADER() in front that gives the
+   treap-related information.  The key and value are assumed to reside
+   in the rest of the structure.
+
+   When calling, we are also passed a comparison function that
+   compares two nodes.  We don't implement a separate 'find' function
+   here, but rather use separate functions for each variety of tree.
+   We are also restricted to not copy treap structures, which most
+   implementations find convenient, because we otherwise would need to
+   know how long the structure is.
+
+   This implementation is based on Stefan Nilsson's article in the
+   July 1997 Doctor Dobb's Journal, "Treaps in Java".  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "gfortran.h"
+
+typedef struct gfc_treap
+{
+  BBT_HEADER (gfc_treap);
+}
+gfc_bbt;
+
+/* Simple linear congruential pseudorandom number generator.  The
+   period of this generator is 44071, which is plenty for our
+   purposes.  */
+
+static int
+pseudo_random (void)
+{
+  static int x0 = 5341;
+
+  x0 = (22611 * x0 + 10) % 44071;
+  return x0;
+}
+
+
+/* Rotate the treap left.  */
+
+static gfc_bbt *
+rotate_left (gfc_bbt *t)
+{
+  gfc_bbt *temp;
+
+  temp = t->right;
+  t->right = t->right->left;
+  temp->left = t;
+
+  return temp;
+}
+
+
+/* Rotate the treap right.  */
+
+static gfc_bbt *
+rotate_right (gfc_bbt *t)
+{
+  gfc_bbt *temp;
+
+  temp = t->left;
+  t->left = t->left->right;
+  temp->right = t;
+
+  return temp;
+}
+
+
+/* Recursive insertion function.  Returns the updated treap, or
+   aborts if we find a duplicate key.  */
+
+static gfc_bbt *
+insert (gfc_bbt *new_bbt, gfc_bbt *t, compare_fn compare)
+{
+  int c;
+
+  if (t == NULL)
+    return new_bbt;
+
+  c = (*compare) (new_bbt, t);
+
+  if (c < 0)
+    {
+      t->left = insert (new_bbt, t->left, compare);
+      if (t->priority < t->left->priority)
+	t = rotate_right (t);
+    }
+  else if (c > 0)
+    {
+      t->right = insert (new_bbt, t->right, compare);
+      if (t->priority < t->right->priority)
+	t = rotate_left (t);
+    }
+  else /* if (c == 0)  */
+    gfc_internal_error("insert_bbt(): Duplicate key found!");
+
+  return t;
+}
+
+
+/* Given root pointer, a new node and a comparison function, insert
+   the new node into the treap.  It is an error to insert a key that
+   already exists.  */
+
+void
+gfc_insert_bbt (void *root, void *new_node, compare_fn compare)
+{
+  gfc_bbt **r, *n;
+
+  r = (gfc_bbt **) root;
+  n = (gfc_bbt *) new_node;
+  n->priority = pseudo_random ();
+  *r = insert (n, *r, compare);
+}
+
+static gfc_bbt *
+delete_root (gfc_bbt *t)
+{
+  gfc_bbt *temp;
+
+  if (t->left == NULL)
+    return t->right;
+  if (t->right == NULL)
+    return t->left;
+
+  if (t->left->priority > t->right->priority)
+    {
+      temp = rotate_right (t);
+      temp->right = delete_root (t);
+    }
+  else
+    {
+      temp = rotate_left (t);
+      temp->left = delete_root (t);
+    }
+
+  return temp;
+}
+
+
+/* Delete an element from a tree.  The 'old' value does not
+   necessarily have to point to the element to be deleted, it must
+   just point to a treap structure with the key to be deleted.
+   Returns the new root node of the tree.  */
+
+static gfc_bbt *
+delete_treap (gfc_bbt *old, gfc_bbt *t, compare_fn compare)
+{
+  int c;
+
+  if (t == NULL)
+    return NULL;
+
+  c = (*compare) (old, t);
+
+  if (c < 0)
+    t->left = delete_treap (old, t->left, compare);
+  if (c > 0)
+    t->right = delete_treap (old, t->right, compare);
+  if (c == 0)
+    t = delete_root (t);
+
+  return t;
+}
+
+
+void
+gfc_delete_bbt (void *root, void *old, compare_fn compare)
+{
+  gfc_bbt **t;
+
+  t = (gfc_bbt **) root;
+  *t = delete_treap ((gfc_bbt *) old, *t, compare);
+}
diff --git a/gcc-4.9/gcc/fortran/check.c b/gcc-4.9/gcc/fortran/check.c
new file mode 100644
index 000000000..119750aab
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/check.c
@@ -0,0 +1,5730 @@
+/* Check functions
+   Copyright (C) 2002-2014 Free Software Foundation, Inc.
+   Contributed by Andy Vaught & Katherine Holcomb
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+
+/* These functions check to see if an argument list is compatible with
+   a particular intrinsic function or subroutine.  Presence of
+   required arguments has already been established, the argument list
+   has been sorted into the right order and has NULL arguments in the
+   correct places for missing optional arguments.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "flags.h"
+#include "gfortran.h"
+#include "intrinsic.h"
+#include "constructor.h"
+#include "target-memory.h"
+
+
+/* Make sure an expression is a scalar.  */
+
+static bool
+scalar_check (gfc_expr *e, int n)
+{
+  if (e->rank == 0)
+    return true;
+
+  gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
+	     gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
+	     &e->where);
+
+  return false;
+}
+
+
+/* Check the type of an expression.  */
+
+static bool
+type_check (gfc_expr *e, int n, bt type)
+{
+  if (e->ts.type == type)
+    return true;
+
+  gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
+	     gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
+	     &e->where, gfc_basic_typename (type));
+
+  return false;
+}
+
+
+/* Check that the expression is a numeric type.  */
+
+static bool
+numeric_check (gfc_expr *e, int n)
+{
+  if (gfc_numeric_ts (&e->ts))
+    return true;
+
+  /* If the expression has not got a type, check if its namespace can
+     offer a default type.  */
+  if ((e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
+	&& e->symtree->n.sym->ts.type == BT_UNKNOWN
+	&& gfc_set_default_type (e->symtree->n.sym, 0, e->symtree->n.sym->ns)
+	&& gfc_numeric_ts (&e->symtree->n.sym->ts))
+    {
+      e->ts = e->symtree->n.sym->ts;
+      return true;
+    }
+
+  gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
+	     gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
+	     &e->where);
+
+  return false;
+}
+
+
+/* Check that an expression is integer or real.  */
+
+static bool
+int_or_real_check (gfc_expr *e, int n)
+{
+  if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
+		 "or REAL", gfc_current_intrinsic_arg[n]->name,
+		 gfc_current_intrinsic, &e->where);
+      return false;
+    }
+
+  return true;
+}
+
+
+/* Check that an expression is real or complex.  */
+
+static bool
+real_or_complex_check (gfc_expr *e, int n)
+{
+  if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL "
+		 "or COMPLEX", gfc_current_intrinsic_arg[n]->name,
+		 gfc_current_intrinsic, &e->where);
+      return false;
+    }
+
+  return true;
+}
+
+
+/* Check that an expression is INTEGER or PROCEDURE.  */
+
+static bool
+int_or_proc_check (gfc_expr *e, int n)
+{
+  if (e->ts.type != BT_INTEGER && e->ts.type != BT_PROCEDURE)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
+		 "or PROCEDURE", gfc_current_intrinsic_arg[n]->name,
+		 gfc_current_intrinsic, &e->where);
+      return false;
+    }
+
+  return true;
+}
+
+
+/* Check that the expression is an optional constant integer
+   and that it specifies a valid kind for that type.  */
+
+static bool
+kind_check (gfc_expr *k, int n, bt type)
+{
+  int kind;
+
+  if (k == NULL)
+    return true;
+
+  if (!type_check (k, n, BT_INTEGER))
+    return false;
+
+  if (!scalar_check (k, n))
+    return false;
+
+  if (!gfc_check_init_expr (k))
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
+		 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
+		 &k->where);
+      return false;
+    }
+
+  if (gfc_extract_int (k, &kind) != NULL
+      || gfc_validate_kind (type, kind, true) < 0)
+    {
+      gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type),
+		 &k->where);
+      return false;
+    }
+
+  return true;
+}
+
+
+/* Make sure the expression is a double precision real.  */
+
+static bool
+double_check (gfc_expr *d, int n)
+{
+  if (!type_check (d, n, BT_REAL))
+    return false;
+
+  if (d->ts.kind != gfc_default_double_kind)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be double "
+		 "precision", gfc_current_intrinsic_arg[n]->name,
+		 gfc_current_intrinsic, &d->where);
+      return false;
+    }
+
+  return true;
+}
+
+
+static bool
+coarray_check (gfc_expr *e, int n)
+{
+  if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
+	&& CLASS_DATA (e)->attr.codimension
+	&& CLASS_DATA (e)->as->corank)
+    {
+      gfc_add_class_array_ref (e);
+      return true;
+    }
+
+  if (!gfc_is_coarray (e))
+    {
+      gfc_error ("Expected coarray variable as '%s' argument to the %s "
+                 "intrinsic at %L", gfc_current_intrinsic_arg[n]->name,
+		 gfc_current_intrinsic, &e->where);
+      return false;
+    }
+
+  return true;
+}
+
+
+/* Make sure the expression is a logical array.  */
+
+static bool
+logical_array_check (gfc_expr *array, int n)
+{
+  if (array->ts.type != BT_LOGICAL || array->rank == 0)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical "
+		 "array", gfc_current_intrinsic_arg[n]->name,
+		 gfc_current_intrinsic, &array->where);
+      return false;
+    }
+
+  return true;
+}
+
+
+/* Make sure an expression is an array.  */
+
+static bool
+array_check (gfc_expr *e, int n)
+{
+  if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
+	&& CLASS_DATA (e)->attr.dimension
+	&& CLASS_DATA (e)->as->rank)
+    {
+      gfc_add_class_array_ref (e);
+      return true;
+    }
+
+  if (e->rank != 0 && e->ts.type != BT_PROCEDURE)
+    return true;
+
+  gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
+	     gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
+	     &e->where);
+
+  return false;
+}
+
+
+/* If expr is a constant, then check to ensure that it is greater than
+   of equal to zero.  */
+
+static bool
+nonnegative_check (const char *arg, gfc_expr *expr)
+{
+  int i;
+
+  if (expr->expr_type == EXPR_CONSTANT)
+    {
+      gfc_extract_int (expr, &i);
+      if (i < 0)
+	{
+	  gfc_error ("'%s' at %L must be nonnegative", arg, &expr->where);
+	  return false;
+	}
+    }
+
+  return true;
+}
+
+
+/* If expr2 is constant, then check that the value is less than
+   (less than or equal to, if 'or_equal' is true) bit_size(expr1).  */
+
+static bool
+less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2,
+		    gfc_expr *expr2, bool or_equal)
+{
+  int i2, i3;
+
+  if (expr2->expr_type == EXPR_CONSTANT)
+    {
+      gfc_extract_int (expr2, &i2);
+      i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
+
+      /* For ISHFT[C], check that |shift| <= bit_size(i).  */
+      if (arg2 == NULL)
+	{
+	  if (i2 < 0)
+	    i2 = -i2;
+
+	  if (i2 > gfc_integer_kinds[i3].bit_size)
+	    {
+	      gfc_error ("The absolute value of SHIFT at %L must be less "
+			 "than or equal to BIT_SIZE('%s')",
+			 &expr2->where, arg1);
+	      return false;
+	    }
+	}
+
+      if (or_equal)
+	{
+	  if (i2 > gfc_integer_kinds[i3].bit_size)
+	    {
+	      gfc_error ("'%s' at %L must be less than "
+			 "or equal to BIT_SIZE('%s')",
+			 arg2, &expr2->where, arg1);
+	      return false;
+	    }
+	}
+      else
+	{
+	  if (i2 >= gfc_integer_kinds[i3].bit_size)
+	    {
+	      gfc_error ("'%s' at %L must be less than BIT_SIZE('%s')",
+			 arg2, &expr2->where, arg1);
+	      return false;
+	    }
+	}
+    }
+
+  return true;
+}
+
+
+/* If expr is constant, then check that the value is less than or equal
+   to the bit_size of the kind k.  */
+
+static bool
+less_than_bitsizekind (const char *arg, gfc_expr *expr, int k)
+{
+  int i, val;
+
+  if (expr->expr_type != EXPR_CONSTANT)
+    return true;
+
+  i = gfc_validate_kind (BT_INTEGER, k, false);
+  gfc_extract_int (expr, &val);
+
+  if (val > gfc_integer_kinds[i].bit_size)
+    {
+      gfc_error ("'%s' at %L must be less than or equal to the BIT_SIZE of "
+		 "INTEGER(KIND=%d)", arg, &expr->where, k);
+      return false;
+    }
+
+  return true;
+}
+
+
+/* If expr2 and expr3 are constants, then check that the value is less than
+   or equal to bit_size(expr1).  */
+
+static bool
+less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2,
+	       gfc_expr *expr2, const char *arg3, gfc_expr *expr3)
+{
+  int i2, i3;
+
+  if (expr2->expr_type == EXPR_CONSTANT && expr3->expr_type == EXPR_CONSTANT)
+    {
+      gfc_extract_int (expr2, &i2);
+      gfc_extract_int (expr3, &i3);
+      i2 += i3;
+      i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
+      if (i2 > gfc_integer_kinds[i3].bit_size)
+	{
+	  gfc_error ("'%s + %s' at %L must be less than or equal "
+		     "to BIT_SIZE('%s')",
+		     arg2, arg3, &expr2->where, arg1);
+	  return false;
+	}
+    }
+
+  return true;
+}
+
+/* Make sure two expressions have the same type.  */
+
+static bool
+same_type_check (gfc_expr *e, int n, gfc_expr *f, int m)
+{
+  if (gfc_compare_types (&e->ts, &f->ts))
+    return true;
+
+  gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
+	     "and kind as '%s'", gfc_current_intrinsic_arg[m]->name,
+	     gfc_current_intrinsic, &f->where,
+	     gfc_current_intrinsic_arg[n]->name);
+
+  return false;
+}
+
+
+/* Make sure that an expression has a certain (nonzero) rank.  */
+
+static bool
+rank_check (gfc_expr *e, int n, int rank)
+{
+  if (e->rank == rank)
+    return true;
+
+  gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
+	     gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
+	     &e->where, rank);
+
+  return false;
+}
+
+
+/* Make sure a variable expression is not an optional dummy argument.  */
+
+static bool
+nonoptional_check (gfc_expr *e, int n)
+{
+  if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
+		 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
+		 &e->where);
+    }
+
+  /* TODO: Recursive check on nonoptional variables?  */
+
+  return true;
+}
+
+
+/* Check for ALLOCATABLE attribute.  */
+
+static bool
+allocatable_check (gfc_expr *e, int n)
+{
+  symbol_attribute attr;
+
+  attr = gfc_variable_attr (e, NULL);
+  if (!attr.allocatable || attr.associate_var)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
+		 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
+		 &e->where);
+      return false;
+    }
+
+  return true;
+}
+
+
+/* Check that an expression has a particular kind.  */
+
+static bool
+kind_value_check (gfc_expr *e, int n, int k)
+{
+  if (e->ts.kind == k)
+    return true;
+
+  gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
+	     gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
+	     &e->where, k);
+
+  return false;
+}
+
+
+/* Make sure an expression is a variable.  */
+
+static bool
+variable_check (gfc_expr *e, int n, bool allow_proc)
+{
+  if (e->expr_type == EXPR_VARIABLE
+      && e->symtree->n.sym->attr.intent == INTENT_IN
+      && (gfc_current_intrinsic_arg[n]->intent == INTENT_OUT
+	  || gfc_current_intrinsic_arg[n]->intent == INTENT_INOUT))
+    {
+      gfc_ref *ref;
+      bool pointer = e->symtree->n.sym->ts.type == BT_CLASS
+		     && CLASS_DATA (e->symtree->n.sym)
+		     ? CLASS_DATA (e->symtree->n.sym)->attr.class_pointer
+		     : e->symtree->n.sym->attr.pointer;
+
+      for (ref = e->ref; ref; ref = ref->next)
+	{
+	  if (pointer && ref->type == REF_COMPONENT)
+	    break;
+	  if (ref->type == REF_COMPONENT
+	      && ((ref->u.c.component->ts.type == BT_CLASS
+		   && CLASS_DATA (ref->u.c.component)->attr.class_pointer)
+		  || (ref->u.c.component->ts.type != BT_CLASS
+		      && ref->u.c.component->attr.pointer)))
+	    break;
+	}
+
+      if (!ref)
+	{
+	  gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be "
+		     "INTENT(IN)", gfc_current_intrinsic_arg[n]->name,
+		     gfc_current_intrinsic, &e->where);
+	  return false;
+	}
+    }
+
+  if (e->expr_type == EXPR_VARIABLE
+      && e->symtree->n.sym->attr.flavor != FL_PARAMETER
+      && (allow_proc || !e->symtree->n.sym->attr.function))
+    return true;
+
+  if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.function
+      && e->symtree->n.sym == e->symtree->n.sym->result)
+    {
+      gfc_namespace *ns;
+      for (ns = gfc_current_ns; ns; ns = ns->parent)
+	if (ns->proc_name == e->symtree->n.sym)
+	  return true;
+    }
+
+  gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
+	     gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where);
+
+  return false;
+}
+
+
+/* Check the common DIM parameter for correctness.  */
+
+static bool
+dim_check (gfc_expr *dim, int n, bool optional)
+{
+  if (dim == NULL)
+    return true;
+
+  if (!type_check (dim, n, BT_INTEGER))
+    return false;
+
+  if (!scalar_check (dim, n))
+    return false;
+
+  if (!optional && !nonoptional_check (dim, n))
+    return false;
+
+  return true;
+}
+
+
+/* If a coarray DIM parameter is a constant, make sure that it is greater than
+   zero and less than or equal to the corank of the given array.  */
+
+static bool
+dim_corank_check (gfc_expr *dim, gfc_expr *array)
+{
+  int corank;
+
+  gcc_assert (array->expr_type == EXPR_VARIABLE);
+
+  if (dim->expr_type != EXPR_CONSTANT)
+    return true;
+
+  if (array->ts.type == BT_CLASS)
+    return true;
+
+  corank = gfc_get_corank (array);
+
+  if (mpz_cmp_ui (dim->value.integer, 1) < 0
+      || mpz_cmp_ui (dim->value.integer, corank) > 0)
+    {
+      gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
+		 "codimension index", gfc_current_intrinsic, &dim->where);
+
+      return false;
+    }
+
+  return true;
+}
+
+
+/* If a DIM parameter is a constant, make sure that it is greater than
+   zero and less than or equal to the rank of the given array.  If
+   allow_assumed is zero then dim must be less than the rank of the array
+   for assumed size arrays.  */
+
+static bool
+dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
+{
+  gfc_array_ref *ar;
+  int rank;
+
+  if (dim == NULL)
+    return true;
+
+  if (dim->expr_type != EXPR_CONSTANT)
+    return true;
+
+  if (array->expr_type == EXPR_FUNCTION && array->value.function.isym
+      && array->value.function.isym->id == GFC_ISYM_SPREAD)
+    rank = array->rank + 1;
+  else
+    rank = array->rank;
+
+  /* Assumed-rank array.  */
+  if (rank == -1)
+    rank = GFC_MAX_DIMENSIONS;
+
+  if (array->expr_type == EXPR_VARIABLE)
+    {
+      ar = gfc_find_array_ref (array);
+      if (ar->as->type == AS_ASSUMED_SIZE
+	  && !allow_assumed
+	  && ar->type != AR_ELEMENT
+	  && ar->type != AR_SECTION)
+	rank--;
+    }
+
+  if (mpz_cmp_ui (dim->value.integer, 1) < 0
+      || mpz_cmp_ui (dim->value.integer, rank) > 0)
+    {
+      gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
+		 "dimension index", gfc_current_intrinsic, &dim->where);
+
+      return false;
+    }
+
+  return true;
+}
+
+
+/* Compare the size of a along dimension ai with the size of b along
+   dimension bi, returning 0 if they are known not to be identical,
+   and 1 if they are identical, or if this cannot be determined.  */
+
+static int
+identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
+{
+  mpz_t a_size, b_size;
+  int ret;
+
+  gcc_assert (a->rank > ai);
+  gcc_assert (b->rank > bi);
+
+  ret = 1;
+
+  if (gfc_array_dimen_size (a, ai, &a_size))
+    {
+      if (gfc_array_dimen_size (b, bi, &b_size))
+	{
+	  if (mpz_cmp (a_size, b_size) != 0)
+	    ret = 0;
+
+	  mpz_clear (b_size);
+	}
+      mpz_clear (a_size);
+    }
+  return ret;
+}
+
+/*  Calculate the length of a character variable, including substrings.
+    Strip away parentheses if necessary.  Return -1 if no length could
+    be determined.  */
+
+static long
+gfc_var_strlen (const gfc_expr *a)
+{
+  gfc_ref *ra;
+
+  while (a->expr_type == EXPR_OP && a->value.op.op == INTRINSIC_PARENTHESES)
+    a = a->value.op.op1;
+
+  for (ra = a->ref; ra != NULL && ra->type != REF_SUBSTRING; ra = ra->next)
+    ;
+
+  if (ra)
+    {
+      long start_a, end_a;
+
+      if (!ra->u.ss.end)
+	return -1;
+
+      if ((!ra->u.ss.start || ra->u.ss.start->expr_type == EXPR_CONSTANT)
+	  && ra->u.ss.end->expr_type == EXPR_CONSTANT)
+	{
+	  start_a = ra->u.ss.start ? mpz_get_si (ra->u.ss.start->value.integer)
+				   : 1;
+	  end_a = mpz_get_si (ra->u.ss.end->value.integer);
+	  return (end_a < start_a) ? 0 : end_a - start_a + 1;
+	}
+      else if (ra->u.ss.start
+	       && gfc_dep_compare_expr (ra->u.ss.start, ra->u.ss.end) == 0)
+	return 1;
+      else
+	return -1;
+    }
+
+  if (a->ts.u.cl && a->ts.u.cl->length
+      && a->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+    return mpz_get_si (a->ts.u.cl->length->value.integer);
+  else if (a->expr_type == EXPR_CONSTANT
+	   && (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL))
+    return a->value.character.length;
+  else
+    return -1;
+
+}
+
+/* Check whether two character expressions have the same length;
+   returns true if they have or if the length cannot be determined,
+   otherwise return false and raise a gfc_error.  */
+
+bool
+gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
+{
+   long len_a, len_b;
+
+   len_a = gfc_var_strlen(a);
+   len_b = gfc_var_strlen(b);
+
+   if (len_a == -1 || len_b == -1 || len_a == len_b)
+     return true;
+   else
+     {
+       gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
+		  len_a, len_b, name, &a->where);
+       return false;
+     }
+}
+
+
+/***** Check functions *****/
+
+/* Check subroutine suitable for intrinsics taking a real argument and
+   a kind argument for the result.  */
+
+static bool
+check_a_kind (gfc_expr *a, gfc_expr *kind, bt type)
+{
+  if (!type_check (a, 0, BT_REAL))
+    return false;
+  if (!kind_check (kind, 1, type))
+    return false;
+
+  return true;
+}
+
+
+/* Check subroutine suitable for ceiling, floor and nint.  */
+
+bool
+gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind)
+{
+  return check_a_kind (a, kind, BT_INTEGER);
+}
+
+
+/* Check subroutine suitable for aint, anint.  */
+
+bool
+gfc_check_a_xkind (gfc_expr *a, gfc_expr *kind)
+{
+  return check_a_kind (a, kind, BT_REAL);
+}
+
+
+bool
+gfc_check_abs (gfc_expr *a)
+{
+  if (!numeric_check (a, 0))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_achar (gfc_expr *a, gfc_expr *kind)
+{
+  if (!type_check (a, 0, BT_INTEGER))
+    return false;
+  if (!kind_check (kind, 1, BT_CHARACTER))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_access_func (gfc_expr *name, gfc_expr *mode)
+{
+  if (!type_check (name, 0, BT_CHARACTER)
+      || !scalar_check (name, 0))
+    return false;
+  if (!kind_value_check (name, 0, gfc_default_character_kind))
+    return false;
+
+  if (!type_check (mode, 1, BT_CHARACTER)
+      || !scalar_check (mode, 1))
+    return false;
+  if (!kind_value_check (mode, 1, gfc_default_character_kind))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
+{
+  if (!logical_array_check (mask, 0))
+    return false;
+
+  if (!dim_check (dim, 1, false))
+    return false;
+
+  if (!dim_rank_check (dim, mask, 0))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_allocated (gfc_expr *array)
+{
+  if (!variable_check (array, 0, false))
+    return false;
+  if (!allocatable_check (array, 0))
+    return false;
+
+  return true;
+}
+
+
+/* Common check function where the first argument must be real or
+   integer and the second argument must be the same as the first.  */
+
+bool
+gfc_check_a_p (gfc_expr *a, gfc_expr *p)
+{
+  if (!int_or_real_check (a, 0))
+    return false;
+
+  if (a->ts.type != p->ts.type)
+    {
+      gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
+		 "have the same type", gfc_current_intrinsic_arg[0]->name,
+		 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
+		 &p->where);
+      return false;
+    }
+
+  if (a->ts.kind != p->ts.kind)
+    {
+      if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L", 
+			   &p->where))
+       return false;
+    }
+
+  return true;
+}
+
+
+bool
+gfc_check_x_yd (gfc_expr *x, gfc_expr *y)
+{
+  if (!double_check (x, 0) || !double_check (y, 1))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
+{
+  symbol_attribute attr1, attr2;
+  int i;
+  bool t;
+  locus *where;
+
+  where = &pointer->where;
+
+  if (pointer->expr_type == EXPR_NULL)
+    goto null_arg;
+
+  attr1 = gfc_expr_attr (pointer);
+
+  if (!attr1.pointer && !attr1.proc_pointer)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
+		 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+		 &pointer->where);
+      return false;
+    }
+
+  /* F2008, C1242.  */
+  if (attr1.pointer && gfc_is_coindexed (pointer))
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
+		 "coindexed", gfc_current_intrinsic_arg[0]->name,
+		 gfc_current_intrinsic, &pointer->where);
+      return false;
+    }
+
+  /* Target argument is optional.  */
+  if (target == NULL)
+    return true;
+
+  where = &target->where;
+  if (target->expr_type == EXPR_NULL)
+    goto null_arg;
+
+  if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION)
+    attr2 = gfc_expr_attr (target);
+  else
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
+		 "or target VARIABLE or FUNCTION",
+		 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
+		 &target->where);
+      return false;
+    }
+
+  if (attr1.pointer && !attr2.pointer && !attr2.target)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
+		 "or a TARGET", gfc_current_intrinsic_arg[1]->name,
+		 gfc_current_intrinsic, &target->where);
+      return false;
+    }
+
+  /* F2008, C1242.  */
+  if (attr1.pointer && gfc_is_coindexed (target))
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
+		 "coindexed", gfc_current_intrinsic_arg[1]->name,
+		 gfc_current_intrinsic, &target->where);
+      return false;
+    }
+
+  t = true;
+  if (!same_type_check (pointer, 0, target, 1))
+    t = false;
+  if (!rank_check (target, 0, pointer->rank))
+    t = false;
+  if (target->rank > 0)
+    {
+      for (i = 0; i < target->rank; i++)
+	if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
+	  {
+	    gfc_error ("Array section with a vector subscript at %L shall not "
+		       "be the target of a pointer",
+		       &target->where);
+	    t = false;
+	    break;
+	  }
+    }
+  return t;
+
+null_arg:
+
+  gfc_error ("NULL pointer at %L is not permitted as actual argument "
+	     "of '%s' intrinsic function", where, gfc_current_intrinsic);
+  return false;
+
+}
+
+
+bool
+gfc_check_atan_2 (gfc_expr *y, gfc_expr *x)
+{
+  /* gfc_notify_std would be a waste of time as the return value
+     is seemingly used only for the generic resolution.  The error
+     will be: Too many arguments.  */
+  if ((gfc_option.allow_std & GFC_STD_F2008) == 0)
+    return false;
+
+  return gfc_check_atan2 (y, x);
+}
+
+
+bool
+gfc_check_atan2 (gfc_expr *y, gfc_expr *x)
+{
+  if (!type_check (y, 0, BT_REAL))
+    return false;
+  if (!same_type_check (y, 0, x, 1))
+    return false;
+
+  return true;
+}
+
+
+static bool
+gfc_check_atomic (gfc_expr *atom, gfc_expr *value)
+{
+  if (!(atom->ts.type == BT_INTEGER && atom->ts.kind == gfc_atomic_int_kind)
+      && !(atom->ts.type == BT_LOGICAL
+	   && atom->ts.kind == gfc_atomic_logical_kind))
+    {
+      gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
+		 "integer of ATOMIC_INT_KIND or a logical of "
+		 "ATOMIC_LOGICAL_KIND", &atom->where, gfc_current_intrinsic);
+      return false;
+    }
+
+  if (!gfc_expr_attr (atom).codimension)
+    {
+      gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a "
+		 "coarray or coindexed", &atom->where, gfc_current_intrinsic);
+      return false;
+    }
+
+  if (atom->ts.type != value->ts.type)
+    {
+      gfc_error ("ATOM and VALUE argument of the %s intrinsic function shall "
+		 "have the same type at %L", gfc_current_intrinsic,
+		 &value->where);
+      return false;
+    }
+
+  return true;
+}
+
+
+bool
+gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value)
+{
+  if (!scalar_check (atom, 0) || !scalar_check (value, 1))
+    return false;
+
+  if (!gfc_check_vardef_context (atom, false, false, false, NULL))
+    {
+      gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
+		 "definable", gfc_current_intrinsic, &atom->where);
+      return false;
+    }
+
+  return gfc_check_atomic (atom, value);
+}
+
+
+bool
+gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom)
+{
+  if (!scalar_check (value, 0) || !scalar_check (atom, 1))
+    return false;
+
+  if (!gfc_check_vardef_context (value, false, false, false, NULL))
+    {
+      gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
+		 "definable", gfc_current_intrinsic, &value->where);
+      return false;
+    }
+
+  return gfc_check_atomic (atom, value);
+}
+
+
+/* BESJN and BESYN functions.  */
+
+bool
+gfc_check_besn (gfc_expr *n, gfc_expr *x)
+{
+  if (!type_check (n, 0, BT_INTEGER))
+    return false;
+  if (n->expr_type == EXPR_CONSTANT)
+    {
+      int i;
+      gfc_extract_int (n, &i);
+      if (i < 0 && !gfc_notify_std (GFC_STD_GNU, "Negative argument "
+				    "N at %L", &n->where))
+	return false;
+    }
+
+  if (!type_check (x, 1, BT_REAL))
+    return false;
+
+  return true;
+}
+
+
+/* Transformational version of the Bessel JN and YN functions.  */
+
+bool
+gfc_check_bessel_n2 (gfc_expr *n1, gfc_expr *n2, gfc_expr *x)
+{
+  if (!type_check (n1, 0, BT_INTEGER))
+    return false;
+  if (!scalar_check (n1, 0))
+    return false;
+  if (!nonnegative_check ("N1", n1))
+    return false;
+
+  if (!type_check (n2, 1, BT_INTEGER))
+    return false;
+  if (!scalar_check (n2, 1))
+    return false;
+  if (!nonnegative_check ("N2", n2))
+    return false;
+
+  if (!type_check (x, 2, BT_REAL))
+    return false;
+  if (!scalar_check (x, 2))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_bge_bgt_ble_blt (gfc_expr *i, gfc_expr *j)
+{
+  if (!type_check (i, 0, BT_INTEGER))
+    return false;
+
+  if (!type_check (j, 1, BT_INTEGER))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos)
+{
+  if (!type_check (i, 0, BT_INTEGER))
+    return false;
+
+  if (!type_check (pos, 1, BT_INTEGER))
+    return false;
+
+  if (!nonnegative_check ("pos", pos))
+    return false;
+
+  if (!less_than_bitsize1 ("i", i, "pos", pos, false))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_char (gfc_expr *i, gfc_expr *kind)
+{
+  if (!type_check (i, 0, BT_INTEGER))
+    return false;
+  if (!kind_check (kind, 1, BT_CHARACTER))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_chdir (gfc_expr *dir)
+{
+  if (!type_check (dir, 0, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (dir, 0, gfc_default_character_kind))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status)
+{
+  if (!type_check (dir, 0, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (dir, 0, gfc_default_character_kind))
+    return false;
+
+  if (status == NULL)
+    return true;
+
+  if (!type_check (status, 1, BT_INTEGER))
+    return false;
+  if (!scalar_check (status, 1))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_chmod (gfc_expr *name, gfc_expr *mode)
+{
+  if (!type_check (name, 0, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (name, 0, gfc_default_character_kind))
+    return false;
+
+  if (!type_check (mode, 1, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (mode, 1, gfc_default_character_kind))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status)
+{
+  if (!type_check (name, 0, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (name, 0, gfc_default_character_kind))
+    return false;
+
+  if (!type_check (mode, 1, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (mode, 1, gfc_default_character_kind))
+    return false;
+
+  if (status == NULL)
+    return true;
+
+  if (!type_check (status, 2, BT_INTEGER))
+    return false;
+
+  if (!scalar_check (status, 2))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
+{
+  if (!numeric_check (x, 0))
+    return false;
+
+  if (y != NULL)
+    {
+      if (!numeric_check (y, 1))
+	return false;
+
+      if (x->ts.type == BT_COMPLEX)
+	{
+	  gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
+		     "present if 'x' is COMPLEX",
+		     gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
+		     &y->where);
+	  return false;
+	}
+
+      if (y->ts.type == BT_COMPLEX)
+	{
+	  gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
+		     "of either REAL or INTEGER",
+		     gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
+		     &y->where);
+	  return false;
+	}
+
+    }
+
+  if (!kind_check (kind, 2, BT_COMPLEX))
+    return false;
+
+  if (!kind && gfc_option.gfc_warn_conversion
+      && x->ts.type == BT_REAL && x->ts.kind > gfc_default_real_kind)
+    gfc_warning_now ("Conversion from %s to default-kind COMPLEX(%d) at %L "
+		     "might loose precision, consider using the KIND argument",
+		     gfc_typename (&x->ts), gfc_default_real_kind, &x->where);
+  else if (y && !kind && gfc_option.gfc_warn_conversion
+	   && y->ts.type == BT_REAL && y->ts.kind > gfc_default_real_kind)
+    gfc_warning_now ("Conversion from %s to default-kind COMPLEX(%d) at %L "
+		     "might loose precision, consider using the KIND argument",
+		     gfc_typename (&y->ts), gfc_default_real_kind, &y->where);
+
+  return true;
+}
+
+
+bool
+gfc_check_complex (gfc_expr *x, gfc_expr *y)
+{
+  if (!int_or_real_check (x, 0))
+    return false;
+  if (!scalar_check (x, 0))
+    return false;
+
+  if (!int_or_real_check (y, 1))
+    return false;
+  if (!scalar_check (y, 1))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
+{
+  if (!logical_array_check (mask, 0))
+    return false;
+  if (!dim_check (dim, 1, false))
+    return false;
+  if (!dim_rank_check (dim, mask, 0))
+    return false;
+  if (!kind_check (kind, 2, BT_INTEGER))
+    return false;
+  if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
+			       "with KIND argument at %L", 
+			       gfc_current_intrinsic, &kind->where))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
+{
+  if (!array_check (array, 0))
+    return false;
+
+  if (!type_check (shift, 1, BT_INTEGER))
+    return false;
+
+  if (!dim_check (dim, 2, true))
+    return false;
+
+  if (!dim_rank_check (dim, array, false))
+    return false;
+
+  if (array->rank == 1 || shift->rank == 0)
+    {
+      if (!scalar_check (shift, 1))
+	return false;
+    }
+  else if (shift->rank == array->rank - 1)
+    {
+      int d;
+      if (!dim)
+	d = 1;
+      else if (dim->expr_type == EXPR_CONSTANT)
+	gfc_extract_int (dim, &d);
+      else
+	d = -1;
+
+      if (d > 0)
+	{
+	  int i, j;
+	  for (i = 0, j = 0; i < array->rank; i++)
+	    if (i != d - 1)
+	      {
+		if (!identical_dimen_shape (array, i, shift, j))
+		  {
+		    gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+			       "invalid shape in dimension %d (%ld/%ld)",
+			       gfc_current_intrinsic_arg[1]->name,
+			       gfc_current_intrinsic, &shift->where, i + 1,
+			       mpz_get_si (array->shape[i]),
+			       mpz_get_si (shift->shape[j]));
+		    return false;
+		  }
+
+		j += 1;
+	      }
+	}
+    }
+  else
+    {
+      gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
+		 "%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
+		 gfc_current_intrinsic, &shift->where, array->rank - 1);
+      return false;
+    }
+
+  return true;
+}
+
+
+bool
+gfc_check_ctime (gfc_expr *time)
+{
+  if (!scalar_check (time, 0))
+    return false;
+
+  if (!type_check (time, 0, BT_INTEGER))
+    return false;
+
+  return true;
+}
+
+
+bool gfc_check_datan2 (gfc_expr *y, gfc_expr *x)
+{
+  if (!double_check (y, 0) || !double_check (x, 1))
+    return false;
+
+  return true;
+}
+
+bool
+gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
+{
+  if (!numeric_check (x, 0))
+    return false;
+
+  if (y != NULL)
+    {
+      if (!numeric_check (y, 1))
+	return false;
+
+      if (x->ts.type == BT_COMPLEX)
+	{
+	  gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
+		     "present if 'x' is COMPLEX",
+		     gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
+		     &y->where);
+	  return false;
+	}
+
+      if (y->ts.type == BT_COMPLEX)
+	{
+	  gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
+		     "of either REAL or INTEGER",
+		     gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
+		     &y->where);
+	  return false;
+	}
+    }
+
+  return true;
+}
+
+
+bool
+gfc_check_dble (gfc_expr *x)
+{
+  if (!numeric_check (x, 0))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_digits (gfc_expr *x)
+{
+  if (!int_or_real_check (x, 0))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
+{
+  switch (vector_a->ts.type)
+    {
+    case BT_LOGICAL:
+      if (!type_check (vector_b, 1, BT_LOGICAL))
+	return false;
+      break;
+
+    case BT_INTEGER:
+    case BT_REAL:
+    case BT_COMPLEX:
+      if (!numeric_check (vector_b, 1))
+	return false;
+      break;
+
+    default:
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
+		 "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
+		 gfc_current_intrinsic, &vector_a->where);
+      return false;
+    }
+
+  if (!rank_check (vector_a, 0, 1))
+    return false;
+
+  if (!rank_check (vector_b, 1, 1))
+    return false;
+
+  if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
+    {
+      gfc_error ("Different shape for arguments '%s' and '%s' at %L for "
+		 "intrinsic 'dot_product'", gfc_current_intrinsic_arg[0]->name,
+		 gfc_current_intrinsic_arg[1]->name, &vector_a->where);
+      return false;
+    }
+
+  return true;
+}
+
+
+bool
+gfc_check_dprod (gfc_expr *x, gfc_expr *y)
+{
+  if (!type_check (x, 0, BT_REAL)
+      || !type_check (y, 1, BT_REAL))
+    return false;
+
+  if (x->ts.kind != gfc_default_real_kind)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
+		 "real", gfc_current_intrinsic_arg[0]->name,
+		 gfc_current_intrinsic, &x->where);
+      return false;
+    }
+
+  if (y->ts.kind != gfc_default_real_kind)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
+		 "real", gfc_current_intrinsic_arg[1]->name,
+		 gfc_current_intrinsic, &y->where);
+      return false;
+    }
+
+  return true;
+}
+
+
+bool
+gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift)
+{
+  if (!type_check (i, 0, BT_INTEGER))
+    return false;
+
+  if (!type_check (j, 1, BT_INTEGER))
+    return false;
+
+  if (i->is_boz && j->is_boz)
+    {
+      gfc_error ("'I' at %L and 'J' at %L cannot both be BOZ literal "
+		 "constants", &i->where, &j->where);
+      return false;
+    }
+
+  if (!i->is_boz && !j->is_boz && !same_type_check (i, 0, j, 1))
+    return false;
+
+  if (!type_check (shift, 2, BT_INTEGER))
+    return false;
+
+  if (!nonnegative_check ("SHIFT", shift))
+    return false;
+
+  if (i->is_boz)
+    {
+      if (!less_than_bitsize1 ("J", j, "SHIFT", shift, true))
+    	return false;
+      i->ts.kind = j->ts.kind;
+    }
+  else
+    {
+      if (!less_than_bitsize1 ("I", i, "SHIFT", shift, true))
+    	return false;
+      j->ts.kind = i->ts.kind;
+    }
+
+  return true;
+}
+
+
+bool
+gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
+		   gfc_expr *dim)
+{
+  if (!array_check (array, 0))
+    return false;
+
+  if (!type_check (shift, 1, BT_INTEGER))
+    return false;
+
+  if (!dim_check (dim, 3, true))
+    return false;
+
+  if (!dim_rank_check (dim, array, false))
+    return false;
+
+  if (array->rank == 1 || shift->rank == 0)
+    {
+      if (!scalar_check (shift, 1))
+	return false;
+    }
+  else if (shift->rank == array->rank - 1)
+    {
+      int d;
+      if (!dim)
+	d = 1;
+      else if (dim->expr_type == EXPR_CONSTANT)
+	gfc_extract_int (dim, &d);
+      else
+	d = -1;
+
+      if (d > 0)
+	{
+	  int i, j;
+	  for (i = 0, j = 0; i < array->rank; i++)
+	    if (i != d - 1)
+	      {
+		if (!identical_dimen_shape (array, i, shift, j))
+		  {
+		    gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+			       "invalid shape in dimension %d (%ld/%ld)",
+			       gfc_current_intrinsic_arg[1]->name,
+			       gfc_current_intrinsic, &shift->where, i + 1,
+			       mpz_get_si (array->shape[i]),
+			       mpz_get_si (shift->shape[j]));
+		    return false;
+		  }
+
+		j += 1;
+	      }
+	}
+    }
+  else
+    {
+      gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
+		 "%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
+		 gfc_current_intrinsic, &shift->where, array->rank - 1);
+      return false;
+    }
+
+  if (boundary != NULL)
+    {
+      if (!same_type_check (array, 0, boundary, 2))
+	return false;
+
+      if (array->rank == 1 || boundary->rank == 0)
+	{
+	  if (!scalar_check (boundary, 2))
+	    return false;
+	}
+      else if (boundary->rank == array->rank - 1)
+	{
+	  if (!gfc_check_conformance (shift, boundary, 
+				      "arguments '%s' and '%s' for "
+				      "intrinsic %s", 
+				      gfc_current_intrinsic_arg[1]->name, 
+				      gfc_current_intrinsic_arg[2]->name, 
+				      gfc_current_intrinsic))
+	    return false;
+	}
+      else
+	{
+	  gfc_error ("'%s' argument of intrinsic '%s' at %L of must have "
+		     "rank %d or be a scalar",
+		     gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
+		     &shift->where, array->rank - 1);
+	  return false;
+	}
+    }
+
+  return true;
+}
+
+bool
+gfc_check_float (gfc_expr *a)
+{
+  if (!type_check (a, 0, BT_INTEGER))
+    return false;
+
+  if ((a->ts.kind != gfc_default_integer_kind)
+      && !gfc_notify_std (GFC_STD_GNU, "non-default INTEGER "
+			  "kind argument to %s intrinsic at %L", 
+			  gfc_current_intrinsic, &a->where))
+    return false;
+
+  return true;
+}
+
+/* A single complex argument.  */
+
+bool
+gfc_check_fn_c (gfc_expr *a)
+{
+  if (!type_check (a, 0, BT_COMPLEX))
+    return false;
+
+  return true;
+}
+
+/* A single real argument.  */
+
+bool
+gfc_check_fn_r (gfc_expr *a)
+{
+  if (!type_check (a, 0, BT_REAL))
+    return false;
+
+  return true;
+}
+
+/* A single double argument.  */
+
+bool
+gfc_check_fn_d (gfc_expr *a)
+{
+  if (!double_check (a, 0))
+    return false;
+
+  return true;
+}
+
+/* A single real or complex argument.  */
+
+bool
+gfc_check_fn_rc (gfc_expr *a)
+{
+  if (!real_or_complex_check (a, 0))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_fn_rc2008 (gfc_expr *a)
+{
+  if (!real_or_complex_check (a, 0))
+    return false;
+
+  if (a->ts.type == BT_COMPLEX
+      && !gfc_notify_std (GFC_STD_F2008, "COMPLEX argument '%s' "
+			  "argument of '%s' intrinsic at %L", 
+			  gfc_current_intrinsic_arg[0]->name, 
+			  gfc_current_intrinsic, &a->where))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_fnum (gfc_expr *unit)
+{
+  if (!type_check (unit, 0, BT_INTEGER))
+    return false;
+
+  if (!scalar_check (unit, 0))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_huge (gfc_expr *x)
+{
+  if (!int_or_real_check (x, 0))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_hypot (gfc_expr *x, gfc_expr *y)
+{
+  if (!type_check (x, 0, BT_REAL))
+    return false;
+  if (!same_type_check (x, 0, y, 1))
+    return false;
+
+  return true;
+}
+
+
+/* Check that the single argument is an integer.  */
+
+bool
+gfc_check_i (gfc_expr *i)
+{
+  if (!type_check (i, 0, BT_INTEGER))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_iand (gfc_expr *i, gfc_expr *j)
+{
+  if (!type_check (i, 0, BT_INTEGER))
+    return false;
+
+  if (!type_check (j, 1, BT_INTEGER))
+    return false;
+
+  if (i->ts.kind != j->ts.kind)
+    {
+      if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L", 
+			   &i->where))
+	return false;
+    }
+
+  return true;
+}
+
+
+bool
+gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len)
+{
+  if (!type_check (i, 0, BT_INTEGER))
+    return false;
+
+  if (!type_check (pos, 1, BT_INTEGER))
+    return false;
+
+  if (!type_check (len, 2, BT_INTEGER))
+    return false;
+
+  if (!nonnegative_check ("pos", pos))
+    return false;
+
+  if (!nonnegative_check ("len", len))
+    return false;
+
+  if (!less_than_bitsize2 ("i", i, "pos", pos, "len", len))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
+{
+  int i;
+
+  if (!type_check (c, 0, BT_CHARACTER))
+    return false;
+
+  if (!kind_check (kind, 1, BT_INTEGER))
+    return false;
+
+  if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
+			       "with KIND argument at %L", 
+			       gfc_current_intrinsic, &kind->where))
+    return false;
+
+  if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
+    {
+      gfc_expr *start;
+      gfc_expr *end;
+      gfc_ref *ref;
+
+      /* Substring references don't have the charlength set.  */
+      ref = c->ref;
+      while (ref && ref->type != REF_SUBSTRING)
+	ref = ref->next;
+
+      gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
+
+      if (!ref)
+	{
+	  /* Check that the argument is length one.  Non-constant lengths
+	     can't be checked here, so assume they are ok.  */
+	  if (c->ts.u.cl && c->ts.u.cl->length)
+	    {
+	      /* If we already have a length for this expression then use it.  */
+	      if (c->ts.u.cl->length->expr_type != EXPR_CONSTANT)
+		return true;
+	      i = mpz_get_si (c->ts.u.cl->length->value.integer);
+	    }
+	  else
+	    return true;
+	}
+      else
+	{
+	  start = ref->u.ss.start;
+	  end = ref->u.ss.end;
+
+	  gcc_assert (start);
+	  if (end == NULL || end->expr_type != EXPR_CONSTANT
+	      || start->expr_type != EXPR_CONSTANT)
+	    return true;
+
+	  i = mpz_get_si (end->value.integer) + 1
+	    - mpz_get_si (start->value.integer);
+	}
+    }
+  else
+    return true;
+
+  if (i != 1)
+    {
+      gfc_error ("Argument of %s at %L must be of length one",
+		 gfc_current_intrinsic, &c->where);
+      return false;
+    }
+
+  return true;
+}
+
+
+bool
+gfc_check_idnint (gfc_expr *a)
+{
+  if (!double_check (a, 0))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_ieor (gfc_expr *i, gfc_expr *j)
+{
+  if (!type_check (i, 0, BT_INTEGER))
+    return false;
+
+  if (!type_check (j, 1, BT_INTEGER))
+    return false;
+
+  if (i->ts.kind != j->ts.kind)
+    {
+      if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L", 
+			   &i->where))
+	return false;
+    }
+
+  return true;
+}
+
+
+bool
+gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
+		 gfc_expr *kind)
+{
+  if (!type_check (string, 0, BT_CHARACTER)
+      || !type_check (substring, 1, BT_CHARACTER))
+    return false;
+
+  if (back != NULL && !type_check (back, 2, BT_LOGICAL))
+    return false;
+
+  if (!kind_check (kind, 3, BT_INTEGER))
+    return false;
+  if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
+			       "with KIND argument at %L", 
+			       gfc_current_intrinsic, &kind->where))
+    return false;
+
+  if (string->ts.kind != substring->ts.kind)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
+		 "kind as '%s'", gfc_current_intrinsic_arg[1]->name,
+		 gfc_current_intrinsic, &substring->where,
+		 gfc_current_intrinsic_arg[0]->name);
+      return false;
+    }
+
+  return true;
+}
+
+
+bool
+gfc_check_int (gfc_expr *x, gfc_expr *kind)
+{
+  if (!numeric_check (x, 0))
+    return false;
+
+  if (!kind_check (kind, 1, BT_INTEGER))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_intconv (gfc_expr *x)
+{
+  if (!numeric_check (x, 0))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_ior (gfc_expr *i, gfc_expr *j)
+{
+  if (!type_check (i, 0, BT_INTEGER))
+    return false;
+
+  if (!type_check (j, 1, BT_INTEGER))
+    return false;
+
+  if (i->ts.kind != j->ts.kind)
+    {
+      if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L", 
+			   &i->where))
+	return false;
+    }
+
+  return true;
+}
+
+
+bool
+gfc_check_ishft (gfc_expr *i, gfc_expr *shift)
+{
+  if (!type_check (i, 0, BT_INTEGER)
+      || !type_check (shift, 1, BT_INTEGER))
+    return false;
+
+  if (!less_than_bitsize1 ("I", i, NULL, shift, true))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size)
+{
+  if (!type_check (i, 0, BT_INTEGER)
+      || !type_check (shift, 1, BT_INTEGER))
+    return false;
+
+  if (size != NULL)
+    {
+      int i2, i3;
+
+      if (!type_check (size, 2, BT_INTEGER))
+	return false;
+
+      if (!less_than_bitsize1 ("I", i, "SIZE", size, true))
+	return false;
+
+      if (size->expr_type == EXPR_CONSTANT)
+	{
+	  gfc_extract_int (size, &i3);
+	  if (i3 <= 0)
+	    {
+	      gfc_error ("SIZE at %L must be positive", &size->where);
+	      return false;
+	    }
+
+	  if (shift->expr_type == EXPR_CONSTANT)
+	    {
+	      gfc_extract_int (shift, &i2);
+	      if (i2 < 0)
+		i2 = -i2;
+
+	      if (i2 > i3)
+		{
+		  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;
+		}
+	     }
+	}
+    }
+  else if (!less_than_bitsize1 ("I", i, NULL, shift, true))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_kill (gfc_expr *pid, gfc_expr *sig)
+{
+  if (!type_check (pid, 0, BT_INTEGER))
+    return false;
+
+  if (!type_check (sig, 1, BT_INTEGER))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status)
+{
+  if (!type_check (pid, 0, BT_INTEGER))
+    return false;
+
+  if (!scalar_check (pid, 0))
+    return false;
+
+  if (!type_check (sig, 1, BT_INTEGER))
+    return false;
+
+  if (!scalar_check (sig, 1))
+    return false;
+
+  if (status == NULL)
+    return true;
+
+  if (!type_check (status, 2, BT_INTEGER))
+    return false;
+
+  if (!scalar_check (status, 2))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_kind (gfc_expr *x)
+{
+  if (x->ts.type == BT_DERIVED)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
+		 "non-derived type", gfc_current_intrinsic_arg[0]->name,
+		 gfc_current_intrinsic, &x->where);
+      return false;
+    }
+
+  return true;
+}
+
+
+bool
+gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
+  if (!array_check (array, 0))
+    return false;
+
+  if (!dim_check (dim, 1, false))
+    return false;
+
+  if (!dim_rank_check (dim, array, 1))
+    return false;
+
+  if (!kind_check (kind, 2, BT_INTEGER))
+    return false;
+  if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
+			       "with KIND argument at %L", 
+			       gfc_current_intrinsic, &kind->where))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_lcobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
+{
+  if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+    {
+      gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+      return false;
+    }
+
+  if (!coarray_check (coarray, 0))
+    return false;
+
+  if (dim != NULL)
+    {
+      if (!dim_check (dim, 1, false))
+        return false;
+
+      if (!dim_corank_check (dim, coarray))
+        return false;
+    }
+
+  if (!kind_check (kind, 2, BT_INTEGER))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
+{
+  if (!type_check (s, 0, BT_CHARACTER))
+    return false;
+
+  if (!kind_check (kind, 1, BT_INTEGER))
+    return false;
+  if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
+			       "with KIND argument at %L", 
+			       gfc_current_intrinsic, &kind->where))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_lge_lgt_lle_llt (gfc_expr *a, gfc_expr *b)
+{
+  if (!type_check (a, 0, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (a, 0, gfc_default_character_kind))
+    return false;
+
+  if (!type_check (b, 1, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (b, 1, gfc_default_character_kind))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_link (gfc_expr *path1, gfc_expr *path2)
+{
+  if (!type_check (path1, 0, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (path1, 0, gfc_default_character_kind))
+    return false;
+
+  if (!type_check (path2, 1, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (path2, 1, gfc_default_character_kind))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
+{
+  if (!type_check (path1, 0, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (path1, 0, gfc_default_character_kind))
+    return false;
+
+  if (!type_check (path2, 1, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (path2, 0, gfc_default_character_kind))
+    return false;
+
+  if (status == NULL)
+    return true;
+
+  if (!type_check (status, 2, BT_INTEGER))
+    return false;
+
+  if (!scalar_check (status, 2))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_loc (gfc_expr *expr)
+{
+  return variable_check (expr, 0, true);
+}
+
+
+bool
+gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2)
+{
+  if (!type_check (path1, 0, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (path1, 0, gfc_default_character_kind))
+    return false;
+
+  if (!type_check (path2, 1, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (path2, 1, gfc_default_character_kind))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
+{
+  if (!type_check (path1, 0, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (path1, 0, gfc_default_character_kind))
+    return false;
+
+  if (!type_check (path2, 1, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (path2, 1, gfc_default_character_kind))
+    return false;
+
+  if (status == NULL)
+    return true;
+
+  if (!type_check (status, 2, BT_INTEGER))
+    return false;
+
+  if (!scalar_check (status, 2))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_logical (gfc_expr *a, gfc_expr *kind)
+{
+  if (!type_check (a, 0, BT_LOGICAL))
+    return false;
+  if (!kind_check (kind, 1, BT_LOGICAL))
+    return false;
+
+  return true;
+}
+
+
+/* Min/max family.  */
+
+static bool
+min_max_args (gfc_actual_arglist *args)
+{
+  gfc_actual_arglist *arg;
+  int i, j, nargs, *nlabels, nlabelless;
+  bool a1 = false, a2 = false;
+
+  if (args == NULL || args->next == NULL)
+    {
+      gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
+		 gfc_current_intrinsic, gfc_current_intrinsic_where);
+      return false;
+    }
+
+  if (!args->name)
+    a1 = true;
+
+  if (!args->next->name)
+    a2 = true;
+
+  nargs = 0;
+  for (arg = args; arg; arg = arg->next)
+    if (arg->name)
+      nargs++;
+
+  if (nargs == 0)
+    return true;
+
+  /* Note: Having a keywordless argument after an "arg=" is checked before.  */
+  nlabelless = 0;
+  nlabels = XALLOCAVEC (int, nargs);
+  for (arg = args, i = 0; arg; arg = arg->next, i++)
+    if (arg->name)
+      {
+	int n;
+	char *endp;
+
+	if (arg->name[0] != 'a' || arg->name[1] < '1' || arg->name[1] > '9')
+	  goto unknown;
+	n = strtol (&arg->name[1], &endp, 10);
+	if (endp[0] != '\0')
+	  goto unknown;
+	if (n <= 0)
+	  goto unknown;
+	if (n <= nlabelless)
+	  goto duplicate;
+	nlabels[i] = n;
+	if (n == 1)
+	  a1 = true;
+	if (n == 2)
+	  a2 = true;
+      }
+    else
+      nlabelless++;
+
+  if (!a1 || !a2)
+    {
+      gfc_error ("Missing '%s' argument to the %s intrinsic at %L",
+	         !a1 ? "a1" : "a2", gfc_current_intrinsic,
+		 gfc_current_intrinsic_where);
+      return false;
+    }
+
+  /* Check for duplicates.  */
+  for (i = 0; i < nargs; i++)
+    for (j = i + 1; j < nargs; j++)
+      if (nlabels[i] == nlabels[j])
+	goto duplicate;
+
+  return true;
+
+duplicate:
+  gfc_error ("Duplicate argument '%s' at %L to intrinsic %s", arg->name,
+	     &arg->expr->where, gfc_current_intrinsic);
+  return false;
+
+unknown:
+  gfc_error ("Unknown argument '%s' at %L to intrinsic %s", arg->name,
+	     &arg->expr->where, gfc_current_intrinsic);
+  return false;
+}
+
+
+static bool
+check_rest (bt type, int kind, gfc_actual_arglist *arglist)
+{
+  gfc_actual_arglist *arg, *tmp;
+  gfc_expr *x;
+  int m, n;
+
+  if (!min_max_args (arglist))
+    return false;
+
+  for (arg = arglist, n=1; arg; arg = arg->next, n++)
+    {
+      x = arg->expr;
+      if (x->ts.type != type || x->ts.kind != kind)
+	{
+	  if (x->ts.type == type)
+	    {
+	      if (!gfc_notify_std (GFC_STD_GNU, "Different type "
+				   "kinds at %L", &x->where))
+		return false;
+	    }
+	  else
+	    {
+	      gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
+			 "%s(%d)", n, gfc_current_intrinsic, &x->where,
+			 gfc_basic_typename (type), kind);
+	      return false;
+	    }
+	}
+
+      for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++)
+	if (!gfc_check_conformance (tmp->expr, x, 
+				    "arguments 'a%d' and 'a%d' for "
+				    "intrinsic '%s'", m, n, 
+				    gfc_current_intrinsic))
+	    return false;
+    }
+
+  return true;
+}
+
+
+bool
+gfc_check_min_max (gfc_actual_arglist *arg)
+{
+  gfc_expr *x;
+
+  if (!min_max_args (arg))
+    return false;
+
+  x = arg->expr;
+
+  if (x->ts.type == BT_CHARACTER)
+    {
+      if (!gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
+			   "with CHARACTER argument at %L", 
+			   gfc_current_intrinsic, &x->where))
+	return false;
+    }
+  else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
+    {
+      gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, "
+		 "REAL or CHARACTER", gfc_current_intrinsic, &x->where);
+      return false;
+    }
+
+  return check_rest (x->ts.type, x->ts.kind, arg);
+}
+
+
+bool
+gfc_check_min_max_integer (gfc_actual_arglist *arg)
+{
+  return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
+}
+
+
+bool
+gfc_check_min_max_real (gfc_actual_arglist *arg)
+{
+  return check_rest (BT_REAL, gfc_default_real_kind, arg);
+}
+
+
+bool
+gfc_check_min_max_double (gfc_actual_arglist *arg)
+{
+  return check_rest (BT_REAL, gfc_default_double_kind, arg);
+}
+
+
+/* End of min/max family.  */
+
+bool
+gfc_check_malloc (gfc_expr *size)
+{
+  if (!type_check (size, 0, BT_INTEGER))
+    return false;
+
+  if (!scalar_check (size, 0))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
+{
+  if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
+		 "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
+		 gfc_current_intrinsic, &matrix_a->where);
+      return false;
+    }
+
+  if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
+		 "or LOGICAL", gfc_current_intrinsic_arg[1]->name,
+		 gfc_current_intrinsic, &matrix_b->where);
+      return false;
+    }
+
+  if ((matrix_a->ts.type == BT_LOGICAL && gfc_numeric_ts (&matrix_b->ts))
+      || (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL))
+    {
+      gfc_error ("Argument types of '%s' intrinsic at %L must match (%s/%s)",
+		 gfc_current_intrinsic, &matrix_a->where,
+		 gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts));
+       return false;
+    }
+
+  switch (matrix_a->rank)
+    {
+    case 1:
+      if (!rank_check (matrix_b, 1, 2))
+	return false;
+      /* Check for case matrix_a has shape(m), matrix_b has shape (m, k).  */
+      if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0))
+	{
+	  gfc_error ("Different shape on dimension 1 for arguments '%s' "
+		     "and '%s' at %L for intrinsic matmul",
+		     gfc_current_intrinsic_arg[0]->name,
+		     gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
+	  return false;
+	}
+      break;
+
+    case 2:
+      if (matrix_b->rank != 2)
+	{
+	  if (!rank_check (matrix_b, 1, 1))
+	    return false;
+	}
+      /* matrix_b has rank 1 or 2 here. Common check for the cases
+	 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
+	 - matrix_a has shape (n,m) and matrix_b has shape (m).  */
+      if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0))
+	{
+	  gfc_error ("Different shape on dimension 2 for argument '%s' and "
+		     "dimension 1 for argument '%s' at %L for intrinsic "
+		     "matmul", gfc_current_intrinsic_arg[0]->name,
+		     gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
+	  return false;
+	}
+      break;
+
+    default:
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
+		 "1 or 2", gfc_current_intrinsic_arg[0]->name,
+		 gfc_current_intrinsic, &matrix_a->where);
+      return false;
+    }
+
+  return true;
+}
+
+
+/* Whoever came up with this interface was probably on something.
+   The possibilities for the occupation of the second and third
+   parameters are:
+
+	 Arg #2     Arg #3
+	 NULL       NULL
+	 DIM	NULL
+	 MASK       NULL
+	 NULL       MASK	     minloc(array, mask=m)
+	 DIM	MASK
+
+   I.e. in the case of minloc(array,mask), mask will be in the second
+   position of the argument list and we'll have to fix that up.  */
+
+bool
+gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
+{
+  gfc_expr *a, *m, *d;
+
+  a = ap->expr;
+  if (!int_or_real_check (a, 0) || !array_check (a, 0))
+    return false;
+
+  d = ap->next->expr;
+  m = ap->next->next->expr;
+
+  if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
+      && ap->next->name == NULL)
+    {
+      m = d;
+      d = NULL;
+      ap->next->expr = NULL;
+      ap->next->next->expr = m;
+    }
+
+  if (!dim_check (d, 1, false))
+    return false;
+
+  if (!dim_rank_check (d, a, 0))
+    return false;
+
+  if (m != NULL && !type_check (m, 2, BT_LOGICAL))
+    return false;
+
+  if (m != NULL
+      && !gfc_check_conformance (a, m, 
+				 "arguments '%s' and '%s' for intrinsic %s", 
+				 gfc_current_intrinsic_arg[0]->name, 
+				 gfc_current_intrinsic_arg[2]->name, 
+				 gfc_current_intrinsic))
+    return false;
+
+  return true;
+}
+
+
+/* Similar to minloc/maxloc, the argument list might need to be
+   reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics.  The
+   difference is that MINLOC/MAXLOC take an additional KIND argument.
+   The possibilities are:
+
+	 Arg #2     Arg #3
+	 NULL       NULL
+	 DIM	NULL
+	 MASK       NULL
+	 NULL       MASK	     minval(array, mask=m)
+	 DIM	MASK
+
+   I.e. in the case of minval(array,mask), mask will be in the second
+   position of the argument list and we'll have to fix that up.  */
+
+static bool
+check_reduction (gfc_actual_arglist *ap)
+{
+  gfc_expr *a, *m, *d;
+
+  a = ap->expr;
+  d = ap->next->expr;
+  m = ap->next->next->expr;
+
+  if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
+      && ap->next->name == NULL)
+    {
+      m = d;
+      d = NULL;
+      ap->next->expr = NULL;
+      ap->next->next->expr = m;
+    }
+
+  if (!dim_check (d, 1, false))
+    return false;
+
+  if (!dim_rank_check (d, a, 0))
+    return false;
+
+  if (m != NULL && !type_check (m, 2, BT_LOGICAL))
+    return false;
+
+  if (m != NULL
+      && !gfc_check_conformance (a, m, 
+				 "arguments '%s' and '%s' for intrinsic %s", 
+				 gfc_current_intrinsic_arg[0]->name, 
+				 gfc_current_intrinsic_arg[2]->name, 
+				 gfc_current_intrinsic))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_minval_maxval (gfc_actual_arglist *ap)
+{
+  if (!int_or_real_check (ap->expr, 0)
+      || !array_check (ap->expr, 0))
+    return false;
+
+  return check_reduction (ap);
+}
+
+
+bool
+gfc_check_product_sum (gfc_actual_arglist *ap)
+{
+  if (!numeric_check (ap->expr, 0)
+      || !array_check (ap->expr, 0))
+    return false;
+
+  return check_reduction (ap);
+}
+
+
+/* For IANY, IALL and IPARITY.  */
+
+bool
+gfc_check_mask (gfc_expr *i, gfc_expr *kind)
+{
+  int k;
+
+  if (!type_check (i, 0, BT_INTEGER))
+    return false;
+
+  if (!nonnegative_check ("I", i))
+    return false;
+
+  if (!kind_check (kind, 1, BT_INTEGER))
+    return false;
+
+  if (kind)
+    gfc_extract_int (kind, &k);
+  else
+    k = gfc_default_integer_kind;
+
+  if (!less_than_bitsizekind ("I", i, k))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_transf_bit_intrins (gfc_actual_arglist *ap)
+{
+  if (ap->expr->ts.type != BT_INTEGER)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER",
+                 gfc_current_intrinsic_arg[0]->name,
+                 gfc_current_intrinsic, &ap->expr->where);
+      return false;
+    }
+
+  if (!array_check (ap->expr, 0))
+    return false;
+
+  return check_reduction (ap);
+}
+
+
+bool
+gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
+{
+  if (!same_type_check (tsource, 0, fsource, 1))
+    return false;
+
+  if (!type_check (mask, 2, BT_LOGICAL))
+    return false;
+
+  if (tsource->ts.type == BT_CHARACTER)
+    return gfc_check_same_strlen (tsource, fsource, "MERGE intrinsic");
+
+  return true;
+}
+
+
+bool
+gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask)
+{
+  if (!type_check (i, 0, BT_INTEGER))
+    return false;
+
+  if (!type_check (j, 1, BT_INTEGER))
+    return false;
+
+  if (!type_check (mask, 2, BT_INTEGER))
+    return false;
+
+  if (!same_type_check (i, 0, j, 1))
+    return false;
+
+  if (!same_type_check (i, 0, mask, 2))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
+{
+  if (!variable_check (from, 0, false))
+    return false;
+  if (!allocatable_check (from, 0))
+    return false;
+  if (gfc_is_coindexed (from))
+    {
+      gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be "
+		 "coindexed", &from->where);
+      return false;
+    }
+
+  if (!variable_check (to, 1, false))
+    return false;
+  if (!allocatable_check (to, 1))
+    return false;
+  if (gfc_is_coindexed (to))
+    {
+      gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be "
+		 "coindexed", &to->where);
+      return false;
+    }
+
+  if (from->ts.type == BT_CLASS && to->ts.type == BT_DERIVED)
+    {
+      gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
+		 "polymorphic if FROM is polymorphic",
+		 &to->where);
+      return false;
+    }
+
+  if (!same_type_check (to, 1, from, 0))
+    return false;
+
+  if (to->rank != from->rank)
+    {
+      gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
+		 "must have the same rank %d/%d", &to->where,  from->rank,
+		 to->rank);
+      return false;
+    }
+
+  /* IR F08/0040; cf. 12-006A.  */
+  if (gfc_get_corank (to) != gfc_get_corank (from))
+    {
+      gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
+		 "must have the same corank %d/%d", &to->where,
+		 gfc_get_corank (from), gfc_get_corank (to));
+      return false;
+    }
+
+  /* CLASS arguments: Make sure the vtab of from is present.  */
+  if (to->ts.type == BT_CLASS && !UNLIMITED_POLY (from))
+    gfc_find_vtab (&from->ts);
+
+  return true;
+}
+
+
+bool
+gfc_check_nearest (gfc_expr *x, gfc_expr *s)
+{
+  if (!type_check (x, 0, BT_REAL))
+    return false;
+
+  if (!type_check (s, 1, BT_REAL))
+    return false;
+
+  if (s->expr_type == EXPR_CONSTANT)
+    {
+      if (mpfr_sgn (s->value.real) == 0)
+	{
+	  gfc_error ("Argument 'S' of NEAREST at %L shall not be zero",
+		     &s->where);
+	  return false;
+	}
+    }
+
+  return true;
+}
+
+
+bool
+gfc_check_new_line (gfc_expr *a)
+{
+  if (!type_check (a, 0, BT_CHARACTER))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_norm2 (gfc_expr *array, gfc_expr *dim)
+{
+  if (!type_check (array, 0, BT_REAL))
+    return false;
+
+  if (!array_check (array, 0))
+    return false;
+
+  if (!dim_rank_check (dim, array, false))
+    return false;
+
+  return true;
+}
+
+bool
+gfc_check_null (gfc_expr *mold)
+{
+  symbol_attribute attr;
+
+  if (mold == NULL)
+    return true;
+
+  if (!variable_check (mold, 0, true))
+    return false;
+
+  attr = gfc_variable_attr (mold, NULL);
+
+  if (!attr.pointer && !attr.proc_pointer && !attr.allocatable)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER, "
+		 "ALLOCATABLE or procedure pointer",
+		 gfc_current_intrinsic_arg[0]->name,
+		 gfc_current_intrinsic, &mold->where);
+      return false;
+    }
+
+  if (attr.allocatable
+      && !gfc_notify_std (GFC_STD_F2003, "NULL intrinsic with "
+			  "allocatable MOLD at %L", &mold->where))
+    return false;
+
+  /* F2008, C1242.  */
+  if (gfc_is_coindexed (mold))
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
+		 "coindexed", gfc_current_intrinsic_arg[0]->name,
+		 gfc_current_intrinsic, &mold->where);
+      return false;
+    }
+
+  return true;
+}
+
+
+bool
+gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
+{
+  if (!array_check (array, 0))
+    return false;
+
+  if (!type_check (mask, 1, BT_LOGICAL))
+    return false;
+
+  if (!gfc_check_conformance (array, mask, 
+			      "arguments '%s' and '%s' for intrinsic '%s'", 
+			      gfc_current_intrinsic_arg[0]->name, 
+			      gfc_current_intrinsic_arg[1]->name, 
+			      gfc_current_intrinsic))
+    return false;
+
+  if (vector != NULL)
+    {
+      mpz_t array_size, vector_size;
+      bool have_array_size, have_vector_size;
+
+      if (!same_type_check (array, 0, vector, 2))
+	return false;
+
+      if (!rank_check (vector, 2, 1))
+	return false;
+
+      /* VECTOR requires at least as many elements as MASK
+         has .TRUE. values.  */
+      have_array_size = gfc_array_size(array, &array_size);
+      have_vector_size = gfc_array_size(vector, &vector_size);
+
+      if (have_vector_size
+	  && (mask->expr_type == EXPR_ARRAY
+	      || (mask->expr_type == EXPR_CONSTANT
+		  && have_array_size)))
+	{
+	  int mask_true_values = 0;
+
+	  if (mask->expr_type == EXPR_ARRAY)
+	    {
+	      gfc_constructor *mask_ctor;
+	      mask_ctor = gfc_constructor_first (mask->value.constructor);
+	      while (mask_ctor)
+		{
+		  if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
+		    {
+		      mask_true_values = 0;
+		      break;
+		    }
+
+		  if (mask_ctor->expr->value.logical)
+		    mask_true_values++;
+
+		  mask_ctor = gfc_constructor_next (mask_ctor);
+		}
+	    }
+	  else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical)
+	    mask_true_values = mpz_get_si (array_size);
+
+	  if (mpz_get_si (vector_size) < mask_true_values)
+	    {
+	      gfc_error ("'%s' argument of '%s' intrinsic at %L must "
+			 "provide at least as many elements as there "
+			 "are .TRUE. values in '%s' (%ld/%d)",
+			 gfc_current_intrinsic_arg[2]->name,
+			 gfc_current_intrinsic, &vector->where,
+			 gfc_current_intrinsic_arg[1]->name,
+			 mpz_get_si (vector_size), mask_true_values);
+	      return false;
+	    }
+	}
+
+      if (have_array_size)
+	mpz_clear (array_size);
+      if (have_vector_size)
+	mpz_clear (vector_size);
+    }
+
+  return true;
+}
+
+
+bool
+gfc_check_parity (gfc_expr *mask, gfc_expr *dim)
+{
+  if (!type_check (mask, 0, BT_LOGICAL))
+    return false;
+
+  if (!array_check (mask, 0))
+    return false;
+
+  if (!dim_rank_check (dim, mask, false))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_precision (gfc_expr *x)
+{
+  if (!real_or_complex_check (x, 0))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_present (gfc_expr *a)
+{
+  gfc_symbol *sym;
+
+  if (!variable_check (a, 0, true))
+    return false;
+
+  sym = a->symtree->n.sym;
+  if (!sym->attr.dummy)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
+		 "dummy variable", gfc_current_intrinsic_arg[0]->name,
+		 gfc_current_intrinsic, &a->where);
+      return false;
+    }
+
+  if (!sym->attr.optional)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
+		 "an OPTIONAL dummy variable",
+		 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+		 &a->where);
+      return false;
+    }
+
+  /* 13.14.82  PRESENT(A)
+     ......
+     Argument.  A shall be the name of an optional dummy argument that is
+     accessible in the subprogram in which the PRESENT function reference
+     appears...  */
+
+  if (a->ref != NULL
+      && !(a->ref->next == NULL && a->ref->type == REF_ARRAY
+	   && (a->ref->u.ar.type == AR_FULL
+	       || (a->ref->u.ar.type == AR_ELEMENT
+		   && a->ref->u.ar.as->rank == 0))))
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
+		 "subobject of '%s'", gfc_current_intrinsic_arg[0]->name,
+		 gfc_current_intrinsic, &a->where, sym->name);
+      return false;
+    }
+
+  return true;
+}
+
+
+bool
+gfc_check_radix (gfc_expr *x)
+{
+  if (!int_or_real_check (x, 0))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_range (gfc_expr *x)
+{
+  if (!numeric_check (x, 0))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_rank (gfc_expr *a ATTRIBUTE_UNUSED)
+{
+  /* Any data object is allowed; a "data object" is a "constant (4.1.3),
+     variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45).  */
+
+  bool is_variable = true;
+
+  /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
+  if (a->expr_type == EXPR_FUNCTION)
+    is_variable = a->value.function.esym
+		  ? a->value.function.esym->result->attr.pointer
+		  : a->symtree->n.sym->result->attr.pointer;
+
+  if (a->expr_type == EXPR_OP || a->expr_type == EXPR_NULL
+      || a->expr_type == EXPR_COMPCALL|| a->expr_type == EXPR_PPC
+      || !is_variable)
+    {
+      gfc_error ("The argument of the RANK intrinsic at %L must be a data "
+		 "object", &a->where);
+      return false;
+    }
+
+  return true;
+}
+
+
+/* real, float, sngl.  */
+bool
+gfc_check_real (gfc_expr *a, gfc_expr *kind)
+{
+  if (!numeric_check (a, 0))
+    return false;
+
+  if (!kind_check (kind, 1, BT_REAL))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_rename (gfc_expr *path1, gfc_expr *path2)
+{
+  if (!type_check (path1, 0, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (path1, 0, gfc_default_character_kind))
+    return false;
+
+  if (!type_check (path2, 1, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (path2, 1, gfc_default_character_kind))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
+{
+  if (!type_check (path1, 0, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (path1, 0, gfc_default_character_kind))
+    return false;
+
+  if (!type_check (path2, 1, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (path2, 1, gfc_default_character_kind))
+    return false;
+
+  if (status == NULL)
+    return true;
+
+  if (!type_check (status, 2, BT_INTEGER))
+    return false;
+
+  if (!scalar_check (status, 2))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_repeat (gfc_expr *x, gfc_expr *y)
+{
+  if (!type_check (x, 0, BT_CHARACTER))
+    return false;
+
+  if (!scalar_check (x, 0))
+    return false;
+
+  if (!type_check (y, 0, BT_INTEGER))
+    return false;
+
+  if (!scalar_check (y, 1))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
+		   gfc_expr *pad, gfc_expr *order)
+{
+  mpz_t size;
+  mpz_t nelems;
+  int shape_size;
+
+  if (!array_check (source, 0))
+    return false;
+
+  if (!rank_check (shape, 1, 1))
+    return false;
+
+  if (!type_check (shape, 1, BT_INTEGER))
+    return false;
+
+  if (!gfc_array_size (shape, &size))
+    {
+      gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
+		 "array of constant size", &shape->where);
+      return false;
+    }
+
+  shape_size = mpz_get_ui (size);
+  mpz_clear (size);
+
+  if (shape_size <= 0)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
+		 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
+		 &shape->where);
+      return false;
+    }
+  else if (shape_size > GFC_MAX_DIMENSIONS)
+    {
+      gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
+		 "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
+      return false;
+    }
+  else if (shape->expr_type == EXPR_ARRAY && gfc_is_constant_expr (shape))
+    {
+      gfc_expr *e;
+      int i, extent;
+      for (i = 0; i < shape_size; ++i)
+	{
+	  e = gfc_constructor_lookup_expr (shape->value.constructor, i);
+	  if (e->expr_type != EXPR_CONSTANT)
+	    continue;
+
+	  gfc_extract_int (e, &extent);
+	  if (extent < 0)
+	    {
+	      gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+			 "negative element (%d)",
+			 gfc_current_intrinsic_arg[1]->name,
+			 gfc_current_intrinsic, &e->where, extent);
+	      return false;
+	    }
+	}
+    }
+
+  if (pad != NULL)
+    {
+      if (!same_type_check (source, 0, pad, 2))
+	return false;
+
+      if (!array_check (pad, 2))
+	return false;
+    }
+
+  if (order != NULL)
+    {
+      if (!array_check (order, 3))
+	return false;
+
+      if (!type_check (order, 3, BT_INTEGER))
+	return false;
+
+      if (order->expr_type == EXPR_ARRAY)
+	{
+	  int i, order_size, dim, perm[GFC_MAX_DIMENSIONS];
+	  gfc_expr *e;
+
+	  for (i = 0; i < GFC_MAX_DIMENSIONS; ++i)
+	    perm[i] = 0;
+
+	  gfc_array_size (order, &size);
+	  order_size = mpz_get_ui (size);
+	  mpz_clear (size);
+
+	  if (order_size != shape_size)
+	    {
+	      gfc_error ("'%s' argument of '%s' intrinsic at %L "
+			 "has wrong number of elements (%d/%d)",
+			 gfc_current_intrinsic_arg[3]->name,
+			 gfc_current_intrinsic, &order->where,
+			 order_size, shape_size);
+	      return false;
+	    }
+
+	  for (i = 1; i <= order_size; ++i)
+	    {
+	      e = gfc_constructor_lookup_expr (order->value.constructor, i-1);
+	      if (e->expr_type != EXPR_CONSTANT)
+		continue;
+
+	      gfc_extract_int (e, &dim);
+
+	      if (dim < 1 || dim > order_size)
+		{
+		  gfc_error ("'%s' argument of '%s' intrinsic at %L "
+			     "has out-of-range dimension (%d)",
+			     gfc_current_intrinsic_arg[3]->name,
+			     gfc_current_intrinsic, &e->where, dim);
+		  return false;
+		}
+
+	      if (perm[dim-1] != 0)
+		{
+		  gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+			     "invalid permutation of dimensions (dimension "
+			     "'%d' duplicated)",
+			     gfc_current_intrinsic_arg[3]->name,
+			     gfc_current_intrinsic, &e->where, dim);
+		  return false;
+		}
+
+	      perm[dim-1] = 1;
+	    }
+	}
+    }
+
+  if (pad == NULL && shape->expr_type == EXPR_ARRAY
+      && gfc_is_constant_expr (shape)
+      && !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as
+	   && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
+    {
+      /* Check the match in size between source and destination.  */
+      if (gfc_array_size (source, &nelems))
+	{
+	  gfc_constructor *c;
+	  bool test;
+
+
+	  mpz_init_set_ui (size, 1);
+	  for (c = gfc_constructor_first (shape->value.constructor);
+	       c; c = gfc_constructor_next (c))
+	    mpz_mul (size, size, c->expr->value.integer);
+
+	  test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
+	  mpz_clear (nelems);
+	  mpz_clear (size);
+
+	  if (test)
+	    {
+	      gfc_error ("Without padding, there are not enough elements "
+			 "in the intrinsic RESHAPE source at %L to match "
+			 "the shape", &source->where);
+	      return false;
+	    }
+	}
+    }
+
+  return true;
+}
+
+
+bool
+gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
+{
+  if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS)
+    {
+        gfc_error ("'%s' argument of '%s' intrinsic at %L "
+		   "cannot be of type %s",
+		   gfc_current_intrinsic_arg[0]->name,
+		   gfc_current_intrinsic,
+		   &a->where, gfc_typename (&a->ts));
+        return false;
+    }
+
+  if (!(gfc_type_is_extensible (a->ts.u.derived) || UNLIMITED_POLY (a)))
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L "
+		 "must be of an extensible type",
+		 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+		 &a->where);
+      return false;
+    }
+
+  if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS)
+    {
+        gfc_error ("'%s' argument of '%s' intrinsic at %L "
+		   "cannot be of type %s",
+		   gfc_current_intrinsic_arg[0]->name,
+		   gfc_current_intrinsic,
+		   &b->where, gfc_typename (&b->ts));
+      return false;
+    }
+
+  if (!(gfc_type_is_extensible (b->ts.u.derived) || UNLIMITED_POLY (b)))
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L "
+		 "must be of an extensible type",
+		 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
+		 &b->where);
+      return false;
+    }
+
+  return true;
+}
+
+
+bool
+gfc_check_scale (gfc_expr *x, gfc_expr *i)
+{
+  if (!type_check (x, 0, BT_REAL))
+    return false;
+
+  if (!type_check (i, 1, BT_INTEGER))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
+{
+  if (!type_check (x, 0, BT_CHARACTER))
+    return false;
+
+  if (!type_check (y, 1, BT_CHARACTER))
+    return false;
+
+  if (z != NULL && !type_check (z, 2, BT_LOGICAL))
+    return false;
+
+  if (!kind_check (kind, 3, BT_INTEGER))
+    return false;
+  if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
+			       "with KIND argument at %L", 
+			       gfc_current_intrinsic, &kind->where))
+    return false;
+
+  if (!same_type_check (x, 0, y, 1))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_secnds (gfc_expr *r)
+{
+  if (!type_check (r, 0, BT_REAL))
+    return false;
+
+  if (!kind_value_check (r, 0, 4))
+    return false;
+
+  if (!scalar_check (r, 0))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_selected_char_kind (gfc_expr *name)
+{
+  if (!type_check (name, 0, BT_CHARACTER))
+    return false;
+
+  if (!kind_value_check (name, 0, gfc_default_character_kind))
+    return false;
+
+  if (!scalar_check (name, 0))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_selected_int_kind (gfc_expr *r)
+{
+  if (!type_check (r, 0, BT_INTEGER))
+    return false;
+
+  if (!scalar_check (r, 0))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix)
+{
+  if (p == NULL && r == NULL
+      && !gfc_notify_std (GFC_STD_F2008, "SELECTED_REAL_KIND with"
+			  " neither 'P' nor 'R' argument at %L", 
+			  gfc_current_intrinsic_where))
+    return false;
+
+  if (p)
+    {
+      if (!type_check (p, 0, BT_INTEGER))
+	return false;
+
+      if (!scalar_check (p, 0))
+	return false;
+    }
+
+  if (r)
+    {
+      if (!type_check (r, 1, BT_INTEGER))
+	return false;
+
+      if (!scalar_check (r, 1))
+	return false;
+    }
+
+  if (radix)
+    {
+      if (!type_check (radix, 1, BT_INTEGER))
+	return false;
+
+      if (!scalar_check (radix, 1))
+	return false;
+
+      if (!gfc_notify_std (GFC_STD_F2008, "'%s' intrinsic with "
+			   "RADIX argument at %L", gfc_current_intrinsic, 
+			   &radix->where))
+	return false;
+    }
+
+  return true;
+}
+
+
+bool
+gfc_check_set_exponent (gfc_expr *x, gfc_expr *i)
+{
+  if (!type_check (x, 0, BT_REAL))
+    return false;
+
+  if (!type_check (i, 1, BT_INTEGER))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_shape (gfc_expr *source, gfc_expr *kind)
+{
+  gfc_array_ref *ar;
+
+  if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
+    return true;
+
+  ar = gfc_find_array_ref (source);
+
+  if (ar->as && ar->as->type == AS_ASSUMED_SIZE && ar->type == AR_FULL)
+    {
+      gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
+		 "an assumed size array", &source->where);
+      return false;
+    }
+
+  if (!kind_check (kind, 1, BT_INTEGER))
+    return false;
+  if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
+			       "with KIND argument at %L", 
+			       gfc_current_intrinsic, &kind->where))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_shift (gfc_expr *i, gfc_expr *shift)
+{
+  if (!type_check (i, 0, BT_INTEGER))
+    return false;
+
+  if (!type_check (shift, 0, BT_INTEGER))
+    return false;
+
+  if (!nonnegative_check ("SHIFT", shift))
+    return false;
+
+  if (!less_than_bitsize1 ("I", i, "SHIFT", shift, true))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_sign (gfc_expr *a, gfc_expr *b)
+{
+  if (!int_or_real_check (a, 0))
+    return false;
+
+  if (!same_type_check (a, 0, b, 1))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
+  if (!array_check (array, 0))
+    return false;
+
+  if (!dim_check (dim, 1, true))
+    return false;
+
+  if (!dim_rank_check (dim, array, 0))
+    return false;
+
+  if (!kind_check (kind, 2, BT_INTEGER))
+    return false;
+  if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
+			       "with KIND argument at %L", 
+			       gfc_current_intrinsic, &kind->where))
+    return false;
+
+
+  return true;
+}
+
+
+bool
+gfc_check_sizeof (gfc_expr *arg)
+{
+  if (arg->ts.type == BT_PROCEDURE)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be a procedure",
+		 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+		 &arg->where);
+      return false;
+    }
+
+  if (arg->ts.type == BT_ASSUMED)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)",
+		 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+		 &arg->where);
+      return false;
+    }
+
+  if (arg->rank && arg->expr_type == EXPR_VARIABLE
+      && arg->symtree->n.sym->as != NULL
+      && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref
+      && arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be an "
+		 "assumed-size array", gfc_current_intrinsic_arg[0]->name,
+		 gfc_current_intrinsic, &arg->where);
+      return false;
+    }
+
+  return true;
+}
+
+
+/* Check whether an expression is interoperable.  When returning false,
+   msg is set to a string telling why the expression is not interoperable,
+   otherwise, it is set to NULL.  The msg string can be used in diagnostics.
+   If c_loc is true, character with len > 1 are allowed (cf. Fortran
+   2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
+   arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
+   are permitted. */
+
+static bool
+is_c_interoperable (gfc_expr *expr, const char **msg, bool c_loc, bool c_f_ptr)
+{
+  *msg = NULL;
+
+  if (expr->ts.type == BT_CLASS)
+    {
+      *msg = "Expression is polymorphic";
+      return false;
+    }
+
+  if (expr->ts.type == BT_DERIVED && !expr->ts.u.derived->attr.is_bind_c
+      && !expr->ts.u.derived->ts.is_iso_c)
+    {
+      *msg = "Expression is a noninteroperable derived type";
+      return false;
+    }
+
+  if (expr->ts.type == BT_PROCEDURE)
+    {
+      *msg = "Procedure unexpected as argument";
+      return false;
+    }
+
+  if (gfc_notification_std (GFC_STD_GNU) && expr->ts.type == BT_LOGICAL)
+    {
+      int i;
+      for (i = 0; gfc_logical_kinds[i].kind; i++)
+        if (gfc_logical_kinds[i].kind == expr->ts.kind)
+          return true;
+      *msg = "Extension to use a non-C_Bool-kind LOGICAL";
+      return false;
+    }
+
+  if (gfc_notification_std (GFC_STD_GNU) && expr->ts.type == BT_CHARACTER
+      && expr->ts.kind != 1)
+    {
+      *msg = "Extension to use a non-C_CHAR-kind CHARACTER";
+      return false;
+    }
+
+  if (expr->ts.type == BT_CHARACTER) {
+    if (expr->ts.deferred)
+      {
+	/* TS 29113 allows deferred-length strings as dummy arguments,
+	   but it is not an interoperable type. */
+	*msg = "Expression shall not be a deferred-length string";
+	return false;
+      }
+
+    if (expr->ts.u.cl && expr->ts.u.cl->length
+	&& !gfc_simplify_expr (expr, 0))
+      gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
+
+    if (!c_loc && expr->ts.u.cl
+	&& (!expr->ts.u.cl->length
+	    || expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
+	    || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0))
+      {
+	*msg = "Type shall have a character length of 1";
+	return false;
+      }
+    }
+
+  /* Note: The following checks are about interoperatable variables, Fortran
+     15.3.5/15.3.6.  In intrinsics like C_LOC or in procedure interface, more
+     is allowed, e.g. assumed-shape arrays with TS 29113.  */
+
+  if (gfc_is_coarray (expr))
+    {
+      *msg = "Coarrays are not interoperable";
+      return false;
+    }
+
+  if (!c_loc && expr->rank > 0 && expr->expr_type != EXPR_ARRAY)
+    {
+      gfc_array_ref *ar = gfc_find_array_ref (expr);
+      if (ar->type != AR_FULL)
+	{
+	  *msg = "Only whole-arrays are interoperable";
+	  return false;
+	}
+      if (!c_f_ptr && ar->as->type != AS_EXPLICIT
+	  && ar->as->type != AS_ASSUMED_SIZE)
+	{
+	  *msg = "Only explicit-size and assumed-size arrays are interoperable";
+	  return false;
+	}
+    }
+
+  return true;
+}
+
+
+bool
+gfc_check_c_sizeof (gfc_expr *arg)
+{
+  const char *msg;
+
+  if (!is_c_interoperable (arg, &msg, false, false))
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be an "
+		 "interoperable data entity: %s",
+		 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+		 &arg->where, msg);
+      return false;
+    }
+
+  if (arg->ts.type == BT_ASSUMED)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
+		 "TYPE(*)",
+		 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+		 &arg->where);
+      return false;
+    }
+
+  if (arg->rank && arg->expr_type == EXPR_VARIABLE
+      && arg->symtree->n.sym->as != NULL
+      && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref
+      && arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be an "
+		 "assumed-size array", gfc_current_intrinsic_arg[0]->name,
+		 gfc_current_intrinsic, &arg->where);
+      return false;
+    }
+
+  return true;
+}
+
+
+bool
+gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2)
+{
+  if (c_ptr_1->ts.type != BT_DERIVED
+      || c_ptr_1->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
+      || (c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR
+	  && c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR))
+    {
+      gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
+		 "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1->where);
+      return false;
+    }
+
+  if (!scalar_check (c_ptr_1, 0))
+    return false;
+
+  if (c_ptr_2
+      && (c_ptr_2->ts.type != BT_DERIVED
+	  || c_ptr_2->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
+	  || (c_ptr_1->ts.u.derived->intmod_sym_id
+	      != c_ptr_2->ts.u.derived->intmod_sym_id)))
+    {
+      gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
+		 "same type as C_PTR_1: %s instead of %s", &c_ptr_1->where,
+		 gfc_typename (&c_ptr_1->ts),
+		 gfc_typename (&c_ptr_2->ts));
+      return false;
+    }
+
+  if (c_ptr_2 && !scalar_check (c_ptr_2, 1))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape)
+{
+  symbol_attribute attr;
+  const char *msg;
+
+  if (cptr->ts.type != BT_DERIVED
+      || cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
+      || cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR)
+    {
+      gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
+		 "type TYPE(C_PTR)", &cptr->where);
+      return false;
+    }
+
+  if (!scalar_check (cptr, 0))
+    return false;
+
+  attr = gfc_expr_attr (fptr);
+
+  if (!attr.pointer)
+    {
+      gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
+		 &fptr->where);
+      return false;
+    }
+
+  if (fptr->ts.type == BT_CLASS)
+    {
+      gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
+		 &fptr->where);
+      return false;
+    }
+
+  if (gfc_is_coindexed (fptr))
+    {
+      gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
+		 "coindexed", &fptr->where);
+      return false;
+    }
+
+  if (fptr->rank == 0 && shape)
+    {
+      gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
+		 "FPTR", &fptr->where);
+      return false;
+    }
+  else if (fptr->rank && !shape)
+    {
+      gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
+		 "FPTR at %L", &fptr->where);
+      return false;
+    }
+
+  if (shape && !rank_check (shape, 2, 1))
+    return false;
+
+  if (shape && !type_check (shape, 2, BT_INTEGER))
+    return false;
+
+  if (shape)
+    {
+      mpz_t size;
+      if (gfc_array_size (shape, &size))
+	{
+	  if (mpz_cmp_ui (size, fptr->rank) != 0)
+	    {
+	      mpz_clear (size);
+	      gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
+			"size as the RANK of FPTR", &shape->where);
+	      return false;
+	    }
+	  mpz_clear (size);
+	}
+    }
+
+  if (fptr->ts.type == BT_CLASS)
+    {
+      gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr->where);
+      return false;
+    }
+
+  if (!is_c_interoperable (fptr, &msg, false, true))
+    return gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable array FPTR "
+			   "at %L to C_F_POINTER: %s", &fptr->where, msg);
+
+  return true;
+}
+
+
+bool
+gfc_check_c_f_procpointer (gfc_expr *cptr, gfc_expr *fptr)
+{
+  symbol_attribute attr;
+
+  if (cptr->ts.type != BT_DERIVED
+      || cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
+      || cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR)
+    {
+      gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
+		 "type TYPE(C_FUNPTR)", &cptr->where);
+      return false;
+    }
+
+  if (!scalar_check (cptr, 0))
+    return false;
+
+  attr = gfc_expr_attr (fptr);
+
+  if (!attr.proc_pointer)
+    {
+      gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
+		 "pointer", &fptr->where);
+      return false;
+    }
+
+  if (gfc_is_coindexed (fptr))
+    {
+      gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
+		 "coindexed", &fptr->where);
+      return false;
+    }
+
+  if (!attr.is_bind_c)
+    return gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable procedure "
+			   "pointer at %L to C_F_PROCPOINTER", &fptr->where);
+
+  return true;
+}
+
+
+bool
+gfc_check_c_funloc (gfc_expr *x)
+{
+  symbol_attribute attr;
+
+  if (gfc_is_coindexed (x))
+    {
+      gfc_error ("Argument X at %L to C_FUNLOC shall not be "
+		 "coindexed", &x->where);
+      return false;
+    }
+
+  attr = gfc_expr_attr (x);
+
+  if (attr.function && !attr.proc_pointer && x->expr_type == EXPR_VARIABLE
+      && x->symtree->n.sym == x->symtree->n.sym->result)
+    {
+      gfc_namespace *ns = gfc_current_ns;
+
+      for (ns = gfc_current_ns; ns; ns = ns->parent)
+	if (x->symtree->n.sym == ns->proc_name)
+	  {
+	    gfc_error ("Function result '%s' at %L is invalid as X argument "
+		       "to C_FUNLOC", x->symtree->n.sym->name, &x->where);
+	    return false;
+	  }
+    }
+
+  if (attr.flavor != FL_PROCEDURE)
+    {
+      gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
+		 "or a procedure pointer", &x->where);
+      return false;
+    }
+
+  if (!attr.is_bind_c)
+    return gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable procedure "
+			   "at %L to C_FUNLOC", &x->where);
+  return true;
+}
+
+
+bool
+gfc_check_c_loc (gfc_expr *x)
+{
+  symbol_attribute attr;
+  const char *msg;
+
+  if (gfc_is_coindexed (x))
+    {
+      gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x->where);
+      return false;
+    }
+
+  if (x->ts.type == BT_CLASS)
+    {
+      gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
+		 &x->where);
+      return false;
+    }
+
+  attr = gfc_expr_attr (x);
+
+  if (!attr.pointer
+      && (x->expr_type != EXPR_VARIABLE || !attr.target
+	  || attr.flavor == FL_PARAMETER))
+    {
+      gfc_error ("Argument X at %L to C_LOC shall have either "
+		 "the POINTER or the TARGET attribute", &x->where);
+      return false;
+    }
+
+  if (x->ts.type == BT_CHARACTER
+      && gfc_var_strlen (x) == 0)
+    {
+      gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
+		 "string", &x->where);
+      return false;
+    }
+
+  if (!is_c_interoperable (x, &msg, true, false))
+    {
+      if (x->ts.type == BT_CLASS)
+	{
+	  gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
+		     &x->where);
+	  return false;
+	}
+     
+      if (x->rank
+	  && !gfc_notify_std (GFC_STD_F2008_TS, 
+			      "Noninteroperable array at %L as"
+			      " argument to C_LOC: %s", &x->where, msg))
+	  return false;
+    }
+  else if (x->rank > 0 && gfc_notification_std (GFC_STD_F2008))
+    {
+      gfc_array_ref *ar = gfc_find_array_ref (x);
+
+      if (ar->as->type != AS_EXPLICIT && ar->as->type != AS_ASSUMED_SIZE
+	  && !attr.allocatable
+	  && !gfc_notify_std (GFC_STD_F2008, 
+			      "Array of interoperable type at %L "
+			      "to C_LOC which is nonallocatable and neither "
+			      "assumed size nor explicit size", &x->where))
+	return false;
+      else if (ar->type != AR_FULL
+	       && !gfc_notify_std (GFC_STD_F2008, "Array section at %L "
+				   "to C_LOC", &x->where))
+	return false;
+    }
+
+  return true;
+}
+
+
+bool
+gfc_check_sleep_sub (gfc_expr *seconds)
+{
+  if (!type_check (seconds, 0, BT_INTEGER))
+    return false;
+
+  if (!scalar_check (seconds, 0))
+    return false;
+
+  return true;
+}
+
+bool
+gfc_check_sngl (gfc_expr *a)
+{
+  if (!type_check (a, 0, BT_REAL))
+    return false;
+
+  if ((a->ts.kind != gfc_default_double_kind)
+      && !gfc_notify_std (GFC_STD_GNU, "non double precision "
+			  "REAL argument to %s intrinsic at %L", 
+			  gfc_current_intrinsic, &a->where))
+    return false;
+
+  return true;
+}
+
+bool
+gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
+{
+  if (source->rank >= GFC_MAX_DIMENSIONS)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
+		 "than rank %d", gfc_current_intrinsic_arg[0]->name,
+		 gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
+
+      return false;
+    }
+
+  if (dim == NULL)
+    return false;
+
+  if (!dim_check (dim, 1, false))
+    return false;
+
+  /* dim_rank_check() does not apply here.  */
+  if (dim
+      && dim->expr_type == EXPR_CONSTANT
+      && (mpz_cmp_ui (dim->value.integer, 1) < 0
+	  || mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0))
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid "
+		 "dimension index", gfc_current_intrinsic_arg[1]->name,
+		 gfc_current_intrinsic, &dim->where);
+      return false;
+    }
+
+  if (!type_check (ncopies, 2, BT_INTEGER))
+    return false;
+
+  if (!scalar_check (ncopies, 2))
+    return false;
+
+  return true;
+}
+
+
+/* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
+   functions).  */
+
+bool
+gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
+{
+  if (!type_check (unit, 0, BT_INTEGER))
+    return false;
+
+  if (!scalar_check (unit, 0))
+    return false;
+
+  if (!type_check (c, 1, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (c, 1, gfc_default_character_kind))
+    return false;
+
+  if (status == NULL)
+    return true;
+
+  if (!type_check (status, 2, BT_INTEGER)
+      || !kind_value_check (status, 2, gfc_default_integer_kind)
+      || !scalar_check (status, 2))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
+{
+  return gfc_check_fgetputc_sub (unit, c, NULL);
+}
+
+
+bool
+gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
+{
+  if (!type_check (c, 0, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (c, 0, gfc_default_character_kind))
+    return false;
+
+  if (status == NULL)
+    return true;
+
+  if (!type_check (status, 1, BT_INTEGER)
+      || !kind_value_check (status, 1, gfc_default_integer_kind)
+      || !scalar_check (status, 1))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_fgetput (gfc_expr *c)
+{
+  return gfc_check_fgetput_sub (c, NULL);
+}
+
+
+bool
+gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
+{
+  if (!type_check (unit, 0, BT_INTEGER))
+    return false;
+
+  if (!scalar_check (unit, 0))
+    return false;
+
+  if (!type_check (offset, 1, BT_INTEGER))
+    return false;
+
+  if (!scalar_check (offset, 1))
+    return false;
+
+  if (!type_check (whence, 2, BT_INTEGER))
+    return false;
+
+  if (!scalar_check (whence, 2))
+    return false;
+
+  if (status == NULL)
+    return true;
+
+  if (!type_check (status, 3, BT_INTEGER))
+    return false;
+
+  if (!kind_value_check (status, 3, 4))
+    return false;
+
+  if (!scalar_check (status, 3))
+    return false;
+
+  return true;
+}
+
+
+
+bool
+gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
+{
+  if (!type_check (unit, 0, BT_INTEGER))
+    return false;
+
+  if (!scalar_check (unit, 0))
+    return false;
+
+  if (!type_check (array, 1, BT_INTEGER)
+      || !kind_value_check (unit, 0, gfc_default_integer_kind))
+    return false;
+
+  if (!array_check (array, 1))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
+{
+  if (!type_check (unit, 0, BT_INTEGER))
+    return false;
+
+  if (!scalar_check (unit, 0))
+    return false;
+
+  if (!type_check (array, 1, BT_INTEGER)
+      || !kind_value_check (array, 1, gfc_default_integer_kind))
+    return false;
+
+  if (!array_check (array, 1))
+    return false;
+
+  if (status == NULL)
+    return true;
+
+  if (!type_check (status, 2, BT_INTEGER)
+      || !kind_value_check (status, 2, gfc_default_integer_kind))
+    return false;
+
+  if (!scalar_check (status, 2))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_ftell (gfc_expr *unit)
+{
+  if (!type_check (unit, 0, BT_INTEGER))
+    return false;
+
+  if (!scalar_check (unit, 0))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
+{
+  if (!type_check (unit, 0, BT_INTEGER))
+    return false;
+
+  if (!scalar_check (unit, 0))
+    return false;
+
+  if (!type_check (offset, 1, BT_INTEGER))
+    return false;
+
+  if (!scalar_check (offset, 1))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_stat (gfc_expr *name, gfc_expr *array)
+{
+  if (!type_check (name, 0, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (name, 0, gfc_default_character_kind))
+    return false;
+
+  if (!type_check (array, 1, BT_INTEGER)
+      || !kind_value_check (array, 1, gfc_default_integer_kind))
+    return false;
+
+  if (!array_check (array, 1))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
+{
+  if (!type_check (name, 0, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (name, 0, gfc_default_character_kind))
+    return false;
+
+  if (!type_check (array, 1, BT_INTEGER)
+      || !kind_value_check (array, 1, gfc_default_integer_kind))
+    return false;
+
+  if (!array_check (array, 1))
+    return false;
+
+  if (status == NULL)
+    return true;
+
+  if (!type_check (status, 2, BT_INTEGER)
+      || !kind_value_check (array, 1, gfc_default_integer_kind))
+    return false;
+
+  if (!scalar_check (status, 2))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub)
+{
+  mpz_t nelems;
+
+  if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+    {
+      gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+      return false;
+    }
+
+  if (!coarray_check (coarray, 0))
+    return false;
+
+  if (sub->rank != 1)
+    {
+      gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
+                gfc_current_intrinsic_arg[1]->name, &sub->where);
+      return false;
+    }
+
+  if (gfc_array_size (sub, &nelems))
+    {
+      int corank = gfc_get_corank (coarray);
+
+      if (mpz_cmp_ui (nelems, corank) != 0)
+	{
+	  gfc_error ("The number of array elements of the SUB argument to "
+		     "IMAGE_INDEX at %L shall be %d (corank) not %d",
+		     &sub->where, corank, (int) mpz_get_si (nelems));
+	  mpz_clear (nelems);
+	  return false;
+	}
+      mpz_clear (nelems);
+    }
+
+  return true;
+}
+
+
+bool
+gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim)
+{
+  if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+    {
+      gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+      return false;
+    }
+
+  if (dim != NULL &&  coarray == NULL)
+    {
+      gfc_error ("DIM argument without ARRAY argument not allowed for THIS_IMAGE "
+                "intrinsic at %L", &dim->where);
+      return false;
+    }
+
+  if (coarray == NULL)
+    return true;
+
+  if (!coarray_check (coarray, 0))
+    return false;
+
+  if (dim != NULL)
+    {
+      if (!dim_check (dim, 1, false))
+       return false;
+
+      if (!dim_corank_check (dim, coarray))
+       return false;
+    }
+
+  return true;
+}
+
+/* Calculate the sizes for transfer, used by gfc_check_transfer and also
+   by gfc_simplify_transfer.  Return false if we cannot do so.  */
+
+bool
+gfc_calculate_transfer_sizes (gfc_expr *source, gfc_expr *mold, gfc_expr *size,
+			      size_t *source_size, size_t *result_size,
+			      size_t *result_length_p)
+{
+  size_t result_elt_size;
+
+  if (source->expr_type == EXPR_FUNCTION)
+    return false;
+
+  if (size && size->expr_type != EXPR_CONSTANT)
+    return false;
+
+  /* Calculate the size of the source.  */
+  *source_size = gfc_target_expr_size (source);
+  if (*source_size == 0)
+    return false;
+
+  /* Determine the size of the element.  */
+  result_elt_size = gfc_element_size (mold);
+  if (result_elt_size == 0)
+    return false;
+
+  if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
+    {
+      int result_length;
+
+      if (size)
+	result_length = (size_t)mpz_get_ui (size->value.integer);
+      else
+	{
+	  result_length = *source_size / result_elt_size;
+	  if (result_length * result_elt_size < *source_size)
+	    result_length += 1;
+	}
+
+      *result_size = result_length * result_elt_size;
+      if (result_length_p)
+	*result_length_p = result_length;
+    }
+  else
+    *result_size = result_elt_size;
+
+  return true;
+}
+
+
+bool
+gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
+{
+  size_t source_size;
+  size_t result_size;
+
+  if (mold->ts.type == BT_HOLLERITH)
+    {
+      gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
+		 &mold->where, gfc_basic_typename (BT_HOLLERITH));
+      return false;
+    }
+
+  if (size != NULL)
+    {
+      if (!type_check (size, 2, BT_INTEGER))
+	return false;
+
+      if (!scalar_check (size, 2))
+	return false;
+
+      if (!nonoptional_check (size, 2))
+	return false;
+    }
+
+  if (!gfc_option.warn_surprising)
+    return true;
+
+  /* If we can't calculate the sizes, we cannot check any more.
+     Return true for that case.  */
+
+  if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size, 
+				     &result_size, NULL))
+    return true;
+
+  if (source_size < result_size)
+    gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
+		"source size %ld < result size %ld", &source->where,
+		(long) source_size, (long) result_size);
+
+  return true;
+}
+
+
+bool
+gfc_check_transpose (gfc_expr *matrix)
+{
+  if (!rank_check (matrix, 0, 2))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
+  if (!array_check (array, 0))
+    return false;
+
+  if (!dim_check (dim, 1, false))
+    return false;
+
+  if (!dim_rank_check (dim, array, 0))
+    return false;
+
+  if (!kind_check (kind, 2, BT_INTEGER))
+    return false;
+  if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
+			       "with KIND argument at %L", 
+			       gfc_current_intrinsic, &kind->where))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
+{
+  if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+    {
+      gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+      return false;
+    }
+
+  if (!coarray_check (coarray, 0))
+    return false;
+
+  if (dim != NULL)
+    {
+      if (!dim_check (dim, 1, false))
+        return false;
+
+      if (!dim_corank_check (dim, coarray))
+        return false;
+    }
+
+  if (!kind_check (kind, 2, BT_INTEGER))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
+{
+  mpz_t vector_size;
+
+  if (!rank_check (vector, 0, 1))
+    return false;
+
+  if (!array_check (mask, 1))
+    return false;
+
+  if (!type_check (mask, 1, BT_LOGICAL))
+    return false;
+
+  if (!same_type_check (vector, 0, field, 2))
+    return false;
+
+  if (mask->expr_type == EXPR_ARRAY
+      && gfc_array_size (vector, &vector_size))
+    {
+      int mask_true_count = 0;
+      gfc_constructor *mask_ctor;
+      mask_ctor = gfc_constructor_first (mask->value.constructor);
+      while (mask_ctor)
+	{
+	  if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
+	    {
+	      mask_true_count = 0;
+	      break;
+	    }
+
+	  if (mask_ctor->expr->value.logical)
+	    mask_true_count++;
+
+	  mask_ctor = gfc_constructor_next (mask_ctor);
+	}
+
+      if (mpz_get_si (vector_size) < mask_true_count)
+	{
+	  gfc_error ("'%s' argument of '%s' intrinsic at %L must "
+		     "provide at least as many elements as there "
+		     "are .TRUE. values in '%s' (%ld/%d)",
+		     gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+		     &vector->where, gfc_current_intrinsic_arg[1]->name,
+		     mpz_get_si (vector_size), mask_true_count);
+	  return false;
+	}
+
+      mpz_clear (vector_size);
+    }
+
+  if (mask->rank != field->rank && field->rank != 0)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
+		 "the same rank as '%s' or be a scalar",
+		 gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
+		 &field->where, gfc_current_intrinsic_arg[1]->name);
+      return false;
+    }
+
+  if (mask->rank == field->rank)
+    {
+      int i;
+      for (i = 0; i < field->rank; i++)
+	if (! identical_dimen_shape (mask, i, field, i))
+	{
+	  gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
+		     "must have identical shape.",
+		     gfc_current_intrinsic_arg[2]->name,
+		     gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
+		     &field->where);
+	}
+    }
+
+  return true;
+}
+
+
+bool
+gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
+{
+  if (!type_check (x, 0, BT_CHARACTER))
+    return false;
+
+  if (!same_type_check (x, 0, y, 1))
+    return false;
+
+  if (z != NULL && !type_check (z, 2, BT_LOGICAL))
+    return false;
+
+  if (!kind_check (kind, 3, BT_INTEGER))
+    return false;
+  if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
+			       "with KIND argument at %L", 
+			       gfc_current_intrinsic, &kind->where))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_trim (gfc_expr *x)
+{
+  if (!type_check (x, 0, BT_CHARACTER))
+    return false;
+
+  if (!scalar_check (x, 0))
+    return false;
+
+   return true;
+}
+
+
+bool
+gfc_check_ttynam (gfc_expr *unit)
+{
+  if (!scalar_check (unit, 0))
+    return false;
+
+  if (!type_check (unit, 0, BT_INTEGER))
+    return false;
+
+  return true;
+}
+
+
+/* Common check function for the half a dozen intrinsics that have a
+   single real argument.  */
+
+bool
+gfc_check_x (gfc_expr *x)
+{
+  if (!type_check (x, 0, BT_REAL))
+    return false;
+
+  return true;
+}
+
+
+/************* Check functions for intrinsic subroutines *************/
+
+bool
+gfc_check_cpu_time (gfc_expr *time)
+{
+  if (!scalar_check (time, 0))
+    return false;
+
+  if (!type_check (time, 0, BT_REAL))
+    return false;
+
+  if (!variable_check (time, 0, false))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
+			 gfc_expr *zone, gfc_expr *values)
+{
+  if (date != NULL)
+    {
+      if (!type_check (date, 0, BT_CHARACTER))
+	return false;
+      if (!kind_value_check (date, 0, gfc_default_character_kind))
+	return false;
+      if (!scalar_check (date, 0))
+	return false;
+      if (!variable_check (date, 0, false))
+	return false;
+    }
+
+  if (time != NULL)
+    {
+      if (!type_check (time, 1, BT_CHARACTER))
+	return false;
+      if (!kind_value_check (time, 1, gfc_default_character_kind))
+	return false;
+      if (!scalar_check (time, 1))
+	return false;
+      if (!variable_check (time, 1, false))
+	return false;
+    }
+
+  if (zone != NULL)
+    {
+      if (!type_check (zone, 2, BT_CHARACTER))
+	return false;
+      if (!kind_value_check (zone, 2, gfc_default_character_kind))
+	return false;
+      if (!scalar_check (zone, 2))
+	return false;
+      if (!variable_check (zone, 2, false))
+	return false;
+    }
+
+  if (values != NULL)
+    {
+      if (!type_check (values, 3, BT_INTEGER))
+	return false;
+      if (!array_check (values, 3))
+	return false;
+      if (!rank_check (values, 3, 1))
+	return false;
+      if (!variable_check (values, 3, false))
+	return false;
+    }
+
+  return true;
+}
+
+
+bool
+gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
+		  gfc_expr *to, gfc_expr *topos)
+{
+  if (!type_check (from, 0, BT_INTEGER))
+    return false;
+
+  if (!type_check (frompos, 1, BT_INTEGER))
+    return false;
+
+  if (!type_check (len, 2, BT_INTEGER))
+    return false;
+
+  if (!same_type_check (from, 0, to, 3))
+    return false;
+
+  if (!variable_check (to, 3, false))
+    return false;
+
+  if (!type_check (topos, 4, BT_INTEGER))
+    return false;
+
+  if (!nonnegative_check ("frompos", frompos))
+    return false;
+
+  if (!nonnegative_check ("topos", topos))
+    return false;
+
+  if (!nonnegative_check ("len", len))
+    return false;
+
+  if (!less_than_bitsize2 ("from", from, "frompos", frompos, "len", len))
+    return false;
+
+  if (!less_than_bitsize2 ("to", to, "topos", topos, "len", len))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_random_number (gfc_expr *harvest)
+{
+  if (!type_check (harvest, 0, BT_REAL))
+    return false;
+
+  if (!variable_check (harvest, 0, false))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
+{
+  unsigned int nargs = 0, kiss_size;
+  locus *where = NULL;
+  mpz_t put_size, get_size;
+  bool have_gfc_real_16; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran.  */
+
+  have_gfc_real_16 = gfc_validate_kind (BT_REAL, 16, true) != -1;
+
+  /* Keep the number of bytes in sync with kiss_size in
+     libgfortran/intrinsics/random.c.  */
+  kiss_size = (have_gfc_real_16 ? 48 : 32) / gfc_default_integer_kind;
+
+  if (size != NULL)
+    {
+      if (size->expr_type != EXPR_VARIABLE
+	  || !size->symtree->n.sym->attr.optional)
+	nargs++;
+
+      if (!scalar_check (size, 0))
+	return false;
+
+      if (!type_check (size, 0, BT_INTEGER))
+	return false;
+
+      if (!variable_check (size, 0, false))
+	return false;
+
+      if (!kind_value_check (size, 0, gfc_default_integer_kind))
+	return false;
+    }
+
+  if (put != NULL)
+    {
+      if (put->expr_type != EXPR_VARIABLE
+	  || !put->symtree->n.sym->attr.optional)
+	{
+	  nargs++;
+	  where = &put->where;
+	}
+
+      if (!array_check (put, 1))
+	return false;
+
+      if (!rank_check (put, 1, 1))
+	return false;
+
+      if (!type_check (put, 1, BT_INTEGER))
+	return false;
+
+      if (!kind_value_check (put, 1, gfc_default_integer_kind))
+	return false;
+
+      if (gfc_array_size (put, &put_size)
+	  && mpz_get_ui (put_size) < kiss_size)
+	gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
+		   "too small (%i/%i)",
+		   gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
+		   where, (int) mpz_get_ui (put_size), kiss_size);
+    }
+
+  if (get != NULL)
+    {
+      if (get->expr_type != EXPR_VARIABLE
+	  || !get->symtree->n.sym->attr.optional)
+	{
+	  nargs++;
+	  where = &get->where;
+	}
+
+      if (!array_check (get, 2))
+	return false;
+
+      if (!rank_check (get, 2, 1))
+	return false;
+
+      if (!type_check (get, 2, BT_INTEGER))
+	return false;
+
+      if (!variable_check (get, 2, false))
+	return false;
+
+      if (!kind_value_check (get, 2, gfc_default_integer_kind))
+	return false;
+
+       if (gfc_array_size (get, &get_size)
+ 	  && mpz_get_ui (get_size) < kiss_size)
+	gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
+		   "too small (%i/%i)",
+		   gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
+		   where, (int) mpz_get_ui (get_size), kiss_size);
+    }
+
+  /* RANDOM_SEED may not have more than one non-optional argument.  */
+  if (nargs > 1)
+    gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
+
+  return true;
+}
+
+
+bool
+gfc_check_second_sub (gfc_expr *time)
+{
+  if (!scalar_check (time, 0))
+    return false;
+
+  if (!type_check (time, 0, BT_REAL))
+    return false;
+
+  if (!kind_value_check (time, 0, 4))
+    return false;
+
+  return true;
+}
+
+
+/* The arguments of SYSTEM_CLOCK are scalar, integer variables.  Note,
+   count, count_rate, and count_max are all optional arguments */
+
+bool
+gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
+			gfc_expr *count_max)
+{
+  if (count != NULL)
+    {
+      if (!scalar_check (count, 0))
+	return false;
+
+      if (!type_check (count, 0, BT_INTEGER))
+	return false;
+
+      if (!variable_check (count, 0, false))
+	return false;
+    }
+
+  if (count_rate != NULL)
+    {
+      if (!scalar_check (count_rate, 1))
+	return false;
+
+      if (!type_check (count_rate, 1, BT_INTEGER))
+	return false;
+
+      if (!variable_check (count_rate, 1, false))
+	return false;
+
+      if (count != NULL
+	  && !same_type_check (count, 0, count_rate, 1))
+	return false;
+
+    }
+
+  if (count_max != NULL)
+    {
+      if (!scalar_check (count_max, 2))
+	return false;
+
+      if (!type_check (count_max, 2, BT_INTEGER))
+	return false;
+
+      if (!variable_check (count_max, 2, false))
+	return false;
+
+      if (count != NULL
+	  && !same_type_check (count, 0, count_max, 2))
+	return false;
+
+      if (count_rate != NULL
+	  && !same_type_check (count_rate, 1, count_max, 2))
+	return false;
+    }
+
+  return true;
+}
+
+
+bool
+gfc_check_irand (gfc_expr *x)
+{
+  if (x == NULL)
+    return true;
+
+  if (!scalar_check (x, 0))
+    return false;
+
+  if (!type_check (x, 0, BT_INTEGER))
+    return false;
+
+  if (!kind_value_check (x, 0, 4))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
+{
+  if (!scalar_check (seconds, 0))
+    return false;
+  if (!type_check (seconds, 0, BT_INTEGER))
+    return false;
+
+  if (!int_or_proc_check (handler, 1))
+    return false;
+  if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1))
+    return false;
+
+  if (status == NULL)
+    return true;
+
+  if (!scalar_check (status, 2))
+    return false;
+  if (!type_check (status, 2, BT_INTEGER))
+    return false;
+  if (!kind_value_check (status, 2, gfc_default_integer_kind))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_rand (gfc_expr *x)
+{
+  if (x == NULL)
+    return true;
+
+  if (!scalar_check (x, 0))
+    return false;
+
+  if (!type_check (x, 0, BT_INTEGER))
+    return false;
+
+  if (!kind_value_check (x, 0, 4))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_srand (gfc_expr *x)
+{
+  if (!scalar_check (x, 0))
+    return false;
+
+  if (!type_check (x, 0, BT_INTEGER))
+    return false;
+
+  if (!kind_value_check (x, 0, 4))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
+{
+  if (!scalar_check (time, 0))
+    return false;
+  if (!type_check (time, 0, BT_INTEGER))
+    return false;
+
+  if (!type_check (result, 1, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (result, 1, gfc_default_character_kind))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_dtime_etime (gfc_expr *x)
+{
+  if (!array_check (x, 0))
+    return false;
+
+  if (!rank_check (x, 0, 1))
+    return false;
+
+  if (!variable_check (x, 0, false))
+    return false;
+
+  if (!type_check (x, 0, BT_REAL))
+    return false;
+
+  if (!kind_value_check (x, 0, 4))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time)
+{
+  if (!array_check (values, 0))
+    return false;
+
+  if (!rank_check (values, 0, 1))
+    return false;
+
+  if (!variable_check (values, 0, false))
+    return false;
+
+  if (!type_check (values, 0, BT_REAL))
+    return false;
+
+  if (!kind_value_check (values, 0, 4))
+    return false;
+
+  if (!scalar_check (time, 1))
+    return false;
+
+  if (!type_check (time, 1, BT_REAL))
+    return false;
+
+  if (!kind_value_check (time, 1, 4))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_fdate_sub (gfc_expr *date)
+{
+  if (!type_check (date, 0, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (date, 0, gfc_default_character_kind))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_gerror (gfc_expr *msg)
+{
+  if (!type_check (msg, 0, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (msg, 0, gfc_default_character_kind))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
+{
+  if (!type_check (cwd, 0, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (cwd, 0, gfc_default_character_kind))
+    return false;
+
+  if (status == NULL)
+    return true;
+
+  if (!scalar_check (status, 1))
+    return false;
+
+  if (!type_check (status, 1, BT_INTEGER))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
+{
+  if (!type_check (pos, 0, BT_INTEGER))
+    return false;
+
+  if (pos->ts.kind > gfc_default_integer_kind)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
+		 "not wider than the default kind (%d)",
+		 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+		 &pos->where, gfc_default_integer_kind);
+      return false;
+    }
+
+  if (!type_check (value, 1, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (value, 1, gfc_default_character_kind))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_getlog (gfc_expr *msg)
+{
+  if (!type_check (msg, 0, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (msg, 0, gfc_default_character_kind))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_exit (gfc_expr *status)
+{
+  if (status == NULL)
+    return true;
+
+  if (!type_check (status, 0, BT_INTEGER))
+    return false;
+
+  if (!scalar_check (status, 0))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_flush (gfc_expr *unit)
+{
+  if (unit == NULL)
+    return true;
+
+  if (!type_check (unit, 0, BT_INTEGER))
+    return false;
+
+  if (!scalar_check (unit, 0))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_free (gfc_expr *i)
+{
+  if (!type_check (i, 0, BT_INTEGER))
+    return false;
+
+  if (!scalar_check (i, 0))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_hostnm (gfc_expr *name)
+{
+  if (!type_check (name, 0, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (name, 0, gfc_default_character_kind))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
+{
+  if (!type_check (name, 0, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (name, 0, gfc_default_character_kind))
+    return false;
+
+  if (status == NULL)
+    return true;
+
+  if (!scalar_check (status, 1))
+    return false;
+
+  if (!type_check (status, 1, BT_INTEGER))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_itime_idate (gfc_expr *values)
+{
+  if (!array_check (values, 0))
+    return false;
+
+  if (!rank_check (values, 0, 1))
+    return false;
+
+  if (!variable_check (values, 0, false))
+    return false;
+
+  if (!type_check (values, 0, BT_INTEGER))
+    return false;
+
+  if (!kind_value_check (values, 0, gfc_default_integer_kind))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
+{
+  if (!type_check (time, 0, BT_INTEGER))
+    return false;
+
+  if (!kind_value_check (time, 0, gfc_default_integer_kind))
+    return false;
+
+  if (!scalar_check (time, 0))
+    return false;
+
+  if (!array_check (values, 1))
+    return false;
+
+  if (!rank_check (values, 1, 1))
+    return false;
+
+  if (!variable_check (values, 1, false))
+    return false;
+
+  if (!type_check (values, 1, BT_INTEGER))
+    return false;
+
+  if (!kind_value_check (values, 1, gfc_default_integer_kind))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
+{
+  if (!scalar_check (unit, 0))
+    return false;
+
+  if (!type_check (unit, 0, BT_INTEGER))
+    return false;
+
+  if (!type_check (name, 1, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (name, 1, gfc_default_character_kind))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_isatty (gfc_expr *unit)
+{
+  if (unit == NULL)
+    return false;
+
+  if (!type_check (unit, 0, BT_INTEGER))
+    return false;
+
+  if (!scalar_check (unit, 0))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_isnan (gfc_expr *x)
+{
+  if (!type_check (x, 0, BT_REAL))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_perror (gfc_expr *string)
+{
+  if (!type_check (string, 0, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (string, 0, gfc_default_character_kind))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_umask (gfc_expr *mask)
+{
+  if (!type_check (mask, 0, BT_INTEGER))
+    return false;
+
+  if (!scalar_check (mask, 0))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
+{
+  if (!type_check (mask, 0, BT_INTEGER))
+    return false;
+
+  if (!scalar_check (mask, 0))
+    return false;
+
+  if (old == NULL)
+    return true;
+
+  if (!scalar_check (old, 1))
+    return false;
+
+  if (!type_check (old, 1, BT_INTEGER))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_unlink (gfc_expr *name)
+{
+  if (!type_check (name, 0, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (name, 0, gfc_default_character_kind))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
+{
+  if (!type_check (name, 0, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (name, 0, gfc_default_character_kind))
+    return false;
+
+  if (status == NULL)
+    return true;
+
+  if (!scalar_check (status, 1))
+    return false;
+
+  if (!type_check (status, 1, BT_INTEGER))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_signal (gfc_expr *number, gfc_expr *handler)
+{
+  if (!scalar_check (number, 0))
+    return false;
+  if (!type_check (number, 0, BT_INTEGER))
+    return false;
+
+  if (!int_or_proc_check (handler, 1))
+    return false;
+  if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
+{
+  if (!scalar_check (number, 0))
+    return false;
+  if (!type_check (number, 0, BT_INTEGER))
+    return false;
+
+  if (!int_or_proc_check (handler, 1))
+    return false;
+  if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1))
+    return false;
+
+  if (status == NULL)
+    return true;
+
+  if (!type_check (status, 2, BT_INTEGER))
+    return false;
+  if (!scalar_check (status, 2))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
+{
+  if (!type_check (cmd, 0, BT_CHARACTER))
+    return false;
+  if (!kind_value_check (cmd, 0, gfc_default_character_kind))
+    return false;
+
+  if (!scalar_check (status, 1))
+    return false;
+
+  if (!type_check (status, 1, BT_INTEGER))
+    return false;
+
+  if (!kind_value_check (status, 1, gfc_default_integer_kind))
+    return false;
+
+  return true;
+}
+
+
+/* This is used for the GNU intrinsics AND, OR and XOR.  */
+bool
+gfc_check_and (gfc_expr *i, gfc_expr *j)
+{
+  if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
+		 "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
+		 gfc_current_intrinsic, &i->where);
+      return false;
+    }
+
+  if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
+		 "or LOGICAL", gfc_current_intrinsic_arg[1]->name,
+		 gfc_current_intrinsic, &j->where);
+      return false;
+    }
+
+  if (i->ts.type != j->ts.type)
+    {
+      gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
+		 "have the same type", gfc_current_intrinsic_arg[0]->name,
+		 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
+		 &j->where);
+      return false;
+    }
+
+  if (!scalar_check (i, 0))
+    return false;
+
+  if (!scalar_check (j, 1))
+    return false;
+
+  return true;
+}
+
+
+bool
+gfc_check_storage_size (gfc_expr *a, gfc_expr *kind)
+{
+  if (a->ts.type == BT_ASSUMED)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)",
+		 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+		 &a->where);
+      return false;
+    }
+
+  if (a->ts.type == BT_PROCEDURE)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be a "
+		 "procedure", gfc_current_intrinsic_arg[0]->name,
+		 gfc_current_intrinsic, &a->where);
+      return false;
+    }
+
+  if (kind == NULL)
+    return true;
+
+  if (!type_check (kind, 1, BT_INTEGER))
+    return false;
+
+  if (!scalar_check (kind, 1))
+    return false;
+
+  if (kind->expr_type != EXPR_CONSTANT)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
+		 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
+		 &kind->where);
+      return false;
+    }
+
+  return true;
+}
diff --git a/gcc-4.9/gcc/fortran/class.c b/gcc-4.9/gcc/fortran/class.c
new file mode 100644
index 000000000..d01d7d8c9
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/class.c
@@ -0,0 +1,2806 @@
+/* Implementation of Fortran 2003 Polymorphism.
+   Copyright (C) 2009-2014 Free Software Foundation, Inc.
+   Contributed by Paul Richard Thomas <pault@gcc.gnu.org>
+   and Janus Weil <janus@gcc.gnu.org>
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+
+/* class.c -- This file contains the front end functions needed to service
+              the implementation of Fortran 2003 polymorphism and other
+              object-oriented features.  */
+
+
+/* Outline of the internal representation:
+
+   Each CLASS variable is encapsulated by a class container, which is a
+   structure with two fields:
+    * _data: A pointer to the actual data of the variable. This field has the
+             declared type of the class variable and its attributes
+             (pointer/allocatable/dimension/...).
+    * _vptr: A pointer to the vtable entry (see below) of the dynamic type.
+
+   For each derived type we set up a "vtable" entry, i.e. a structure with the
+   following fields:
+    * _hash:     A hash value serving as a unique identifier for this type.
+    * _size:     The size in bytes of the derived type.
+    * _extends:  A pointer to the vtable entry of the parent derived type.
+    * _def_init: A pointer to a default initialized variable of this type.
+    * _copy:     A procedure pointer to a copying procedure.
+    * _final:    A procedure pointer to a wrapper function, which frees
+		 allocatable components and calls FINAL subroutines.
+
+   After these follow procedure pointer components for the specific
+   type-bound procedures.  */
+
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "gfortran.h"
+#include "constructor.h"
+#include "target-memory.h"
+
+/* Inserts a derived type component reference in a data reference chain.
+    TS: base type of the ref chain so far, in which we will pick the component
+    REF: the address of the GFC_REF pointer to update
+    NAME: name of the component to insert
+   Note that component insertion makes sense only if we are at the end of
+   the chain (*REF == NULL) or if we are adding a missing "_data" component
+   to access the actual contents of a class object.  */
+
+static void
+insert_component_ref (gfc_typespec *ts, gfc_ref **ref, const char * const name)
+{
+  gfc_symbol *type_sym;
+  gfc_ref *new_ref;
+
+  gcc_assert (ts->type == BT_DERIVED || ts->type == BT_CLASS);
+  type_sym = ts->u.derived;
+
+  new_ref = gfc_get_ref ();
+  new_ref->type = REF_COMPONENT;
+  new_ref->next = *ref;
+  new_ref->u.c.sym = type_sym;
+  new_ref->u.c.component = gfc_find_component (type_sym, name, true, true);
+  gcc_assert (new_ref->u.c.component);
+
+  if (new_ref->next)
+    {
+      gfc_ref *next = NULL;
+
+      /* We need to update the base type in the trailing reference chain to
+	 that of the new component.  */
+
+      gcc_assert (strcmp (name, "_data") == 0);
+
+      if (new_ref->next->type == REF_COMPONENT)
+	next = new_ref->next;
+      else if (new_ref->next->type == REF_ARRAY
+	       && new_ref->next->next
+	       && new_ref->next->next->type == REF_COMPONENT)
+	next = new_ref->next->next;
+
+      if (next != NULL)
+	{
+	  gcc_assert (new_ref->u.c.component->ts.type == BT_CLASS
+		      || new_ref->u.c.component->ts.type == BT_DERIVED);
+	  next->u.c.sym = new_ref->u.c.component->ts.u.derived;
+	}
+    }
+
+  *ref = new_ref;
+}
+
+
+/* Tells whether we need to add a "_data" reference to access REF subobject
+   from an object of type TS.  If FIRST_REF_IN_CHAIN is set, then the base
+   object accessed by REF is a variable; in other words it is a full object,
+   not a subobject.  */
+
+static bool
+class_data_ref_missing (gfc_typespec *ts, gfc_ref *ref, bool first_ref_in_chain)
+{
+  /* Only class containers may need the "_data" reference.  */
+  if (ts->type != BT_CLASS)
+    return false;
+
+  /* Accessing a class container with an array reference is certainly wrong.  */
+  if (ref->type != REF_COMPONENT)
+    return true;
+
+  /* Accessing the class container's fields is fine.  */
+  if (ref->u.c.component->name[0] == '_')
+    return false;
+
+  /* At this point we have a class container with a non class container's field
+     component reference.  We don't want to add the "_data" component if we are
+     at the first reference and the symbol's type is an extended derived type.
+     In that case, conv_parent_component_references will do the right thing so
+     it is not absolutely necessary.  Omitting it prevents a regression (see
+     class_41.f03) in the interface mapping mechanism.  When evaluating string
+     lengths depending on dummy arguments, we create a fake symbol with a type
+     equal to that of the dummy type.  However, because of type extension,
+     the backend type (corresponding to the actual argument) can have a
+     different (extended) type.  Adding the "_data" component explicitly, using
+     the base type, confuses the gfc_conv_component_ref code which deals with
+     the extended type.  */
+  if (first_ref_in_chain && ts->u.derived->attr.extension)
+    return false;
+
+  /* We have a class container with a non class container's field component
+     reference that doesn't fall into the above.  */
+  return true;
+}
+
+
+/* Browse through a data reference chain and add the missing "_data" references
+   when a subobject of a class object is accessed without it.
+   Note that it doesn't add the "_data" reference when the class container
+   is the last element in the reference chain.  */
+
+void
+gfc_fix_class_refs (gfc_expr *e)
+{
+  gfc_typespec *ts;
+  gfc_ref **ref;
+
+  if ((e->expr_type != EXPR_VARIABLE
+       && e->expr_type != EXPR_FUNCTION)
+      || (e->expr_type == EXPR_FUNCTION
+	  && e->value.function.isym != NULL))
+    return;
+
+  if (e->expr_type == EXPR_VARIABLE)
+    ts = &e->symtree->n.sym->ts;
+  else
+    {
+      gfc_symbol *func;
+
+      gcc_assert (e->expr_type == EXPR_FUNCTION);
+      if (e->value.function.esym != NULL)
+	func = e->value.function.esym;
+      else
+	func = e->symtree->n.sym;
+
+      if (func->result != NULL)
+	ts = &func->result->ts;
+      else
+	ts = &func->ts;
+    }
+
+  for (ref = &e->ref; *ref != NULL; ref = &(*ref)->next)
+    {
+      if (class_data_ref_missing (ts, *ref, ref == &e->ref))
+	insert_component_ref (ts, ref, "_data");
+
+      if ((*ref)->type == REF_COMPONENT)
+	ts = &(*ref)->u.c.component->ts;
+    }
+}
+
+
+/* Insert a reference to the component of the given name.
+   Only to be used with CLASS containers and vtables.  */
+
+void
+gfc_add_component_ref (gfc_expr *e, const char *name)
+{
+  gfc_ref **tail = &(e->ref);
+  gfc_ref *next = NULL;
+  gfc_symbol *derived = e->symtree->n.sym->ts.u.derived;
+  while (*tail != NULL)
+    {
+      if ((*tail)->type == REF_COMPONENT)
+	{
+	  if (strcmp ((*tail)->u.c.component->name, "_data") == 0
+		&& (*tail)->next
+		&& (*tail)->next->type == REF_ARRAY
+		&& (*tail)->next->next == NULL)
+	    return;
+	  derived = (*tail)->u.c.component->ts.u.derived;
+	}
+      if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL)
+	break;
+      tail = &((*tail)->next);
+    }
+  if (derived->components->next->ts.type == BT_DERIVED &&
+      derived->components->next->ts.u.derived == NULL)
+    {
+      /* Fix up missing vtype.  */
+      gfc_symbol *vtab = gfc_find_derived_vtab (derived->components->ts.u.derived);
+      gcc_assert (vtab);
+      derived->components->next->ts.u.derived = vtab->ts.u.derived;
+    }
+  if (*tail != NULL && strcmp (name, "_data") == 0)
+    next = *tail;
+  (*tail) = gfc_get_ref();
+  (*tail)->next = next;
+  (*tail)->type = REF_COMPONENT;
+  (*tail)->u.c.sym = derived;
+  (*tail)->u.c.component = gfc_find_component (derived, name, true, true);
+  gcc_assert((*tail)->u.c.component);
+  if (!next)
+    e->ts = (*tail)->u.c.component->ts;
+}
+
+
+/* This is used to add both the _data component reference and an array
+   reference to class expressions.  Used in translation of intrinsic
+   array inquiry functions.  */
+
+void
+gfc_add_class_array_ref (gfc_expr *e)
+{
+  int rank = CLASS_DATA (e)->as->rank;
+  gfc_array_spec *as = CLASS_DATA (e)->as;
+  gfc_ref *ref = NULL;
+  gfc_add_component_ref (e, "_data");
+  e->rank = rank;
+  for (ref = e->ref; ref; ref = ref->next)
+    if (!ref->next)
+      break;
+  if (ref->type != REF_ARRAY)
+    {
+      ref->next = gfc_get_ref ();
+      ref = ref->next;
+      ref->type = REF_ARRAY;
+      ref->u.ar.type = AR_FULL;
+      ref->u.ar.as = as;
+    }
+}
+
+
+/* Unfortunately, class array expressions can appear in various conditions;
+   with and without both _data component and an arrayspec.  This function
+   deals with that variability.  The previous reference to 'ref' is to a
+   class array.  */
+
+static bool
+class_array_ref_detected (gfc_ref *ref, bool *full_array)
+{
+  bool no_data = false;
+  bool with_data = false;
+
+  /* An array reference with no _data component.  */
+  if (ref && ref->type == REF_ARRAY
+	&& !ref->next
+	&& ref->u.ar.type != AR_ELEMENT)
+    {
+      if (full_array)
+        *full_array = ref->u.ar.type == AR_FULL;
+      no_data = true;
+    }
+
+  /* Cover cases where _data appears, with or without an array ref.  */
+  if (ref && ref->type == REF_COMPONENT
+	&& strcmp (ref->u.c.component->name, "_data") == 0)
+    {
+      if (!ref->next)
+	{
+	  with_data = true;
+	  if (full_array)
+	    *full_array = true;
+	}
+      else if (ref->next && ref->next->type == REF_ARRAY
+	    && !ref->next->next
+	    && ref->type == REF_COMPONENT
+	    && ref->next->type == REF_ARRAY
+	    && ref->next->u.ar.type != AR_ELEMENT)
+	{
+	  with_data = true;
+	  if (full_array)
+	    *full_array = ref->next->u.ar.type == AR_FULL;
+	}
+    }
+
+  return no_data || with_data;
+}
+
+
+/* Returns true if the expression contains a reference to a class
+   array.  Notice that class array elements return false.  */
+
+bool
+gfc_is_class_array_ref (gfc_expr *e, bool *full_array)
+{
+  gfc_ref *ref;
+
+  if (!e->rank)
+    return false;
+
+  if (full_array)
+    *full_array= false;
+
+  /* Is this a class array object? ie. Is the symbol of type class?  */
+  if (e->symtree
+	&& e->symtree->n.sym->ts.type == BT_CLASS
+	&& CLASS_DATA (e->symtree->n.sym)
+	&& CLASS_DATA (e->symtree->n.sym)->attr.dimension
+	&& class_array_ref_detected (e->ref, full_array))
+    return true;
+
+  /* Or is this a class array component reference?  */
+  for (ref = e->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_COMPONENT
+	    && ref->u.c.component->ts.type == BT_CLASS
+	    && CLASS_DATA (ref->u.c.component)->attr.dimension
+	    && class_array_ref_detected (ref->next, full_array))
+	return true;
+    }
+
+  return false;
+}
+
+
+/* Returns true if the expression is a reference to a class
+   scalar.  This function is necessary because such expressions
+   can be dressed with a reference to the _data component and so
+   have a type other than BT_CLASS.  */
+
+bool
+gfc_is_class_scalar_expr (gfc_expr *e)
+{
+  gfc_ref *ref;
+
+  if (e->rank)
+    return false;
+
+  /* Is this a class object?  */
+  if (e->symtree
+	&& e->symtree->n.sym->ts.type == BT_CLASS
+	&& CLASS_DATA (e->symtree->n.sym)
+	&& !CLASS_DATA (e->symtree->n.sym)->attr.dimension
+	&& (e->ref == NULL
+	    || (strcmp (e->ref->u.c.component->name, "_data") == 0
+		&& e->ref->next == NULL)))
+    return true;
+
+  /* Or is the final reference BT_CLASS or _data?  */
+  for (ref = e->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_COMPONENT
+	    && ref->u.c.component->ts.type == BT_CLASS
+	    && CLASS_DATA (ref->u.c.component)
+	    && !CLASS_DATA (ref->u.c.component)->attr.dimension
+	    && (ref->next == NULL
+		|| (strcmp (ref->next->u.c.component->name, "_data") == 0
+		    && ref->next->next == NULL)))
+	return true;
+    }
+
+  return false;
+}
+
+
+/* Tells whether the expression E is a reference to a (scalar) class container.
+   Scalar because array class containers usually have an array reference after
+   them, and gfc_fix_class_refs will add the missing "_data" component reference
+   in that case.  */
+
+bool
+gfc_is_class_container_ref (gfc_expr *e)
+{
+  gfc_ref *ref;
+  bool result;
+
+  if (e->expr_type != EXPR_VARIABLE)
+    return e->ts.type == BT_CLASS;
+
+  if (e->symtree->n.sym->ts.type == BT_CLASS)
+    result = true;
+  else
+    result = false;
+
+  for (ref = e->ref; ref; ref = ref->next)
+    {
+      if (ref->type != REF_COMPONENT)
+	result = false;
+      else if (ref->u.c.component->ts.type == BT_CLASS)
+	result = true;
+      else
+	result = false;
+    }
+
+  return result;
+}
+
+
+/* Build an initializer for CLASS pointers,
+   initializing the _data component to the init_expr (or NULL) and the _vptr
+   component to the corresponding type (or the declared type, given by ts).  */
+
+gfc_expr *
+gfc_class_initializer (gfc_typespec *ts, gfc_expr *init_expr)
+{
+  gfc_expr *init;
+  gfc_component *comp;
+  gfc_symbol *vtab = NULL;
+
+  if (init_expr && init_expr->expr_type != EXPR_NULL)
+    vtab = gfc_find_vtab (&init_expr->ts);
+  else
+    vtab = gfc_find_vtab (ts);
+
+  init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
+					     &ts->u.derived->declared_at);
+  init->ts = *ts;
+
+  for (comp = ts->u.derived->components; comp; comp = comp->next)
+    {
+      gfc_constructor *ctor = gfc_constructor_get();
+      if (strcmp (comp->name, "_vptr") == 0 && vtab)
+	ctor->expr = gfc_lval_expr_from_sym (vtab);
+      else if (init_expr && init_expr->expr_type != EXPR_NULL)
+	  ctor->expr = gfc_copy_expr (init_expr);
+      else
+	ctor->expr = gfc_get_null_expr (NULL);
+      gfc_constructor_append (&init->value.constructor, ctor);
+    }
+
+  return init;
+}
+
+
+/* Create a unique string identifier for a derived type, composed of its name
+   and module name. This is used to construct unique names for the class
+   containers and vtab symbols.  */
+
+static void
+get_unique_type_string (char *string, gfc_symbol *derived)
+{
+  char dt_name[GFC_MAX_SYMBOL_LEN+1];
+  if (derived->attr.unlimited_polymorphic)
+    strcpy (dt_name, "STAR");
+  else
+    strcpy (dt_name, derived->name);
+  dt_name[0] = TOUPPER (dt_name[0]);
+  if (derived->attr.unlimited_polymorphic)
+    sprintf (string, "_%s", dt_name);
+  else if (derived->module)
+    sprintf (string, "%s_%s", derived->module, dt_name);
+  else if (derived->ns->proc_name)
+    sprintf (string, "%s_%s", derived->ns->proc_name->name, dt_name);
+  else
+    sprintf (string, "_%s", dt_name);
+}
+
+
+/* A relative of 'get_unique_type_string' which makes sure the generated
+   string will not be too long (replacing it by a hash string if needed).  */
+
+static void
+get_unique_hashed_string (char *string, gfc_symbol *derived)
+{
+  char tmp[2*GFC_MAX_SYMBOL_LEN+2];
+  get_unique_type_string (&tmp[0], derived);
+  /* If string is too long, use hash value in hex representation (allow for
+     extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab).
+     We need space to for 15 characters "__class_" + symbol name + "_%d_%da",
+     where %d is the (co)rank which can be up to n = 15.  */
+  if (strlen (tmp) > GFC_MAX_SYMBOL_LEN - 15)
+    {
+      int h = gfc_hash_value (derived);
+      sprintf (string, "%X", h);
+    }
+  else
+    strcpy (string, tmp);
+}
+
+
+/* Assign a hash value for a derived type. The algorithm is that of SDBM.  */
+
+unsigned int
+gfc_hash_value (gfc_symbol *sym)
+{
+  unsigned int hash = 0;
+  char c[2*(GFC_MAX_SYMBOL_LEN+1)];
+  int i, len;
+
+  get_unique_type_string (&c[0], sym);
+  len = strlen (c);
+
+  for (i = 0; i < len; i++)
+    hash = (hash << 6) + (hash << 16) - hash + c[i];
+
+  /* Return the hash but take the modulus for the sake of module read,
+     even though this slightly increases the chance of collision.  */
+  return (hash % 100000000);
+}
+
+
+/* Assign a hash value for an intrinsic type. The algorithm is that of SDBM.  */
+
+unsigned int
+gfc_intrinsic_hash_value (gfc_typespec *ts)
+{
+  unsigned int hash = 0;
+  const char *c = gfc_typename (ts);
+  int i, len;
+
+  len = strlen (c);
+
+  for (i = 0; i < len; i++)
+    hash = (hash << 6) + (hash << 16) - hash + c[i];
+
+  /* Return the hash but take the modulus for the sake of module read,
+     even though this slightly increases the chance of collision.  */
+  return (hash % 100000000);
+}
+
+
+/* Build a polymorphic CLASS entity, using the symbol that comes from
+   build_sym. A CLASS entity is represented by an encapsulating type,
+   which contains the declared type as '_data' component, plus a pointer
+   component '_vptr' which determines the dynamic type.  */
+
+bool
+gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
+			gfc_array_spec **as)
+{
+  char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
+  gfc_symbol *fclass;
+  gfc_symbol *vtab;
+  gfc_component *c;
+  gfc_namespace *ns;
+  int rank;
+
+  gcc_assert (as);
+
+  if (*as && (*as)->type == AS_ASSUMED_SIZE)
+    {
+      gfc_error ("Assumed size polymorphic objects or components, such "
+		 "as that at %C, have not yet been implemented");
+      return false;
+    }
+
+  if (attr->class_ok)
+    /* Class container has already been built.  */
+    return true;
+
+  attr->class_ok = attr->dummy || attr->pointer || attr->allocatable
+		   || attr->select_type_temporary || attr->associate_var;
+
+  if (!attr->class_ok)
+    /* We can not build the class container yet.  */
+    return true;
+
+  /* Determine the name of the encapsulating type.  */
+  rank = !(*as) || (*as)->rank == -1 ? GFC_MAX_DIMENSIONS : (*as)->rank;
+  get_unique_hashed_string (tname, ts->u.derived);
+  if ((*as) && attr->allocatable)
+    sprintf (name, "__class_%s_%d_%da", tname, rank, (*as)->corank);
+  else if ((*as) && attr->pointer)
+    sprintf (name, "__class_%s_%d_%dp", tname, rank, (*as)->corank);
+  else if ((*as))
+    sprintf (name, "__class_%s_%d_%d", tname, rank, (*as)->corank);
+  else if (attr->pointer)
+    sprintf (name, "__class_%s_p", tname);
+  else if (attr->allocatable)
+    sprintf (name, "__class_%s_a", tname);
+  else
+    sprintf (name, "__class_%s", tname);
+
+  if (ts->u.derived->attr.unlimited_polymorphic)
+    {
+      /* Find the top-level namespace.  */
+      for (ns = gfc_current_ns; ns; ns = ns->parent)
+	if (!ns->parent)
+	  break;
+    }
+  else
+    ns = ts->u.derived->ns;
+
+  gfc_find_symbol (name, ns, 0, &fclass);
+  if (fclass == NULL)
+    {
+      gfc_symtree *st;
+      /* If not there, create a new symbol.  */
+      fclass = gfc_new_symbol (name, ns);
+      st = gfc_new_symtree (&ns->sym_root, name);
+      st->n.sym = fclass;
+      gfc_set_sym_referenced (fclass);
+      fclass->refs++;
+      fclass->ts.type = BT_UNKNOWN;
+      if (!ts->u.derived->attr.unlimited_polymorphic)
+	fclass->attr.abstract = ts->u.derived->attr.abstract;
+      fclass->f2k_derived = gfc_get_namespace (NULL, 0);
+      if (!gfc_add_flavor (&fclass->attr, FL_DERIVED, NULL,
+			   &gfc_current_locus))
+	return false;
+
+      /* Add component '_data'.  */
+      if (!gfc_add_component (fclass, "_data", &c))
+	return false;
+      c->ts = *ts;
+      c->ts.type = BT_DERIVED;
+      c->attr.access = ACCESS_PRIVATE;
+      c->ts.u.derived = ts->u.derived;
+      c->attr.class_pointer = attr->pointer;
+      c->attr.pointer = attr->pointer || (attr->dummy && !attr->allocatable)
+			|| attr->select_type_temporary;
+      c->attr.allocatable = attr->allocatable;
+      c->attr.dimension = attr->dimension;
+      c->attr.codimension = attr->codimension;
+      c->attr.abstract = fclass->attr.abstract;
+      c->as = (*as);
+      c->initializer = NULL;
+
+      /* Add component '_vptr'.  */
+      if (!gfc_add_component (fclass, "_vptr", &c))
+	return false;
+      c->ts.type = BT_DERIVED;
+
+      if (ts->u.derived->attr.unlimited_polymorphic)
+	{
+	  vtab = gfc_find_derived_vtab (ts->u.derived);
+	  gcc_assert (vtab);
+	  c->ts.u.derived = vtab->ts.u.derived;
+	}
+      else
+	/* Build vtab later.  */
+	c->ts.u.derived = NULL;
+
+      c->attr.access = ACCESS_PRIVATE;
+      c->attr.pointer = 1;
+    }
+
+  if (!ts->u.derived->attr.unlimited_polymorphic)
+    {
+      /* Since the extension field is 8 bit wide, we can only have
+	 up to 255 extension levels.  */
+      if (ts->u.derived->attr.extension == 255)
+	{
+	  gfc_error ("Maximum extension level reached with type '%s' at %L",
+		     ts->u.derived->name, &ts->u.derived->declared_at);
+	return false;
+	}
+
+      fclass->attr.extension = ts->u.derived->attr.extension + 1;
+      fclass->attr.alloc_comp = ts->u.derived->attr.alloc_comp;
+      fclass->attr.coarray_comp = ts->u.derived->attr.coarray_comp;
+    }
+
+  fclass->attr.is_class = 1;
+  ts->u.derived = fclass;
+  attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0;
+  (*as) = NULL;
+  return true;
+}
+
+
+/* Add a procedure pointer component to the vtype
+   to represent a specific type-bound procedure.  */
+
+static void
+add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb)
+{
+  gfc_component *c;
+
+  if (tb->non_overridable)
+    return;
+
+  c = gfc_find_component (vtype, name, true, true);
+
+  if (c == NULL)
+    {
+      /* Add procedure component.  */
+      if (!gfc_add_component (vtype, name, &c))
+	return;
+
+      if (!c->tb)
+	c->tb = XCNEW (gfc_typebound_proc);
+      *c->tb = *tb;
+      c->tb->ppc = 1;
+      c->attr.procedure = 1;
+      c->attr.proc_pointer = 1;
+      c->attr.flavor = FL_PROCEDURE;
+      c->attr.access = ACCESS_PRIVATE;
+      c->attr.external = 1;
+      c->attr.untyped = 1;
+      c->attr.if_source = IFSRC_IFBODY;
+    }
+  else if (c->attr.proc_pointer && c->tb)
+    {
+      *c->tb = *tb;
+      c->tb->ppc = 1;
+    }
+
+  if (tb->u.specific)
+    {
+      gfc_symbol *ifc = tb->u.specific->n.sym;
+      c->ts.interface = ifc;
+      if (!tb->deferred)
+	c->initializer = gfc_get_variable_expr (tb->u.specific);
+      c->attr.pure = ifc->attr.pure;
+    }
+}
+
+
+/* Add all specific type-bound procedures in the symtree 'st' to a vtype.  */
+
+static void
+add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype)
+{
+  if (!st)
+    return;
+
+  if (st->left)
+    add_procs_to_declared_vtab1 (st->left, vtype);
+
+  if (st->right)
+    add_procs_to_declared_vtab1 (st->right, vtype);
+
+  if (st->n.tb && !st->n.tb->error
+      && !st->n.tb->is_generic && st->n.tb->u.specific)
+    add_proc_comp (vtype, st->name, st->n.tb);
+}
+
+
+/* Copy procedure pointers components from the parent type.  */
+
+static void
+copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype)
+{
+  gfc_component *cmp;
+  gfc_symbol *vtab;
+
+  vtab = gfc_find_derived_vtab (declared);
+
+  for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next)
+    {
+      if (gfc_find_component (vtype, cmp->name, true, true))
+	continue;
+
+      add_proc_comp (vtype, cmp->name, cmp->tb);
+    }
+}
+
+
+/* Returns true if any of its nonpointer nonallocatable components or
+   their nonpointer nonallocatable subcomponents has a finalization
+   subroutine.  */
+
+static bool
+has_finalizer_component (gfc_symbol *derived)
+{
+   gfc_component *c;
+
+  for (c = derived->components; c; c = c->next)
+    {
+      if (c->ts.type == BT_DERIVED && c->ts.u.derived->f2k_derived
+	  && c->ts.u.derived->f2k_derived->finalizers)
+	return true;
+
+      if (c->ts.type == BT_DERIVED
+	  && !c->attr.pointer && !c->attr.allocatable
+	  && has_finalizer_component (c->ts.u.derived))
+	return true;
+    }
+  return false;
+}
+
+
+static bool
+comp_is_finalizable (gfc_component *comp)
+{
+  if (comp->attr.proc_pointer)
+    return false;
+  else if (comp->attr.allocatable && comp->ts.type != BT_CLASS)
+    return true;
+  else if (comp->ts.type == BT_DERIVED && !comp->attr.pointer
+	   && (comp->ts.u.derived->attr.alloc_comp
+	       || has_finalizer_component (comp->ts.u.derived)
+	       || (comp->ts.u.derived->f2k_derived
+		   && comp->ts.u.derived->f2k_derived->finalizers)))
+    return true;
+  else if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
+	    && CLASS_DATA (comp)->attr.allocatable)
+    return true;
+  else
+    return false;
+}
+
+
+/* Call DEALLOCATE for the passed component if it is allocatable, if it is
+   neither allocatable nor a pointer but has a finalizer, call it. If it
+   is a nonpointer component with allocatable components or has finalizers, walk
+   them. Either of them is required; other nonallocatables and pointers aren't
+   handled gracefully.
+   Note: If the component is allocatable, the DEALLOCATE handling takes care
+   of calling the appropriate finalizers, coarray deregistering, and
+   deallocation of allocatable subcomponents.  */
+
+static void
+finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
+		    gfc_symbol *stat, gfc_symbol *fini_coarray, gfc_code **code)
+{
+  gfc_expr *e;
+  gfc_ref *ref;
+
+  if (!comp_is_finalizable (comp))
+    return;
+
+  e = gfc_copy_expr (expr);
+  if (!e->ref)
+    e->ref = ref = gfc_get_ref ();
+  else
+    {
+      for (ref = e->ref; ref->next; ref = ref->next)
+	;
+      ref->next = gfc_get_ref ();
+      ref = ref->next;
+    }
+  ref->type = REF_COMPONENT;
+  ref->u.c.sym = derived;
+  ref->u.c.component = comp;
+  e->ts = comp->ts;
+
+  if (comp->attr.dimension || comp->attr.codimension
+      || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
+	  && (CLASS_DATA (comp)->attr.dimension
+	      || CLASS_DATA (comp)->attr.codimension)))
+    {
+      ref->next = gfc_get_ref ();
+      ref->next->type = REF_ARRAY;
+      ref->next->u.ar.dimen = 0;
+      ref->next->u.ar.as = comp->ts.type == BT_CLASS ? CLASS_DATA (comp)->as
+							: comp->as;
+      e->rank = ref->next->u.ar.as->rank;
+      ref->next->u.ar.type = e->rank ? AR_FULL : AR_ELEMENT;
+    }
+
+  /* Call DEALLOCATE (comp, stat=ignore).  */
+  if (comp->attr.allocatable
+      || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
+	  && CLASS_DATA (comp)->attr.allocatable))
+    {
+      gfc_code *dealloc, *block = NULL;
+
+      /* Add IF (fini_coarray).  */
+      if (comp->attr.codimension
+	  || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
+	      && CLASS_DATA (comp)->attr.allocatable))
+	{
+	  block = gfc_get_code (EXEC_IF);
+	  if (*code)
+	    {
+	      (*code)->next = block;
+	      (*code) = (*code)->next;
+	    }
+	  else
+	      (*code) = block;
+
+	  block->block = gfc_get_code (EXEC_IF);
+	  block = block->block;
+	  block->expr1 = gfc_lval_expr_from_sym (fini_coarray);
+	}
+
+      dealloc = gfc_get_code (EXEC_DEALLOCATE);
+
+      dealloc->ext.alloc.list = gfc_get_alloc ();
+      dealloc->ext.alloc.list->expr = e;
+      dealloc->expr1 = gfc_lval_expr_from_sym (stat);
+
+      if (block)
+	block->next = dealloc;
+      else if (*code)
+	{
+	  (*code)->next = dealloc;
+	  (*code) = (*code)->next;
+	}
+      else
+	(*code) = dealloc;
+    }
+  else if (comp->ts.type == BT_DERIVED
+	    && comp->ts.u.derived->f2k_derived
+	    && comp->ts.u.derived->f2k_derived->finalizers)
+    {
+      /* Call FINAL_WRAPPER (comp);  */
+      gfc_code *final_wrap;
+      gfc_symbol *vtab;
+      gfc_component *c;
+
+      vtab = gfc_find_derived_vtab (comp->ts.u.derived);
+      for (c = vtab->ts.u.derived->components; c; c = c->next)
+	if (strcmp (c->name, "_final") == 0)
+	  break;
+
+      gcc_assert (c);
+      final_wrap = gfc_get_code (EXEC_CALL);
+      final_wrap->symtree = c->initializer->symtree;
+      final_wrap->resolved_sym = c->initializer->symtree->n.sym;
+      final_wrap->ext.actual = gfc_get_actual_arglist ();
+      final_wrap->ext.actual->expr = e;
+
+      if (*code)
+	{
+	  (*code)->next = final_wrap;
+	  (*code) = (*code)->next;
+	}
+      else
+	(*code) = final_wrap;
+    }
+  else
+    {
+      gfc_component *c;
+
+      for (c = comp->ts.u.derived->components; c; c = c->next)
+	finalize_component (e, comp->ts.u.derived, c, stat, fini_coarray, code);
+      gfc_free_expr (e);
+    }
+}
+
+
+/* Generate code equivalent to
+   CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
+		     + offset, c_ptr), ptr).  */
+
+static gfc_code *
+finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr,
+			 gfc_expr *offset, gfc_namespace *sub_ns)
+{
+  gfc_code *block;
+  gfc_expr *expr, *expr2;
+
+  /* C_F_POINTER().  */
+  block = gfc_get_code (EXEC_CALL);
+  gfc_get_sym_tree ("c_f_pointer", sub_ns, &block->symtree, true);
+  block->resolved_sym = block->symtree->n.sym;
+  block->resolved_sym->attr.flavor = FL_PROCEDURE;
+  block->resolved_sym->attr.intrinsic = 1;
+  block->resolved_sym->attr.subroutine = 1;
+  block->resolved_sym->from_intmod = INTMOD_ISO_C_BINDING;
+  block->resolved_sym->intmod_sym_id = ISOCBINDING_F_POINTER;
+  block->resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_C_F_POINTER);
+  gfc_commit_symbol (block->resolved_sym);
+
+  /* C_F_POINTER's first argument: TRANSFER ( <addr>, c_intptr_t).  */
+  block->ext.actual = gfc_get_actual_arglist ();
+  block->ext.actual->next = gfc_get_actual_arglist ();
+  block->ext.actual->next->expr = gfc_get_int_expr (gfc_index_integer_kind,
+						    NULL, 0);
+  block->ext.actual->next->next = gfc_get_actual_arglist (); /* SIZE. */
+
+  /* The <addr> part: TRANSFER (C_LOC (array), c_intptr_t).  */
+
+  /* TRANSFER's first argument: C_LOC (array).  */
+  expr = gfc_get_expr ();
+  expr->expr_type = EXPR_FUNCTION;
+  gfc_get_sym_tree ("c_loc", sub_ns, &expr->symtree, false);
+  expr->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+  expr->symtree->n.sym->intmod_sym_id = ISOCBINDING_LOC;
+  expr->symtree->n.sym->attr.intrinsic = 1;
+  expr->symtree->n.sym->from_intmod = INTMOD_ISO_C_BINDING;
+  expr->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_C_LOC);
+  expr->value.function.actual = gfc_get_actual_arglist ();
+  expr->value.function.actual->expr
+	    = gfc_lval_expr_from_sym (array);
+  expr->symtree->n.sym->result = expr->symtree->n.sym;
+  gfc_commit_symbol (expr->symtree->n.sym);
+  expr->ts.type = BT_INTEGER;
+  expr->ts.kind = gfc_index_integer_kind;
+
+  /* TRANSFER.  */
+  expr2 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_TRANSFER, "transfer",
+				    gfc_current_locus, 3, expr,
+				    gfc_get_int_expr (gfc_index_integer_kind,
+						      NULL, 0), NULL);
+  expr2->ts.type = BT_INTEGER;
+  expr2->ts.kind = gfc_index_integer_kind;
+
+  /* <array addr> + <offset>.  */
+  block->ext.actual->expr = gfc_get_expr ();
+  block->ext.actual->expr->expr_type = EXPR_OP;
+  block->ext.actual->expr->value.op.op = INTRINSIC_PLUS;
+  block->ext.actual->expr->value.op.op1 = expr2;
+  block->ext.actual->expr->value.op.op2 = offset;
+  block->ext.actual->expr->ts = expr->ts;
+
+  /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=.  */
+  block->ext.actual->next = gfc_get_actual_arglist ();
+  block->ext.actual->next->expr = gfc_lval_expr_from_sym (ptr);
+  block->ext.actual->next->next = gfc_get_actual_arglist ();
+
+  return block;
+}
+
+
+/* Calculates the offset to the (idx+1)th element of an array, taking the
+   stride into account. It generates the code:
+     offset = 0
+     do idx2 = 1, rank
+       offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1) * strides(idx2)
+     end do
+     offset = offset * byte_stride.  */
+
+static gfc_code*
+finalization_get_offset (gfc_symbol *idx, gfc_symbol *idx2, gfc_symbol *offset,
+			 gfc_symbol *strides, gfc_symbol *sizes,
+			 gfc_symbol *byte_stride, gfc_expr *rank,
+			 gfc_code *block, gfc_namespace *sub_ns)
+{
+  gfc_iterator *iter;
+  gfc_expr *expr, *expr2;
+
+  /* offset = 0.  */
+  block->next = gfc_get_code (EXEC_ASSIGN);
+  block = block->next;
+  block->expr1 = gfc_lval_expr_from_sym (offset);
+  block->expr2 = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+
+  /* Create loop.  */
+  iter = gfc_get_iterator ();
+  iter->var = gfc_lval_expr_from_sym (idx2);
+  iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+  iter->end = gfc_copy_expr (rank);
+  iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+  block->next = gfc_get_code (EXEC_DO);
+  block = block->next;
+  block->ext.iterator = iter;
+  block->block = gfc_get_code (EXEC_DO);
+
+  /* Loop body: offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1)
+				  * strides(idx2).  */
+
+  /* mod (idx, sizes(idx2)).  */
+  expr = gfc_lval_expr_from_sym (sizes);
+  expr->ref = gfc_get_ref ();
+  expr->ref->type = REF_ARRAY;
+  expr->ref->u.ar.as = sizes->as;
+  expr->ref->u.ar.type = AR_ELEMENT;
+  expr->ref->u.ar.dimen = 1;
+  expr->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
+  expr->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx2);
+
+  expr = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_MOD, "mod",
+				   gfc_current_locus, 2,
+				   gfc_lval_expr_from_sym (idx), expr);
+  expr->ts = idx->ts;
+
+  /* (...) / sizes(idx2-1).  */
+  expr2 = gfc_get_expr ();
+  expr2->expr_type = EXPR_OP;
+  expr2->value.op.op = INTRINSIC_DIVIDE;
+  expr2->value.op.op1 = expr;
+  expr2->value.op.op2 = gfc_lval_expr_from_sym (sizes);
+  expr2->value.op.op2->ref = gfc_get_ref ();
+  expr2->value.op.op2->ref->type = REF_ARRAY;
+  expr2->value.op.op2->ref->u.ar.as = sizes->as;
+  expr2->value.op.op2->ref->u.ar.type = AR_ELEMENT;
+  expr2->value.op.op2->ref->u.ar.dimen = 1;
+  expr2->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
+  expr2->value.op.op2->ref->u.ar.start[0] = gfc_get_expr ();
+  expr2->value.op.op2->ref->u.ar.start[0]->expr_type = EXPR_OP;
+  expr2->value.op.op2->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS;
+  expr2->value.op.op2->ref->u.ar.start[0]->value.op.op1
+	= gfc_lval_expr_from_sym (idx2);
+  expr2->value.op.op2->ref->u.ar.start[0]->value.op.op2
+	= gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+  expr2->value.op.op2->ref->u.ar.start[0]->ts
+	= expr2->value.op.op2->ref->u.ar.start[0]->value.op.op1->ts;
+  expr2->ts = idx->ts;
+
+  /* ... * strides(idx2).  */
+  expr = gfc_get_expr ();
+  expr->expr_type = EXPR_OP;
+  expr->value.op.op = INTRINSIC_TIMES;
+  expr->value.op.op1 = expr2;
+  expr->value.op.op2 = gfc_lval_expr_from_sym (strides);
+  expr->value.op.op2->ref = gfc_get_ref ();
+  expr->value.op.op2->ref->type = REF_ARRAY;
+  expr->value.op.op2->ref->u.ar.type = AR_ELEMENT;
+  expr->value.op.op2->ref->u.ar.dimen = 1;
+  expr->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
+  expr->value.op.op2->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx2);
+  expr->value.op.op2->ref->u.ar.as = strides->as;
+  expr->ts = idx->ts;
+
+  /* offset = offset + ...  */
+  block->block->next = gfc_get_code (EXEC_ASSIGN);
+  block->block->next->expr1 = gfc_lval_expr_from_sym (offset);
+  block->block->next->expr2 = gfc_get_expr ();
+  block->block->next->expr2->expr_type = EXPR_OP;
+  block->block->next->expr2->value.op.op = INTRINSIC_PLUS;
+  block->block->next->expr2->value.op.op1 = gfc_lval_expr_from_sym (offset);
+  block->block->next->expr2->value.op.op2 = expr;
+  block->block->next->expr2->ts = idx->ts;
+
+  /* After the loop:  offset = offset * byte_stride.  */
+  block->next = gfc_get_code (EXEC_ASSIGN);
+  block = block->next;
+  block->expr1 = gfc_lval_expr_from_sym (offset);
+  block->expr2 = gfc_get_expr ();
+  block->expr2->expr_type = EXPR_OP;
+  block->expr2->value.op.op = INTRINSIC_TIMES;
+  block->expr2->value.op.op1 = gfc_lval_expr_from_sym (offset);
+  block->expr2->value.op.op2 = gfc_lval_expr_from_sym (byte_stride);
+  block->expr2->ts = block->expr2->value.op.op1->ts;
+  return block;
+}
+
+
+/* Insert code of the following form:
+
+   block
+     integer(c_intptr_t) :: i
+
+     if ((byte_stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
+	  && (is_contiguous || !final_rank3->attr.contiguous
+	      || final_rank3->as->type != AS_ASSUMED_SHAPE))
+         || 0 == STORAGE_SIZE (array)) then
+       call final_rank3 (array)
+     else
+       block
+         integer(c_intptr_t) :: offset, j
+         type(t) :: tmp(shape (array))
+
+         do i = 0, size (array)-1
+	   offset = obtain_offset(i, strides, sizes, byte_stride)
+	   addr = transfer (c_loc (array), addr) + offset
+	   call c_f_pointer (transfer (addr, cptr), ptr)
+
+	   addr = transfer (c_loc (tmp), addr)
+			    + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
+	   call c_f_pointer (transfer (addr, cptr), ptr2)
+	   ptr2 = ptr
+         end do
+         call final_rank3 (tmp)
+       end block
+     end if
+   block  */
+
+static void
+finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
+			      gfc_symbol *array, gfc_symbol *byte_stride,
+			      gfc_symbol *idx, gfc_symbol *ptr,
+			      gfc_symbol *nelem,
+			      gfc_symbol *strides, gfc_symbol *sizes,
+			      gfc_symbol *idx2, gfc_symbol *offset,
+			      gfc_symbol *is_contiguous, gfc_expr *rank,
+			      gfc_namespace *sub_ns)
+{
+  gfc_symbol *tmp_array, *ptr2;
+  gfc_expr *size_expr, *offset2, *expr;
+  gfc_namespace *ns;
+  gfc_iterator *iter;
+  gfc_code *block2;
+  int i;
+
+  block->next = gfc_get_code (EXEC_IF);
+  block = block->next;
+
+  block->block = gfc_get_code (EXEC_IF);
+  block = block->block;
+
+  /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE.  */
+  size_expr = gfc_get_expr ();
+  size_expr->where = gfc_current_locus;
+  size_expr->expr_type = EXPR_OP;
+  size_expr->value.op.op = INTRINSIC_DIVIDE;
+
+  /* STORAGE_SIZE (array,kind=c_intptr_t).  */
+  size_expr->value.op.op1
+	= gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STORAGE_SIZE,
+				    "storage_size", gfc_current_locus, 2,
+				    gfc_lval_expr_from_sym (array),
+				    gfc_get_int_expr (gfc_index_integer_kind,
+						      NULL, 0));
+
+  /* NUMERIC_STORAGE_SIZE.  */
+  size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
+					      gfc_character_storage_size);
+  size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
+  size_expr->ts = size_expr->value.op.op1->ts;
+
+  /* IF condition: (stride == size_expr
+		    && ((fini's as->ASSUMED_SIZE && !fini's attr.contiguous)
+			|| is_contiguous)
+		   || 0 == size_expr.  */
+  block->expr1 = gfc_get_expr ();
+  block->expr1->ts.type = BT_LOGICAL;
+  block->expr1->ts.kind = gfc_default_logical_kind;
+  block->expr1->expr_type = EXPR_OP;
+  block->expr1->where = gfc_current_locus;
+
+  block->expr1->value.op.op = INTRINSIC_OR;
+
+  /* byte_stride == size_expr */
+  expr = gfc_get_expr ();
+  expr->ts.type = BT_LOGICAL;
+  expr->ts.kind = gfc_default_logical_kind;
+  expr->expr_type = EXPR_OP;
+  expr->where = gfc_current_locus;
+  expr->value.op.op = INTRINSIC_EQ;
+  expr->value.op.op1
+	= gfc_lval_expr_from_sym (byte_stride);
+  expr->value.op.op2 = size_expr;
+
+  /* If strides aren't allowed (not assumed shape or CONTIGUOUS),
+     add is_contiguous check.  */
+
+  if (fini->proc_tree->n.sym->formal->sym->as->type != AS_ASSUMED_SHAPE
+      || fini->proc_tree->n.sym->formal->sym->attr.contiguous)
+    {
+      gfc_expr *expr2;
+      expr2 = gfc_get_expr ();
+      expr2->ts.type = BT_LOGICAL;
+      expr2->ts.kind = gfc_default_logical_kind;
+      expr2->expr_type = EXPR_OP;
+      expr2->where = gfc_current_locus;
+      expr2->value.op.op = INTRINSIC_AND;
+      expr2->value.op.op1 = expr;
+      expr2->value.op.op2 = gfc_lval_expr_from_sym (is_contiguous);
+      expr = expr2;
+    }
+
+  block->expr1->value.op.op1 = expr;
+
+  /* 0 == size_expr */
+  block->expr1->value.op.op2 = gfc_get_expr ();
+  block->expr1->value.op.op2->ts.type = BT_LOGICAL;
+  block->expr1->value.op.op2->ts.kind = gfc_default_logical_kind;
+  block->expr1->value.op.op2->expr_type = EXPR_OP;
+  block->expr1->value.op.op2->where = gfc_current_locus;
+  block->expr1->value.op.op2->value.op.op = INTRINSIC_EQ;
+  block->expr1->value.op.op2->value.op.op1 =
+			gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+  block->expr1->value.op.op2->value.op.op2 = gfc_copy_expr (size_expr);
+
+  /* IF body: call final subroutine.  */
+  block->next = gfc_get_code (EXEC_CALL);
+  block->next->symtree = fini->proc_tree;
+  block->next->resolved_sym = fini->proc_tree->n.sym;
+  block->next->ext.actual = gfc_get_actual_arglist ();
+  block->next->ext.actual->expr = gfc_lval_expr_from_sym (array);
+
+  /* ELSE.  */
+
+  block->block = gfc_get_code (EXEC_IF);
+  block = block->block;
+
+  /* BLOCK ... END BLOCK.  */
+  block->next = gfc_get_code (EXEC_BLOCK);
+  block = block->next;
+
+  ns = gfc_build_block_ns (sub_ns);
+  block->ext.block.ns = ns;
+  block->ext.block.assoc = NULL;
+
+  gfc_get_symbol ("ptr2", ns, &ptr2);
+  ptr2->ts.type = BT_DERIVED;
+  ptr2->ts.u.derived = array->ts.u.derived;
+  ptr2->attr.flavor = FL_VARIABLE;
+  ptr2->attr.pointer = 1;
+  ptr2->attr.artificial = 1;
+  gfc_set_sym_referenced (ptr2);
+  gfc_commit_symbol (ptr2);
+
+  gfc_get_symbol ("tmp_array", ns, &tmp_array);
+  tmp_array->ts.type = BT_DERIVED;
+  tmp_array->ts.u.derived = array->ts.u.derived;
+  tmp_array->attr.flavor = FL_VARIABLE;
+  tmp_array->attr.dimension = 1;
+  tmp_array->attr.artificial = 1;
+  tmp_array->as = gfc_get_array_spec();
+  tmp_array->attr.intent = INTENT_INOUT;
+  tmp_array->as->type = AS_EXPLICIT;
+  tmp_array->as->rank = fini->proc_tree->n.sym->formal->sym->as->rank;
+
+  for (i = 0; i < tmp_array->as->rank; i++)
+    {
+      gfc_expr *shape_expr;
+      tmp_array->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
+						  NULL, 1);
+      /* SIZE (array, dim=i+1, kind=gfc_index_integer_kind).  */
+      shape_expr
+	= gfc_build_intrinsic_call (sub_ns, GFC_ISYM_SIZE, "size",
+				    gfc_current_locus, 3,
+				    gfc_lval_expr_from_sym (array),
+				    gfc_get_int_expr (gfc_default_integer_kind,
+						      NULL, i+1),
+				    gfc_get_int_expr (gfc_default_integer_kind,
+						      NULL,
+						      gfc_index_integer_kind));
+      shape_expr->ts.kind = gfc_index_integer_kind;
+      tmp_array->as->upper[i] = shape_expr;
+    }
+  gfc_set_sym_referenced (tmp_array);
+  gfc_commit_symbol (tmp_array);
+
+  /* Create loop.  */
+  iter = gfc_get_iterator ();
+  iter->var = gfc_lval_expr_from_sym (idx);
+  iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+  iter->end = gfc_lval_expr_from_sym (nelem);
+  iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+
+  block = gfc_get_code (EXEC_DO);
+  ns->code = block;
+  block->ext.iterator = iter;
+  block->block = gfc_get_code (EXEC_DO);
+
+  /* Offset calculation for the new array: idx * size of type (in bytes).  */
+  offset2 = gfc_get_expr ();
+  offset2->expr_type = EXPR_OP;
+  offset2->value.op.op = INTRINSIC_TIMES;
+  offset2->value.op.op1 = gfc_lval_expr_from_sym (idx);
+  offset2->value.op.op2 = gfc_copy_expr (size_expr);
+  offset2->ts = byte_stride->ts;
+
+  /* Offset calculation of "array".  */
+  block2 = finalization_get_offset (idx, idx2, offset, strides, sizes,
+				    byte_stride, rank, block->block, sub_ns);
+
+  /* Create code for
+     CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
+		       + idx * stride, c_ptr), ptr).  */
+  block2->next = finalization_scalarizer (array, ptr,
+					  gfc_lval_expr_from_sym (offset),
+					  sub_ns);
+  block2 = block2->next;
+  block2->next = finalization_scalarizer (tmp_array, ptr2, offset2, sub_ns);
+  block2 = block2->next;
+
+  /* ptr2 = ptr.  */
+  block2->next = gfc_get_code (EXEC_ASSIGN);
+  block2 = block2->next;
+  block2->expr1 = gfc_lval_expr_from_sym (ptr2);
+  block2->expr2 = gfc_lval_expr_from_sym (ptr);
+
+  /* Call now the user's final subroutine. */
+  block->next  = gfc_get_code (EXEC_CALL);
+  block = block->next;
+  block->symtree = fini->proc_tree;
+  block->resolved_sym = fini->proc_tree->n.sym;
+  block->ext.actual = gfc_get_actual_arglist ();
+  block->ext.actual->expr = gfc_lval_expr_from_sym (tmp_array);
+
+  if (fini->proc_tree->n.sym->formal->sym->attr.intent == INTENT_IN)
+    return;
+
+  /* Copy back.  */
+
+  /* Loop.  */
+  iter = gfc_get_iterator ();
+  iter->var = gfc_lval_expr_from_sym (idx);
+  iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+  iter->end = gfc_lval_expr_from_sym (nelem);
+  iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+
+  block->next = gfc_get_code (EXEC_DO);
+  block = block->next;
+  block->ext.iterator = iter;
+  block->block = gfc_get_code (EXEC_DO);
+
+  /* Offset calculation of "array".  */
+  block2 = finalization_get_offset (idx, idx2, offset, strides, sizes,
+				    byte_stride, rank, block->block, sub_ns);
+
+  /* Create code for
+     CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
+		       + offset, c_ptr), ptr).  */
+  block2->next = finalization_scalarizer (array, ptr,
+					  gfc_lval_expr_from_sym (offset),
+					  sub_ns);
+  block2 = block2->next;
+  block2->next = finalization_scalarizer (tmp_array, ptr2,
+					  gfc_copy_expr (offset2), sub_ns);
+  block2 = block2->next;
+
+  /* ptr = ptr2.  */
+  block2->next = gfc_get_code (EXEC_ASSIGN);
+  block2->next->expr1 = gfc_lval_expr_from_sym (ptr);
+  block2->next->expr2 = gfc_lval_expr_from_sym (ptr2);
+}
+
+
+/* Generate the finalization/polymorphic freeing wrapper subroutine for the
+   derived type "derived". The function first calls the approriate FINAL
+   subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable
+   components (but not the inherited ones). Last, it calls the wrapper
+   subroutine of the parent. The generated wrapper procedure takes as argument
+   an assumed-rank array.
+   If neither allocatable components nor FINAL subroutines exists, the vtab
+   will contain a NULL pointer.
+   The generated function has the form
+     _final(assumed-rank array, stride, skip_corarray)
+   where the array has to be contiguous (except of the lowest dimension). The
+   stride (in bytes) is used to allow different sizes for ancestor types by
+   skipping over the additionally added components in the scalarizer. If
+   "fini_coarray" is false, coarray components are not finalized to allow for
+   the correct semantic with intrinsic assignment.  */
+
+static void
+generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
+			       const char *tname, gfc_component *vtab_final)
+{
+  gfc_symbol *final, *array, *fini_coarray, *byte_stride, *sizes, *strides;
+  gfc_symbol *ptr = NULL, *idx, *idx2, *is_contiguous, *offset, *nelem;
+  gfc_component *comp;
+  gfc_namespace *sub_ns;
+  gfc_code *last_code, *block;
+  char name[GFC_MAX_SYMBOL_LEN+1];
+  bool finalizable_comp = false;
+  bool expr_null_wrapper = false;
+  gfc_expr *ancestor_wrapper = NULL, *rank;
+  gfc_iterator *iter;
+
+  if (derived->attr.unlimited_polymorphic)
+    {
+      vtab_final->initializer = gfc_get_null_expr (NULL);
+      return;
+    }
+
+  /* Search for the ancestor's finalizers. */
+  if (derived->attr.extension && derived->components
+      && (!derived->components->ts.u.derived->attr.abstract
+	  || has_finalizer_component (derived)))
+    {
+      gfc_symbol *vtab;
+      gfc_component *comp;
+
+      vtab = gfc_find_derived_vtab (derived->components->ts.u.derived);
+      for (comp = vtab->ts.u.derived->components; comp; comp = comp->next)
+	if (comp->name[0] == '_' && comp->name[1] == 'f')
+	  {
+	    ancestor_wrapper = comp->initializer;
+	    break;
+	  }
+    }
+
+  /* No wrapper of the ancestor and no own FINAL subroutines and allocatable
+     components: Return a NULL() expression; we defer this a bit to have have
+     an interface declaration.  */
+  if ((!ancestor_wrapper || ancestor_wrapper->expr_type == EXPR_NULL)
+      && !derived->attr.alloc_comp
+      && (!derived->f2k_derived || !derived->f2k_derived->finalizers)
+      && !has_finalizer_component (derived))
+    expr_null_wrapper = true;
+  else
+    /* Check whether there are new allocatable components.  */
+    for (comp = derived->components; comp; comp = comp->next)
+      {
+	if (comp == derived->components && derived->attr.extension
+	    && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
+	continue;
+
+	finalizable_comp |= comp_is_finalizable (comp);
+      }
+
+  /* If there is no new finalizer and no new allocatable, return with
+     an expr to the ancestor's one.  */
+  if (!expr_null_wrapper && !finalizable_comp
+      && (!derived->f2k_derived || !derived->f2k_derived->finalizers))
+    {
+      gcc_assert (ancestor_wrapper && ancestor_wrapper->ref == NULL
+	          && ancestor_wrapper->expr_type == EXPR_VARIABLE);
+      vtab_final->initializer = gfc_copy_expr (ancestor_wrapper);
+      vtab_final->ts.interface = vtab_final->initializer->symtree->n.sym;
+      return;
+    }
+
+  /* We now create a wrapper, which does the following:
+     1. Call the suitable finalization subroutine for this type
+     2. Loop over all noninherited allocatable components and noninherited
+	components with allocatable components and DEALLOCATE those; this will
+	take care of finalizers, coarray deregistering and allocatable
+	nested components.
+     3. Call the ancestor's finalizer.  */
+
+  /* Declare the wrapper function; it takes an assumed-rank array
+     and a VALUE logical as arguments. */
+
+  /* Set up the namespace.  */
+  sub_ns = gfc_get_namespace (ns, 0);
+  sub_ns->sibling = ns->contained;
+  if (!expr_null_wrapper)
+    ns->contained = sub_ns;
+  sub_ns->resolved = 1;
+
+  /* Set up the procedure symbol.  */
+  sprintf (name, "__final_%s", tname);
+  gfc_get_symbol (name, sub_ns, &final);
+  sub_ns->proc_name = final;
+  final->attr.flavor = FL_PROCEDURE;
+  final->attr.function = 1;
+  final->attr.pure = 0;
+  final->result = final;
+  final->ts.type = BT_INTEGER;
+  final->ts.kind = 4;
+  final->attr.artificial = 1;
+  final->attr.if_source = expr_null_wrapper ? IFSRC_IFBODY : IFSRC_DECL;
+  if (ns->proc_name->attr.flavor == FL_MODULE)
+    final->module = ns->proc_name->name;
+  gfc_set_sym_referenced (final);
+  gfc_commit_symbol (final);
+
+  /* Set up formal argument.  */
+  gfc_get_symbol ("array", sub_ns, &array);
+  array->ts.type = BT_DERIVED;
+  array->ts.u.derived = derived;
+  array->attr.flavor = FL_VARIABLE;
+  array->attr.dummy = 1;
+  array->attr.contiguous = 1;
+  array->attr.dimension = 1;
+  array->attr.artificial = 1;
+  array->as = gfc_get_array_spec();
+  array->as->type = AS_ASSUMED_RANK;
+  array->as->rank = -1;
+  array->attr.intent = INTENT_INOUT;
+  gfc_set_sym_referenced (array);
+  final->formal = gfc_get_formal_arglist ();
+  final->formal->sym = array;
+  gfc_commit_symbol (array);
+
+  /* Set up formal argument.  */
+  gfc_get_symbol ("byte_stride", sub_ns, &byte_stride);
+  byte_stride->ts.type = BT_INTEGER;
+  byte_stride->ts.kind = gfc_index_integer_kind;
+  byte_stride->attr.flavor = FL_VARIABLE;
+  byte_stride->attr.dummy = 1;
+  byte_stride->attr.value = 1;
+  byte_stride->attr.artificial = 1;
+  gfc_set_sym_referenced (byte_stride);
+  final->formal->next = gfc_get_formal_arglist ();
+  final->formal->next->sym = byte_stride;
+  gfc_commit_symbol (byte_stride);
+
+  /* Set up formal argument.  */
+  gfc_get_symbol ("fini_coarray", sub_ns, &fini_coarray);
+  fini_coarray->ts.type = BT_LOGICAL;
+  fini_coarray->ts.kind = 1;
+  fini_coarray->attr.flavor = FL_VARIABLE;
+  fini_coarray->attr.dummy = 1;
+  fini_coarray->attr.value = 1;
+  fini_coarray->attr.artificial = 1;
+  gfc_set_sym_referenced (fini_coarray);
+  final->formal->next->next = gfc_get_formal_arglist ();
+  final->formal->next->next->sym = fini_coarray;
+  gfc_commit_symbol (fini_coarray);
+
+  /* Return with a NULL() expression but with an interface which has
+     the formal arguments.  */
+  if (expr_null_wrapper)
+    {
+      vtab_final->initializer = gfc_get_null_expr (NULL);
+      vtab_final->ts.interface = final;
+      return;
+    }
+
+  /* Local variables.  */
+
+  gfc_get_symbol ("idx", sub_ns, &idx);
+  idx->ts.type = BT_INTEGER;
+  idx->ts.kind = gfc_index_integer_kind;
+  idx->attr.flavor = FL_VARIABLE;
+  idx->attr.artificial = 1;
+  gfc_set_sym_referenced (idx);
+  gfc_commit_symbol (idx);
+
+  gfc_get_symbol ("idx2", sub_ns, &idx2);
+  idx2->ts.type = BT_INTEGER;
+  idx2->ts.kind = gfc_index_integer_kind;
+  idx2->attr.flavor = FL_VARIABLE;
+  idx2->attr.artificial = 1;
+  gfc_set_sym_referenced (idx2);
+  gfc_commit_symbol (idx2);
+
+  gfc_get_symbol ("offset", sub_ns, &offset);
+  offset->ts.type = BT_INTEGER;
+  offset->ts.kind = gfc_index_integer_kind;
+  offset->attr.flavor = FL_VARIABLE;
+  offset->attr.artificial = 1;
+  gfc_set_sym_referenced (offset);
+  gfc_commit_symbol (offset);
+
+  /* Create RANK expression.  */
+  rank = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_RANK, "rank",
+				   gfc_current_locus, 1,
+				   gfc_lval_expr_from_sym (array));
+  if (rank->ts.kind != idx->ts.kind)
+    gfc_convert_type_warn (rank, &idx->ts, 2, 0);
+
+  /* Create is_contiguous variable.  */
+  gfc_get_symbol ("is_contiguous", sub_ns, &is_contiguous);
+  is_contiguous->ts.type = BT_LOGICAL;
+  is_contiguous->ts.kind = gfc_default_logical_kind;
+  is_contiguous->attr.flavor = FL_VARIABLE;
+  is_contiguous->attr.artificial = 1;
+  gfc_set_sym_referenced (is_contiguous);
+  gfc_commit_symbol (is_contiguous);
+
+  /* Create "sizes(0..rank)" variable, which contains the multiplied
+     up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1),
+     sizes(2) = sizes(1) * extent(dim=2) etc.  */
+  gfc_get_symbol ("sizes", sub_ns, &sizes);
+  sizes->ts.type = BT_INTEGER;
+  sizes->ts.kind = gfc_index_integer_kind;
+  sizes->attr.flavor = FL_VARIABLE;
+  sizes->attr.dimension = 1;
+  sizes->attr.artificial = 1;
+  sizes->as = gfc_get_array_spec();
+  sizes->attr.intent = INTENT_INOUT;
+  sizes->as->type = AS_EXPLICIT;
+  sizes->as->rank = 1;
+  sizes->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+  sizes->as->upper[0] = gfc_copy_expr (rank);
+  gfc_set_sym_referenced (sizes);
+  gfc_commit_symbol (sizes);
+
+  /* Create "strides(1..rank)" variable, which contains the strides per
+     dimension.  */
+  gfc_get_symbol ("strides", sub_ns, &strides);
+  strides->ts.type = BT_INTEGER;
+  strides->ts.kind = gfc_index_integer_kind;
+  strides->attr.flavor = FL_VARIABLE;
+  strides->attr.dimension = 1;
+  strides->attr.artificial = 1;
+  strides->as = gfc_get_array_spec();
+  strides->attr.intent = INTENT_INOUT;
+  strides->as->type = AS_EXPLICIT;
+  strides->as->rank = 1;
+  strides->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+  strides->as->upper[0] = gfc_copy_expr (rank);
+  gfc_set_sym_referenced (strides);
+  gfc_commit_symbol (strides);
+
+
+  /* Set return value to 0.  */
+  last_code = gfc_get_code (EXEC_ASSIGN);
+  last_code->expr1 = gfc_lval_expr_from_sym (final);
+  last_code->expr2 = gfc_get_int_expr (4, NULL, 0);
+  sub_ns->code = last_code;
+
+  /* Set:  is_contiguous = .true.  */
+  last_code->next = gfc_get_code (EXEC_ASSIGN);
+  last_code = last_code->next;
+  last_code->expr1 = gfc_lval_expr_from_sym (is_contiguous);
+  last_code->expr2 = gfc_get_logical_expr (gfc_default_logical_kind,
+					   &gfc_current_locus, true);
+
+  /* Set:  sizes(0) = 1.  */
+  last_code->next = gfc_get_code (EXEC_ASSIGN);
+  last_code = last_code->next;
+  last_code->expr1 = gfc_lval_expr_from_sym (sizes);
+  last_code->expr1->ref = gfc_get_ref ();
+  last_code->expr1->ref->type = REF_ARRAY;
+  last_code->expr1->ref->u.ar.type = AR_ELEMENT;
+  last_code->expr1->ref->u.ar.dimen = 1;
+  last_code->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
+  last_code->expr1->ref->u.ar.start[0]
+		= gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+  last_code->expr1->ref->u.ar.as = sizes->as;
+  last_code->expr2 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+
+  /* Create:
+     DO idx = 1, rank
+       strides(idx) = _F._stride (array, dim=idx)
+       sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind)
+       if (strides (idx) /= sizes(i-1)) is_contiguous = .false.
+     END DO.  */
+
+  /* Create loop.  */
+  iter = gfc_get_iterator ();
+  iter->var = gfc_lval_expr_from_sym (idx);
+  iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+  iter->end = gfc_copy_expr (rank);
+  iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+  last_code->next = gfc_get_code (EXEC_DO);
+  last_code = last_code->next;
+  last_code->ext.iterator = iter;
+  last_code->block = gfc_get_code (EXEC_DO);
+
+  /* strides(idx) = _F._stride(array,dim=idx). */
+  last_code->block->next = gfc_get_code (EXEC_ASSIGN);
+  block = last_code->block->next;
+
+  block->expr1 = gfc_lval_expr_from_sym (strides);
+  block->expr1->ref = gfc_get_ref ();
+  block->expr1->ref->type = REF_ARRAY;
+  block->expr1->ref->u.ar.type = AR_ELEMENT;
+  block->expr1->ref->u.ar.dimen = 1;
+  block->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
+  block->expr1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx);
+  block->expr1->ref->u.ar.as = strides->as;
+
+  block->expr2 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STRIDE, "stride",
+					   gfc_current_locus, 2,
+					   gfc_lval_expr_from_sym (array),
+					   gfc_lval_expr_from_sym (idx));
+
+  /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
+  block->next = gfc_get_code (EXEC_ASSIGN);
+  block = block->next;
+
+  /* sizes(idx) = ... */
+  block->expr1 = gfc_lval_expr_from_sym (sizes);
+  block->expr1->ref = gfc_get_ref ();
+  block->expr1->ref->type = REF_ARRAY;
+  block->expr1->ref->u.ar.type = AR_ELEMENT;
+  block->expr1->ref->u.ar.dimen = 1;
+  block->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
+  block->expr1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx);
+  block->expr1->ref->u.ar.as = sizes->as;
+
+  block->expr2 = gfc_get_expr ();
+  block->expr2->expr_type = EXPR_OP;
+  block->expr2->value.op.op = INTRINSIC_TIMES;
+
+  /* sizes(idx-1). */
+  block->expr2->value.op.op1 = gfc_lval_expr_from_sym (sizes);
+  block->expr2->value.op.op1->ref = gfc_get_ref ();
+  block->expr2->value.op.op1->ref->type = REF_ARRAY;
+  block->expr2->value.op.op1->ref->u.ar.as = sizes->as;
+  block->expr2->value.op.op1->ref->u.ar.type = AR_ELEMENT;
+  block->expr2->value.op.op1->ref->u.ar.dimen = 1;
+  block->expr2->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
+  block->expr2->value.op.op1->ref->u.ar.start[0] = gfc_get_expr ();
+  block->expr2->value.op.op1->ref->u.ar.start[0]->expr_type = EXPR_OP;
+  block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS;
+  block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op1
+	= gfc_lval_expr_from_sym (idx);
+  block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op2
+	= gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+  block->expr2->value.op.op1->ref->u.ar.start[0]->ts
+	= block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op1->ts;
+
+  /* size(array, dim=idx, kind=index_kind).  */
+  block->expr2->value.op.op2
+	= gfc_build_intrinsic_call (sub_ns, GFC_ISYM_SIZE, "size",
+				    gfc_current_locus, 3,
+				    gfc_lval_expr_from_sym (array),
+				    gfc_lval_expr_from_sym (idx),
+				    gfc_get_int_expr (gfc_index_integer_kind,
+						      NULL,
+						      gfc_index_integer_kind));
+  block->expr2->value.op.op2->ts.kind = gfc_index_integer_kind;
+  block->expr2->ts = idx->ts;
+
+  /* if (strides (idx) /= sizes(idx-1)) is_contiguous = .false.  */
+  block->next = gfc_get_code (EXEC_IF);
+  block = block->next;
+
+  block->block = gfc_get_code (EXEC_IF);
+  block = block->block;
+
+  /* if condition: strides(idx) /= sizes(idx-1).  */
+  block->expr1 = gfc_get_expr ();
+  block->expr1->ts.type = BT_LOGICAL;
+  block->expr1->ts.kind = gfc_default_logical_kind;
+  block->expr1->expr_type = EXPR_OP;
+  block->expr1->where = gfc_current_locus;
+  block->expr1->value.op.op = INTRINSIC_NE;
+
+  block->expr1->value.op.op1 = gfc_lval_expr_from_sym (strides);
+  block->expr1->value.op.op1->ref = gfc_get_ref ();
+  block->expr1->value.op.op1->ref->type = REF_ARRAY;
+  block->expr1->value.op.op1->ref->u.ar.type = AR_ELEMENT;
+  block->expr1->value.op.op1->ref->u.ar.dimen = 1;
+  block->expr1->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
+  block->expr1->value.op.op1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx);
+  block->expr1->value.op.op1->ref->u.ar.as = strides->as;
+
+  block->expr1->value.op.op2 = gfc_lval_expr_from_sym (sizes);
+  block->expr1->value.op.op2->ref = gfc_get_ref ();
+  block->expr1->value.op.op2->ref->type = REF_ARRAY;
+  block->expr1->value.op.op2->ref->u.ar.as = sizes->as;
+  block->expr1->value.op.op2->ref->u.ar.type = AR_ELEMENT;
+  block->expr1->value.op.op2->ref->u.ar.dimen = 1;
+  block->expr1->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
+  block->expr1->value.op.op2->ref->u.ar.start[0] = gfc_get_expr ();
+  block->expr1->value.op.op2->ref->u.ar.start[0]->expr_type = EXPR_OP;
+  block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS;
+  block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op1
+	= gfc_lval_expr_from_sym (idx);
+  block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op2
+	= gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+  block->expr1->value.op.op2->ref->u.ar.start[0]->ts
+	= block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op1->ts;
+
+  /* if body: is_contiguous = .false.  */
+  block->next = gfc_get_code (EXEC_ASSIGN);
+  block = block->next;
+  block->expr1 = gfc_lval_expr_from_sym (is_contiguous);
+  block->expr2 = gfc_get_logical_expr (gfc_default_logical_kind,
+				       &gfc_current_locus, false);
+
+  /* Obtain the size (number of elements) of "array" MINUS ONE,
+     which is used in the scalarization.  */
+  gfc_get_symbol ("nelem", sub_ns, &nelem);
+  nelem->ts.type = BT_INTEGER;
+  nelem->ts.kind = gfc_index_integer_kind;
+  nelem->attr.flavor = FL_VARIABLE;
+  nelem->attr.artificial = 1;
+  gfc_set_sym_referenced (nelem);
+  gfc_commit_symbol (nelem);
+
+  /* nelem = sizes (rank) - 1.  */
+  last_code->next = gfc_get_code (EXEC_ASSIGN);
+  last_code = last_code->next;
+
+  last_code->expr1 = gfc_lval_expr_from_sym (nelem);
+
+  last_code->expr2 = gfc_get_expr ();
+  last_code->expr2->expr_type = EXPR_OP;
+  last_code->expr2->value.op.op = INTRINSIC_MINUS;
+  last_code->expr2->value.op.op2
+	= gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+  last_code->expr2->ts = last_code->expr2->value.op.op2->ts;
+
+  last_code->expr2->value.op.op1 = gfc_lval_expr_from_sym (sizes);
+  last_code->expr2->value.op.op1->ref = gfc_get_ref ();
+  last_code->expr2->value.op.op1->ref->type = REF_ARRAY;
+  last_code->expr2->value.op.op1->ref->u.ar.type = AR_ELEMENT;
+  last_code->expr2->value.op.op1->ref->u.ar.dimen = 1;
+  last_code->expr2->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
+  last_code->expr2->value.op.op1->ref->u.ar.start[0] = gfc_copy_expr (rank);
+  last_code->expr2->value.op.op1->ref->u.ar.as = sizes->as;
+
+  /* Call final subroutines. We now generate code like:
+     use iso_c_binding
+     integer, pointer :: ptr
+     type(c_ptr) :: cptr
+     integer(c_intptr_t) :: i, addr
+
+     select case (rank (array))
+       case (3)
+         ! If needed, the array is packed
+	 call final_rank3 (array)
+       case default:
+	 do i = 0, size (array)-1
+	   addr = transfer (c_loc (array), addr) + i * stride
+	   call c_f_pointer (transfer (addr, cptr), ptr)
+	   call elemental_final (ptr)
+	 end do
+     end select */
+
+  if (derived->f2k_derived && derived->f2k_derived->finalizers)
+    {
+      gfc_finalizer *fini, *fini_elem = NULL;
+
+      gfc_get_symbol ("ptr", sub_ns, &ptr);
+      ptr->ts.type = BT_DERIVED;
+      ptr->ts.u.derived = derived;
+      ptr->attr.flavor = FL_VARIABLE;
+      ptr->attr.pointer = 1;
+      ptr->attr.artificial = 1;
+      gfc_set_sym_referenced (ptr);
+      gfc_commit_symbol (ptr);
+
+      /* SELECT CASE (RANK (array)).  */
+      last_code->next = gfc_get_code (EXEC_SELECT);
+      last_code = last_code->next;
+      last_code->expr1 = gfc_copy_expr (rank);
+      block = NULL;
+
+      for (fini = derived->f2k_derived->finalizers; fini; fini = fini->next)
+	{
+	  gcc_assert (fini->proc_tree);   /* Should have been set in gfc_resolve_finalizers.  */
+	  if (fini->proc_tree->n.sym->attr.elemental)
+	    {
+	      fini_elem = fini;
+	      continue;
+	    }
+
+	  /* CASE (fini_rank).  */
+	  if (block)
+	    {
+	      block->block = gfc_get_code (EXEC_SELECT);
+	      block = block->block;
+	    }
+	  else
+	    {
+	      block = gfc_get_code (EXEC_SELECT);
+	      last_code->block = block;
+	    }
+	  block->ext.block.case_list = gfc_get_case ();
+	  block->ext.block.case_list->where = gfc_current_locus;
+	  if (fini->proc_tree->n.sym->formal->sym->attr.dimension)
+	    block->ext.block.case_list->low
+	     = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+				 fini->proc_tree->n.sym->formal->sym->as->rank);
+	  else
+	    block->ext.block.case_list->low
+		= gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
+	  block->ext.block.case_list->high
+		= gfc_copy_expr (block->ext.block.case_list->low);
+
+	  /* CALL fini_rank (array) - possibly with packing.  */
+          if (fini->proc_tree->n.sym->formal->sym->attr.dimension)
+	    finalizer_insert_packed_call (block, fini, array, byte_stride,
+					  idx, ptr, nelem, strides,
+					  sizes, idx2, offset, is_contiguous,
+					  rank, sub_ns);
+	  else
+	    {
+	      block->next = gfc_get_code (EXEC_CALL);
+	      block->next->symtree = fini->proc_tree;
+	      block->next->resolved_sym = fini->proc_tree->n.sym;
+	      block->next->ext.actual = gfc_get_actual_arglist ();
+	      block->next->ext.actual->expr = gfc_lval_expr_from_sym (array);
+	    }
+	}
+
+      /* Elemental call - scalarized.  */
+      if (fini_elem)
+	{
+	  /* CASE DEFAULT.  */
+	  if (block)
+	    {
+	      block->block = gfc_get_code (EXEC_SELECT);
+	      block = block->block;
+	    }
+	  else
+	    {
+	      block = gfc_get_code (EXEC_SELECT);
+	      last_code->block = block;
+	    }
+	  block->ext.block.case_list = gfc_get_case ();
+
+	  /* Create loop.  */
+	  iter = gfc_get_iterator ();
+	  iter->var = gfc_lval_expr_from_sym (idx);
+	  iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+	  iter->end = gfc_lval_expr_from_sym (nelem);
+	  iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+	  block->next = gfc_get_code (EXEC_DO);
+	  block = block->next;
+	  block->ext.iterator = iter;
+	  block->block = gfc_get_code (EXEC_DO);
+
+	  /* Offset calculation.  */
+	  block = finalization_get_offset (idx, idx2, offset, strides, sizes,
+					   byte_stride, rank, block->block,
+					   sub_ns);
+
+	  /* Create code for
+	     CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
+			       + offset, c_ptr), ptr).  */
+	  block->next
+		= finalization_scalarizer (array, ptr,
+					   gfc_lval_expr_from_sym (offset),
+					   sub_ns);
+	  block = block->next;
+
+	  /* CALL final_elemental (array).  */
+	  block->next = gfc_get_code (EXEC_CALL);
+	  block = block->next;
+	  block->symtree = fini_elem->proc_tree;
+	  block->resolved_sym = fini_elem->proc_sym;
+	  block->ext.actual = gfc_get_actual_arglist ();
+	  block->ext.actual->expr = gfc_lval_expr_from_sym (ptr);
+	}
+    }
+
+  /* Finalize and deallocate allocatable components. The same manual
+     scalarization is used as above.  */
+
+  if (finalizable_comp)
+    {
+      gfc_symbol *stat;
+      gfc_code *block = NULL;
+
+      if (!ptr)
+	{
+	  gfc_get_symbol ("ptr", sub_ns, &ptr);
+	  ptr->ts.type = BT_DERIVED;
+	  ptr->ts.u.derived = derived;
+	  ptr->attr.flavor = FL_VARIABLE;
+	  ptr->attr.pointer = 1;
+	  ptr->attr.artificial = 1;
+	  gfc_set_sym_referenced (ptr);
+	  gfc_commit_symbol (ptr);
+	}
+
+      gfc_get_symbol ("ignore", sub_ns, &stat);
+      stat->attr.flavor = FL_VARIABLE;
+      stat->attr.artificial = 1;
+      stat->ts.type = BT_INTEGER;
+      stat->ts.kind = gfc_default_integer_kind;
+      gfc_set_sym_referenced (stat);
+      gfc_commit_symbol (stat);
+
+      /* Create loop.  */
+      iter = gfc_get_iterator ();
+      iter->var = gfc_lval_expr_from_sym (idx);
+      iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+      iter->end = gfc_lval_expr_from_sym (nelem);
+      iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+      last_code->next = gfc_get_code (EXEC_DO);
+      last_code = last_code->next;
+      last_code->ext.iterator = iter;
+      last_code->block = gfc_get_code (EXEC_DO);
+
+      /* Offset calculation.  */
+      block = finalization_get_offset (idx, idx2, offset, strides, sizes,
+				       byte_stride, rank, last_code->block,
+				       sub_ns);
+
+      /* Create code for
+	 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
+			   + idx * stride, c_ptr), ptr).  */
+      block->next = finalization_scalarizer (array, ptr,
+					     gfc_lval_expr_from_sym(offset),
+					     sub_ns);
+      block = block->next;
+
+      for (comp = derived->components; comp; comp = comp->next)
+	{
+	  if (comp == derived->components && derived->attr.extension
+	      && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
+	    continue;
+
+	  finalize_component (gfc_lval_expr_from_sym (ptr), derived, comp,
+			      stat, fini_coarray, &block);
+	  if (!last_code->block->next)
+	    last_code->block->next = block;
+	}
+
+    }
+
+  /* Call the finalizer of the ancestor.  */
+  if (ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
+    {
+      last_code->next = gfc_get_code (EXEC_CALL);
+      last_code = last_code->next;
+      last_code->symtree = ancestor_wrapper->symtree;
+      last_code->resolved_sym = ancestor_wrapper->symtree->n.sym;
+
+      last_code->ext.actual = gfc_get_actual_arglist ();
+      last_code->ext.actual->expr = gfc_lval_expr_from_sym (array);
+      last_code->ext.actual->next = gfc_get_actual_arglist ();
+      last_code->ext.actual->next->expr = gfc_lval_expr_from_sym (byte_stride);
+      last_code->ext.actual->next->next = gfc_get_actual_arglist ();
+      last_code->ext.actual->next->next->expr
+			= gfc_lval_expr_from_sym (fini_coarray);
+    }
+
+  gfc_free_expr (rank);
+  vtab_final->initializer = gfc_lval_expr_from_sym (final);
+  vtab_final->ts.interface = final;
+}
+
+
+/* Add procedure pointers for all type-bound procedures to a vtab.  */
+
+static void
+add_procs_to_declared_vtab (gfc_symbol *derived, gfc_symbol *vtype)
+{
+  gfc_symbol* super_type;
+
+  super_type = gfc_get_derived_super_type (derived);
+
+  if (super_type && (super_type != derived))
+    {
+      /* Make sure that the PPCs appear in the same order as in the parent.  */
+      copy_vtab_proc_comps (super_type, vtype);
+      /* Only needed to get the PPC initializers right.  */
+      add_procs_to_declared_vtab (super_type, vtype);
+    }
+
+  if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
+    add_procs_to_declared_vtab1 (derived->f2k_derived->tb_sym_root, vtype);
+
+  if (derived->f2k_derived && derived->f2k_derived->tb_uop_root)
+    add_procs_to_declared_vtab1 (derived->f2k_derived->tb_uop_root, vtype);
+}
+
+
+/* Find or generate the symbol for a derived type's vtab.  */
+
+gfc_symbol *
+gfc_find_derived_vtab (gfc_symbol *derived)
+{
+  gfc_namespace *ns;
+  gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
+  gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
+
+  /* Find the top-level namespace.  */
+  for (ns = gfc_current_ns; ns; ns = ns->parent)
+    if (!ns->parent)
+      break;
+
+  /* If the type is a class container, use the underlying derived type.  */
+  if (!derived->attr.unlimited_polymorphic && derived->attr.is_class)
+    derived = gfc_get_derived_super_type (derived);
+
+  if (ns)
+    {
+      char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
+
+      get_unique_hashed_string (tname, derived);
+      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);
+      if (vtab == NULL)
+	gfc_find_symbol (name, derived->ns, 0, &vtab);
+
+      if (vtab == NULL)
+	{
+	  gfc_get_symbol (name, ns, &vtab);
+	  vtab->ts.type = BT_DERIVED;
+	  if (!gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL,
+			       &gfc_current_locus))
+	    goto cleanup;
+	  vtab->attr.target = 1;
+	  vtab->attr.save = SAVE_IMPLICIT;
+	  vtab->attr.vtab = 1;
+	  vtab->attr.access = ACCESS_PUBLIC;
+	  gfc_set_sym_referenced (vtab);
+	  sprintf (name, "__vtype_%s", tname);
+
+	  gfc_find_symbol (name, ns, 0, &vtype);
+	  if (vtype == NULL)
+	    {
+	      gfc_component *c;
+	      gfc_symbol *parent = NULL, *parent_vtab = NULL;
+
+	      gfc_get_symbol (name, ns, &vtype);
+	      if (!gfc_add_flavor (&vtype->attr, FL_DERIVED, NULL,
+				   &gfc_current_locus))
+		goto cleanup;
+	      vtype->attr.access = ACCESS_PUBLIC;
+	      vtype->attr.vtype = 1;
+	      gfc_set_sym_referenced (vtype);
+
+	      /* Add component '_hash'.  */
+	      if (!gfc_add_component (vtype, "_hash", &c))
+		goto cleanup;
+	      c->ts.type = BT_INTEGER;
+	      c->ts.kind = 4;
+	      c->attr.access = ACCESS_PRIVATE;
+	      c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
+						 NULL, derived->hash_value);
+
+	      /* Add component '_size'.  */
+	      if (!gfc_add_component (vtype, "_size", &c))
+		goto cleanup;
+	      c->ts.type = BT_INTEGER;
+	      c->ts.kind = 4;
+	      c->attr.access = ACCESS_PRIVATE;
+	      /* Remember the derived type in ts.u.derived,
+		 so that the correct initializer can be set later on
+		 (in gfc_conv_structure).  */
+	      c->ts.u.derived = derived;
+	      c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
+						 NULL, 0);
+
+	      /* Add component _extends.  */
+	      if (!gfc_add_component (vtype, "_extends", &c))
+		goto cleanup;
+	      c->attr.pointer = 1;
+	      c->attr.access = ACCESS_PRIVATE;
+	      if (!derived->attr.unlimited_polymorphic)
+		parent = gfc_get_derived_super_type (derived);
+	      else
+		parent = NULL;
+
+	      if (parent)
+		{
+		  parent_vtab = gfc_find_derived_vtab (parent);
+		  c->ts.type = BT_DERIVED;
+		  c->ts.u.derived = parent_vtab->ts.u.derived;
+		  c->initializer = gfc_get_expr ();
+		  c->initializer->expr_type = EXPR_VARIABLE;
+		  gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns,
+				     0, &c->initializer->symtree);
+		}
+	      else
+		{
+		  c->ts.type = BT_DERIVED;
+		  c->ts.u.derived = vtype;
+		  c->initializer = gfc_get_null_expr (NULL);
+		}
+
+	      if (!derived->attr.unlimited_polymorphic
+		  && derived->components == NULL
+		  && !derived->attr.zero_comp)
+		{
+		  /* At this point an error must have occurred.
+		     Prevent further errors on the vtype components.  */
+		  found_sym = vtab;
+		  goto have_vtype;
+		}
+
+	      /* Add component _def_init.  */
+	      if (!gfc_add_component (vtype, "_def_init", &c))
+		goto cleanup;
+	      c->attr.pointer = 1;
+	      c->attr.artificial = 1;
+	      c->attr.access = ACCESS_PRIVATE;
+	      c->ts.type = BT_DERIVED;
+	      c->ts.u.derived = derived;
+	      if (derived->attr.unlimited_polymorphic
+		  || derived->attr.abstract)
+		c->initializer = gfc_get_null_expr (NULL);
+	      else
+		{
+		  /* Construct default initialization variable.  */
+		  sprintf (name, "__def_init_%s", tname);
+		  gfc_get_symbol (name, ns, &def_init);
+		  def_init->attr.target = 1;
+		  def_init->attr.artificial = 1;
+		  def_init->attr.save = SAVE_IMPLICIT;
+		  def_init->attr.access = ACCESS_PUBLIC;
+		  def_init->attr.flavor = FL_VARIABLE;
+		  gfc_set_sym_referenced (def_init);
+		  def_init->ts.type = BT_DERIVED;
+		  def_init->ts.u.derived = derived;
+		  def_init->value = gfc_default_initializer (&def_init->ts);
+
+		  c->initializer = gfc_lval_expr_from_sym (def_init);
+		}
+
+	      /* Add component _copy.  */
+	      if (!gfc_add_component (vtype, "_copy", &c))
+		goto cleanup;
+	      c->attr.proc_pointer = 1;
+	      c->attr.access = ACCESS_PRIVATE;
+	      c->tb = XCNEW (gfc_typebound_proc);
+	      c->tb->ppc = 1;
+	      if (derived->attr.unlimited_polymorphic
+		  || derived->attr.abstract)
+		c->initializer = gfc_get_null_expr (NULL);
+	      else
+		{
+		  /* Set up namespace.  */
+		  gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
+		  sub_ns->sibling = ns->contained;
+		  ns->contained = sub_ns;
+		  sub_ns->resolved = 1;
+		  /* Set up procedure symbol.  */
+		  sprintf (name, "__copy_%s", tname);
+		  gfc_get_symbol (name, sub_ns, &copy);
+		  sub_ns->proc_name = copy;
+		  copy->attr.flavor = FL_PROCEDURE;
+		  copy->attr.subroutine = 1;
+		  copy->attr.pure = 1;
+		  copy->attr.artificial = 1;
+		  copy->attr.if_source = IFSRC_DECL;
+		  /* This is elemental so that arrays are automatically
+		     treated correctly by the scalarizer.  */
+		  copy->attr.elemental = 1;
+		  if (ns->proc_name->attr.flavor == FL_MODULE)
+		    copy->module = ns->proc_name->name;
+		  gfc_set_sym_referenced (copy);
+		  /* Set up formal arguments.  */
+		  gfc_get_symbol ("src", sub_ns, &src);
+		  src->ts.type = BT_DERIVED;
+		  src->ts.u.derived = derived;
+		  src->attr.flavor = FL_VARIABLE;
+		  src->attr.dummy = 1;
+		  src->attr.artificial = 1;
+     		  src->attr.intent = INTENT_IN;
+		  gfc_set_sym_referenced (src);
+		  copy->formal = gfc_get_formal_arglist ();
+		  copy->formal->sym = src;
+		  gfc_get_symbol ("dst", sub_ns, &dst);
+		  dst->ts.type = BT_DERIVED;
+		  dst->ts.u.derived = derived;
+		  dst->attr.flavor = FL_VARIABLE;
+		  dst->attr.dummy = 1;
+		  dst->attr.artificial = 1;
+		  dst->attr.intent = INTENT_INOUT;
+		  gfc_set_sym_referenced (dst);
+		  copy->formal->next = gfc_get_formal_arglist ();
+		  copy->formal->next->sym = dst;
+		  /* Set up code.  */
+		  sub_ns->code = gfc_get_code (EXEC_INIT_ASSIGN);
+		  sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst);
+		  sub_ns->code->expr2 = gfc_lval_expr_from_sym (src);
+		  /* Set initializer.  */
+		  c->initializer = gfc_lval_expr_from_sym (copy);
+		  c->ts.interface = copy;
+		}
+
+	      /* Add component _final, which contains a procedure pointer to
+		 a wrapper which handles both the freeing of allocatable
+		 components and the calls to finalization subroutines.
+		 Note: The actual wrapper function can only be generated
+		 at resolution time.  */
+	      if (!gfc_add_component (vtype, "_final", &c))
+		goto cleanup;
+	      c->attr.proc_pointer = 1;
+	      c->attr.access = ACCESS_PRIVATE;
+	      c->tb = XCNEW (gfc_typebound_proc);
+	      c->tb->ppc = 1;
+	      generate_finalization_wrapper (derived, ns, tname, c);
+
+	      /* Add procedure pointers for type-bound procedures.  */
+	      if (!derived->attr.unlimited_polymorphic)
+		add_procs_to_declared_vtab (derived, vtype);
+	  }
+
+have_vtype:
+	  vtab->ts.u.derived = vtype;
+	  vtab->value = gfc_default_initializer (&vtab->ts);
+	}
+    }
+
+  found_sym = vtab;
+
+cleanup:
+  /* It is unexpected to have some symbols added at resolution or code
+     generation time. We commit the changes in order to keep a clean state.  */
+  if (found_sym)
+    {
+      gfc_commit_symbol (vtab);
+      if (vtype)
+	gfc_commit_symbol (vtype);
+      if (def_init)
+	gfc_commit_symbol (def_init);
+      if (copy)
+	gfc_commit_symbol (copy);
+      if (src)
+	gfc_commit_symbol (src);
+      if (dst)
+	gfc_commit_symbol (dst);
+    }
+  else
+    gfc_undo_symbols ();
+
+  return found_sym;
+}
+
+
+/* Check if a derived type is finalizable. That is the case if it
+   (1) has a FINAL subroutine or
+   (2) has a nonpointer nonallocatable component of finalizable type.
+   If it is finalizable, return an expression containing the
+   finalization wrapper.  */
+
+bool
+gfc_is_finalizable (gfc_symbol *derived, gfc_expr **final_expr)
+{
+  gfc_symbol *vtab;
+  gfc_component *c;
+
+  /* (1) Check for FINAL subroutines.  */
+  if (derived->f2k_derived && derived->f2k_derived->finalizers)
+    goto yes;
+
+  /* (2) Check for components of finalizable type.  */
+  for (c = derived->components; c; c = c->next)
+    if (c->ts.type == BT_DERIVED
+	&& !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable
+	&& gfc_is_finalizable (c->ts.u.derived, NULL))
+      goto yes;
+
+  return false;
+
+yes:
+  /* Make sure vtab is generated.  */
+  vtab = gfc_find_derived_vtab (derived);
+  if (final_expr)
+    {
+      /* Return finalizer expression.  */
+      gfc_component *final;
+      final = vtab->ts.u.derived->components->next->next->next->next->next;
+      gcc_assert (strcmp (final->name, "_final") == 0);
+      gcc_assert (final->initializer
+		  && final->initializer->expr_type != EXPR_NULL);
+      *final_expr = final->initializer;
+    }
+  return true;
+}
+
+
+/* Find (or generate) the symbol for an intrinsic type's vtab.  This is
+   needed to support unlimited polymorphism.  */
+
+static gfc_symbol *
+find_intrinsic_vtab (gfc_typespec *ts)
+{
+  gfc_namespace *ns;
+  gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL;
+  gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
+  int charlen = 0;
+
+  if (ts->type == BT_CHARACTER)
+    {
+      if (ts->deferred)
+	{
+	  gfc_error ("TODO: Deferred character length variable at %C cannot "
+		     "yet be associated with unlimited polymorphic entities");
+	  return NULL;
+	}
+      else if (ts->u.cl && ts->u.cl->length
+	       && ts->u.cl->length->expr_type == EXPR_CONSTANT)
+	charlen = mpz_get_si (ts->u.cl->length->value.integer);
+    }
+
+  /* Find the top-level namespace.  */
+  for (ns = gfc_current_ns; ns; ns = ns->parent)
+    if (!ns->parent)
+      break;
+
+  if (ns)
+    {
+      char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
+
+      if (ts->type == BT_CHARACTER)
+	sprintf (tname, "%s_%d_%d", gfc_basic_typename (ts->type),
+		 charlen, ts->kind);
+      else
+	sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind);
+
+      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);
+
+      if (vtab == NULL)
+	{
+	  gfc_get_symbol (name, ns, &vtab);
+	  vtab->ts.type = BT_DERIVED;
+	  if (!gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL,
+			       &gfc_current_locus))
+	    goto cleanup;
+	  vtab->attr.target = 1;
+	  vtab->attr.save = SAVE_IMPLICIT;
+	  vtab->attr.vtab = 1;
+	  vtab->attr.access = ACCESS_PUBLIC;
+	  gfc_set_sym_referenced (vtab);
+	  sprintf (name, "__vtype_%s", tname);
+
+	  gfc_find_symbol (name, ns, 0, &vtype);
+	  if (vtype == NULL)
+	    {
+	      gfc_component *c;
+	      int hash;
+	      gfc_namespace *sub_ns;
+	      gfc_namespace *contained;
+	      gfc_expr *e;
+
+	      gfc_get_symbol (name, ns, &vtype);
+	      if (!gfc_add_flavor (&vtype->attr, FL_DERIVED, NULL,
+				   &gfc_current_locus))
+		goto cleanup;
+	      vtype->attr.access = ACCESS_PUBLIC;
+	      vtype->attr.vtype = 1;
+	      gfc_set_sym_referenced (vtype);
+
+	      /* Add component '_hash'.  */
+	      if (!gfc_add_component (vtype, "_hash", &c))
+		goto cleanup;
+	      c->ts.type = BT_INTEGER;
+	      c->ts.kind = 4;
+	      c->attr.access = ACCESS_PRIVATE;
+	      hash = gfc_intrinsic_hash_value (ts);
+	      c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
+						 NULL, hash);
+
+	      /* Add component '_size'.  */
+	      if (!gfc_add_component (vtype, "_size", &c))
+		goto cleanup;
+	      c->ts.type = BT_INTEGER;
+	      c->ts.kind = 4;
+	      c->attr.access = ACCESS_PRIVATE;
+
+	      /* Build a minimal expression to make use of
+		 target-memory.c/gfc_element_size for 'size'. */
+	      e = gfc_get_expr ();
+	      e->ts = *ts;
+	      e->expr_type = EXPR_VARIABLE;
+	      c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
+						 NULL,
+						 (int)gfc_element_size (e));
+	      gfc_free_expr (e);
+
+	      /* Add component _extends.  */
+	      if (!gfc_add_component (vtype, "_extends", &c))
+		goto cleanup;
+	      c->attr.pointer = 1;
+	      c->attr.access = ACCESS_PRIVATE;
+	      c->ts.type = BT_VOID;
+	      c->initializer = gfc_get_null_expr (NULL);
+
+	      /* Add component _def_init.  */
+	      if (!gfc_add_component (vtype, "_def_init", &c))
+		goto cleanup;
+	      c->attr.pointer = 1;
+	      c->attr.access = ACCESS_PRIVATE;
+	      c->ts.type = BT_VOID;
+	      c->initializer = gfc_get_null_expr (NULL);
+
+	      /* Add component _copy.  */
+	      if (!gfc_add_component (vtype, "_copy", &c))
+		goto cleanup;
+	      c->attr.proc_pointer = 1;
+	      c->attr.access = ACCESS_PRIVATE;
+	      c->tb = XCNEW (gfc_typebound_proc);
+	      c->tb->ppc = 1;
+
+	      if (ts->type != BT_CHARACTER)
+		sprintf (name, "__copy_%s", tname);
+	      else
+		{
+		  /* __copy is always the same for characters.
+		     Check to see if copy function already exists.  */
+		  sprintf (name, "__copy_character_%d", ts->kind);
+		  contained = ns->contained;
+		  for (; contained; contained = contained->sibling)
+		    if (contained->proc_name
+			&& strcmp (name, contained->proc_name->name) == 0)
+		      {
+			copy = contained->proc_name;
+			goto got_char_copy;
+		      }
+		}
+
+	      /* Set up namespace.  */
+	      sub_ns = gfc_get_namespace (ns, 0);
+	      sub_ns->sibling = ns->contained;
+	      ns->contained = sub_ns;
+	      sub_ns->resolved = 1;
+	      /* Set up procedure symbol.  */
+	      gfc_get_symbol (name, sub_ns, &copy);
+	      sub_ns->proc_name = copy;
+	      copy->attr.flavor = FL_PROCEDURE;
+	      copy->attr.subroutine = 1;
+	      copy->attr.pure = 1;
+	      copy->attr.if_source = IFSRC_DECL;
+	      /* This is elemental so that arrays are automatically
+		 treated correctly by the scalarizer.  */
+	      copy->attr.elemental = 1;
+	      if (ns->proc_name->attr.flavor == FL_MODULE)
+		copy->module = ns->proc_name->name;
+		  gfc_set_sym_referenced (copy);
+	      /* Set up formal arguments.  */
+	      gfc_get_symbol ("src", sub_ns, &src);
+	      src->ts.type = ts->type;
+	      src->ts.kind = ts->kind;
+	      src->attr.flavor = FL_VARIABLE;
+	      src->attr.dummy = 1;
+	      src->attr.intent = INTENT_IN;
+	      gfc_set_sym_referenced (src);
+	      copy->formal = gfc_get_formal_arglist ();
+	      copy->formal->sym = src;
+	      gfc_get_symbol ("dst", sub_ns, &dst);
+	      dst->ts.type = ts->type;
+	      dst->ts.kind = ts->kind;
+	      dst->attr.flavor = FL_VARIABLE;
+	      dst->attr.dummy = 1;
+	      dst->attr.intent = INTENT_INOUT;
+	      gfc_set_sym_referenced (dst);
+	      copy->formal->next = gfc_get_formal_arglist ();
+	      copy->formal->next->sym = dst;
+	      /* Set up code.  */
+	      sub_ns->code = gfc_get_code (EXEC_INIT_ASSIGN);
+	      sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst);
+	      sub_ns->code->expr2 = gfc_lval_expr_from_sym (src);
+	    got_char_copy:
+	      /* Set initializer.  */
+	      c->initializer = gfc_lval_expr_from_sym (copy);
+	      c->ts.interface = copy;
+
+	      /* Add component _final.  */
+	      if (!gfc_add_component (vtype, "_final", &c))
+		goto cleanup;
+	      c->attr.proc_pointer = 1;
+	      c->attr.access = ACCESS_PRIVATE;
+	      c->tb = XCNEW (gfc_typebound_proc);
+	      c->tb->ppc = 1;
+	      c->initializer = gfc_get_null_expr (NULL);
+	    }
+	  vtab->ts.u.derived = vtype;
+	  vtab->value = gfc_default_initializer (&vtab->ts);
+	}
+    }
+
+  found_sym = vtab;
+
+cleanup:
+  /* It is unexpected to have some symbols added at resolution or code
+     generation time. We commit the changes in order to keep a clean state.  */
+  if (found_sym)
+    {
+      gfc_commit_symbol (vtab);
+      if (vtype)
+	gfc_commit_symbol (vtype);
+      if (copy)
+	gfc_commit_symbol (copy);
+      if (src)
+	gfc_commit_symbol (src);
+      if (dst)
+	gfc_commit_symbol (dst);
+    }
+  else
+    gfc_undo_symbols ();
+
+  return found_sym;
+}
+
+
+/*  Find (or generate) a vtab for an arbitrary type (derived or intrinsic).  */
+
+gfc_symbol *
+gfc_find_vtab (gfc_typespec *ts)
+{
+  switch (ts->type)
+    {
+    case BT_UNKNOWN:
+      return NULL;
+    case BT_DERIVED:
+      return gfc_find_derived_vtab (ts->u.derived);
+    case BT_CLASS:
+      return gfc_find_derived_vtab (ts->u.derived->components->ts.u.derived);
+    default:
+      return find_intrinsic_vtab (ts);
+    }
+}
+
+
+/* General worker function to find either a type-bound procedure or a
+   type-bound user operator.  */
+
+static gfc_symtree*
+find_typebound_proc_uop (gfc_symbol* derived, bool* t,
+			 const char* name, bool noaccess, bool uop,
+			 locus* where)
+{
+  gfc_symtree* res;
+  gfc_symtree* root;
+
+  /* Set default to failure.  */
+  if (t)
+    *t = false;
+
+  if (derived->f2k_derived)
+    /* Set correct symbol-root.  */
+    root = (uop ? derived->f2k_derived->tb_uop_root
+		: derived->f2k_derived->tb_sym_root);
+  else
+    return NULL;
+
+  /* Try to find it in the current type's namespace.  */
+  res = gfc_find_symtree (root, name);
+  if (res && res->n.tb && !res->n.tb->error)
+    {
+      /* We found one.  */
+      if (t)
+	*t = true;
+
+      if (!noaccess && derived->attr.use_assoc
+	  && res->n.tb->access == ACCESS_PRIVATE)
+	{
+	  if (where)
+	    gfc_error ("'%s' of '%s' is PRIVATE at %L",
+		       name, derived->name, where);
+	  if (t)
+	    *t = false;
+	}
+
+      return res;
+    }
+
+  /* Otherwise, recurse on parent type if derived is an extension.  */
+  if (derived->attr.extension)
+    {
+      gfc_symbol* super_type;
+      super_type = gfc_get_derived_super_type (derived);
+      gcc_assert (super_type);
+
+      return find_typebound_proc_uop (super_type, t, name,
+				      noaccess, uop, where);
+    }
+
+  /* Nothing found.  */
+  return NULL;
+}
+
+
+/* Find a type-bound procedure or user operator by name for a derived-type
+   (looking recursively through the super-types).  */
+
+gfc_symtree*
+gfc_find_typebound_proc (gfc_symbol* derived, bool* t,
+			 const char* name, bool noaccess, locus* where)
+{
+  return find_typebound_proc_uop (derived, t, name, noaccess, false, where);
+}
+
+gfc_symtree*
+gfc_find_typebound_user_op (gfc_symbol* derived, bool* t,
+			    const char* name, bool noaccess, locus* where)
+{
+  return find_typebound_proc_uop (derived, t, name, noaccess, true, where);
+}
+
+
+/* Find a type-bound intrinsic operator looking recursively through the
+   super-type hierarchy.  */
+
+gfc_typebound_proc*
+gfc_find_typebound_intrinsic_op (gfc_symbol* derived, bool* t,
+				 gfc_intrinsic_op op, bool noaccess,
+				 locus* where)
+{
+  gfc_typebound_proc* res;
+
+  /* Set default to failure.  */
+  if (t)
+    *t = false;
+
+  /* Try to find it in the current type's namespace.  */
+  if (derived->f2k_derived)
+    res = derived->f2k_derived->tb_op[op];
+  else
+    res = NULL;
+
+  /* Check access.  */
+  if (res && !res->error)
+    {
+      /* We found one.  */
+      if (t)
+	*t = true;
+
+      if (!noaccess && derived->attr.use_assoc
+	  && res->access == ACCESS_PRIVATE)
+	{
+	  if (where)
+	    gfc_error ("'%s' of '%s' is PRIVATE at %L",
+		       gfc_op2string (op), derived->name, where);
+	  if (t)
+	    *t = false;
+	}
+
+      return res;
+    }
+
+  /* Otherwise, recurse on parent type if derived is an extension.  */
+  if (derived->attr.extension)
+    {
+      gfc_symbol* super_type;
+      super_type = gfc_get_derived_super_type (derived);
+      gcc_assert (super_type);
+
+      return gfc_find_typebound_intrinsic_op (super_type, t, op,
+					      noaccess, where);
+    }
+
+  /* Nothing found.  */
+  return NULL;
+}
+
+
+/* Get a typebound-procedure symtree or create and insert it if not yet
+   present.  This is like a very simplified version of gfc_get_sym_tree for
+   tbp-symtrees rather than regular ones.  */
+
+gfc_symtree*
+gfc_get_tbp_symtree (gfc_symtree **root, const char *name)
+{
+  gfc_symtree *result;
+
+  result = gfc_find_symtree (*root, name);
+  if (!result)
+    {
+      result = gfc_new_symtree (root, name);
+      gcc_assert (result);
+      result->n.tb = NULL;
+    }
+
+  return result;
+}
diff --git a/gcc-4.9/gcc/fortran/config-lang.in b/gcc-4.9/gcc/fortran/config-lang.in
new file mode 100644
index 000000000..23da31c49
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/config-lang.in
@@ -0,0 +1,33 @@
+# Copyright (C) 2004-2014 Free Software Foundation, Inc.
+#
+# This file is part of GCC.
+#
+# GCC is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3, or (at your option)
+# any later version.
+#
+# GCC is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with GCC; see the file COPYING3.  If not see
+# <http://www.gnu.org/licenses/>.
+
+# Configure looks for the existence of this file to auto-config each language.
+# We define several parameters used by configure:
+#
+# language	- name of language as it would appear in $(LANGUAGES)
+# compilers	- value to add to $(COMPILERS)
+# diff_excludes	- files to ignore when building diffs between two versions.
+
+language="fortran"
+
+compilers="f951\$(exeext)"
+
+target_libs=target-libgfortran
+
+gtfiles="\$(srcdir)/fortran/f95-lang.c \$(srcdir)/fortran/trans-decl.c \$(srcdir)/fortran/trans-intrinsic.c \$(srcdir)/fortran/trans-io.c \$(srcdir)/fortran/trans-stmt.c \$(srcdir)/fortran/trans-types.c \$(srcdir)/fortran/trans-types.h \$(srcdir)/fortran/trans.h \$(srcdir)/fortran/trans-const.h"
+
diff --git a/gcc-4.9/gcc/fortran/constructor.c b/gcc-4.9/gcc/fortran/constructor.c
new file mode 100644
index 000000000..d1e39ed21
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/constructor.c
@@ -0,0 +1,277 @@
+/* Array and structure constructors
+   Copyright (C) 2009-2014 Free Software Foundation, Inc.
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "gfortran.h"
+#include "constructor.h"
+
+
+static void
+node_free (splay_tree_value value)
+{
+  gfc_constructor *c = (gfc_constructor*)value;
+
+  if (c->expr)
+    gfc_free_expr (c->expr);
+
+  if (c->iterator)
+    gfc_free_iterator (c->iterator, 1);
+
+  mpz_clear (c->offset);
+  mpz_clear (c->repeat);
+
+  free (c);
+}
+
+
+static gfc_constructor *
+node_copy (splay_tree_node node, void *base)
+{
+  gfc_constructor *c, *src = (gfc_constructor*)node->value;
+
+  c = XCNEW (gfc_constructor);
+  c->base = (gfc_constructor_base)base;
+  c->expr = gfc_copy_expr (src->expr);
+  c->iterator = gfc_copy_iterator (src->iterator);
+  c->where = src->where;
+  c->n.component = src->n.component;
+
+  mpz_init_set (c->offset, src->offset);
+  mpz_init_set (c->repeat, src->repeat);
+
+  return c;
+}
+
+
+static int
+node_copy_and_insert (splay_tree_node node, void *base)
+{
+  int n = mpz_get_si (((gfc_constructor*)node->value)->offset);
+  gfc_constructor_insert ((gfc_constructor_base*)base,
+			  node_copy (node, base), n);
+  return 0;
+}
+
+
+gfc_constructor *
+gfc_constructor_get (void)
+{
+  gfc_constructor *c = XCNEW (gfc_constructor);
+  c->base = NULL;
+  c->expr = NULL;
+  c->iterator = NULL;
+
+  mpz_init_set_si (c->offset, 0);
+  mpz_init_set_si (c->repeat, 1);
+
+  return c;
+}
+
+gfc_constructor_base gfc_constructor_get_base (void)
+{
+  return splay_tree_new (splay_tree_compare_ints, NULL, node_free);
+}
+
+
+gfc_constructor_base
+gfc_constructor_copy (gfc_constructor_base base)
+{
+  gfc_constructor_base new_base;
+
+  if (!base)
+    return NULL;
+
+  new_base = gfc_constructor_get_base ();
+  splay_tree_foreach (base, node_copy_and_insert, &new_base);
+
+  return new_base;
+}
+
+
+void
+gfc_constructor_free (gfc_constructor_base base)
+{
+  if (base)
+    splay_tree_delete (base);
+}
+
+
+gfc_constructor *
+gfc_constructor_append (gfc_constructor_base *base, gfc_constructor *c)
+{
+  int offset = 0;
+  if (*base)
+    offset = (int)(splay_tree_max (*base)->key) + 1;
+
+  return gfc_constructor_insert (base, c, offset);
+}
+
+
+gfc_constructor *
+gfc_constructor_append_expr (gfc_constructor_base *base,
+			     gfc_expr *e, locus *where)
+{
+  gfc_constructor *c = gfc_constructor_get ();
+  c->expr = e;
+  if (where)
+    c->where = *where;
+
+  return gfc_constructor_append (base, c);
+}
+
+
+gfc_constructor *
+gfc_constructor_insert (gfc_constructor_base *base, gfc_constructor *c, int n)
+{
+  splay_tree_node node;
+
+  if (*base == NULL)
+    *base = splay_tree_new (splay_tree_compare_ints, NULL, node_free);
+
+  c->base = *base;
+  mpz_set_si (c->offset, n);
+
+  node = splay_tree_insert (*base, (splay_tree_key) n, (splay_tree_value) c);
+  gcc_assert (node);
+
+  return (gfc_constructor*)node->value;
+}
+
+
+gfc_constructor *
+gfc_constructor_insert_expr (gfc_constructor_base *base,
+			     gfc_expr *e, locus *where, int n)
+{
+  gfc_constructor *c = gfc_constructor_get ();
+  c->expr = e;
+  if (where)
+    c->where = *where;
+
+  return gfc_constructor_insert (base, c, n);
+}
+
+
+gfc_constructor *
+gfc_constructor_lookup (gfc_constructor_base base, int offset)
+{
+  gfc_constructor *c;
+  splay_tree_node node;
+
+  if (!base)
+    return NULL;
+
+  node = splay_tree_lookup (base, (splay_tree_key) offset);
+  if (node)
+    return (gfc_constructor *) node->value;
+
+  /* Check if the previous node has a repeat count big enough to
+     cover the offset looked for.  */
+  node = splay_tree_predecessor (base, (splay_tree_key) offset);
+  if (!node)
+    return NULL;
+
+  c = (gfc_constructor *) node->value;
+  if (mpz_cmp_si (c->repeat, 1) > 0)
+    {
+      if (mpz_get_si (c->offset) + mpz_get_si (c->repeat) <= offset)
+	c = NULL;
+    }
+  else
+    c = NULL;
+
+  return c;
+}
+
+
+gfc_expr *
+gfc_constructor_lookup_expr (gfc_constructor_base base, int offset)
+{
+  gfc_constructor *c = gfc_constructor_lookup (base, offset);
+  return c ? c->expr : NULL;
+}
+
+
+int
+gfc_constructor_expr_foreach (gfc_constructor *ctor ATTRIBUTE_UNUSED,
+			      int(*f)(gfc_expr *) ATTRIBUTE_UNUSED)
+{
+  gcc_assert (0);
+  return 0;
+}
+
+void
+gfc_constructor_swap (gfc_constructor *ctor ATTRIBUTE_UNUSED,
+                      int n ATTRIBUTE_UNUSED, int m ATTRIBUTE_UNUSED)
+{
+  gcc_assert (0);
+}
+
+
+
+gfc_constructor *
+gfc_constructor_first (gfc_constructor_base base)
+{
+  if (base)
+    {
+      splay_tree_node node = splay_tree_min (base);
+      return node ? (gfc_constructor*) node->value : NULL;
+    }
+  else
+    return NULL;
+}
+
+
+gfc_constructor *
+gfc_constructor_next (gfc_constructor *ctor)
+{
+  if (ctor)
+    {
+      splay_tree_node node = splay_tree_successor (ctor->base,
+						   mpz_get_si (ctor->offset));
+      return node ? (gfc_constructor*) node->value : NULL;
+    }
+  else
+    return NULL;
+}
+
+
+void
+gfc_constructor_remove (gfc_constructor *ctor)
+{
+  if (ctor)
+    splay_tree_remove (ctor->base, mpz_get_si (ctor->offset));
+}
+
+
+gfc_constructor *
+gfc_constructor_lookup_next (gfc_constructor_base base, int offset)
+{
+  splay_tree_node node;
+
+  if (!base)
+    return NULL;
+
+  node = splay_tree_successor (base, (splay_tree_key) offset);
+  if (!node)
+    return NULL;
+
+  return (gfc_constructor *) node->value;
+}
diff --git a/gcc-4.9/gcc/fortran/constructor.h b/gcc-4.9/gcc/fortran/constructor.h
new file mode 100644
index 000000000..c4e48667e
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/constructor.h
@@ -0,0 +1,89 @@
+/* Array and structure constructors
+   Copyright (C) 2009-2014 Free Software Foundation, Inc.
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+#ifndef GFC_CONSTRUCTOR_H
+#define GFC_CONSTRUCTOR_H
+
+/* Get a new constructor structure.  */
+gfc_constructor *gfc_constructor_get (void);
+
+gfc_constructor_base gfc_constructor_get_base (void);
+
+/* Copy a constructor structure.  */
+gfc_constructor_base gfc_constructor_copy (gfc_constructor_base base);
+
+
+/* Free a gfc_constructor structure.  */
+void gfc_constructor_free (gfc_constructor_base base);
+
+
+/* Given an constructor structure, append the expression node onto
+   the constructor. Returns the constructor node appended.  */
+gfc_constructor *gfc_constructor_append (gfc_constructor_base *base,
+					 gfc_constructor *c);
+
+gfc_constructor *gfc_constructor_append_expr (gfc_constructor_base *base,
+					      gfc_expr *e, locus *where);
+
+
+/* Given an constructor structure, place the expression node at position.
+   Returns the constructor node inserted.  */
+gfc_constructor *gfc_constructor_insert (gfc_constructor_base *base,
+					 gfc_constructor *c, int n);
+
+gfc_constructor *gfc_constructor_insert_expr (gfc_constructor_base *base,
+					      gfc_expr *e, locus *where,
+					      int n);
+
+/* Given an array constructor expression and an element number (starting
+   at zero), return a pointer to the array element.  NULL is returned if
+   the size of the array has been exceeded. The expression node returned
+   remains a part of the array and should not be freed.  */
+
+gfc_constructor *gfc_constructor_lookup (gfc_constructor_base base, int n);
+
+/* Convenience function. Same as ...
+     gfc_constructor *c = gfc_constructor_lookup (base, n);
+     gfc_expr *e = c ? c->expr : NULL;
+*/
+gfc_expr *gfc_constructor_lookup_expr (gfc_constructor_base base, int n);
+
+
+int gfc_constructor_expr_foreach (gfc_constructor *ctor, int(*)(gfc_expr *));
+
+
+void gfc_constructor_swap (gfc_constructor *ctor, int n, int m);
+
+
+
+/* Get the first constructor node in the constructure structure.
+   Returns NULL if there is no such expression.  */
+gfc_constructor *gfc_constructor_first (gfc_constructor_base base);
+
+/* Get the next constructor node in the constructure structure.
+   Returns NULL if there is no next expression.  */
+gfc_constructor *gfc_constructor_next (gfc_constructor *ctor);
+
+/* Remove the gfc_constructor node from the splay tree.  */
+void gfc_constructor_remove (gfc_constructor *);
+
+/* Return first constructor node after offset.  */
+gfc_constructor *gfc_constructor_lookup_next (gfc_constructor_base, int);
+
+#endif /* GFC_CONSTRUCTOR_H */
diff --git a/gcc-4.9/gcc/fortran/convert.c b/gcc-4.9/gcc/fortran/convert.c
new file mode 100644
index 000000000..34c52c810
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/convert.c
@@ -0,0 +1,112 @@
+/* Data type conversion
+   Copyright (C) 1987-2014 Free Software Foundation, Inc.
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+
+/* This file contains the functions for converting expressions to
+   different data types for the translation of the gfortran internal
+   representation to GIMPLE.  The only entry point is `convert'.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "tree.h"
+#include "convert.h"
+
+/* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
+   or validate its data type for a GIMPLE `if' or `while' statement.
+
+   The resulting type should always be `boolean_type_node'.  */
+
+static tree
+truthvalue_conversion (tree expr)
+{
+  switch (TREE_CODE (TREE_TYPE (expr)))
+    {
+    case BOOLEAN_TYPE:
+      if (TREE_TYPE (expr) == boolean_type_node)
+	return expr;
+      else if (COMPARISON_CLASS_P (expr))
+	{
+	  TREE_TYPE (expr) = boolean_type_node;
+	  return expr;
+	}
+      else if (TREE_CODE (expr) == NOP_EXPR)
+        return fold_build1_loc (input_location, NOP_EXPR,
+			    boolean_type_node, TREE_OPERAND (expr, 0));
+      else
+        return fold_build1_loc (input_location, NOP_EXPR, boolean_type_node,
+				expr);
+
+    case INTEGER_TYPE:
+      if (TREE_CODE (expr) == INTEGER_CST)
+	return integer_zerop (expr) ? boolean_false_node : boolean_true_node;
+      else
+        return fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+				expr, build_int_cst (TREE_TYPE (expr), 0));
+
+    default:
+      gcc_unreachable ();
+    }
+}
+
+/* Create an expression whose value is that of EXPR,
+   converted to type TYPE.  The TREE_TYPE of the value
+   is always TYPE.  This function implements all reasonable
+   conversions; callers should filter out those that are
+   not permitted by the language being compiled.  */
+
+tree
+convert (tree type, tree expr)
+{
+  tree e = expr;
+  enum tree_code code;
+
+  if (type == TREE_TYPE (expr))
+    return expr;
+
+  if (TREE_CODE (type) == ERROR_MARK
+      || TREE_CODE (expr) == ERROR_MARK
+      || TREE_CODE (TREE_TYPE (expr)) == ERROR_MARK)
+    return expr;
+
+  gcc_checking_assert (TREE_CODE (TREE_TYPE (expr)) != VOID_TYPE);
+
+  if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (expr)))
+    return fold_build1_loc (input_location, NOP_EXPR, type, expr);
+
+  code = TREE_CODE (type);
+  if (code == VOID_TYPE)
+    return fold_build1_loc (input_location, CONVERT_EXPR, type, e);
+  if (code == BOOLEAN_TYPE)
+    return fold_build1_loc (input_location, NOP_EXPR, type,
+			    truthvalue_conversion (e));
+  if (code == INTEGER_TYPE)
+    return fold (convert_to_integer (type, e));
+  if (code == POINTER_TYPE || code == REFERENCE_TYPE)
+    return fold (convert_to_pointer (type, e));
+  if (code == REAL_TYPE)
+    return fold (convert_to_real (type, e));
+  if (code == COMPLEX_TYPE)
+    return fold (convert_to_complex (type, e));
+  if (code == VECTOR_TYPE)
+    return fold (convert_to_vector (type, e));
+
+  gcc_unreachable ();
+}
+
diff --git a/gcc-4.9/gcc/fortran/cpp.c b/gcc-4.9/gcc/fortran/cpp.c
new file mode 100644
index 000000000..169599003
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/cpp.c
@@ -0,0 +1,1151 @@
+/* Copyright (C) 2008-2014 Free Software Foundation, Inc.
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "tm.h"
+#include "tree.h"
+#include "version.h"
+#include "flags.h"
+
+
+#include "options.h"
+#include "gfortran.h"
+#include "tm_p.h"		/* Target prototypes.  */
+#include "target.h"
+#include "toplev.h"
+#include "diagnostic.h"
+
+#include "../../libcpp/internal.h"
+#include "cpp.h"
+#include "incpath.h"
+#include "cppbuiltin.h"
+#include "mkdeps.h"
+
+#ifndef TARGET_SYSTEM_ROOT
+# define TARGET_SYSTEM_ROOT NULL
+#endif
+
+#ifndef TARGET_CPU_CPP_BUILTINS
+# define TARGET_CPU_CPP_BUILTINS()
+#endif
+
+#ifndef TARGET_OS_CPP_BUILTINS
+# define TARGET_OS_CPP_BUILTINS()
+#endif
+
+#ifndef TARGET_OBJFMT_CPP_BUILTINS
+# define TARGET_OBJFMT_CPP_BUILTINS()
+#endif
+
+
+/* Holds switches parsed by gfc_cpp_handle_option (), but whose
+   handling is deferred to gfc_cpp_init ().  */
+typedef struct
+{
+    enum opt_code code;
+    const char *arg;
+}
+gfc_cpp_deferred_opt_t;
+
+
+/* Defined and undefined macros being queued for output with -dU at
+   the next newline.  */
+typedef struct gfc_cpp_macro_queue
+{
+  struct gfc_cpp_macro_queue *next;	/* Next macro in the list.  */
+  char *macro;				/* The name of the macro if not
+					   defined, the full definition if
+					   defined.  */
+} gfc_cpp_macro_queue;
+static gfc_cpp_macro_queue *cpp_define_queue, *cpp_undefine_queue;
+
+struct gfc_cpp_option_data
+{
+  /* Argument of -cpp, implied by SPEC;
+     if NULL, preprocessing disabled.  */
+  const char *temporary_filename;
+
+  const char *output_filename;          /* -o <arg>  */
+  int preprocess_only;                  /* -E  */
+  int discard_comments;                 /* -C  */
+  int discard_comments_in_macro_exp;    /* -CC  */
+  int print_include_names;              /* -H  */
+  int no_line_commands;                 /* -P  */
+  char dump_macros;                     /* -d[DMNU]  */
+  int dump_includes;                    /* -dI  */
+  int working_directory;                /* -fworking-directory  */
+  int no_predefined;                    /* -undef */
+  int standard_include_paths;           /* -nostdinc */
+  int verbose;                          /* -v */
+  int deps;                             /* -M */
+  int deps_skip_system;                 /* -MM */
+  const char *deps_filename;            /* -M[M]D */
+  const char *deps_filename_user;       /* -MF <arg> */
+  int deps_missing_are_generated;       /* -MG */
+  int deps_phony;                       /* -MP */
+  int warn_date_time;                   /* -Wdate-time */
+
+  const char *multilib;                 /* -imultilib <dir>  */
+  const char *prefix;                   /* -iprefix <dir>  */
+  const char *sysroot;                  /* -isysroot <dir>  */
+
+  /* Options whose handling needs to be deferred until the
+     appropriate cpp-objects are created:
+      -A predicate=answer
+      -D <macro>[=<val>]
+      -U <macro>  */
+  gfc_cpp_deferred_opt_t *deferred_opt;
+  int deferred_opt_count;
+}
+gfc_cpp_option;
+
+/* Structures used with libcpp:  */
+static cpp_options *cpp_option = NULL;
+static cpp_reader *cpp_in = NULL;
+
+/* Encapsulates state used to convert a stream of cpp-tokens into
+   a text file.  */
+static struct
+{
+  FILE *outf;			/* Stream to write to.  */
+  const cpp_token *prev;	/* Previous token.  */
+  const cpp_token *source;	/* Source token for spacing.  */
+  int src_line;			/* Line number currently being written.  */
+  unsigned char printed;	/* Nonzero if something output at line.  */
+  bool first_time;		/* cb_file_change hasn't been called yet.  */
+} print;
+
+/* General output routines.  */
+static void scan_translation_unit (cpp_reader *);
+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_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 *);
+static void cb_def_pragma (cpp_reader *, source_location);
+static void cb_include (cpp_reader *, source_location, const unsigned char *,
+			const char *, int, const cpp_token **);
+static void cb_ident (cpp_reader *, source_location, const cpp_string *);
+static void cb_used_define (cpp_reader *, source_location, cpp_hashnode *);
+static void cb_used_undef (cpp_reader *, source_location, cpp_hashnode *);
+static bool cb_cpp_error (cpp_reader *, int, int, location_t, unsigned int,
+			  const char *, va_list *)
+     ATTRIBUTE_GCC_DIAG(6,0);
+void pp_dir_change (cpp_reader *, const char *);
+
+static int dump_macro (cpp_reader *, cpp_hashnode *, void *);
+static void dump_queued_macros (cpp_reader *);
+
+
+static void
+cpp_define_builtins (cpp_reader *pfile)
+{
+  /* Initialize CPP built-ins; '1' corresponds to 'flag_hosted'
+     in C, defines __STDC_HOSTED__?!  */
+  cpp_init_builtins (pfile, 0);
+
+  /* Initialize GFORTRAN specific builtins.
+     These are documented.  */
+  define_language_independent_builtin_macros (pfile);
+  cpp_define (pfile, "__GFORTRAN__=1");
+  cpp_define (pfile, "_LANGUAGE_FORTRAN=1");
+
+  if (gfc_option.gfc_flag_openmp)
+    cpp_define (pfile, "_OPENMP=201107");
+
+  /* The defines below are necessary for the TARGET_* macros.
+
+     FIXME:  Note that builtin_define_std() actually is a function
+     in c-cppbuiltin.c which uses flags undefined for Fortran.
+     Let's skip this for now. If needed, one needs to look into it
+     once more.  */
+
+# define builtin_define(TXT) cpp_define (pfile, TXT)
+# define builtin_define_std(TXT)
+# define builtin_assert(TXT) cpp_assert (pfile, TXT)
+
+  /* FIXME: Pandora's Box
+    Using the macros below results in multiple breakages:
+     - mingw will fail to compile this file as dependent macros
+       assume to be used in c-cppbuiltin.c only. Further, they use
+       flags only valid/defined in C (same as noted above).
+       [config/i386/mingw32.h, config/i386/cygming.h]
+     - other platforms (not as popular) break similarly
+       [grep for 'builtin_define_with_int_value' in gcc/config/]
+
+  TARGET_CPU_CPP_BUILTINS ();
+  TARGET_OS_CPP_BUILTINS ();
+  TARGET_OBJFMT_CPP_BUILTINS (); */
+
+#undef builtin_define
+#undef builtin_define_std
+#undef builtin_assert
+}
+
+bool
+gfc_cpp_enabled (void)
+{
+  return gfc_cpp_option.temporary_filename != NULL;
+}
+
+bool
+gfc_cpp_preprocess_only (void)
+{
+  return gfc_cpp_option.preprocess_only;
+}
+
+bool
+gfc_cpp_makedep (void)
+{
+  return gfc_cpp_option.deps;
+}
+
+void
+gfc_cpp_add_dep (const char *name, bool system)
+{
+  if (!gfc_cpp_option.deps_skip_system || !system)
+    deps_add_dep (cpp_get_deps (cpp_in), name);
+}
+
+void
+gfc_cpp_add_target (const char *name)
+{
+  deps_add_target (cpp_get_deps (cpp_in), name, 0);
+}
+
+
+const char *
+gfc_cpp_temporary_file (void)
+{
+  return gfc_cpp_option.temporary_filename;
+}
+
+void
+gfc_cpp_init_options (unsigned int decoded_options_count,
+		      struct cl_decoded_option *decoded_options ATTRIBUTE_UNUSED)
+{
+  /* Do not create any objects from libcpp here. If no
+     preprocessing is requested, this would be wasted
+     time and effort.
+
+     See gfc_cpp_post_options() instead.  */
+
+  gfc_cpp_option.temporary_filename = NULL;
+  gfc_cpp_option.output_filename = NULL;
+  gfc_cpp_option.preprocess_only = 0;
+  gfc_cpp_option.discard_comments = 1;
+  gfc_cpp_option.discard_comments_in_macro_exp = 1;
+  gfc_cpp_option.print_include_names = 0;
+  gfc_cpp_option.no_line_commands = 0;
+  gfc_cpp_option.dump_macros = '\0';
+  gfc_cpp_option.dump_includes = 0;
+  gfc_cpp_option.working_directory = -1;
+  gfc_cpp_option.no_predefined = 0;
+  gfc_cpp_option.standard_include_paths = 1;
+  gfc_cpp_option.verbose = 0;
+  gfc_cpp_option.warn_date_time = 0;
+  gfc_cpp_option.deps = 0;
+  gfc_cpp_option.deps_skip_system = 0;
+  gfc_cpp_option.deps_phony = 0;
+  gfc_cpp_option.deps_missing_are_generated = 0;
+  gfc_cpp_option.deps_filename = NULL;
+  gfc_cpp_option.deps_filename_user = NULL;
+
+  gfc_cpp_option.multilib = NULL;
+  gfc_cpp_option.prefix = NULL;
+  gfc_cpp_option.sysroot = TARGET_SYSTEM_ROOT;
+
+  gfc_cpp_option.deferred_opt = XNEWVEC (gfc_cpp_deferred_opt_t,
+					 decoded_options_count);
+  gfc_cpp_option.deferred_opt_count = 0;
+}
+
+int
+gfc_cpp_handle_option (size_t scode, const char *arg, int value ATTRIBUTE_UNUSED)
+{
+  int result = 1;
+  enum opt_code code = (enum opt_code) scode;
+
+  switch (code)
+  {
+    default:
+      result = 0;
+      break;
+
+    case OPT_cpp_:
+      gfc_cpp_option.temporary_filename = arg;
+      break;
+
+    case OPT_nocpp:
+      gfc_cpp_option.temporary_filename = 0L;
+      break;
+
+    case OPT_d:
+      for ( ; *arg; ++arg)
+        switch (*arg)
+	{
+	  case 'D':
+	  case 'M':
+	  case 'N':
+	  case 'U':
+	    gfc_cpp_option.dump_macros = *arg;
+	    break;
+
+	  case 'I':
+	    gfc_cpp_option.dump_includes = 1;
+	    break;
+	}
+      break;
+
+    case OPT_fworking_directory:
+      gfc_cpp_option.working_directory = value;
+      break;
+
+    case OPT_idirafter:
+      gfc_cpp_add_include_path_after (xstrdup(arg), true);
+      break;
+
+    case OPT_imultilib:
+      gfc_cpp_option.multilib = arg;
+      break;
+
+    case OPT_iprefix:
+      gfc_cpp_option.prefix = arg;
+      break;
+
+    case OPT_isysroot:
+      gfc_cpp_option.sysroot = arg;
+      break;
+
+    case OPT_iquote:
+    case OPT_isystem:
+      gfc_cpp_add_include_path (xstrdup(arg), true);
+      break;
+
+    case OPT_nostdinc:
+      gfc_cpp_option.standard_include_paths = value;
+      break;
+
+    case OPT_o:
+      if (!gfc_cpp_option.output_filename)
+	gfc_cpp_option.output_filename = arg;
+      else
+	gfc_fatal_error ("output filename specified twice");
+      break;
+
+    case OPT_undef:
+      gfc_cpp_option.no_predefined = value;
+      break;
+
+    case OPT_v:
+      gfc_cpp_option.verbose = value;
+      break;
+
+    case OPT_Wdate_time:
+      gfc_cpp_option.warn_date_time = value;
+      break;
+
+    case OPT_A:
+    case OPT_D:
+    case OPT_U:
+      gfc_cpp_option.deferred_opt[gfc_cpp_option.deferred_opt_count].code = code;
+      gfc_cpp_option.deferred_opt[gfc_cpp_option.deferred_opt_count].arg = arg;
+      gfc_cpp_option.deferred_opt_count++;
+      break;
+
+    case OPT_C:
+      gfc_cpp_option.discard_comments = 0;
+      break;
+
+    case OPT_CC:
+      gfc_cpp_option.discard_comments = 0;
+      gfc_cpp_option.discard_comments_in_macro_exp = 0;
+      break;
+
+    case OPT_E:
+      gfc_cpp_option.preprocess_only = 1;
+      break;
+
+    case OPT_H:
+      gfc_cpp_option.print_include_names = 1;
+      break;
+
+    case OPT_MM:
+      gfc_cpp_option.deps_skip_system = 1;
+      /* fall through */
+
+    case OPT_M:
+      gfc_cpp_option.deps = 1;
+      break;
+
+    case OPT_MMD:
+      gfc_cpp_option.deps_skip_system = 1;
+      /* fall through */
+
+    case OPT_MD:
+      gfc_cpp_option.deps = 1;
+      gfc_cpp_option.deps_filename = arg;
+      break;
+
+    case OPT_MF:
+      /* If specified multiple times, last one wins.  */
+      gfc_cpp_option.deps_filename_user = arg;
+      break;
+
+    case OPT_MG:
+      gfc_cpp_option.deps_missing_are_generated = 1;
+      break;
+
+    case OPT_MP:
+      gfc_cpp_option.deps_phony = 1;
+      break;
+
+    case OPT_MQ:
+    case OPT_MT:
+      gfc_cpp_option.deferred_opt[gfc_cpp_option.deferred_opt_count].code = code;
+      gfc_cpp_option.deferred_opt[gfc_cpp_option.deferred_opt_count].arg = arg;
+      gfc_cpp_option.deferred_opt_count++;
+      break;
+
+    case OPT_P:
+      gfc_cpp_option.no_line_commands = 1;
+      break;
+  }
+
+  return result;
+}
+
+
+void
+gfc_cpp_post_options (void)
+{
+  /* Any preprocessing-related option without '-cpp' is considered
+     an error.  */
+  if (!gfc_cpp_enabled ()
+      && (gfc_cpp_preprocess_only ()
+	  || gfc_cpp_makedep ()
+	  || !gfc_cpp_option.discard_comments
+	  || !gfc_cpp_option.discard_comments_in_macro_exp
+	  || gfc_cpp_option.print_include_names
+	  || gfc_cpp_option.no_line_commands
+	  || gfc_cpp_option.dump_macros
+	  || gfc_cpp_option.dump_includes))
+    gfc_fatal_error("To enable preprocessing, use -cpp");
+
+  if (!gfc_cpp_enabled ())
+    return;
+
+  cpp_in = cpp_create_reader (CLK_GNUC89, NULL, line_table);
+  gcc_assert (cpp_in);
+
+  /* The cpp_options-structure defines far more flags than those set here.
+     If any other is implemented, see c-opt.c (sanitize_cpp_opts) for
+     inter-option dependencies that may need to be enforced.  */
+  cpp_option = cpp_get_options (cpp_in);
+  gcc_assert (cpp_option);
+
+  /* TODO: allow non-traditional modes, e.g. by -cpp-std=...?  */
+  cpp_option->traditional = 1;
+  cpp_option->cplusplus_comments = 0;
+
+  cpp_option->cpp_pedantic = pedantic;
+
+  cpp_option->dollars_in_ident = gfc_option.flag_dollar_ok;
+  cpp_option->discard_comments = gfc_cpp_option.discard_comments;
+  cpp_option->discard_comments_in_macro_exp = gfc_cpp_option.discard_comments_in_macro_exp;
+  cpp_option->print_include_names = gfc_cpp_option.print_include_names;
+  cpp_option->preprocessed = gfc_option.flag_preprocessed;
+  cpp_option->warn_date_time = gfc_cpp_option.warn_date_time;
+
+  if (gfc_cpp_makedep ())
+    {
+      cpp_option->deps.style = DEPS_USER;
+      cpp_option->deps.phony_targets = gfc_cpp_option.deps_phony;
+      cpp_option->deps.missing_files = gfc_cpp_option.deps_missing_are_generated;
+
+      /* -MF <arg> overrides -M[M]D.  */
+      if (gfc_cpp_option.deps_filename_user)
+	gfc_cpp_option.deps_filename = gfc_cpp_option.deps_filename_user;
+  }
+
+  if (gfc_cpp_option.working_directory == -1)
+    gfc_cpp_option.working_directory = (debug_info_level != DINFO_LEVEL_NONE);
+
+  cpp_post_options (cpp_in);
+
+  gfc_cpp_register_include_paths ();
+}
+
+
+void
+gfc_cpp_init_0 (void)
+{
+  struct cpp_callbacks *cb;
+
+  cb = cpp_get_callbacks (cpp_in);
+  cb->file_change = cb_file_change;
+  cb->line_change = cb_line_change;
+  cb->ident = cb_ident;
+  cb->def_pragma = cb_def_pragma;
+  cb->error = cb_cpp_error;
+
+  if (gfc_cpp_option.dump_includes)
+    cb->include = cb_include;
+
+  if ((gfc_cpp_option.dump_macros == 'D')
+      || (gfc_cpp_option.dump_macros == 'N'))
+    {
+      cb->define = cb_define;
+      cb->undef  = cb_undef;
+    }
+
+  if (gfc_cpp_option.dump_macros == 'U')
+    {
+      cb->before_define = dump_queued_macros;
+      cb->used_define = cb_used_define;
+      cb->used_undef = cb_used_undef;
+    }
+
+  /* Initialize the print structure.  Setting print.src_line to -1 here is
+     a trick to guarantee that the first token of the file will cause
+     a linemarker to be output by maybe_print_line.  */
+  print.src_line = -1;
+  print.printed = 0;
+  print.prev = 0;
+  print.first_time = 1;
+
+  if (gfc_cpp_preprocess_only ())
+    {
+      if (gfc_cpp_option.output_filename)
+	{
+	  /* This needs cheating: with "-E -o <file>", the user wants the
+	     preprocessed output in <file>. However, if nothing is done
+	     about it <file> is also used for assembler output. Hence, it
+	     is necessary to redirect assembler output (actually nothing
+	     as -E implies -fsyntax-only) to another file, otherwise the
+	     output from preprocessing is lost.  */
+	  asm_file_name = gfc_cpp_option.temporary_filename;
+
+	  print.outf = fopen (gfc_cpp_option.output_filename, "w");
+	  if (print.outf == NULL)
+	    gfc_fatal_error ("opening output file %s: %s",
+			     gfc_cpp_option.output_filename,
+			     xstrerror (errno));
+	}
+      else
+	print.outf = stdout;
+    }
+  else
+    {
+      print.outf = fopen (gfc_cpp_option.temporary_filename, "w");
+      if (print.outf == NULL)
+	gfc_fatal_error ("opening output file %s: %s",
+			 gfc_cpp_option.temporary_filename, xstrerror (errno));
+    }
+
+  gcc_assert(cpp_in);
+  if (!cpp_read_main_file (cpp_in, gfc_source_file))
+    errorcount++;
+}
+
+void
+gfc_cpp_init (void)
+{
+  int i;
+
+  if (gfc_option.flag_preprocessed)
+    return;
+
+  cpp_change_file (cpp_in, LC_RENAME, _("<built-in>"));
+  if (!gfc_cpp_option.no_predefined)
+    {
+      /* Make sure all of the builtins about to be declared have
+	BUILTINS_LOCATION has their source_location.  */
+      source_location builtins_loc = BUILTINS_LOCATION;
+      cpp_force_token_locations (cpp_in, &builtins_loc);
+
+      cpp_define_builtins (cpp_in);
+
+      cpp_stop_forcing_token_locations (cpp_in);
+    }
+
+  /* Handle deferred options from command-line.  */
+  cpp_change_file (cpp_in, LC_RENAME, _("<command-line>"));
+
+  for (i = 0; i < gfc_cpp_option.deferred_opt_count; i++)
+    {
+      gfc_cpp_deferred_opt_t *opt = &gfc_cpp_option.deferred_opt[i];
+
+      if (opt->code == OPT_D)
+	cpp_define (cpp_in, opt->arg);
+      else if (opt->code == OPT_U)
+	cpp_undef (cpp_in, opt->arg);
+      else if (opt->code == OPT_A)
+	{
+	  if (opt->arg[0] == '-')
+	    cpp_unassert (cpp_in, opt->arg + 1);
+	  else
+	    cpp_assert (cpp_in, opt->arg);
+	}
+      else if (opt->code == OPT_MT || opt->code == OPT_MQ)
+	deps_add_target (cpp_get_deps (cpp_in),
+			 opt->arg, opt->code == OPT_MQ);
+    }
+
+  if (gfc_cpp_option.working_directory
+      && gfc_cpp_option.preprocess_only && !gfc_cpp_option.no_line_commands)
+    pp_dir_change (cpp_in, get_src_pwd ());
+}
+
+bool
+gfc_cpp_preprocess (const char *source_file)
+{
+  if (!gfc_cpp_enabled ())
+    return false;
+
+  cpp_change_file (cpp_in, LC_RENAME, source_file);
+
+  if (cpp_option->traditional)
+    scan_translation_unit_trad (cpp_in);
+  else
+    scan_translation_unit (cpp_in);
+
+  /* -dM command line option.  */
+  if (gfc_cpp_preprocess_only () &&
+      gfc_cpp_option.dump_macros == 'M')
+    {
+      putc ('\n', print.outf);
+      cpp_forall_identifiers (cpp_in, dump_macro, NULL);
+    }
+
+  putc ('\n', print.outf);
+
+  if (!gfc_cpp_preprocess_only ()
+      || (gfc_cpp_preprocess_only () && gfc_cpp_option.output_filename))
+    fclose (print.outf);
+
+  return true;
+}
+
+void
+gfc_cpp_done (void)
+{
+  if (!gfc_cpp_enabled ())
+    return;
+
+  gcc_assert (cpp_in);
+
+  if (gfc_cpp_makedep ())
+    {
+      if (gfc_cpp_option.deps_filename)
+	{
+	  FILE *f = fopen (gfc_cpp_option.deps_filename, "w");
+	  if (f)
+	    {
+	      cpp_finish (cpp_in, f);
+	      fclose (f);
+	    }
+	  else
+	    gfc_fatal_error ("opening output file %s: %s",
+			     gfc_cpp_option.deps_filename,
+			     xstrerror (errno));
+	}
+      else
+	cpp_finish (cpp_in, stdout);
+    }
+
+  cpp_undef_all (cpp_in);
+  cpp_clear_file_cache (cpp_in);
+}
+
+/* PATH must be malloc-ed and NULL-terminated.  */
+void
+gfc_cpp_add_include_path (char *path, bool user_supplied)
+{
+  /* CHAIN sets cpp_dir->sysp which differs from 0 if PATH is a system
+     include path. Fortran does not define any system include paths.  */
+  int cxx_aware = 0;
+
+  add_path (path, BRACKET, cxx_aware, user_supplied);
+}
+
+void
+gfc_cpp_add_include_path_after (char *path, bool user_supplied)
+{
+  int cxx_aware = 0;
+  add_path (path, AFTER, cxx_aware, user_supplied);
+}
+
+void
+gfc_cpp_register_include_paths (void)
+{
+  int cxx_stdinc = 0;
+  register_include_chains (cpp_in, gfc_cpp_option.sysroot,
+			   gfc_cpp_option.prefix, gfc_cpp_option.multilib,
+			   gfc_cpp_option.standard_include_paths, cxx_stdinc,
+			   gfc_cpp_option.verbose);
+}
+
+
+
+static void scan_translation_unit_trad (cpp_reader *);
+static void account_for_newlines (const unsigned char *, size_t);
+static int dump_macro (cpp_reader *, cpp_hashnode *, void *);
+
+static void print_line (source_location, const char *);
+static void maybe_print_line (source_location);
+
+
+/* Writes out the preprocessed file, handling spacing and paste
+   avoidance issues.  */
+static void
+scan_translation_unit (cpp_reader *pfile)
+{
+  bool avoid_paste = false;
+
+  print.source = NULL;
+  for (;;)
+    {
+      const cpp_token *token = cpp_get_token (pfile);
+
+      if (token->type == CPP_PADDING)
+	{
+	  avoid_paste = true;
+	  if (print.source == NULL
+	      || (!(print.source->flags & PREV_WHITE)
+		  && token->val.source == NULL))
+	    print.source = token->val.source;
+	  continue;
+	}
+
+      if (token->type == CPP_EOF)
+	break;
+
+      /* Subtle logic to output a space if and only if necessary.  */
+      if (avoid_paste)
+	{
+	  if (print.source == NULL)
+	    print.source = token;
+	  if (print.source->flags & PREV_WHITE
+	      || (print.prev
+		  && cpp_avoid_paste (pfile, print.prev, token))
+	      || (print.prev == NULL && token->type == CPP_HASH))
+	    putc (' ', print.outf);
+	}
+      else if (token->flags & PREV_WHITE)
+	putc (' ', print.outf);
+
+      avoid_paste = false;
+      print.source = NULL;
+      print.prev = token;
+      cpp_output_token (token, print.outf);
+
+      if (token->type == CPP_COMMENT)
+	account_for_newlines (token->val.str.text, token->val.str.len);
+    }
+}
+
+/* Adjust print.src_line for newlines embedded in output.  */
+static void
+account_for_newlines (const unsigned char *str, size_t len)
+{
+  while (len--)
+    if (*str++ == '\n')
+      print.src_line++;
+}
+
+/* Writes out a traditionally preprocessed file.  */
+static void
+scan_translation_unit_trad (cpp_reader *pfile)
+{
+  while (_cpp_read_logical_line_trad (pfile))
+    {
+      size_t len = pfile->out.cur - pfile->out.base;
+      maybe_print_line (pfile->out.first_line);
+      fwrite (pfile->out.base, 1, len, print.outf);
+      print.printed = 1;
+      if (!CPP_OPTION (pfile, discard_comments))
+	account_for_newlines (pfile->out.base, len);
+    }
+}
+
+/* If the token read on logical line LINE needs to be output on a
+   different line to the current one, output the required newlines or
+   a line marker.  */
+static void
+maybe_print_line (source_location src_loc)
+{
+  const struct line_map *map = linemap_lookup (line_table, src_loc);
+  int src_line = SOURCE_LINE (map, src_loc);
+
+  /* End the previous line of text.  */
+  if (print.printed)
+    {
+      putc ('\n', print.outf);
+      print.src_line++;
+      print.printed = 0;
+    }
+
+  if (src_line >= print.src_line && src_line < print.src_line + 8)
+    {
+      while (src_line > print.src_line)
+	{
+	  putc ('\n', print.outf);
+	  print.src_line++;
+	}
+    }
+  else
+    print_line (src_loc, "");
+}
+
+/* Output a line marker for logical line LINE.  Special flags are "1"
+   or "2" indicating entering or leaving a file.  */
+static void
+print_line (source_location src_loc, const char *special_flags)
+{
+  /* End any previous line of text.  */
+  if (print.printed)
+    putc ('\n', print.outf);
+  print.printed = 0;
+
+  if (!gfc_cpp_option.no_line_commands)
+    {
+      expanded_location loc;
+      size_t to_file_len;
+      unsigned char *to_file_quoted;
+      unsigned char *p;
+      int sysp;
+
+      loc = expand_location (src_loc);
+      to_file_len = strlen (loc.file);
+      to_file_quoted = (unsigned char *) alloca (to_file_len * 4 + 1);
+
+      print.src_line = loc.line;
+
+      /* cpp_quote_string does not nul-terminate, so we have to do it
+	 ourselves.  */
+      p = cpp_quote_string (to_file_quoted,
+			    (const unsigned char *) loc.file, to_file_len);
+      *p = '\0';
+      fprintf (print.outf, "# %u \"%s\"%s",
+	       print.src_line == 0 ? 1 : print.src_line,
+	       to_file_quoted, special_flags);
+
+      sysp = in_system_header_at (src_loc);
+      if (sysp == 2)
+	fputs (" 3 4", print.outf);
+      else if (sysp == 1)
+	fputs (" 3", print.outf);
+
+      putc ('\n', print.outf);
+    }
+}
+
+static void
+cb_file_change (cpp_reader * ARG_UNUSED (pfile), const struct line_map *map)
+{
+  const char *flags = "";
+
+  if (gfc_cpp_option.no_line_commands)
+    return;
+
+  if (!map)
+    return;
+
+      if (print.first_time)
+	{
+	  /* Avoid printing foo.i when the main file is foo.c.  */
+	  if (!cpp_get_options (cpp_in)->preprocessed)
+	    print_line (map->start_location, flags);
+	  print.first_time = 0;
+	}
+      else
+	{
+	  /* 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);
+	      maybe_print_line (LAST_SOURCE_LINE_LOCATION (from));
+	    }
+	  if (map->reason == LC_ENTER)
+	    flags = " 1";
+	  else if (map->reason == LC_LEAVE)
+	    flags = " 2";
+	  print_line (map->start_location, flags);
+	}
+
+}
+
+/* Called when a line of output is started.  TOKEN is the first token
+   of the line, and at end of file will be CPP_EOF.  */
+static void
+cb_line_change (cpp_reader *pfile, const cpp_token *token,
+		int parsing_args)
+{
+  source_location src_loc = token->src_loc;
+
+  if (token->type == CPP_EOF || parsing_args)
+    return;
+
+  maybe_print_line (src_loc);
+  print.prev = 0;
+  print.source = 0;
+
+  /* Supply enough spaces to put this token in its original column,
+     one space per column greater than 2, since scan_translation_unit
+     will provide a space if PREV_WHITE.  Don't bother trying to
+     reconstruct tabs; we can't get it right in general, and nothing
+     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);
+      int spaces = SOURCE_COLUMN (map, src_loc) - 2;
+      print.printed = 1;
+
+      while (-- spaces >= 0)
+	putc (' ', print.outf);
+    }
+}
+
+static void
+cb_ident (cpp_reader *pfile ATTRIBUTE_UNUSED, source_location line,
+	  const cpp_string *str)
+{
+  maybe_print_line (line);
+  fprintf (print.outf, "#ident %s\n", str->text);
+  print.src_line++;
+}
+
+static void
+cb_define (cpp_reader *pfile ATTRIBUTE_UNUSED, source_location line,
+           cpp_hashnode *node ATTRIBUTE_UNUSED)
+{
+  maybe_print_line (line);
+  fputs ("#define ", print.outf);
+
+  /* 'D' is whole definition; 'N' is name only.  */
+  if (gfc_cpp_option.dump_macros == 'D')
+    fputs ((const char *) cpp_macro_definition (pfile, node),
+	   print.outf);
+  else
+    fputs ((const char *) NODE_NAME (node), print.outf);
+
+  putc ('\n', print.outf);
+  if (LOCATION_LINE (line) != 0)
+    print.src_line++;
+}
+
+static void
+cb_undef (cpp_reader *pfile ATTRIBUTE_UNUSED, source_location line,
+	  cpp_hashnode *node)
+{
+  maybe_print_line (line);
+  fprintf (print.outf, "#undef %s\n", NODE_NAME (node));
+  print.src_line++;
+}
+
+static void
+cb_include (cpp_reader *pfile ATTRIBUTE_UNUSED, source_location line,
+	    const unsigned char *dir, const char *header, int angle_brackets,
+	    const cpp_token **comments)
+{
+  maybe_print_line (line);
+  if (angle_brackets)
+    fprintf (print.outf, "#%s <%s>", dir, header);
+  else
+    fprintf (print.outf, "#%s \"%s\"", dir, header);
+
+  if (comments != NULL)
+    {
+      while (*comments != NULL)
+	{
+	  if ((*comments)->flags & PREV_WHITE)
+	    putc (' ', print.outf);
+	  cpp_output_token (*comments, print.outf);
+	  ++comments;
+	}
+    }
+
+  putc ('\n', print.outf);
+  print.src_line++;
+}
+
+/* Dump out the hash table.  */
+static int
+dump_macro (cpp_reader *pfile, cpp_hashnode *node, void *v ATTRIBUTE_UNUSED)
+{
+  if (node->type == NT_MACRO && !(node->flags & NODE_BUILTIN))
+    {
+      fputs ("#define ", print.outf);
+      fputs ((const char *) cpp_macro_definition (pfile, node),
+	     print.outf);
+      putc ('\n', print.outf);
+      print.src_line++;
+    }
+
+  return 1;
+}
+
+static void
+cb_used_define (cpp_reader *pfile, source_location line ATTRIBUTE_UNUSED,
+		cpp_hashnode *node)
+{
+  gfc_cpp_macro_queue *q;
+  q = XNEW (gfc_cpp_macro_queue);
+  q->macro = xstrdup ((const char *) cpp_macro_definition (pfile, node));
+  q->next = cpp_define_queue;
+  cpp_define_queue = q;
+}
+
+/* Callback from cpp_error for PFILE to print diagnostics from the
+   preprocessor.  The diagnostic is of type LEVEL, with REASON set
+   to the reason code if LEVEL is represents a warning, at location
+   LOCATION, with column number possibly overridden by COLUMN_OVERRIDE
+   if not zero; MSG is the translated message and AP the arguments.
+   Returns true if a diagnostic was emitted, false otherwise.  */
+
+static bool
+cb_cpp_error (cpp_reader *pfile ATTRIBUTE_UNUSED, int level, int reason,
+	      location_t location, unsigned int column_override,
+	      const char *msg, va_list *ap)
+{
+  diagnostic_info diagnostic;
+  diagnostic_t dlevel;
+  bool save_warn_system_headers = global_dc->dc_warn_system_headers;
+  bool ret;
+
+  switch (level)
+    {
+    case CPP_DL_WARNING_SYSHDR:
+      global_dc->dc_warn_system_headers = 1;
+      /* Fall through.  */
+    case CPP_DL_WARNING:
+      dlevel = DK_WARNING;
+      break;
+    case CPP_DL_PEDWARN:
+      dlevel = DK_PEDWARN;
+      break;
+    case CPP_DL_ERROR:
+      dlevel = DK_ERROR;
+      break;
+    case CPP_DL_ICE:
+      dlevel = DK_ICE;
+      break;
+    case CPP_DL_NOTE:
+      dlevel = DK_NOTE;
+      break;
+    case CPP_DL_FATAL:
+      dlevel = DK_FATAL;
+      break;
+    default:
+      gcc_unreachable ();
+    }
+  diagnostic_set_info_translated (&diagnostic, msg, ap,
+				  location, dlevel);
+  if (column_override)
+    diagnostic_override_column (&diagnostic, column_override);
+  if (reason == CPP_W_WARNING_DIRECTIVE)
+    diagnostic_override_option_index (&diagnostic, OPT_Wcpp);
+  ret = report_diagnostic (&diagnostic);
+  if (level == CPP_DL_WARNING_SYSHDR)
+    global_dc->dc_warn_system_headers = save_warn_system_headers;
+  return ret;
+}
+
+/* Callback called when -fworking-director and -E to emit working
+   directory in cpp output file.  */
+
+void
+pp_dir_change (cpp_reader *pfile ATTRIBUTE_UNUSED, const char *dir)
+{
+  size_t to_file_len = strlen (dir);
+  unsigned char *to_file_quoted =
+     (unsigned char *) alloca (to_file_len * 4 + 1);
+  unsigned char *p;
+
+  /* cpp_quote_string does not nul-terminate, so we have to do it ourselves.  */
+  p = cpp_quote_string (to_file_quoted, (const unsigned char *) dir, to_file_len);
+  *p = '\0';
+  fprintf (print.outf, "# 1 \"%s//\"\n", to_file_quoted);
+}
+
+/* Copy a #pragma directive to the preprocessed output.  */
+static void
+cb_def_pragma (cpp_reader *pfile, source_location line)
+{
+  maybe_print_line (line);
+  fputs ("#pragma ", print.outf);
+  cpp_output_line (pfile, print.outf);
+  print.src_line++;
+}
+
+static void
+cb_used_undef (cpp_reader *pfile ATTRIBUTE_UNUSED,
+	       source_location line ATTRIBUTE_UNUSED,
+	       cpp_hashnode *node)
+{
+  gfc_cpp_macro_queue *q;
+  q = XNEW (gfc_cpp_macro_queue);
+  q->macro = xstrdup ((const char *) NODE_NAME (node));
+  q->next = cpp_undefine_queue;
+  cpp_undefine_queue = q;
+}
+
+static void
+dump_queued_macros (cpp_reader *pfile ATTRIBUTE_UNUSED)
+{
+  gfc_cpp_macro_queue *q;
+
+  /* End the previous line of text.  */
+  if (print.printed)
+    {
+      putc ('\n', print.outf);
+      print.src_line++;
+      print.printed = 0;
+    }
+
+  for (q = cpp_define_queue; q;)
+    {
+      gfc_cpp_macro_queue *oq;
+      fputs ("#define ", print.outf);
+      fputs (q->macro, print.outf);
+      putc ('\n', print.outf);
+      print.src_line++;
+      oq = q;
+      q = q->next;
+      free (oq->macro);
+      free (oq);
+    }
+  cpp_define_queue = NULL;
+  for (q = cpp_undefine_queue; q;)
+    {
+      gfc_cpp_macro_queue *oq;
+      fprintf (print.outf, "#undef %s\n", q->macro);
+      print.src_line++;
+      oq = q;
+      q = q->next;
+      free (oq->macro);
+      free (oq);
+    }
+  cpp_undefine_queue = NULL;
+}
diff --git a/gcc-4.9/gcc/fortran/cpp.h b/gcc-4.9/gcc/fortran/cpp.h
new file mode 100644
index 000000000..71fd6aa1e
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/cpp.h
@@ -0,0 +1,55 @@
+/* Copyright (C) 2008-2014 Free Software Foundation, Inc.
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+#ifndef GFC_CPP_H
+#define GFC_CPP_H
+
+/* Returns true if preprocessing is enabled, false otherwise.  */
+bool gfc_cpp_enabled (void);
+
+bool gfc_cpp_preprocess_only (void);
+
+bool gfc_cpp_makedep (void);
+
+void gfc_cpp_add_dep (const char *name, bool system);
+
+void gfc_cpp_add_target (const char *name);
+
+const char *gfc_cpp_temporary_file (void);
+
+
+void gfc_cpp_init_0 (void);
+void gfc_cpp_init (void);
+
+void gfc_cpp_init_options (unsigned int decoded_options_count,
+			   struct cl_decoded_option *decoded_options);
+
+int gfc_cpp_handle_option(size_t scode, const char *arg, int value);
+
+void gfc_cpp_post_options (void);
+
+bool gfc_cpp_preprocess (const char *source_file);
+
+void gfc_cpp_done (void);
+
+void gfc_cpp_add_include_path (char *path, bool user_supplied);
+void gfc_cpp_add_include_path_after (char *path, bool user_supplied);
+
+void gfc_cpp_register_include_paths (void);
+
+#endif /* GFC_CPP_H */
diff --git a/gcc-4.9/gcc/fortran/data.c b/gcc-4.9/gcc/fortran/data.c
new file mode 100644
index 000000000..8b270ac30
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/data.c
@@ -0,0 +1,708 @@
+/* Supporting functions for resolving DATA statement.
+   Copyright (C) 2002-2014 Free Software Foundation, Inc.
+   Contributed by Lifang Zeng <zlf605@hotmail.com>
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+
+/* Notes for DATA statement implementation:
+									       
+   We first assign initial value to each symbol by gfc_assign_data_value
+   during resolving DATA statement. Refer to check_data_variable and
+   traverse_data_list in resolve.c.
+									       
+   The complexity exists in the handling of array section, implied do
+   and array of struct appeared in DATA statement.
+									       
+   We call gfc_conv_structure, gfc_con_array_array_initializer,
+   etc., to convert the initial value. Refer to trans-expr.c and
+   trans-array.c.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "gfortran.h"
+#include "data.h"
+#include "constructor.h"
+
+static void formalize_init_expr (gfc_expr *);
+
+/* Calculate the array element offset.  */
+
+static void
+get_array_index (gfc_array_ref *ar, mpz_t *offset)
+{
+  gfc_expr *e;
+  int i;
+  mpz_t delta;
+  mpz_t tmp;
+
+  mpz_init (tmp);
+  mpz_set_si (*offset, 0);
+  mpz_init_set_si (delta, 1);
+  for (i = 0; i < ar->dimen; i++)
+    {
+      e = gfc_copy_expr (ar->start[i]);
+      gfc_simplify_expr (e, 1);
+
+      if ((gfc_is_constant_expr (ar->as->lower[i]) == 0)
+	  || (gfc_is_constant_expr (ar->as->upper[i]) == 0)
+	  || (gfc_is_constant_expr (e) == 0))
+	gfc_error ("non-constant array in DATA statement %L", &ar->where);
+
+      mpz_set (tmp, e->value.integer);
+      gfc_free_expr (e);
+      mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
+      mpz_mul (tmp, tmp, delta);
+      mpz_add (*offset, tmp, *offset);
+
+      mpz_sub (tmp, ar->as->upper[i]->value.integer,
+	       ar->as->lower[i]->value.integer);
+      mpz_add_ui (tmp, tmp, 1);
+      mpz_mul (delta, tmp, delta);
+    }
+  mpz_clear (delta);
+  mpz_clear (tmp);
+}
+
+/* Find if there is a constructor which component is equal to COM.
+   TODO: remove this, use symbol.c(gfc_find_component) instead.  */
+
+static gfc_constructor *
+find_con_by_component (gfc_component *com, gfc_constructor_base base)
+{
+  gfc_constructor *c;
+
+  for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
+    if (com == c->n.component)
+      return c;
+
+  return NULL;
+}
+
+
+/* Create a character type initialization expression from RVALUE.
+   TS [and REF] describe [the substring of] the variable being initialized.
+   INIT is the existing initializer, not NULL.  Initialization is performed
+   according to normal assignment rules.  */
+
+static gfc_expr *
+create_character_initializer (gfc_expr *init, gfc_typespec *ts,
+			      gfc_ref *ref, gfc_expr *rvalue)
+{
+  int len, start, end;
+  gfc_char_t *dest;
+  bool alloced_init = false;
+	    
+  gfc_extract_int (ts->u.cl->length, &len);
+
+  if (init == NULL)
+    {
+      /* Create a new initializer.  */
+      init = gfc_get_character_expr (ts->kind, NULL, NULL, len);
+      init->ts = *ts;
+      alloced_init = true;
+    }
+
+  dest = init->value.character.string;
+
+  if (ref)
+    {
+      gfc_expr *start_expr, *end_expr;
+
+      gcc_assert (ref->type == REF_SUBSTRING);
+
+      /* Only set a substring of the destination.  Fortran substring bounds
+	 are one-based [start, end], we want zero based [start, end).  */
+      start_expr = gfc_copy_expr (ref->u.ss.start);
+      end_expr = gfc_copy_expr (ref->u.ss.end);
+
+      if ((!gfc_simplify_expr(start_expr, 1))
+	  || !(gfc_simplify_expr(end_expr, 1)))
+	{
+	  gfc_error ("failure to simplify substring reference in DATA "
+		     "statement at %L", &ref->u.ss.start->where);
+	  gfc_free_expr (start_expr);
+	  gfc_free_expr (end_expr);
+	  if (alloced_init)
+	    gfc_free_expr (init);
+	  return NULL;
+	}
+
+      gfc_extract_int (start_expr, &start);
+      gfc_free_expr (start_expr);
+      start--;
+      gfc_extract_int (end_expr, &end);
+      gfc_free_expr (end_expr);
+    }
+  else
+    {
+      /* Set the whole string.  */
+      start = 0;
+      end = len;
+    }
+
+  /* Copy the initial value.  */
+  if (rvalue->ts.type == BT_HOLLERITH)
+    len = rvalue->representation.length - rvalue->ts.u.pad;
+  else
+    len = rvalue->value.character.length;
+
+  if (len > end - start)
+    {
+      gfc_warning_now ("Initialization string starting at %L was "
+		       "truncated to fit the variable (%d/%d)",
+		       &rvalue->where, end - start, len);
+      len = end - start;
+    }
+
+  if (rvalue->ts.type == BT_HOLLERITH)
+    {
+      int i;
+      for (i = 0; i < len; i++)
+	dest[start+i] = rvalue->representation.string[i];
+    }
+  else
+    memcpy (&dest[start], rvalue->value.character.string,
+	    len * sizeof (gfc_char_t));
+
+  /* Pad with spaces.  Substrings will already be blanked.  */
+  if (len < end - start && ref == NULL)
+    gfc_wide_memset (&dest[start + len], ' ', end - (start + len));
+
+  if (rvalue->ts.type == BT_HOLLERITH)
+    {
+      init->representation.length = init->value.character.length;
+      init->representation.string
+	= gfc_widechar_to_char (init->value.character.string,
+				init->value.character.length);
+    }
+
+  return init;
+}
+
+
+/* Assign the initial value RVALUE to  LVALUE's symbol->value. If the
+   LVALUE already has an initialization, we extend this, otherwise we
+   create a new one.  If REPEAT is non-NULL, initialize *REPEAT
+   consecutive values in LVALUE the same value in RVALUE.  In that case,
+   LVALUE must refer to a full array, not an array section.  */
+
+bool
+gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
+		       mpz_t *repeat)
+{
+  gfc_ref *ref;
+  gfc_expr *init;
+  gfc_expr *expr = NULL;
+  gfc_constructor *con;
+  gfc_constructor *last_con;
+  gfc_symbol *symbol;
+  gfc_typespec *last_ts;
+  mpz_t offset;
+
+  symbol = lvalue->symtree->n.sym;
+  init = symbol->value;
+  last_ts = &symbol->ts;
+  last_con = NULL;
+  mpz_init_set_si (offset, 0);
+
+  /* Find/create the parent expressions for subobject references.  */
+  for (ref = lvalue->ref; ref; ref = ref->next)
+    {
+      /* Break out of the loop if we find a substring.  */
+      if (ref->type == REF_SUBSTRING)
+	{
+	  /* A substring should always be the last subobject reference.  */
+	  gcc_assert (ref->next == NULL);
+	  break;
+	}
+
+      /* Use the existing initializer expression if it exists.  Otherwise
+	 create a new one.  */
+      if (init == NULL)
+	expr = gfc_get_expr ();
+      else
+	expr = init;
+
+      /* Find or create this element.  */
+      switch (ref->type)
+	{
+	case REF_ARRAY:
+	  if (ref->u.ar.as->rank == 0)
+	    {
+	      gcc_assert (ref->u.ar.as->corank > 0);
+	      if (init == NULL)
+		free (expr);
+	      continue;
+	    }
+
+	  if (init && expr->expr_type != EXPR_ARRAY)
+	    {
+	      gfc_error ("'%s' at %L already is initialized at %L",
+			 lvalue->symtree->n.sym->name, &lvalue->where,
+			 &init->where);
+	      goto abort;
+	    }
+
+	  if (init == NULL)
+	    {
+	      /* The element typespec will be the same as the array
+		 typespec.  */
+	      expr->ts = *last_ts;
+	      /* Setup the expression to hold the constructor.  */
+	      expr->expr_type = EXPR_ARRAY;
+	      expr->rank = ref->u.ar.as->rank;
+	    }
+
+	  if (ref->u.ar.type == AR_ELEMENT)
+	    get_array_index (&ref->u.ar, &offset);
+	  else
+	    mpz_set (offset, index);
+
+	  /* Check the bounds.  */
+	  if (mpz_cmp_si (offset, 0) < 0)
+	    {
+	      gfc_error ("Data element below array lower bound at %L",
+			 &lvalue->where);
+	      goto abort;
+	    }
+	  else if (repeat != NULL
+		   && ref->u.ar.type != AR_ELEMENT)
+	    {
+	      mpz_t size, end;
+	      gcc_assert (ref->u.ar.type == AR_FULL
+			  && ref->next == NULL);
+	      mpz_init_set (end, offset);
+	      mpz_add (end, end, *repeat);
+	      if (spec_size (ref->u.ar.as, &size))
+		{
+		  if (mpz_cmp (end, size) > 0)
+		    {
+		      mpz_clear (size);
+		      gfc_error ("Data element above array upper bound at %L",
+				 &lvalue->where);
+		      goto abort;
+		    }
+		  mpz_clear (size);
+		}
+
+	      con = gfc_constructor_lookup (expr->value.constructor,
+					    mpz_get_si (offset));
+	      if (!con)
+		{
+		  con = gfc_constructor_lookup_next (expr->value.constructor,
+						     mpz_get_si (offset));
+		  if (con != NULL && mpz_cmp (con->offset, end) >= 0)
+		    con = NULL;
+		}
+
+	      /* Overwriting an existing initializer is non-standard but
+		 usually only provokes a warning from other compilers.  */
+	      if (con != NULL && con->expr != NULL)
+		{
+		  /* Order in which the expressions arrive here depends on
+		     whether they are from data statements or F95 style
+		     declarations.  Therefore, check which is the most
+		     recent.  */
+		  gfc_expr *exprd;
+		  exprd = (LOCATION_LINE (con->expr->where.lb->location)
+			   > LOCATION_LINE (rvalue->where.lb->location))
+			  ? con->expr : rvalue;
+		  if (gfc_notify_std (GFC_STD_GNU,
+				      "re-initialization of '%s' at %L",
+				      symbol->name, &exprd->where) == false)
+		    return false;
+		}
+
+	      while (con != NULL)
+		{
+		  gfc_constructor *next_con = gfc_constructor_next (con);
+
+		  if (mpz_cmp (con->offset, end) >= 0)
+		    break;
+		  if (mpz_cmp (con->offset, offset) < 0)
+		    {
+		      gcc_assert (mpz_cmp_si (con->repeat, 1) > 0);
+		      mpz_sub (con->repeat, offset, con->offset);
+		    }
+		  else if (mpz_cmp_si (con->repeat, 1) > 0
+			   && mpz_get_si (con->offset)
+			      + mpz_get_si (con->repeat) > mpz_get_si (end))
+		    {
+		      int endi;
+		      splay_tree_node node
+			= splay_tree_lookup (con->base,
+					     mpz_get_si (con->offset));
+		      gcc_assert (node
+				  && con == (gfc_constructor *) node->value
+				  && node->key == (splay_tree_key)
+						  mpz_get_si (con->offset));
+		      endi = mpz_get_si (con->offset)
+			     + mpz_get_si (con->repeat);
+		      if (endi > mpz_get_si (end) + 1)
+			mpz_set_si (con->repeat, endi - mpz_get_si (end));
+		      else
+			mpz_set_si (con->repeat, 1);
+		      mpz_set (con->offset, end);
+		      node->key = (splay_tree_key) mpz_get_si (end);
+		      break;
+		    }
+		  else
+		    gfc_constructor_remove (con);
+		  con = next_con;
+		}
+
+	      con = gfc_constructor_insert_expr (&expr->value.constructor,
+						 NULL, &rvalue->where,
+						 mpz_get_si (offset));
+	      mpz_set (con->repeat, *repeat);
+	      repeat = NULL;
+	      mpz_clear (end);
+	      break;
+	    }
+	  else
+	    {
+	      mpz_t size;
+	      if (spec_size (ref->u.ar.as, &size))
+		{
+		  if (mpz_cmp (offset, size) >= 0)
+		    {
+		      mpz_clear (size);
+		      gfc_error ("Data element above array upper bound at %L",
+		                 &lvalue->where);
+		      goto abort;
+		    }
+		  mpz_clear (size);
+		}
+	    }
+
+	  con = gfc_constructor_lookup (expr->value.constructor,
+					mpz_get_si (offset));
+	  if (!con)
+	    {
+	      con = gfc_constructor_insert_expr (&expr->value.constructor,
+						 NULL, &rvalue->where,
+						 mpz_get_si (offset));
+	    }
+	  else if (mpz_cmp_si (con->repeat, 1) > 0)
+	    {
+	      /* Need to split a range.  */
+	      if (mpz_cmp (con->offset, offset) < 0)
+		{
+		  gfc_constructor *pred_con = con;
+		  con = gfc_constructor_insert_expr (&expr->value.constructor,
+						     NULL, &con->where,
+						     mpz_get_si (offset));
+		  con->expr = gfc_copy_expr (pred_con->expr);
+		  mpz_add (con->repeat, pred_con->offset, pred_con->repeat);
+		  mpz_sub (con->repeat, con->repeat, offset);
+		  mpz_sub (pred_con->repeat, offset, pred_con->offset);
+		}
+	      if (mpz_cmp_si (con->repeat, 1) > 0)
+		{
+		  gfc_constructor *succ_con;
+		  succ_con
+		    = gfc_constructor_insert_expr (&expr->value.constructor,
+						   NULL, &con->where,
+						   mpz_get_si (offset) + 1);
+		  succ_con->expr = gfc_copy_expr (con->expr);
+		  mpz_sub_ui (succ_con->repeat, con->repeat, 1);
+		  mpz_set_si (con->repeat, 1);
+		}
+	    }
+	  break;
+
+	case REF_COMPONENT:
+	  if (init == NULL)
+	    {
+	      /* Setup the expression to hold the constructor.  */
+	      expr->expr_type = EXPR_STRUCTURE;
+	      expr->ts.type = BT_DERIVED;
+	      expr->ts.u.derived = ref->u.c.sym;
+	    }
+	  else
+	    gcc_assert (expr->expr_type == EXPR_STRUCTURE);
+	  last_ts = &ref->u.c.component->ts;
+
+	  /* Find the same element in the existing constructor.  */
+	  con = find_con_by_component (ref->u.c.component,
+				       expr->value.constructor);
+
+	  if (con == NULL)
+	    {
+	      /* Create a new constructor.  */
+	      con = gfc_constructor_append_expr (&expr->value.constructor,
+						 NULL, NULL);
+	      con->n.component = ref->u.c.component;
+	    }
+	  break;
+
+	default:
+	  gcc_unreachable ();
+	}
+
+      if (init == NULL)
+	{
+	  /* Point the container at the new expression.  */
+	  if (last_con == NULL)
+	    symbol->value = expr;
+	  else
+	    last_con->expr = expr;
+	}
+      init = con->expr;
+      last_con = con;
+    }
+
+  mpz_clear (offset);
+  gcc_assert (repeat == NULL);
+
+  if (ref || last_ts->type == BT_CHARACTER)
+    {
+      if (lvalue->ts.u.cl->length == NULL && !(ref && ref->u.ss.length != NULL))
+	return false;
+      expr = create_character_initializer (init, last_ts, ref, rvalue);
+    }
+  else
+    {
+      /* Overwriting an existing initializer is non-standard but usually only
+	 provokes a warning from other compilers.  */
+      if (init != NULL)
+	{
+	  /* Order in which the expressions arrive here depends on whether
+	     they are from data statements or F95 style declarations.
+	     Therefore, check which is the most recent.  */
+	  expr = (LOCATION_LINE (init->where.lb->location)
+		  > LOCATION_LINE (rvalue->where.lb->location))
+	       ? init : rvalue;
+	  if (gfc_notify_std (GFC_STD_GNU,
+			      "re-initialization of '%s' at %L",
+			      symbol->name, &expr->where) == false)
+	    return false;
+	}
+
+      expr = gfc_copy_expr (rvalue);
+      if (!gfc_compare_types (&lvalue->ts, &expr->ts))
+	gfc_convert_type (expr, &lvalue->ts, 0);
+    }
+
+  if (last_con == NULL)
+    symbol->value = expr;
+  else
+    last_con->expr = expr;
+
+  return true;
+
+abort:
+  if (!init)
+    gfc_free_expr (expr);
+  mpz_clear (offset);
+  return false;
+}
+
+
+/* Modify the index of array section and re-calculate the array offset.  */
+
+void 
+gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
+		     mpz_t *offset_ret)
+{
+  int i;
+  mpz_t delta;
+  mpz_t tmp; 
+  bool forwards;
+  int cmp;
+
+  for (i = 0; i < ar->dimen; i++)
+    {
+      if (ar->dimen_type[i] != DIMEN_RANGE)
+	continue;
+
+      if (ar->stride[i])
+	{
+	  mpz_add (section_index[i], section_index[i],
+		   ar->stride[i]->value.integer);
+	if (mpz_cmp_si (ar->stride[i]->value.integer, 0) >= 0)
+	  forwards = true;
+	else
+	  forwards = false;
+	}
+      else
+	{
+	  mpz_add_ui (section_index[i], section_index[i], 1);
+	  forwards = true;
+	}
+      
+      if (ar->end[i])
+	cmp = mpz_cmp (section_index[i], ar->end[i]->value.integer);
+      else
+	cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
+
+      if ((cmp > 0 && forwards) || (cmp < 0 && !forwards))
+	{
+	  /* Reset index to start, then loop to advance the next index.  */
+	  if (ar->start[i])
+	    mpz_set (section_index[i], ar->start[i]->value.integer);
+	  else
+	    mpz_set (section_index[i], ar->as->lower[i]->value.integer);
+	}
+      else
+	break;
+    }
+
+  mpz_set_si (*offset_ret, 0);
+  mpz_init_set_si (delta, 1);
+  mpz_init (tmp);
+  for (i = 0; i < ar->dimen; i++)
+    {
+      mpz_sub (tmp, section_index[i], ar->as->lower[i]->value.integer);
+      mpz_mul (tmp, tmp, delta);
+      mpz_add (*offset_ret, tmp, *offset_ret);
+
+      mpz_sub (tmp, ar->as->upper[i]->value.integer, 
+	       ar->as->lower[i]->value.integer);
+      mpz_add_ui (tmp, tmp, 1);
+      mpz_mul (delta, tmp, delta);
+    }
+  mpz_clear (tmp);
+  mpz_clear (delta);
+}
+
+
+/* Rearrange a structure constructor so the elements are in the specified
+   order.  Also insert NULL entries if necessary.  */
+
+static void
+formalize_structure_cons (gfc_expr *expr)
+{
+  gfc_constructor_base base = NULL;
+  gfc_constructor *cur;
+  gfc_component *order;
+
+  /* Constructor is already formalized.  */
+  cur = gfc_constructor_first (expr->value.constructor);
+  if (!cur || cur->n.component == NULL)
+    return;
+
+  for (order = expr->ts.u.derived->components; order; order = order->next)
+    {
+      cur = find_con_by_component (order, expr->value.constructor);
+      if (cur)
+	gfc_constructor_append_expr (&base, cur->expr, &cur->expr->where);
+      else
+	gfc_constructor_append_expr (&base, NULL, NULL);
+    }
+
+  /* For all what it's worth, one would expect
+       gfc_constructor_free (expr->value.constructor);
+     here. However, if the constructor is actually free'd,
+     hell breaks loose in the testsuite?!  */
+
+  expr->value.constructor = base;
+}
+
+
+/* Make sure an initialization expression is in normalized form, i.e., all
+   elements of the constructors are in the correct order.  */
+
+static void
+formalize_init_expr (gfc_expr *expr)
+{
+  expr_t type;
+  gfc_constructor *c;
+
+  if (expr == NULL)
+    return;
+
+  type = expr->expr_type;
+  switch (type)
+    {
+    case EXPR_ARRAY:
+      for (c = gfc_constructor_first (expr->value.constructor);
+	   c; c = gfc_constructor_next (c))
+	formalize_init_expr (c->expr);
+
+    break;
+
+    case EXPR_STRUCTURE:
+      formalize_structure_cons (expr);
+      break;
+
+    default:
+      break;
+    }
+}
+
+
+/* Resolve symbol's initial value after all data statement.  */
+
+void
+gfc_formalize_init_value (gfc_symbol *sym)
+{
+  formalize_init_expr (sym->value);
+}
+
+
+/* Get the integer value into RET_AS and SECTION from AS and AR, and return
+   offset.  */
+ 
+void
+gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset)
+{
+  int i;
+  mpz_t delta;
+  mpz_t tmp;
+
+  mpz_set_si (*offset, 0);
+  mpz_init (tmp);
+  mpz_init_set_si (delta, 1);
+  for (i = 0; i < ar->dimen; i++)
+    {
+      mpz_init (section_index[i]);
+      switch (ar->dimen_type[i])
+	{
+	case DIMEN_ELEMENT:
+	case DIMEN_RANGE:
+	  if (ar->start[i])
+	    {
+	      mpz_sub (tmp, ar->start[i]->value.integer,
+		       ar->as->lower[i]->value.integer);
+	      mpz_mul (tmp, tmp, delta);
+	      mpz_add (*offset, tmp, *offset);
+	      mpz_set (section_index[i], ar->start[i]->value.integer);
+	    }
+	  else
+	      mpz_set (section_index[i], ar->as->lower[i]->value.integer);
+	  break;
+
+	case DIMEN_VECTOR:
+	  gfc_internal_error ("TODO: Vector sections in data statements");
+
+	default:
+	  gcc_unreachable ();
+	}
+
+      mpz_sub (tmp, ar->as->upper[i]->value.integer, 
+	       ar->as->lower[i]->value.integer);
+      mpz_add_ui (tmp, tmp, 1);
+      mpz_mul (delta, tmp, delta);
+    }
+
+  mpz_clear (tmp);
+  mpz_clear (delta);
+}
+
diff --git a/gcc-4.9/gcc/fortran/data.h b/gcc-4.9/gcc/fortran/data.h
new file mode 100644
index 000000000..5e23ac75f
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/data.h
@@ -0,0 +1,23 @@
+/* Header for functions resolving DATA statements.
+   Copyright (C) 2007-2014 Free Software Foundation, Inc.
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+void gfc_formalize_init_value (gfc_symbol *);
+void gfc_get_section_index (gfc_array_ref *, mpz_t *, mpz_t *);
+bool gfc_assign_data_value (gfc_expr *, gfc_expr *, mpz_t, mpz_t *);
+void gfc_advance_section (mpz_t *, gfc_array_ref *, mpz_t *);
diff --git a/gcc-4.9/gcc/fortran/decl.c b/gcc-4.9/gcc/fortran/decl.c
new file mode 100644
index 000000000..4048ac913
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/decl.c
@@ -0,0 +1,8725 @@
+/* Declaration statement matcher
+   Copyright (C) 2002-2014 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "gfortran.h"
+#include "match.h"
+#include "parse.h"
+#include "flags.h"
+#include "constructor.h"
+#include "tree.h"
+#include "stringpool.h"
+
+/* Macros to access allocate memory for gfc_data_variable,
+   gfc_data_value and gfc_data.  */
+#define gfc_get_data_variable() XCNEW (gfc_data_variable)
+#define gfc_get_data_value() XCNEW (gfc_data_value)
+#define gfc_get_data() XCNEW (gfc_data)
+
+
+static bool set_binding_label (const char **, const char *, int);
+
+
+/* This flag is set if an old-style length selector is matched
+   during a type-declaration statement.  */
+
+static int old_char_selector;
+
+/* When variables acquire types and attributes from a declaration
+   statement, they get them from the following static variables.  The
+   first part of a declaration sets these variables and the second
+   part copies these into symbol structures.  */
+
+static gfc_typespec current_ts;
+
+static symbol_attribute current_attr;
+static gfc_array_spec *current_as;
+static int colon_seen;
+
+/* The current binding label (if any).  */
+static const char* curr_binding_label;
+/* Need to know how many identifiers are on the current data declaration
+   line in case we're given the BIND(C) attribute with a NAME= specifier.  */
+static int num_idents_on_line;
+/* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
+   can supply a name if the curr_binding_label is nil and NAME= was not.  */
+static int has_name_equals = 0;
+
+/* Initializer of the previous enumerator.  */
+
+static gfc_expr *last_initializer;
+
+/* History of all the enumerators is maintained, so that
+   kind values of all the enumerators could be updated depending
+   upon the maximum initialized value.  */
+
+typedef struct enumerator_history
+{
+  gfc_symbol *sym;
+  gfc_expr *initializer;
+  struct enumerator_history *next;
+}
+enumerator_history;
+
+/* Header of enum history chain.  */
+
+static enumerator_history *enum_history = NULL;
+
+/* Pointer of enum history node containing largest initializer.  */
+
+static enumerator_history *max_enum = NULL;
+
+/* gfc_new_block points to the symbol of a newly matched block.  */
+
+gfc_symbol *gfc_new_block;
+
+bool gfc_matching_function;
+
+
+/********************* DATA statement subroutines *********************/
+
+static bool in_match_data = false;
+
+bool
+gfc_in_match_data (void)
+{
+  return in_match_data;
+}
+
+static void
+set_in_match_data (bool set_value)
+{
+  in_match_data = set_value;
+}
+
+/* Free a gfc_data_variable structure and everything beneath it.  */
+
+static void
+free_variable (gfc_data_variable *p)
+{
+  gfc_data_variable *q;
+
+  for (; p; p = q)
+    {
+      q = p->next;
+      gfc_free_expr (p->expr);
+      gfc_free_iterator (&p->iter, 0);
+      free_variable (p->list);
+      free (p);
+    }
+}
+
+
+/* Free a gfc_data_value structure and everything beneath it.  */
+
+static void
+free_value (gfc_data_value *p)
+{
+  gfc_data_value *q;
+
+  for (; p; p = q)
+    {
+      q = p->next;
+      mpz_clear (p->repeat);
+      gfc_free_expr (p->expr);
+      free (p);
+    }
+}
+
+
+/* Free a list of gfc_data structures.  */
+
+void
+gfc_free_data (gfc_data *p)
+{
+  gfc_data *q;
+
+  for (; p; p = q)
+    {
+      q = p->next;
+      free_variable (p->var);
+      free_value (p->value);
+      free (p);
+    }
+}
+
+
+/* Free all data in a namespace.  */
+
+static void
+gfc_free_data_all (gfc_namespace *ns)
+{
+  gfc_data *d;
+
+  for (;ns->data;)
+    {
+      d = ns->data->next;
+      free (ns->data);
+      ns->data = d;
+    }
+}
+
+
+static match var_element (gfc_data_variable *);
+
+/* Match a list of variables terminated by an iterator and a right
+   parenthesis.  */
+
+static match
+var_list (gfc_data_variable *parent)
+{
+  gfc_data_variable *tail, var;
+  match m;
+
+  m = var_element (&var);
+  if (m == MATCH_ERROR)
+    return MATCH_ERROR;
+  if (m == MATCH_NO)
+    goto syntax;
+
+  tail = gfc_get_data_variable ();
+  *tail = var;
+
+  parent->list = tail;
+
+  for (;;)
+    {
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+
+      m = gfc_match_iterator (&parent->iter, 1);
+      if (m == MATCH_YES)
+	break;
+      if (m == MATCH_ERROR)
+	return MATCH_ERROR;
+
+      m = var_element (&var);
+      if (m == MATCH_ERROR)
+	return MATCH_ERROR;
+      if (m == MATCH_NO)
+	goto syntax;
+
+      tail->next = gfc_get_data_variable ();
+      tail = tail->next;
+
+      *tail = var;
+    }
+
+  if (gfc_match_char (')') != MATCH_YES)
+    goto syntax;
+  return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (ST_DATA);
+  return MATCH_ERROR;
+}
+
+
+/* Match a single element in a data variable list, which can be a
+   variable-iterator list.  */
+
+static match
+var_element (gfc_data_variable *new_var)
+{
+  match m;
+  gfc_symbol *sym;
+
+  memset (new_var, 0, sizeof (gfc_data_variable));
+
+  if (gfc_match_char ('(') == MATCH_YES)
+    return var_list (new_var);
+
+  m = gfc_match_variable (&new_var->expr, 0);
+  if (m != MATCH_YES)
+    return m;
+
+  sym = new_var->expr->symtree->n.sym;
+
+  /* Symbol should already have an associated type.  */
+  if (!gfc_check_symbol_typed (sym, gfc_current_ns, false, gfc_current_locus))
+    return MATCH_ERROR;
+
+  if (!sym->attr.function && gfc_current_ns->parent
+      && gfc_current_ns->parent == sym->ns)
+    {
+      gfc_error ("Host associated variable '%s' may not be in the DATA "
+		 "statement at %C", sym->name);
+      return MATCH_ERROR;
+    }
+
+  if (gfc_current_state () != COMP_BLOCK_DATA
+      && sym->attr.in_common
+      && !gfc_notify_std (GFC_STD_GNU, "initialization of "
+			  "common block variable '%s' in DATA statement at %C",
+			  sym->name))
+    return MATCH_ERROR;
+
+  if (!gfc_add_data (&sym->attr, sym->name, &new_var->expr->where))
+    return MATCH_ERROR;
+
+  return MATCH_YES;
+}
+
+
+/* Match the top-level list of data variables.  */
+
+static match
+top_var_list (gfc_data *d)
+{
+  gfc_data_variable var, *tail, *new_var;
+  match m;
+
+  tail = NULL;
+
+  for (;;)
+    {
+      m = var_element (&var);
+      if (m == MATCH_NO)
+	goto syntax;
+      if (m == MATCH_ERROR)
+	return MATCH_ERROR;
+
+      new_var = gfc_get_data_variable ();
+      *new_var = var;
+
+      if (tail == NULL)
+	d->var = new_var;
+      else
+	tail->next = new_var;
+
+      tail = new_var;
+
+      if (gfc_match_char ('/') == MATCH_YES)
+	break;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+    }
+
+  return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (ST_DATA);
+  gfc_free_data_all (gfc_current_ns);
+  return MATCH_ERROR;
+}
+
+
+static match
+match_data_constant (gfc_expr **result)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_symbol *sym, *dt_sym = NULL;
+  gfc_expr *expr;
+  match m;
+  locus old_loc;
+
+  m = gfc_match_literal_constant (&expr, 1);
+  if (m == MATCH_YES)
+    {
+      *result = expr;
+      return MATCH_YES;
+    }
+
+  if (m == MATCH_ERROR)
+    return MATCH_ERROR;
+
+  m = gfc_match_null (result);
+  if (m != MATCH_NO)
+    return m;
+
+  old_loc = gfc_current_locus;
+
+  /* Should this be a structure component, try to match it
+     before matching a name.  */
+  m = gfc_match_rvalue (result);
+  if (m == MATCH_ERROR)
+    return m;
+
+  if (m == MATCH_YES && (*result)->expr_type == EXPR_STRUCTURE)
+    {
+      if (!gfc_simplify_expr (*result, 0))
+	m = MATCH_ERROR;
+      return m;
+    }
+  else if (m == MATCH_YES)
+    gfc_free_expr (*result);
+
+  gfc_current_locus = old_loc;
+
+  m = gfc_match_name (name);
+  if (m != MATCH_YES)
+    return m;
+
+  if (gfc_find_symbol (name, NULL, 1, &sym))
+    return MATCH_ERROR;
+
+  if (sym && sym->attr.generic)
+    dt_sym = gfc_find_dt_in_generic (sym);
+
+  if (sym == NULL
+      || (sym->attr.flavor != FL_PARAMETER
+	  && (!dt_sym || dt_sym->attr.flavor != FL_DERIVED)))
+    {
+      gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
+		 name);
+      return MATCH_ERROR;
+    }
+  else if (dt_sym && dt_sym->attr.flavor == FL_DERIVED)
+    return gfc_match_structure_constructor (dt_sym, result);
+
+  /* Check to see if the value is an initialization array expression.  */
+  if (sym->value->expr_type == EXPR_ARRAY)
+    {
+      gfc_current_locus = old_loc;
+
+      m = gfc_match_init_expr (result);
+      if (m == MATCH_ERROR)
+	return m;
+
+      if (m == MATCH_YES)
+	{
+	  if (!gfc_simplify_expr (*result, 0))
+	    m = MATCH_ERROR;
+
+	  if ((*result)->expr_type == EXPR_CONSTANT)
+	    return m;
+          else
+	    {
+	      gfc_error ("Invalid initializer %s in Data statement at %C", name);
+	      return MATCH_ERROR;
+	    }
+	}
+    }
+
+  *result = gfc_copy_expr (sym->value);
+  return MATCH_YES;
+}
+
+
+/* Match a list of values in a DATA statement.  The leading '/' has
+   already been seen at this point.  */
+
+static match
+top_val_list (gfc_data *data)
+{
+  gfc_data_value *new_val, *tail;
+  gfc_expr *expr;
+  match m;
+
+  tail = NULL;
+
+  for (;;)
+    {
+      m = match_data_constant (&expr);
+      if (m == MATCH_NO)
+	goto syntax;
+      if (m == MATCH_ERROR)
+	return MATCH_ERROR;
+
+      new_val = gfc_get_data_value ();
+      mpz_init (new_val->repeat);
+
+      if (tail == NULL)
+	data->value = new_val;
+      else
+	tail->next = new_val;
+
+      tail = new_val;
+
+      if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
+	{
+	  tail->expr = expr;
+	  mpz_set_ui (tail->repeat, 1);
+	}
+      else
+	{
+	  mpz_set (tail->repeat, expr->value.integer);
+	  gfc_free_expr (expr);
+
+	  m = match_data_constant (&tail->expr);
+	  if (m == MATCH_NO)
+	    goto syntax;
+	  if (m == MATCH_ERROR)
+	    return MATCH_ERROR;
+	}
+
+      if (gfc_match_char ('/') == MATCH_YES)
+	break;
+      if (gfc_match_char (',') == MATCH_NO)
+	goto syntax;
+    }
+
+  return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (ST_DATA);
+  gfc_free_data_all (gfc_current_ns);
+  return MATCH_ERROR;
+}
+
+
+/* Matches an old style initialization.  */
+
+static match
+match_old_style_init (const char *name)
+{
+  match m;
+  gfc_symtree *st;
+  gfc_symbol *sym;
+  gfc_data *newdata;
+
+  /* Set up data structure to hold initializers.  */
+  gfc_find_sym_tree (name, NULL, 0, &st);
+  sym = st->n.sym;
+
+  newdata = gfc_get_data ();
+  newdata->var = gfc_get_data_variable ();
+  newdata->var->expr = gfc_get_variable_expr (st);
+  newdata->where = gfc_current_locus;
+
+  /* Match initial value list. This also eats the terminal '/'.  */
+  m = top_val_list (newdata);
+  if (m != MATCH_YES)
+    {
+      free (newdata);
+      return m;
+    }
+
+  if (gfc_pure (NULL))
+    {
+      gfc_error ("Initialization at %C is not allowed in a PURE procedure");
+      free (newdata);
+      return MATCH_ERROR;
+    }
+  gfc_unset_implicit_pure (gfc_current_ns->proc_name);
+
+  /* Mark the variable as having appeared in a data statement.  */
+  if (!gfc_add_data (&sym->attr, sym->name, &sym->declared_at))
+    {
+      free (newdata);
+      return MATCH_ERROR;
+    }
+
+  /* Chain in namespace list of DATA initializers.  */
+  newdata->next = gfc_current_ns->data;
+  gfc_current_ns->data = newdata;
+
+  return m;
+}
+
+
+/* Match the stuff following a DATA statement. If ERROR_FLAG is set,
+   we are matching a DATA statement and are therefore issuing an error
+   if we encounter something unexpected, if not, we're trying to match
+   an old-style initialization expression of the form INTEGER I /2/.  */
+
+match
+gfc_match_data (void)
+{
+  gfc_data *new_data;
+  match m;
+
+  set_in_match_data (true);
+
+  for (;;)
+    {
+      new_data = gfc_get_data ();
+      new_data->where = gfc_current_locus;
+
+      m = top_var_list (new_data);
+      if (m != MATCH_YES)
+	goto cleanup;
+
+      m = top_val_list (new_data);
+      if (m != MATCH_YES)
+	goto cleanup;
+
+      new_data->next = gfc_current_ns->data;
+      gfc_current_ns->data = new_data;
+
+      if (gfc_match_eos () == MATCH_YES)
+	break;
+
+      gfc_match_char (',');	/* Optional comma */
+    }
+
+  set_in_match_data (false);
+
+  if (gfc_pure (NULL))
+    {
+      gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
+      return MATCH_ERROR;
+    }
+  gfc_unset_implicit_pure (gfc_current_ns->proc_name);
+
+  return MATCH_YES;
+
+cleanup:
+  set_in_match_data (false);
+  gfc_free_data (new_data);
+  return MATCH_ERROR;
+}
+
+
+/************************ Declaration statements *********************/
+
+
+/* Auxiliary function to merge DIMENSION and CODIMENSION array specs.  */
+
+static bool
+merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
+{
+  int i;
+
+  if ((from->type == AS_ASSUMED_RANK && to->corank)
+      || (to->type == AS_ASSUMED_RANK && from->corank))
+    {
+      gfc_error ("The assumed-rank array at %C shall not have a codimension");
+      return false;
+    }
+
+  if (to->rank == 0 && from->rank > 0)
+    {
+      to->rank = from->rank;
+      to->type = from->type;
+      to->cray_pointee = from->cray_pointee;
+      to->cp_was_assumed = from->cp_was_assumed;
+
+      for (i = 0; i < to->corank; i++)
+	{
+	  to->lower[from->rank + i] = to->lower[i];
+	  to->upper[from->rank + i] = to->upper[i];
+	}
+      for (i = 0; i < from->rank; i++)
+	{
+	  if (copy)
+	    {
+	      to->lower[i] = gfc_copy_expr (from->lower[i]);
+	      to->upper[i] = gfc_copy_expr (from->upper[i]);
+	    }
+	  else
+	    {
+	      to->lower[i] = from->lower[i];
+	      to->upper[i] = from->upper[i];
+	    }
+	}
+    }
+  else if (to->corank == 0 && from->corank > 0)
+    {
+      to->corank = from->corank;
+      to->cotype = from->cotype;
+
+      for (i = 0; i < from->corank; i++)
+	{
+	  if (copy)
+	    {
+	      to->lower[to->rank + i] = gfc_copy_expr (from->lower[i]);
+	      to->upper[to->rank + i] = gfc_copy_expr (from->upper[i]);
+	    }
+	  else
+	    {
+	      to->lower[to->rank + i] = from->lower[i];
+	      to->upper[to->rank + i] = from->upper[i];
+	    }
+	}
+    }
+
+  return true;
+}
+
+
+/* Match an intent specification.  Since this can only happen after an
+   INTENT word, a legal intent-spec must follow.  */
+
+static sym_intent
+match_intent_spec (void)
+{
+
+  if (gfc_match (" ( in out )") == MATCH_YES)
+    return INTENT_INOUT;
+  if (gfc_match (" ( in )") == MATCH_YES)
+    return INTENT_IN;
+  if (gfc_match (" ( out )") == MATCH_YES)
+    return INTENT_OUT;
+
+  gfc_error ("Bad INTENT specification at %C");
+  return INTENT_UNKNOWN;
+}
+
+
+/* Matches a character length specification, which is either a
+   specification expression, '*', or ':'.  */
+
+static match
+char_len_param_value (gfc_expr **expr, bool *deferred)
+{
+  match m;
+
+  *expr = NULL;
+  *deferred = false;
+
+  if (gfc_match_char ('*') == MATCH_YES)
+    return MATCH_YES;
+
+  if (gfc_match_char (':') == MATCH_YES)
+    {
+      if (!gfc_notify_std (GFC_STD_F2003, "deferred type "
+			   "parameter at %C"))
+	return MATCH_ERROR;
+
+      *deferred = true;
+
+      return MATCH_YES;
+    }
+
+  m = gfc_match_expr (expr);
+
+  if (m == MATCH_YES
+      && !gfc_expr_check_typed (*expr, gfc_current_ns, false))
+    return MATCH_ERROR;
+
+  if (m == MATCH_YES && (*expr)->expr_type == EXPR_FUNCTION)
+    {
+      if ((*expr)->value.function.actual
+	  && (*expr)->value.function.actual->expr->symtree)
+	{
+	  gfc_expr *e;
+	  e = (*expr)->value.function.actual->expr;
+	  if (e->symtree->n.sym->attr.flavor == FL_PROCEDURE
+	      && e->expr_type == EXPR_VARIABLE)
+	    {
+	      if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
+		goto syntax;
+	      if (e->symtree->n.sym->ts.type == BT_CHARACTER
+		  && e->symtree->n.sym->ts.u.cl
+		  && e->symtree->n.sym->ts.u.cl->length->ts.type == BT_UNKNOWN)
+	        goto syntax;
+	    }
+	}
+    }
+  return m;
+
+syntax:
+  gfc_error ("Conflict in attributes of function argument at %C");
+  return MATCH_ERROR;
+}
+
+
+/* A character length is a '*' followed by a literal integer or a
+   char_len_param_value in parenthesis.  */
+
+static match
+match_char_length (gfc_expr **expr, bool *deferred, bool obsolescent_check)
+{
+  int length;
+  match m;
+
+  *deferred = false;
+  m = gfc_match_char ('*');
+  if (m != MATCH_YES)
+    return m;
+
+  m = gfc_match_small_literal_int (&length, NULL);
+  if (m == MATCH_ERROR)
+    return m;
+
+  if (m == MATCH_YES)
+    {
+      if (obsolescent_check
+	  && !gfc_notify_std (GFC_STD_F95_OBS, "Old-style character length at %C"))
+	return MATCH_ERROR;
+      *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, length);
+      return m;
+    }
+
+  if (gfc_match_char ('(') == MATCH_NO)
+    goto syntax;
+
+  m = char_len_param_value (expr, deferred);
+  if (m != MATCH_YES && gfc_matching_function)
+    {
+      gfc_undo_symbols ();
+      m = MATCH_YES;
+    }
+
+  if (m == MATCH_ERROR)
+    return m;
+  if (m == MATCH_NO)
+    goto syntax;
+
+  if (gfc_match_char (')') == MATCH_NO)
+    {
+      gfc_free_expr (*expr);
+      *expr = NULL;
+      goto syntax;
+    }
+
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in character length specification at %C");
+  return MATCH_ERROR;
+}
+
+
+/* Special subroutine for finding a symbol.  Check if the name is found
+   in the current name space.  If not, and we're compiling a function or
+   subroutine and the parent compilation unit is an interface, then check
+   to see if the name we've been given is the name of the interface
+   (located in another namespace).  */
+
+static int
+find_special (const char *name, gfc_symbol **result, bool allow_subroutine)
+{
+  gfc_state_data *s;
+  gfc_symtree *st;
+  int i;
+
+  i = gfc_get_sym_tree (name, NULL, &st, allow_subroutine);
+  if (i == 0)
+    {
+      *result = st ? st->n.sym : NULL;
+      goto end;
+    }
+
+  if (gfc_current_state () != COMP_SUBROUTINE
+      && gfc_current_state () != COMP_FUNCTION)
+    goto end;
+
+  s = gfc_state_stack->previous;
+  if (s == NULL)
+    goto end;
+
+  if (s->state != COMP_INTERFACE)
+    goto end;
+  if (s->sym == NULL)
+    goto end;		  /* Nameless interface.  */
+
+  if (strcmp (name, s->sym->name) == 0)
+    {
+      *result = s->sym;
+      return 0;
+    }
+
+end:
+  return i;
+}
+
+
+/* Special subroutine for getting a symbol node associated with a
+   procedure name, used in SUBROUTINE and FUNCTION statements.  The
+   symbol is created in the parent using with symtree node in the
+   child unit pointing to the symbol.  If the current namespace has no
+   parent, then the symbol is just created in the current unit.  */
+
+static int
+get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
+{
+  gfc_symtree *st;
+  gfc_symbol *sym;
+  int rc = 0;
+
+  /* Module functions have to be left in their own namespace because
+     they have potentially (almost certainly!) already been referenced.
+     In this sense, they are rather like external functions.  This is
+     fixed up in resolve.c(resolve_entries), where the symbol name-
+     space is set to point to the master function, so that the fake
+     result mechanism can work.  */
+  if (module_fcn_entry)
+    {
+      /* Present if entry is declared to be a module procedure.  */
+      rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result);
+
+      if (*result == NULL)
+	rc = gfc_get_symbol (name, NULL, result);
+      else if (!gfc_get_symbol (name, NULL, &sym) && sym
+		 && (*result)->ts.type == BT_UNKNOWN
+		 && sym->attr.flavor == FL_UNKNOWN)
+	/* Pick up the typespec for the entry, if declared in the function
+	   body.  Note that this symbol is FL_UNKNOWN because it will
+	   only have appeared in a type declaration.  The local symtree
+	   is set to point to the module symbol and a unique symtree
+	   to the local version.  This latter ensures a correct clearing
+	   of the symbols.  */
+	{
+	  /* If the ENTRY proceeds its specification, we need to ensure
+	     that this does not raise a "has no IMPLICIT type" error.  */
+	  if (sym->ts.type == BT_UNKNOWN)
+	    sym->attr.untyped = 1;
+
+	  (*result)->ts = sym->ts;
+
+	  /* Put the symbol in the procedure namespace so that, should
+	     the ENTRY precede its specification, the specification
+	     can be applied.  */
+	  (*result)->ns = gfc_current_ns;
+
+	  gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
+	  st->n.sym = *result;
+	  st = gfc_get_unique_symtree (gfc_current_ns);
+	  st->n.sym = sym;
+	}
+    }
+  else
+    rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
+
+  if (rc)
+    return rc;
+
+  sym = *result;
+
+  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
+	 whose name clashes with that of the encompassing procedure;
+	 this is handled using gsymbols to register unique,globally
+	 accessible names.  */
+      if (sym->attr.flavor != 0
+	  && sym->attr.proc != 0
+	  && (sym->attr.subroutine || sym->attr.function)
+	  && sym->attr.if_source != IFSRC_UNKNOWN)
+	gfc_error_now ("Procedure '%s' 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 ("Name '%s' 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
+	 references only set ts.type.  */
+      if (sym->ts.kind != 0
+	  && !sym->attr.implicit_type
+	  && sym->attr.proc == 0
+	  && gfc_current_ns->parent != NULL
+	  && sym->attr.access == 0
+	  && !module_fcn_entry)
+	gfc_error_now ("Procedure '%s' 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)
+    return rc;
+
+  /* Module function entries will already have a symtree in
+     the current namespace but will need one at module level.  */
+  if (module_fcn_entry)
+    {
+      /* Present if entry is declared to be a module procedure.  */
+      rc = gfc_find_sym_tree (name, gfc_current_ns->parent, 0, &st);
+      if (st == NULL)
+	st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name);
+    }
+  else
+    st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
+
+  st->n.sym = sym;
+  sym->refs++;
+
+  /* See if the procedure should be a module procedure.  */
+
+  if (((sym->ns->proc_name != NULL
+		&& sym->ns->proc_name->attr.flavor == FL_MODULE
+		&& sym->attr.proc != PROC_MODULE)
+	    || (module_fcn_entry && sym->attr.proc != PROC_MODULE))
+	&& !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
+    rc = 2;
+
+  return rc;
+}
+
+
+/* Verify that the given symbol representing a parameter is C
+   interoperable, by checking to see if it was marked as such after
+   its declaration.  If the given symbol is not interoperable, a
+   warning is reported, thus removing the need to return the status to
+   the calling function.  The standard does not require the user use
+   one of the iso_c_binding named constants to declare an
+   interoperable parameter, but we can't be sure if the param is C
+   interop or not if the user doesn't.  For example, integer(4) may be
+   legal Fortran, but doesn't have meaning in C.  It may interop with
+   a number of the C types, which causes a problem because the
+   compiler can't know which one.  This code is almost certainly not
+   portable, and the user will get what they deserve if the C type
+   across platforms isn't always interoperable with integer(4).  If
+   the user had used something like integer(c_int) or integer(c_long),
+   the compiler could have automatically handled the varying sizes
+   across platforms.  */
+
+bool
+gfc_verify_c_interop_param (gfc_symbol *sym)
+{
+  int is_c_interop = 0;
+  bool retval = true;
+
+  /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
+     Don't repeat the checks here.  */
+  if (sym->attr.implicit_type)
+    return true;
+
+  /* For subroutines or functions that are passed to a BIND(C) procedure,
+     they're interoperable if they're BIND(C) and their params are all
+     interoperable.  */
+  if (sym->attr.flavor == FL_PROCEDURE)
+    {
+      if (sym->attr.is_bind_c == 0)
+        {
+          gfc_error_now ("Procedure '%s' at %L must have the BIND(C) "
+                         "attribute to be C interoperable", sym->name,
+                         &(sym->declared_at));
+
+          return false;
+        }
+      else
+        {
+          if (sym->attr.is_c_interop == 1)
+            /* We've already checked this procedure; don't check it again.  */
+            return true;
+          else
+            return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
+                                      sym->common_block);
+        }
+    }
+
+  /* See if we've stored a reference to a procedure that owns sym.  */
+  if (sym->ns != NULL && sym->ns->proc_name != NULL)
+    {
+      if (sym->ns->proc_name->attr.is_bind_c == 1)
+	{
+	  is_c_interop = (gfc_verify_c_interop(&(sym->ts)) ? 1 : 0);
+
+	  if (is_c_interop != 1)
+	    {
+	      /* Make personalized messages to give better feedback.  */
+	      if (sym->ts.type == BT_DERIVED)
+		gfc_error ("Variable '%s' at %L is a dummy argument to the "
+			   "BIND(C) procedure '%s' but is not C interoperable "
+			   "because derived type '%s' is not C interoperable",
+			   sym->name, &(sym->declared_at),
+			   sym->ns->proc_name->name,
+			   sym->ts.u.derived->name);
+	      else if (sym->ts.type == BT_CLASS)
+		gfc_error ("Variable '%s' at %L is a dummy argument to the "
+			   "BIND(C) procedure '%s' but is not C interoperable "
+			   "because it is polymorphic",
+			   sym->name, &(sym->declared_at),
+			   sym->ns->proc_name->name);
+	      else if (gfc_option.warn_c_binding_type)
+		gfc_warning ("Variable '%s' at %L is a dummy argument of the "
+			     "BIND(C) procedure '%s' but may not be C "
+			     "interoperable",
+			     sym->name, &(sym->declared_at),
+			     sym->ns->proc_name->name);
+	    }
+
+          /* Character strings are only C interoperable if they have a
+             length of 1.  */
+          if (sym->ts.type == BT_CHARACTER)
+	    {
+	      gfc_charlen *cl = sym->ts.u.cl;
+	      if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT
+                  || mpz_cmp_si (cl->length->value.integer, 1) != 0)
+		{
+		  gfc_error ("Character argument '%s' at %L "
+			     "must be length 1 because "
+                             "procedure '%s' is BIND(C)",
+			     sym->name, &sym->declared_at,
+                             sym->ns->proc_name->name);
+		  retval = false;
+		}
+	    }
+
+	  /* We have to make sure that any param to a bind(c) routine does
+	     not have the allocatable, pointer, or optional attributes,
+	     according to J3/04-007, section 5.1.  */
+	  if (sym->attr.allocatable == 1
+	      && !gfc_notify_std (GFC_STD_F2008_TS, "Variable '%s' at %L with "
+				  "ALLOCATABLE attribute in procedure '%s' "
+				  "with BIND(C)", sym->name,
+				  &(sym->declared_at),
+				  sym->ns->proc_name->name))
+	    retval = false;
+
+	  if (sym->attr.pointer == 1
+	      && !gfc_notify_std (GFC_STD_F2008_TS, "Variable '%s' at %L with "
+				  "POINTER attribute in procedure '%s' "
+				  "with BIND(C)", sym->name,
+				  &(sym->declared_at),
+				  sym->ns->proc_name->name))
+	    retval = false;
+
+	  if ((sym->attr.allocatable || sym->attr.pointer) && !sym->as)
+	    {
+	      gfc_error ("Scalar variable '%s' at %L with POINTER or "
+			 "ALLOCATABLE in procedure '%s' with BIND(C) is not yet"
+			 " supported", sym->name, &(sym->declared_at),
+			 sym->ns->proc_name->name);
+	      retval = false;
+	    }
+
+	  if (sym->attr.optional == 1 && sym->attr.value)
+	    {
+	      gfc_error ("Variable '%s' at %L cannot have both the OPTIONAL "
+			 "and the VALUE attribute because procedure '%s' "
+			 "is BIND(C)", sym->name, &(sym->declared_at),
+			 sym->ns->proc_name->name);
+	      retval = false;
+	    }
+	  else if (sym->attr.optional == 1
+		   && !gfc_notify_std (GFC_STD_F2008_TS, "Variable '%s' "
+				       "at %L with OPTIONAL attribute in "
+				       "procedure '%s' which is BIND(C)", 
+				       sym->name, &(sym->declared_at), 
+				       sym->ns->proc_name->name))
+	    retval = false;
+
+          /* Make sure that if it has the dimension attribute, that it is
+	     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 (GFC_STD_F2008_TS, "Assumed-shape array '%s' "
+				  "at %L as dummy argument to the BIND(C) "
+				  "procedure '%s' at %L", sym->name, 
+				  &(sym->declared_at), 
+				  sym->ns->proc_name->name, 
+				  &(sym->ns->proc_name->declared_at)))
+	    retval = false;
+	}
+    }
+
+  return retval;
+}
+
+
+
+/* Function called by variable_decl() that adds a name to the symbol table.  */
+
+static bool
+build_sym (const char *name, gfc_charlen *cl, bool cl_deferred,
+	   gfc_array_spec **as, locus *var_locus)
+{
+  symbol_attribute attr;
+  gfc_symbol *sym;
+
+  if (gfc_get_symbol (name, NULL, &sym))
+    return false;
+
+  /* Start updating the symbol table.  Add basic type attribute if present.  */
+  if (current_ts.type != BT_UNKNOWN
+      && (sym->attr.implicit_type == 0
+	  || !gfc_compare_types (&sym->ts, &current_ts))
+      && !gfc_add_type (sym, &current_ts, var_locus))
+    return false;
+
+  if (sym->ts.type == BT_CHARACTER)
+    {
+      sym->ts.u.cl = cl;
+      sym->ts.deferred = cl_deferred;
+    }
+
+  /* Add dimension attribute if present.  */
+  if (!gfc_set_array_spec (sym, *as, var_locus))
+    return false;
+  *as = NULL;
+
+  /* Add attribute to symbol.  The copy is so that we can reset the
+     dimension attribute.  */
+  attr = current_attr;
+  attr.dimension = 0;
+  attr.codimension = 0;
+
+  if (!gfc_copy_attr (&sym->attr, &attr, var_locus))
+    return false;
+
+  /* Finish any work that may need to be done for the binding label,
+     if it's a bind(c).  The bind(c) attr is found before the symbol
+     is made, and before the symbol name (for data decls), so the
+     current_ts is holding the binding label, or nothing if the
+     name= attr wasn't given.  Therefore, test here if we're dealing
+     with a bind(c) and make sure the binding label is set correctly.  */
+  if (sym->attr.is_bind_c == 1)
+    {
+      if (!sym->binding_label)
+        {
+	  /* Set the binding label and verify that if a NAME= was specified
+	     then only one identifier was in the entity-decl-list.  */
+	  if (!set_binding_label (&sym->binding_label, sym->name, 
+				  num_idents_on_line))
+            return false;
+        }
+    }
+
+  /* See if we know we're in a common block, and if it's a bind(c)
+     common then we need to make sure we're an interoperable type.  */
+  if (sym->attr.in_common == 1)
+    {
+      /* Test the common block object.  */
+      if (sym->common_block != NULL && sym->common_block->is_bind_c == 1
+          && sym->ts.is_c_interop != 1)
+        {
+          gfc_error_now ("Variable '%s' in common block '%s' at %C "
+                         "must be declared with a C interoperable "
+                         "kind since common block '%s' is BIND(C)",
+                         sym->name, sym->common_block->name,
+                         sym->common_block->name);
+          gfc_clear_error ();
+        }
+    }
+
+  sym->attr.implied_index = 0;
+
+  if (sym->ts.type == BT_CLASS)
+    return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
+
+  return true;
+}
+
+
+/* Set character constant to the given length. The constant will be padded or
+   truncated.  If we're inside an array constructor without a typespec, we
+   additionally check that all elements have the same length; check_len -1
+   means no checking.  */
+
+void
+gfc_set_constant_character_len (int len, gfc_expr *expr, int check_len)
+{
+  gfc_char_t *s;
+  int slen;
+
+  gcc_assert (expr->expr_type == EXPR_CONSTANT);
+  gcc_assert (expr->ts.type == BT_CHARACTER);
+
+  slen = expr->value.character.length;
+  if (len != slen)
+    {
+      s = gfc_get_wide_string (len + 1);
+      memcpy (s, expr->value.character.string,
+	      MIN (len, slen) * sizeof (gfc_char_t));
+      if (len > slen)
+	gfc_wide_memset (&s[slen], ' ', len - slen);
+
+      if (gfc_option.warn_character_truncation && slen > len)
+	gfc_warning_now ("CHARACTER expression at %L is being truncated "
+			 "(%d/%d)", &expr->where, slen, len);
+
+      /* Apply the standard by 'hand' otherwise it gets cleared for
+	 initializers.  */
+      if (check_len != -1 && slen != check_len
+          && !(gfc_option.allow_std & GFC_STD_GNU))
+	gfc_error_now ("The CHARACTER elements of the array constructor "
+		       "at %L must have the same length (%d/%d)",
+			&expr->where, slen, check_len);
+
+      s[len] = '\0';
+      free (expr->value.character.string);
+      expr->value.character.string = s;
+      expr->value.character.length = len;
+    }
+}
+
+
+/* Function to create and update the enumerator history
+   using the information passed as arguments.
+   Pointer "max_enum" is also updated, to point to
+   enum history node containing largest initializer.
+
+   SYM points to the symbol node of enumerator.
+   INIT points to its enumerator value.  */
+
+static void
+create_enum_history (gfc_symbol *sym, gfc_expr *init)
+{
+  enumerator_history *new_enum_history;
+  gcc_assert (sym != NULL && init != NULL);
+
+  new_enum_history = XCNEW (enumerator_history);
+
+  new_enum_history->sym = sym;
+  new_enum_history->initializer = init;
+  new_enum_history->next = NULL;
+
+  if (enum_history == NULL)
+    {
+      enum_history = new_enum_history;
+      max_enum = enum_history;
+    }
+  else
+    {
+      new_enum_history->next = enum_history;
+      enum_history = new_enum_history;
+
+      if (mpz_cmp (max_enum->initializer->value.integer,
+		   new_enum_history->initializer->value.integer) < 0)
+	max_enum = new_enum_history;
+    }
+}
+
+
+/* Function to free enum kind history.  */
+
+void
+gfc_free_enum_history (void)
+{
+  enumerator_history *current = enum_history;
+  enumerator_history *next;
+
+  while (current != NULL)
+    {
+      next = current->next;
+      free (current);
+      current = next;
+    }
+  max_enum = NULL;
+  enum_history = NULL;
+}
+
+
+/* Function called by variable_decl() that adds an initialization
+   expression to a symbol.  */
+
+static bool
+add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
+{
+  symbol_attribute attr;
+  gfc_symbol *sym;
+  gfc_expr *init;
+
+  init = *initp;
+  if (find_special (name, &sym, false))
+    return false;
+
+  attr = sym->attr;
+
+  /* If this symbol is confirming an implicit parameter type,
+     then an initialization expression is not allowed.  */
+  if (attr.flavor == FL_PARAMETER
+      && sym->value != NULL
+      && *initp != NULL)
+    {
+      gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
+		 sym->name);
+      return false;
+    }
+
+  if (init == NULL)
+    {
+      /* An initializer is required for PARAMETER declarations.  */
+      if (attr.flavor == FL_PARAMETER)
+	{
+	  gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
+	  return false;
+	}
+    }
+  else
+    {
+      /* If a variable appears in a DATA block, it cannot have an
+	 initializer.  */
+      if (sym->attr.data)
+	{
+	  gfc_error ("Variable '%s' at %C with an initializer already "
+		     "appears in a DATA statement", sym->name);
+	  return false;
+	}
+
+      /* Check if the assignment can happen. This has to be put off
+	 until later for derived type variables and procedure pointers.  */
+      if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
+	  && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
+	  && !sym->attr.proc_pointer
+	  && !gfc_check_assign_symbol (sym, NULL, init))
+	return false;
+
+      if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl
+	    && init->ts.type == BT_CHARACTER)
+	{
+	  /* Update symbol character length according initializer.  */
+	  if (!gfc_check_assign_symbol (sym, NULL, init))
+	    return false;
+
+	  if (sym->ts.u.cl->length == NULL)
+	    {
+	      int clen;
+	      /* If there are multiple CHARACTER variables declared on the
+		 same line, we don't want them to share the same length.  */
+	      sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+
+	      if (sym->attr.flavor == FL_PARAMETER)
+		{
+		  if (init->expr_type == EXPR_CONSTANT)
+		    {
+		      clen = init->value.character.length;
+		      sym->ts.u.cl->length
+				= gfc_get_int_expr (gfc_default_integer_kind,
+						    NULL, clen);
+		    }
+		  else if (init->expr_type == EXPR_ARRAY)
+		    {
+		      gfc_constructor *c;
+		      c = gfc_constructor_first (init->value.constructor);
+		      clen = c->expr->value.character.length;
+		      sym->ts.u.cl->length
+				= gfc_get_int_expr (gfc_default_integer_kind,
+						    NULL, clen);
+		    }
+		  else if (init->ts.u.cl && init->ts.u.cl->length)
+		    sym->ts.u.cl->length =
+				gfc_copy_expr (sym->value->ts.u.cl->length);
+		}
+	    }
+	  /* Update initializer character length according symbol.  */
+	  else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+	    {
+	      int len = mpz_get_si (sym->ts.u.cl->length->value.integer);
+
+	      if (init->expr_type == EXPR_CONSTANT)
+		gfc_set_constant_character_len (len, init, -1);
+	      else if (init->expr_type == EXPR_ARRAY)
+		{
+		  gfc_constructor *c;
+
+		  /* Build a new charlen to prevent simplification from
+		     deleting the length before it is resolved.  */
+		  init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+		  init->ts.u.cl->length = gfc_copy_expr (sym->ts.u.cl->length);
+
+		  for (c = gfc_constructor_first (init->value.constructor);
+		       c; c = gfc_constructor_next (c))
+		    gfc_set_constant_character_len (len, c->expr, -1);
+		}
+	    }
+	}
+
+      /* If sym is implied-shape, set its upper bounds from init.  */
+      if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
+	  && sym->as->type == AS_IMPLIED_SHAPE)
+	{
+	  int dim;
+
+	  if (init->rank == 0)
+	    {
+	      gfc_error ("Can't initialize implied-shape array at %L"
+			 " with scalar", &sym->declared_at);
+	      return false;
+	    }
+	  gcc_assert (sym->as->rank == init->rank);
+
+	  /* Shape should be present, we get an initialization expression.  */
+	  gcc_assert (init->shape);
+
+	  for (dim = 0; dim < sym->as->rank; ++dim)
+	    {
+	      int k;
+	      gfc_expr* lower;
+	      gfc_expr* e;
+
+	      lower = sym->as->lower[dim];
+	      if (lower->expr_type != EXPR_CONSTANT)
+		{
+		  gfc_error ("Non-constant lower bound in implied-shape"
+			     " declaration at %L", &lower->where);
+		  return false;
+		}
+
+	      /* All dimensions must be without upper bound.  */
+	      gcc_assert (!sym->as->upper[dim]);
+
+	      k = lower->ts.kind;
+	      e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at);
+	      mpz_add (e->value.integer,
+		       lower->value.integer, init->shape[dim]);
+	      mpz_sub_ui (e->value.integer, e->value.integer, 1);
+	      sym->as->upper[dim] = e;
+	    }
+
+	  sym->as->type = AS_EXPLICIT;
+	}
+
+      /* Need to check if the expression we initialized this
+	 to was one of the iso_c_binding named constants.  If so,
+	 and we're a parameter (constant), let it be iso_c.
+	 For example:
+	 integer(c_int), parameter :: my_int = c_int
+	 integer(my_int) :: my_int_2
+	 If we mark my_int as iso_c (since we can see it's value
+	 is equal to one of the named constants), then my_int_2
+	 will be considered C interoperable.  */
+      if (sym->ts.type != BT_CHARACTER && sym->ts.type != BT_DERIVED)
+	{
+	  sym->ts.is_iso_c |= init->ts.is_iso_c;
+	  sym->ts.is_c_interop |= init->ts.is_c_interop;
+	  /* attr bits needed for module files.  */
+	  sym->attr.is_iso_c |= init->ts.is_iso_c;
+	  sym->attr.is_c_interop |= init->ts.is_c_interop;
+	  if (init->ts.is_iso_c)
+	    sym->ts.f90_type = init->ts.f90_type;
+	}
+
+      /* Add initializer.  Make sure we keep the ranks sane.  */
+      if (sym->attr.dimension && init->rank == 0)
+	{
+	  mpz_t size;
+	  gfc_expr *array;
+	  int n;
+	  if (sym->attr.flavor == FL_PARAMETER
+		&& init->expr_type == EXPR_CONSTANT
+		&& spec_size (sym->as, &size)
+		&& mpz_cmp_si (size, 0) > 0)
+	    {
+	      array = gfc_get_array_expr (init->ts.type, init->ts.kind,
+					  &init->where);
+	      for (n = 0; n < (int)mpz_get_si (size); n++)
+		gfc_constructor_append_expr (&array->value.constructor,
+					     n == 0
+						? init
+						: gfc_copy_expr (init),
+					     &init->where);
+
+	      array->shape = gfc_get_shape (sym->as->rank);
+	      for (n = 0; n < sym->as->rank; n++)
+		spec_dimen_size (sym->as, n, &array->shape[n]);
+
+	      init = array;
+	      mpz_clear (size);
+	    }
+	  init->rank = sym->as->rank;
+	}
+
+      sym->value = init;
+      if (sym->attr.save == SAVE_NONE)
+	sym->attr.save = SAVE_IMPLICIT;
+      *initp = NULL;
+    }
+
+  return true;
+}
+
+
+/* Function called by variable_decl() that adds a name to a structure
+   being built.  */
+
+static bool
+build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
+	      gfc_array_spec **as)
+{
+  gfc_component *c;
+  bool t = true;
+
+  /* F03:C438/C439. If the current symbol is of the same derived type that we're
+     constructing, it must have the pointer attribute.  */
+  if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
+      && current_ts.u.derived == gfc_current_block ()
+      && current_attr.pointer == 0)
+    {
+      gfc_error ("Component at %C must have the POINTER attribute");
+      return false;
+    }
+
+  if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
+    {
+      if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
+	{
+	  gfc_error ("Array component of structure at %C must have explicit "
+		     "or deferred shape");
+	  return false;
+	}
+    }
+
+  if (!gfc_add_component (gfc_current_block(), name, &c))
+    return false;
+
+  c->ts = current_ts;
+  if (c->ts.type == BT_CHARACTER)
+    c->ts.u.cl = cl;
+  c->attr = current_attr;
+
+  c->initializer = *init;
+  *init = NULL;
+
+  c->as = *as;
+  if (c->as != NULL)
+    {
+      if (c->as->corank)
+	c->attr.codimension = 1;
+      if (c->as->rank)
+	c->attr.dimension = 1;
+    }
+  *as = NULL;
+
+  /* Should this ever get more complicated, combine with similar section
+     in add_init_expr_to_sym into a separate function.  */
+  if (c->ts.type == BT_CHARACTER && !c->attr.pointer && c->initializer
+      && c->ts.u.cl
+      && c->ts.u.cl->length && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+    {
+      int len;
+
+      gcc_assert (c->ts.u.cl && c->ts.u.cl->length);
+      gcc_assert (c->ts.u.cl->length->expr_type == EXPR_CONSTANT);
+      gcc_assert (c->ts.u.cl->length->ts.type == BT_INTEGER);
+
+      len = mpz_get_si (c->ts.u.cl->length->value.integer);
+
+      if (c->initializer->expr_type == EXPR_CONSTANT)
+	gfc_set_constant_character_len (len, c->initializer, -1);
+      else if (mpz_cmp (c->ts.u.cl->length->value.integer,
+			c->initializer->ts.u.cl->length->value.integer))
+	{
+	  gfc_constructor *ctor;
+	  ctor = gfc_constructor_first (c->initializer->value.constructor);
+
+	  if (ctor)
+	    {
+	      int first_len;
+	      bool has_ts = (c->initializer->ts.u.cl
+			     && c->initializer->ts.u.cl->length_from_typespec);
+
+	      /* Remember the length of the first element for checking
+		 that all elements *in the constructor* have the same
+		 length.  This need not be the length of the LHS!  */
+	      gcc_assert (ctor->expr->expr_type == EXPR_CONSTANT);
+	      gcc_assert (ctor->expr->ts.type == BT_CHARACTER);
+	      first_len = ctor->expr->value.character.length;
+
+	      for ( ; ctor; ctor = gfc_constructor_next (ctor))
+		if (ctor->expr->expr_type == EXPR_CONSTANT)
+		{
+		  gfc_set_constant_character_len (len, ctor->expr,
+						  has_ts ? -1 : first_len);
+		  ctor->expr->ts.u.cl->length = gfc_copy_expr (c->ts.u.cl->length);
+		}
+	    }
+	}
+    }
+
+  /* Check array components.  */
+  if (!c->attr.dimension)
+    goto scalar;
+
+  if (c->attr.pointer)
+    {
+      if (c->as->type != AS_DEFERRED)
+	{
+	  gfc_error ("Pointer array component of structure at %C must have a "
+		     "deferred shape");
+	  t = false;
+	}
+    }
+  else if (c->attr.allocatable)
+    {
+      if (c->as->type != AS_DEFERRED)
+	{
+	  gfc_error ("Allocatable component of structure at %C must have a "
+		     "deferred shape");
+	  t = false;
+	}
+    }
+  else
+    {
+      if (c->as->type != AS_EXPLICIT)
+	{
+	  gfc_error ("Array component of structure at %C must have an "
+		     "explicit shape");
+	  t = false;
+	}
+    }
+
+scalar:
+  if (c->ts.type == BT_CLASS)
+    {
+      bool t2 = gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
+
+      if (t)
+	t = t2;
+    }
+
+  return t;
+}
+
+
+/* Match a 'NULL()', and possibly take care of some side effects.  */
+
+match
+gfc_match_null (gfc_expr **result)
+{
+  gfc_symbol *sym;
+  match m, m2 = MATCH_NO;
+
+  if ((m = gfc_match (" null ( )")) == MATCH_ERROR)
+    return MATCH_ERROR;
+
+  if (m == MATCH_NO)
+    {
+      locus old_loc;
+      char name[GFC_MAX_SYMBOL_LEN + 1];
+
+      if ((m2 = gfc_match (" null (")) != MATCH_YES)
+	return m2;
+
+      old_loc = gfc_current_locus;
+      if ((m2 = gfc_match (" %n ) ", name)) == MATCH_ERROR)
+	return MATCH_ERROR;
+      if (m2 != MATCH_YES
+	  && ((m2 = gfc_match (" mold = %n )", name)) == MATCH_ERROR))
+	return MATCH_ERROR;
+      if (m2 == MATCH_NO)
+	{
+	  gfc_current_locus = old_loc;
+	  return MATCH_NO;
+	}
+    }
+
+  /* The NULL symbol now has to be/become an intrinsic function.  */
+  if (gfc_get_symbol ("null", NULL, &sym))
+    {
+      gfc_error ("NULL() initialization at %C is ambiguous");
+      return MATCH_ERROR;
+    }
+
+  gfc_intrinsic_symbol (sym);
+
+  if (sym->attr.proc != PROC_INTRINSIC
+      && !(sym->attr.use_assoc && sym->attr.intrinsic)
+      && (!gfc_add_procedure(&sym->attr, PROC_INTRINSIC, sym->name, NULL)
+	  || !gfc_add_function (&sym->attr, sym->name, NULL)))
+    return MATCH_ERROR;
+
+  *result = gfc_get_null_expr (&gfc_current_locus);
+
+  /* Invalid per F2008, C512.  */
+  if (m2 == MATCH_YES)
+    {
+      gfc_error ("NULL() initialization at %C may not have MOLD");
+      return MATCH_ERROR;
+    }
+
+  return MATCH_YES;
+}
+
+
+/* Match the initialization expr for a data pointer or procedure pointer.  */
+
+static match
+match_pointer_init (gfc_expr **init, int procptr)
+{
+  match m;
+
+  if (gfc_pure (NULL) && gfc_state_stack->state != COMP_DERIVED)
+    {
+      gfc_error ("Initialization of pointer at %C is not allowed in "
+		 "a PURE procedure");
+      return MATCH_ERROR;
+    }
+  gfc_unset_implicit_pure (gfc_current_ns->proc_name);
+
+  /* Match NULL() initialization.  */
+  m = gfc_match_null (init);
+  if (m != MATCH_NO)
+    return m;
+
+  /* Match non-NULL initialization.  */
+  gfc_matching_ptr_assignment = !procptr;
+  gfc_matching_procptr_assignment = procptr;
+  m = gfc_match_rvalue (init);
+  gfc_matching_ptr_assignment = 0;
+  gfc_matching_procptr_assignment = 0;
+  if (m == MATCH_ERROR)
+    return MATCH_ERROR;
+  else if (m == MATCH_NO)
+    {
+      gfc_error ("Error in pointer initialization at %C");
+      return MATCH_ERROR;
+    }
+
+  if (!procptr)
+    gfc_resolve_expr (*init);
+
+  if (!gfc_notify_std (GFC_STD_F2008, "non-NULL pointer "
+		       "initialization at %C"))
+    return MATCH_ERROR;
+
+  return MATCH_YES;
+}
+
+
+static bool
+check_function_name (char *name)
+{
+  /* In functions that have a RESULT variable defined, the function name always
+     refers to function calls.  Therefore, the name is not allowed to appear in
+     specification statements. When checking this, be careful about
+     'hidden' procedure pointer results ('ppr@').  */
+
+  if (gfc_current_state () == COMP_FUNCTION)
+    {
+      gfc_symbol *block = gfc_current_block ();
+      if (block && block->result && block->result != block
+	  && strcmp (block->result->name, "ppr@") != 0
+	  && strcmp (block->name, name) == 0)
+	{
+	  gfc_error ("Function name '%s' not allowed at %C", name);
+	  return false;
+	}
+    }
+
+  return true;
+}
+
+
+/* Match a variable name with an optional initializer.  When this
+   subroutine is called, a variable is expected to be parsed next.
+   Depending on what is happening at the moment, updates either the
+   symbol table or the current interface.  */
+
+static match
+variable_decl (int elem)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_expr *initializer, *char_len;
+  gfc_array_spec *as;
+  gfc_array_spec *cp_as; /* Extra copy for Cray Pointees.  */
+  gfc_charlen *cl;
+  bool cl_deferred;
+  locus var_locus;
+  match m;
+  bool t;
+  gfc_symbol *sym;
+
+  initializer = NULL;
+  as = NULL;
+  cp_as = NULL;
+
+  /* When we get here, we've just matched a list of attributes and
+     maybe a type and a double colon.  The next thing we expect to see
+     is the name of the symbol.  */
+  m = gfc_match_name (name);
+  if (m != MATCH_YES)
+    goto cleanup;
+
+  var_locus = gfc_current_locus;
+
+  /* Now we could see the optional array spec. or character length.  */
+  m = gfc_match_array_spec (&as, true, true);
+  if (m == MATCH_ERROR)
+    goto cleanup;
+
+  if (m == MATCH_NO)
+    as = gfc_copy_array_spec (current_as);
+  else if (current_as
+	   && !merge_array_spec (current_as, as, true))
+    {
+      m = MATCH_ERROR;
+      goto cleanup;
+    }
+
+  if (gfc_option.flag_cray_pointer)
+    cp_as = gfc_copy_array_spec (as);
+
+  /* At this point, we know for sure if the symbol is PARAMETER and can thus
+     determine (and check) whether it can be implied-shape.  If it
+     was parsed as assumed-size, change it because PARAMETERs can not
+     be assumed-size.  */
+  if (as)
+    {
+      if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER)
+	{
+	  m = MATCH_ERROR;
+	  gfc_error ("Non-PARAMETER symbol '%s' at %L can't be implied-shape",
+		     name, &var_locus);
+	  goto cleanup;
+	}
+
+      if (as->type == AS_ASSUMED_SIZE && as->rank == 1
+	  && current_attr.flavor == FL_PARAMETER)
+	as->type = AS_IMPLIED_SHAPE;
+
+      if (as->type == AS_IMPLIED_SHAPE
+	  && !gfc_notify_std (GFC_STD_F2008, "Implied-shape array at %L", 
+			      &var_locus))
+	{
+	  m = MATCH_ERROR;
+	  goto cleanup;
+	}
+    }
+
+  char_len = NULL;
+  cl = NULL;
+  cl_deferred = false;
+
+  if (current_ts.type == BT_CHARACTER)
+    {
+      switch (match_char_length (&char_len, &cl_deferred, false))
+	{
+	case MATCH_YES:
+	  cl = gfc_new_charlen (gfc_current_ns, NULL);
+
+	  cl->length = char_len;
+	  break;
+
+	/* Non-constant lengths need to be copied after the first
+	   element.  Also copy assumed lengths.  */
+	case MATCH_NO:
+	  if (elem > 1
+	      && (current_ts.u.cl->length == NULL
+		  || current_ts.u.cl->length->expr_type != EXPR_CONSTANT))
+	    {
+	      cl = gfc_new_charlen (gfc_current_ns, NULL);
+	      cl->length = gfc_copy_expr (current_ts.u.cl->length);
+	    }
+	  else
+	    cl = current_ts.u.cl;
+
+	  cl_deferred = current_ts.deferred;
+
+	  break;
+
+	case MATCH_ERROR:
+	  goto cleanup;
+	}
+    }
+
+  /*  If this symbol has already shown up in a Cray Pointer declaration,
+      then we want to set the type & bail out.  */
+  if (gfc_option.flag_cray_pointer)
+    {
+      gfc_find_symbol (name, gfc_current_ns, 1, &sym);
+      if (sym != NULL && sym->attr.cray_pointee)
+	{
+	  sym->ts.type = current_ts.type;
+	  sym->ts.kind = current_ts.kind;
+	  sym->ts.u.cl = cl;
+	  sym->ts.u.derived = current_ts.u.derived;
+	  sym->ts.is_c_interop = current_ts.is_c_interop;
+	  sym->ts.is_iso_c = current_ts.is_iso_c;
+	  m = MATCH_YES;
+
+	  /* Check to see if we have an array specification.  */
+	  if (cp_as != NULL)
+	    {
+	      if (sym->as != NULL)
+		{
+		  gfc_error ("Duplicate array spec for Cray pointee at %C");
+		  gfc_free_array_spec (cp_as);
+		  m = MATCH_ERROR;
+		  goto cleanup;
+		}
+	      else
+		{
+		  if (!gfc_set_array_spec (sym, cp_as, &var_locus))
+		    gfc_internal_error ("Couldn't set pointee array spec.");
+
+		  /* Fix the array spec.  */
+		  m = gfc_mod_pointee_as (sym->as);
+		  if (m == MATCH_ERROR)
+		    goto cleanup;
+		}
+	    }
+	  goto cleanup;
+	}
+      else
+	{
+	  gfc_free_array_spec (cp_as);
+	}
+    }
+
+  /* Procedure pointer as function result.  */
+  if (gfc_current_state () == COMP_FUNCTION
+      && strcmp ("ppr@", gfc_current_block ()->name) == 0
+      && strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0)
+    strcpy (name, "ppr@");
+
+  if (gfc_current_state () == COMP_FUNCTION
+      && strcmp (name, gfc_current_block ()->name) == 0
+      && gfc_current_block ()->result
+      && strcmp ("ppr@", gfc_current_block ()->result->name) == 0)
+    strcpy (name, "ppr@");
+
+  /* OK, we've successfully matched the declaration.  Now put the
+     symbol in the current namespace, because it might be used in the
+     optional initialization expression for this symbol, e.g. this is
+     perfectly legal:
+
+     integer, parameter :: i = huge(i)
+
+     This is only true for parameters or variables of a basic type.
+     For components of derived types, it is not true, so we don't
+     create a symbol for those yet.  If we fail to create the symbol,
+     bail out.  */
+  if (gfc_current_state () != COMP_DERIVED
+      && !build_sym (name, cl, cl_deferred, &as, &var_locus))
+    {
+      m = MATCH_ERROR;
+      goto cleanup;
+    }
+
+  if (!check_function_name (name))
+    {
+      m = MATCH_ERROR;
+      goto cleanup;
+    }
+
+  /* We allow old-style initializations of the form
+       integer i /2/, j(4) /3*3, 1/
+     (if no colon has been seen). These are different from data
+     statements in that initializers are only allowed to apply to the
+     variable immediately preceding, i.e.
+       integer i, j /1, 2/
+     is not allowed. Therefore we have to do some work manually, that
+     could otherwise be left to the matchers for DATA statements.  */
+
+  if (!colon_seen && gfc_match (" /") == MATCH_YES)
+    {
+      if (!gfc_notify_std (GFC_STD_GNU, "Old-style "
+			   "initialization at %C"))
+	return MATCH_ERROR;
+
+      return match_old_style_init (name);
+    }
+
+  /* The double colon must be present in order to have initializers.
+     Otherwise the statement is ambiguous with an assignment statement.  */
+  if (colon_seen)
+    {
+      if (gfc_match (" =>") == MATCH_YES)
+	{
+	  if (!current_attr.pointer)
+	    {
+	      gfc_error ("Initialization at %C isn't for a pointer variable");
+	      m = MATCH_ERROR;
+	      goto cleanup;
+	    }
+
+	  m = match_pointer_init (&initializer, 0);
+	  if (m != MATCH_YES)
+	    goto cleanup;
+	}
+      else if (gfc_match_char ('=') == MATCH_YES)
+	{
+	  if (current_attr.pointer)
+	    {
+	      gfc_error ("Pointer initialization at %C requires '=>', "
+			 "not '='");
+	      m = MATCH_ERROR;
+	      goto cleanup;
+	    }
+
+	  m = gfc_match_init_expr (&initializer);
+	  if (m == MATCH_NO)
+	    {
+	      gfc_error ("Expected an initialization expression at %C");
+	      m = MATCH_ERROR;
+	    }
+
+	  if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL)
+	      && gfc_state_stack->state != COMP_DERIVED)
+	    {
+	      gfc_error ("Initialization of variable at %C is not allowed in "
+			 "a PURE procedure");
+	      m = MATCH_ERROR;
+	    }
+
+	  if (current_attr.flavor != FL_PARAMETER
+	      && gfc_state_stack->state != COMP_DERIVED)
+	    gfc_unset_implicit_pure (gfc_current_ns->proc_name);
+
+	  if (m != MATCH_YES)
+	    goto cleanup;
+	}
+    }
+
+  if (initializer != NULL && current_attr.allocatable
+	&& gfc_current_state () == COMP_DERIVED)
+    {
+      gfc_error ("Initialization of allocatable component at %C is not "
+		 "allowed");
+      m = MATCH_ERROR;
+      goto cleanup;
+    }
+
+  /* Add the initializer.  Note that it is fine if initializer is
+     NULL here, because we sometimes also need to check if a
+     declaration *must* have an initialization expression.  */
+  if (gfc_current_state () != COMP_DERIVED)
+    t = add_init_expr_to_sym (name, &initializer, &var_locus);
+  else
+    {
+      if (current_ts.type == BT_DERIVED
+	  && !current_attr.pointer && !initializer)
+	initializer = gfc_default_initializer (&current_ts);
+      t = build_struct (name, cl, &initializer, &as);
+    }
+
+  m = (t) ? MATCH_YES : MATCH_ERROR;
+
+cleanup:
+  /* Free stuff up and return.  */
+  gfc_free_expr (initializer);
+  gfc_free_array_spec (as);
+
+  return m;
+}
+
+
+/* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
+   This assumes that the byte size is equal to the kind number for
+   non-COMPLEX types, and equal to twice the kind number for COMPLEX.  */
+
+match
+gfc_match_old_kind_spec (gfc_typespec *ts)
+{
+  match m;
+  int original_kind;
+
+  if (gfc_match_char ('*') != MATCH_YES)
+    return MATCH_NO;
+
+  m = gfc_match_small_literal_int (&ts->kind, NULL);
+  if (m != MATCH_YES)
+    return MATCH_ERROR;
+
+  original_kind = ts->kind;
+
+  /* Massage the kind numbers for complex types.  */
+  if (ts->type == BT_COMPLEX)
+    {
+      if (ts->kind % 2)
+	{
+	  gfc_error ("Old-style type declaration %s*%d not supported at %C",
+		     gfc_basic_typename (ts->type), original_kind);
+	  return MATCH_ERROR;
+	}
+      ts->kind /= 2;
+
+    }
+
+  if (ts->type == BT_INTEGER && ts->kind == 4 && gfc_option.flag_integer4_kind == 8)
+    ts->kind = 8;
+
+  if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
+    {
+      if (ts->kind == 4)
+	{
+	  if (gfc_option.flag_real4_kind == 8)
+	    ts->kind =  8;
+	  if (gfc_option.flag_real4_kind == 10)
+	    ts->kind = 10;
+	  if (gfc_option.flag_real4_kind == 16)
+	    ts->kind = 16;
+	}
+
+      if (ts->kind == 8)
+	{
+	  if (gfc_option.flag_real8_kind == 4)
+	    ts->kind = 4;
+	  if (gfc_option.flag_real8_kind == 10)
+	    ts->kind = 10;
+	  if (gfc_option.flag_real8_kind == 16)
+	    ts->kind = 16;
+	}
+    }
+
+  if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
+    {
+      gfc_error ("Old-style type declaration %s*%d not supported at %C",
+		 gfc_basic_typename (ts->type), original_kind);
+      return MATCH_ERROR;
+    }
+
+  if (!gfc_notify_std (GFC_STD_GNU, 
+		       "Nonstandard type declaration %s*%d at %C", 
+		       gfc_basic_typename(ts->type), original_kind))
+    return MATCH_ERROR;
+
+  return MATCH_YES;
+}
+
+
+/* Match a kind specification.  Since kinds are generally optional, we
+   usually return MATCH_NO if something goes wrong.  If a "kind="
+   string is found, then we know we have an error.  */
+
+match
+gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only)
+{
+  locus where, loc;
+  gfc_expr *e;
+  match m, n;
+  char c;
+  const char *msg;
+
+  m = MATCH_NO;
+  n = MATCH_YES;
+  e = NULL;
+
+  where = loc = gfc_current_locus;
+
+  if (kind_expr_only)
+    goto kind_expr;
+
+  if (gfc_match_char ('(') == MATCH_NO)
+    return MATCH_NO;
+
+  /* Also gobbles optional text.  */
+  if (gfc_match (" kind = ") == MATCH_YES)
+    m = MATCH_ERROR;
+
+  loc = gfc_current_locus;
+
+kind_expr:
+  n = gfc_match_init_expr (&e);
+
+  if (n != MATCH_YES)
+    {
+      if (gfc_matching_function)
+	{
+	  /* The function kind expression might include use associated or
+	     imported parameters and try again after the specification
+	     expressions.....  */
+	  if (gfc_match_char (')') != MATCH_YES)
+	    {
+	      gfc_error ("Missing right parenthesis at %C");
+	      m = MATCH_ERROR;
+	      goto no_match;
+	    }
+
+	  gfc_free_expr (e);
+	  gfc_undo_symbols ();
+	  return MATCH_YES;
+	}
+      else
+	{
+	  /* ....or else, the match is real.  */
+	  if (n == MATCH_NO)
+	    gfc_error ("Expected initialization expression at %C");
+	  if (n != MATCH_YES)
+	    return MATCH_ERROR;
+	}
+    }
+
+  if (e->rank != 0)
+    {
+      gfc_error ("Expected scalar initialization expression at %C");
+      m = MATCH_ERROR;
+      goto no_match;
+    }
+
+  msg = gfc_extract_int (e, &ts->kind);
+
+  if (msg != NULL)
+    {
+      gfc_error (msg);
+      m = MATCH_ERROR;
+      goto no_match;
+    }
+
+  /* Before throwing away the expression, let's see if we had a
+     C interoperable kind (and store the fact).	 */
+  if (e->ts.is_c_interop == 1)
+    {
+      /* Mark this as C interoperable if being declared with one
+	 of the named constants from iso_c_binding.  */
+      ts->is_c_interop = e->ts.is_iso_c;
+      ts->f90_type = e->ts.f90_type;
+    }
+
+  gfc_free_expr (e);
+  e = NULL;
+
+  /* Ignore errors to this point, if we've gotten here.  This means
+     we ignore the m=MATCH_ERROR from above.  */
+  if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
+    {
+      gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
+		 gfc_basic_typename (ts->type));
+      gfc_current_locus = where;
+      return MATCH_ERROR;
+    }
+
+  /* Warn if, e.g., c_int is used for a REAL variable, but not
+     if, e.g., c_double is used for COMPLEX as the standard
+     explicitly says that the kind type parameter for complex and real
+     variable is the same, i.e. c_float == c_float_complex.  */
+  if (ts->f90_type != BT_UNKNOWN && ts->f90_type != ts->type
+      && !((ts->f90_type == BT_REAL && ts->type == BT_COMPLEX)
+	   || (ts->f90_type == BT_COMPLEX && ts->type == BT_REAL)))
+    gfc_warning_now ("C kind type parameter is for type %s but type at %L "
+		     "is %s", gfc_basic_typename (ts->f90_type), &where,
+		     gfc_basic_typename (ts->type));
+
+  gfc_gobble_whitespace ();
+  if ((c = gfc_next_ascii_char ()) != ')'
+      && (ts->type != BT_CHARACTER || c != ','))
+    {
+      if (ts->type == BT_CHARACTER)
+	gfc_error ("Missing right parenthesis or comma at %C");
+      else
+	gfc_error ("Missing right parenthesis at %C");
+      m = MATCH_ERROR;
+    }
+  else
+     /* All tests passed.  */
+     m = MATCH_YES;
+
+  if(m == MATCH_ERROR)
+     gfc_current_locus = where;
+
+  if (ts->type == BT_INTEGER && ts->kind == 4 && gfc_option.flag_integer4_kind == 8)
+    ts->kind =  8;
+
+  if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
+    {
+      if (ts->kind == 4)
+	{
+	  if (gfc_option.flag_real4_kind == 8)
+	    ts->kind =  8;
+	  if (gfc_option.flag_real4_kind == 10)
+	    ts->kind = 10;
+	  if (gfc_option.flag_real4_kind == 16)
+	    ts->kind = 16;
+	}
+
+      if (ts->kind == 8)
+	{
+	  if (gfc_option.flag_real8_kind == 4)
+	    ts->kind = 4;
+	  if (gfc_option.flag_real8_kind == 10)
+	    ts->kind = 10;
+	  if (gfc_option.flag_real8_kind == 16)
+	    ts->kind = 16;
+	}
+    }
+
+  /* Return what we know from the test(s).  */
+  return m;
+
+no_match:
+  gfc_free_expr (e);
+  gfc_current_locus = where;
+  return m;
+}
+
+
+static match
+match_char_kind (int * kind, int * is_iso_c)
+{
+  locus where;
+  gfc_expr *e;
+  match m, n;
+  const char *msg;
+
+  m = MATCH_NO;
+  e = NULL;
+  where = gfc_current_locus;
+
+  n = gfc_match_init_expr (&e);
+
+  if (n != MATCH_YES && gfc_matching_function)
+    {
+      /* The expression might include use-associated or imported
+	 parameters and try again after the specification
+	 expressions.  */
+      gfc_free_expr (e);
+      gfc_undo_symbols ();
+      return MATCH_YES;
+    }
+
+  if (n == MATCH_NO)
+    gfc_error ("Expected initialization expression at %C");
+  if (n != MATCH_YES)
+    return MATCH_ERROR;
+
+  if (e->rank != 0)
+    {
+      gfc_error ("Expected scalar initialization expression at %C");
+      m = MATCH_ERROR;
+      goto no_match;
+    }
+
+  msg = gfc_extract_int (e, kind);
+  *is_iso_c = e->ts.is_iso_c;
+  if (msg != NULL)
+    {
+      gfc_error (msg);
+      m = MATCH_ERROR;
+      goto no_match;
+    }
+
+  gfc_free_expr (e);
+
+  /* Ignore errors to this point, if we've gotten here.  This means
+     we ignore the m=MATCH_ERROR from above.  */
+  if (gfc_validate_kind (BT_CHARACTER, *kind, true) < 0)
+    {
+      gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind);
+      m = MATCH_ERROR;
+    }
+  else
+     /* All tests passed.  */
+     m = MATCH_YES;
+
+  if (m == MATCH_ERROR)
+     gfc_current_locus = where;
+
+  /* Return what we know from the test(s).  */
+  return m;
+
+no_match:
+  gfc_free_expr (e);
+  gfc_current_locus = where;
+  return m;
+}
+
+
+/* Match the various kind/length specifications in a CHARACTER
+   declaration.  We don't return MATCH_NO.  */
+
+match
+gfc_match_char_spec (gfc_typespec *ts)
+{
+  int kind, seen_length, is_iso_c;
+  gfc_charlen *cl;
+  gfc_expr *len;
+  match m;
+  bool deferred;
+
+  len = NULL;
+  seen_length = 0;
+  kind = 0;
+  is_iso_c = 0;
+  deferred = false;
+
+  /* Try the old-style specification first.  */
+  old_char_selector = 0;
+
+  m = match_char_length (&len, &deferred, true);
+  if (m != MATCH_NO)
+    {
+      if (m == MATCH_YES)
+	old_char_selector = 1;
+      seen_length = 1;
+      goto done;
+    }
+
+  m = gfc_match_char ('(');
+  if (m != MATCH_YES)
+    {
+      m = MATCH_YES;	/* Character without length is a single char.  */
+      goto done;
+    }
+
+  /* Try the weird case:  ( KIND = <int> [ , LEN = <len-param> ] ).  */
+  if (gfc_match (" kind =") == MATCH_YES)
+    {
+      m = match_char_kind (&kind, &is_iso_c);
+
+      if (m == MATCH_ERROR)
+	goto done;
+      if (m == MATCH_NO)
+	goto syntax;
+
+      if (gfc_match (" , len =") == MATCH_NO)
+	goto rparen;
+
+      m = char_len_param_value (&len, &deferred);
+      if (m == MATCH_NO)
+	goto syntax;
+      if (m == MATCH_ERROR)
+	goto done;
+      seen_length = 1;
+
+      goto rparen;
+    }
+
+  /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>".  */
+  if (gfc_match (" len =") == MATCH_YES)
+    {
+      m = char_len_param_value (&len, &deferred);
+      if (m == MATCH_NO)
+	goto syntax;
+      if (m == MATCH_ERROR)
+	goto done;
+      seen_length = 1;
+
+      if (gfc_match_char (')') == MATCH_YES)
+	goto done;
+
+      if (gfc_match (" , kind =") != MATCH_YES)
+	goto syntax;
+
+      if (match_char_kind (&kind, &is_iso_c) == MATCH_ERROR)
+	goto done;
+
+      goto rparen;
+    }
+
+  /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ).  */
+  m = char_len_param_value (&len, &deferred);
+  if (m == MATCH_NO)
+    goto syntax;
+  if (m == MATCH_ERROR)
+    goto done;
+  seen_length = 1;
+
+  m = gfc_match_char (')');
+  if (m == MATCH_YES)
+    goto done;
+
+  if (gfc_match_char (',') != MATCH_YES)
+    goto syntax;
+
+  gfc_match (" kind =");	/* Gobble optional text.  */
+
+  m = match_char_kind (&kind, &is_iso_c);
+  if (m == MATCH_ERROR)
+    goto done;
+  if (m == MATCH_NO)
+    goto syntax;
+
+rparen:
+  /* Require a right-paren at this point.  */
+  m = gfc_match_char (')');
+  if (m == MATCH_YES)
+    goto done;
+
+syntax:
+  gfc_error ("Syntax error in CHARACTER declaration at %C");
+  m = MATCH_ERROR;
+  gfc_free_expr (len);
+  return m;
+
+done:
+  /* Deal with character functions after USE and IMPORT statements.  */
+  if (gfc_matching_function)
+    {
+      gfc_free_expr (len);
+      gfc_undo_symbols ();
+      return MATCH_YES;
+    }
+
+  if (m != MATCH_YES)
+    {
+      gfc_free_expr (len);
+      return m;
+    }
+
+  /* Do some final massaging of the length values.  */
+  cl = gfc_new_charlen (gfc_current_ns, NULL);
+
+  if (seen_length == 0)
+    cl->length = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+  else
+    cl->length = len;
+
+  ts->u.cl = cl;
+  ts->kind = kind == 0 ? gfc_default_character_kind : kind;
+  ts->deferred = deferred;
+
+  /* We have to know if it was a C interoperable kind so we can
+     do accurate type checking of bind(c) procs, etc.  */
+  if (kind != 0)
+    /* Mark this as C interoperable if being declared with one
+       of the named constants from iso_c_binding.  */
+    ts->is_c_interop = is_iso_c;
+  else if (len != NULL)
+    /* Here, we might have parsed something such as: character(c_char)
+       In this case, the parsing code above grabs the c_char when
+       looking for the length (line 1690, roughly).  it's the last
+       testcase for parsing the kind params of a character variable.
+       However, it's not actually the length.	 this seems like it
+       could be an error.
+       To see if the user used a C interop kind, test the expr
+       of the so called length, and see if it's C interoperable.  */
+    ts->is_c_interop = len->ts.is_iso_c;
+
+  return MATCH_YES;
+}
+
+
+/* Matches a declaration-type-spec (F03:R502).  If successful, sets the ts
+   structure to the matched specification.  This is necessary for FUNCTION and
+   IMPLICIT statements.
+
+   If implicit_flag is nonzero, then we don't check for the optional
+   kind specification.  Not doing so is needed for matching an IMPLICIT
+   statement correctly.  */
+
+match
+gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_symbol *sym, *dt_sym;
+  match m;
+  char c;
+  bool seen_deferred_kind, matched_type;
+  const char *dt_name;
+
+  /* A belt and braces check that the typespec is correctly being treated
+     as a deferred characteristic association.  */
+  seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION)
+			  && (gfc_current_block ()->result->ts.kind == -1)
+			  && (ts->kind == -1);
+  gfc_clear_ts (ts);
+  if (seen_deferred_kind)
+    ts->kind = -1;
+
+  /* Clear the current binding label, in case one is given.  */
+  curr_binding_label = NULL;
+
+  if (gfc_match (" byte") == MATCH_YES)
+    {
+      if (!gfc_notify_std (GFC_STD_GNU, "BYTE type at %C"))
+	return MATCH_ERROR;
+
+      if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
+	{
+	  gfc_error ("BYTE type used at %C "
+		     "is not available on the target machine");
+	  return MATCH_ERROR;
+	}
+
+      ts->type = BT_INTEGER;
+      ts->kind = 1;
+      return MATCH_YES;
+    }
+
+
+  m = gfc_match (" type (");
+  matched_type = (m == MATCH_YES);
+  if (matched_type)
+    {
+      gfc_gobble_whitespace ();
+      if (gfc_peek_ascii_char () == '*')
+	{
+	  if ((m = gfc_match ("*)")) != MATCH_YES)
+	    return m;
+	  if (gfc_current_state () == COMP_DERIVED)
+	    {
+	      gfc_error ("Assumed type at %C is not allowed for components");
+	      return MATCH_ERROR;
+	    }
+	  if (!gfc_notify_std (GFC_STD_F2008_TS, "Assumed type "
+			       "at %C"))
+	    return MATCH_ERROR;
+	  ts->type = BT_ASSUMED;
+	  return MATCH_YES;
+	}
+
+      m = gfc_match ("%n", name);
+      matched_type = (m == MATCH_YES);
+    }
+
+  if ((matched_type && strcmp ("integer", name) == 0)
+      || (!matched_type && gfc_match (" integer") == MATCH_YES))
+    {
+      ts->type = BT_INTEGER;
+      ts->kind = gfc_default_integer_kind;
+      goto get_kind;
+    }
+
+  if ((matched_type && strcmp ("character", name) == 0)
+      || (!matched_type && gfc_match (" character") == MATCH_YES))
+    {
+      if (matched_type
+	  && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
+			      "intrinsic-type-spec at %C"))
+	return MATCH_ERROR;
+
+      ts->type = BT_CHARACTER;
+      if (implicit_flag == 0)
+	m = gfc_match_char_spec (ts);
+      else
+	m = MATCH_YES;
+
+      if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES)
+	m = MATCH_ERROR;
+
+      return m;
+    }
+
+  if ((matched_type && strcmp ("real", name) == 0)
+      || (!matched_type && gfc_match (" real") == MATCH_YES))
+    {
+      ts->type = BT_REAL;
+      ts->kind = gfc_default_real_kind;
+      goto get_kind;
+    }
+
+  if ((matched_type
+       && (strcmp ("doubleprecision", name) == 0
+	   || (strcmp ("double", name) == 0
+	       && gfc_match (" precision") == MATCH_YES)))
+      || (!matched_type && gfc_match (" double precision") == MATCH_YES))
+    {
+      if (matched_type
+	  && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
+			      "intrinsic-type-spec at %C"))
+	return MATCH_ERROR;
+      if (matched_type && gfc_match_char (')') != MATCH_YES)
+	return MATCH_ERROR;
+
+      ts->type = BT_REAL;
+      ts->kind = gfc_default_double_kind;
+      return MATCH_YES;
+    }
+
+  if ((matched_type && strcmp ("complex", name) == 0)
+      || (!matched_type && gfc_match (" complex") == MATCH_YES))
+    {
+      ts->type = BT_COMPLEX;
+      ts->kind = gfc_default_complex_kind;
+      goto get_kind;
+    }
+
+  if ((matched_type
+       && (strcmp ("doublecomplex", name) == 0
+	   || (strcmp ("double", name) == 0
+	       && gfc_match (" complex") == MATCH_YES)))
+      || (!matched_type && gfc_match (" double complex") == MATCH_YES))
+    {
+      if (!gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C"))
+	return MATCH_ERROR;
+
+      if (matched_type
+	  && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
+			      "intrinsic-type-spec at %C"))
+	return MATCH_ERROR;
+
+      if (matched_type && gfc_match_char (')') != MATCH_YES)
+	return MATCH_ERROR;
+
+      ts->type = BT_COMPLEX;
+      ts->kind = gfc_default_double_kind;
+      return MATCH_YES;
+    }
+
+  if ((matched_type && strcmp ("logical", name) == 0)
+      || (!matched_type && gfc_match (" logical") == MATCH_YES))
+    {
+      ts->type = BT_LOGICAL;
+      ts->kind = gfc_default_logical_kind;
+      goto get_kind;
+    }
+
+  if (matched_type)
+    m = gfc_match_char (')');
+
+  if (m == MATCH_YES)
+    ts->type = BT_DERIVED;
+  else
+    {
+      /* Match CLASS declarations.  */
+      m = gfc_match (" class ( * )");
+      if (m == MATCH_ERROR)
+	return MATCH_ERROR;
+      else if (m == MATCH_YES)
+	{
+	  gfc_symbol *upe;
+	  gfc_symtree *st;
+	  ts->type = BT_CLASS;
+	  gfc_find_symbol ("STAR", gfc_current_ns, 1, &upe);
+	  if (upe == NULL)
+	    {
+	      upe = gfc_new_symbol ("STAR", gfc_current_ns);
+	      st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR");
+	      st->n.sym = upe;
+	      gfc_set_sym_referenced (upe);
+	      upe->refs++;
+	      upe->ts.type = BT_VOID;
+	      upe->attr.unlimited_polymorphic = 1;
+	      /* This is essential to force the construction of
+		 unlimited polymorphic component class containers.  */
+	      upe->attr.zero_comp = 1;
+	      if (!gfc_add_flavor (&upe->attr, FL_DERIVED, NULL, 
+				   &gfc_current_locus))
+	  return MATCH_ERROR;
+	}
+	  else
+	    {
+	      st = gfc_find_symtree (gfc_current_ns->sym_root, "STAR");
+	      if (st == NULL)
+		st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR");
+	      st->n.sym = upe;
+	      upe->refs++;
+	    }
+	  ts->u.derived = upe;
+	  return m;
+	}
+
+      m = gfc_match (" class ( %n )", name);
+      if (m != MATCH_YES)
+	return m;
+      ts->type = BT_CLASS;
+
+      if (!gfc_notify_std (GFC_STD_F2003, "CLASS statement at %C"))
+	return MATCH_ERROR;
+    }
+
+  /* Defer association of the derived type until the end of the
+     specification block.  However, if the derived type can be
+     found, add it to the typespec.  */
+  if (gfc_matching_function)
+    {
+      ts->u.derived = NULL;
+      if (gfc_current_state () != COMP_INTERFACE
+	    && !gfc_find_symbol (name, NULL, 1, &sym) && sym)
+	{
+	  sym = gfc_find_dt_in_generic (sym);
+	  ts->u.derived = sym;
+	}
+      return MATCH_YES;
+    }
+
+  /* Search for the name but allow the components to be defined later.  If
+     type = -1, this typespec has been seen in a function declaration but
+     the type could not be accessed at that point.  The actual derived type is
+     stored in a symtree with the first letter of the name capitalized; the
+     symtree with the all lower-case name contains the associated
+     generic function.  */
+  dt_name = gfc_get_string ("%c%s",
+			    (char) TOUPPER ((unsigned char) name[0]),
+			    (const char*)&name[1]);
+  sym = NULL;
+  dt_sym = NULL;
+  if (ts->kind != -1)
+    {
+      gfc_get_ha_symbol (name, &sym);
+      if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym))
+	{
+	  gfc_error ("Type name '%s' at %C is ambiguous", name);
+	  return MATCH_ERROR;
+	}
+      if (sym->generic && !dt_sym)
+	dt_sym = gfc_find_dt_in_generic (sym);
+    }
+  else if (ts->kind == -1)
+    {
+      int iface = gfc_state_stack->previous->state != COMP_INTERFACE
+		    || gfc_current_ns->has_import_set;
+      gfc_find_symbol (name, NULL, iface, &sym);
+      if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
+	{
+	  gfc_error ("Type name '%s' at %C is ambiguous", name);
+	  return MATCH_ERROR;
+	}
+      if (sym && sym->generic && !dt_sym)
+	dt_sym = gfc_find_dt_in_generic (sym);
+
+      ts->kind = 0;
+      if (sym == NULL)
+	return MATCH_NO;
+    }
+
+  if ((sym->attr.flavor != FL_UNKNOWN
+       && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic))
+      || sym->attr.subroutine)
+    {
+      gfc_error ("Type name '%s' at %C conflicts with previously declared "
+	         "entity at %L, which has the same name", name,
+		 &sym->declared_at);
+      return MATCH_ERROR;
+    }
+
+  gfc_set_sym_referenced (sym);
+  if (!sym->attr.generic
+      && !gfc_add_generic (&sym->attr, sym->name, NULL))
+    return MATCH_ERROR;
+
+  if (!sym->attr.function
+      && !gfc_add_function (&sym->attr, sym->name, NULL))
+    return MATCH_ERROR;
+
+  if (!dt_sym)
+    {
+      gfc_interface *intr, *head;
+
+      /* Use upper case to save the actual derived-type symbol.  */
+      gfc_get_symbol (dt_name, NULL, &dt_sym);
+      dt_sym->name = gfc_get_string (sym->name);
+      head = sym->generic;
+      intr = gfc_get_interface ();
+      intr->sym = dt_sym;
+      intr->where = gfc_current_locus;
+      intr->next = head;
+      sym->generic = intr;
+      sym->attr.if_source = IFSRC_DECL;
+    }
+
+  gfc_set_sym_referenced (dt_sym);
+
+  if (dt_sym->attr.flavor != FL_DERIVED
+      && !gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL))
+    return MATCH_ERROR;
+
+  ts->u.derived = dt_sym;
+
+  return MATCH_YES;
+
+get_kind:
+  if (matched_type
+      && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
+			  "intrinsic-type-spec at %C"))
+    return MATCH_ERROR;
+
+  /* For all types except double, derived and character, look for an
+     optional kind specifier.  MATCH_NO is actually OK at this point.  */
+  if (implicit_flag == 1)
+    {
+	if (matched_type && gfc_match_char (')') != MATCH_YES)
+	  return MATCH_ERROR;
+
+	return MATCH_YES;
+    }
+
+  if (gfc_current_form == FORM_FREE)
+    {
+      c = gfc_peek_ascii_char ();
+      if (!gfc_is_whitespace (c) && c != '*' && c != '('
+	  && c != ':' && c != ',')
+        {
+	  if (matched_type && c == ')')
+	    {
+	      gfc_next_ascii_char ();
+	      return MATCH_YES;
+	    }
+	  return MATCH_NO;
+	}
+    }
+
+  m = gfc_match_kind_spec (ts, false);
+  if (m == MATCH_NO && ts->type != BT_CHARACTER)
+    m = gfc_match_old_kind_spec (ts);
+
+  if (matched_type && gfc_match_char (')') != MATCH_YES)
+    return MATCH_ERROR;
+
+  /* Defer association of the KIND expression of function results
+     until after USE and IMPORT statements.  */
+  if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ())
+	 || gfc_matching_function)
+    return MATCH_YES;
+
+  if (m == MATCH_NO)
+    m = MATCH_YES;		/* No kind specifier found.  */
+
+  return m;
+}
+
+
+/* Match an IMPLICIT NONE statement.  Actually, this statement is
+   already matched in parse.c, or we would not end up here in the
+   first place.  So the only thing we need to check, is if there is
+   trailing garbage.  If not, the match is successful.  */
+
+match
+gfc_match_implicit_none (void)
+{
+  return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
+}
+
+
+/* Match the letter range(s) of an IMPLICIT statement.  */
+
+static match
+match_implicit_range (void)
+{
+  char c, c1, c2;
+  int inner;
+  locus cur_loc;
+
+  cur_loc = gfc_current_locus;
+
+  gfc_gobble_whitespace ();
+  c = gfc_next_ascii_char ();
+  if (c != '(')
+    {
+      gfc_error ("Missing character range in IMPLICIT at %C");
+      goto bad;
+    }
+
+  inner = 1;
+  while (inner)
+    {
+      gfc_gobble_whitespace ();
+      c1 = gfc_next_ascii_char ();
+      if (!ISALPHA (c1))
+	goto bad;
+
+      gfc_gobble_whitespace ();
+      c = gfc_next_ascii_char ();
+
+      switch (c)
+	{
+	case ')':
+	  inner = 0;		/* Fall through.  */
+
+	case ',':
+	  c2 = c1;
+	  break;
+
+	case '-':
+	  gfc_gobble_whitespace ();
+	  c2 = gfc_next_ascii_char ();
+	  if (!ISALPHA (c2))
+	    goto bad;
+
+	  gfc_gobble_whitespace ();
+	  c = gfc_next_ascii_char ();
+
+	  if ((c != ',') && (c != ')'))
+	    goto bad;
+	  if (c == ')')
+	    inner = 0;
+
+	  break;
+
+	default:
+	  goto bad;
+	}
+
+      if (c1 > c2)
+	{
+	  gfc_error ("Letters must be in alphabetic order in "
+		     "IMPLICIT statement at %C");
+	  goto bad;
+	}
+
+      /* See if we can add the newly matched range to the pending
+	 implicits from this IMPLICIT statement.  We do not check for
+	 conflicts with whatever earlier IMPLICIT statements may have
+	 set.  This is done when we've successfully finished matching
+	 the current one.  */
+      if (!gfc_add_new_implicit_range (c1, c2))
+	goto bad;
+    }
+
+  return MATCH_YES;
+
+bad:
+  gfc_syntax_error (ST_IMPLICIT);
+
+  gfc_current_locus = cur_loc;
+  return MATCH_ERROR;
+}
+
+
+/* Match an IMPLICIT statement, storing the types for
+   gfc_set_implicit() if the statement is accepted by the parser.
+   There is a strange looking, but legal syntactic construction
+   possible.  It looks like:
+
+     IMPLICIT INTEGER (a-b) (c-d)
+
+   This is legal if "a-b" is a constant expression that happens to
+   equal one of the legal kinds for integers.  The real problem
+   happens with an implicit specification that looks like:
+
+     IMPLICIT INTEGER (a-b)
+
+   In this case, a typespec matcher that is "greedy" (as most of the
+   matchers are) gobbles the character range as a kindspec, leaving
+   nothing left.  We therefore have to go a bit more slowly in the
+   matching process by inhibiting the kindspec checking during
+   typespec matching and checking for a kind later.  */
+
+match
+gfc_match_implicit (void)
+{
+  gfc_typespec ts;
+  locus cur_loc;
+  char c;
+  match m;
+
+  gfc_clear_ts (&ts);
+
+  /* We don't allow empty implicit statements.  */
+  if (gfc_match_eos () == MATCH_YES)
+    {
+      gfc_error ("Empty IMPLICIT statement at %C");
+      return MATCH_ERROR;
+    }
+
+  do
+    {
+      /* First cleanup.  */
+      gfc_clear_new_implicit ();
+
+      /* A basic type is mandatory here.  */
+      m = gfc_match_decl_type_spec (&ts, 1);
+      if (m == MATCH_ERROR)
+	goto error;
+      if (m == MATCH_NO)
+	goto syntax;
+
+      cur_loc = gfc_current_locus;
+      m = match_implicit_range ();
+
+      if (m == MATCH_YES)
+	{
+	  /* We may have <TYPE> (<RANGE>).  */
+	  gfc_gobble_whitespace ();
+	  c = gfc_next_ascii_char ();
+	  if ((c == '\n') || (c == ','))
+	    {
+	      /* Check for CHARACTER with no length parameter.  */
+	      if (ts.type == BT_CHARACTER && !ts.u.cl)
+		{
+		  ts.kind = gfc_default_character_kind;
+		  ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+		  ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
+						      NULL, 1);
+		}
+
+	      /* Record the Successful match.  */
+	      if (!gfc_merge_new_implicit (&ts))
+		return MATCH_ERROR;
+	      continue;
+	    }
+
+	  gfc_current_locus = cur_loc;
+	}
+
+      /* Discard the (incorrectly) matched range.  */
+      gfc_clear_new_implicit ();
+
+      /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>).  */
+      if (ts.type == BT_CHARACTER)
+	m = gfc_match_char_spec (&ts);
+      else
+	{
+	  m = gfc_match_kind_spec (&ts, false);
+	  if (m == MATCH_NO)
+	    {
+	      m = gfc_match_old_kind_spec (&ts);
+	      if (m == MATCH_ERROR)
+		goto error;
+	      if (m == MATCH_NO)
+		goto syntax;
+	    }
+	}
+      if (m == MATCH_ERROR)
+	goto error;
+
+      m = match_implicit_range ();
+      if (m == MATCH_ERROR)
+	goto error;
+      if (m == MATCH_NO)
+	goto syntax;
+
+      gfc_gobble_whitespace ();
+      c = gfc_next_ascii_char ();
+      if ((c != '\n') && (c != ','))
+	goto syntax;
+
+      if (!gfc_merge_new_implicit (&ts))
+	return MATCH_ERROR;
+    }
+  while (c == ',');
+
+  return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (ST_IMPLICIT);
+
+error:
+  return MATCH_ERROR;
+}
+
+
+match
+gfc_match_import (void)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  match m;
+  gfc_symbol *sym;
+  gfc_symtree *st;
+
+  if (gfc_current_ns->proc_name == NULL
+      || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY)
+    {
+      gfc_error ("IMPORT statement at %C only permitted in "
+		 "an INTERFACE body");
+      return MATCH_ERROR;
+    }
+
+  if (!gfc_notify_std (GFC_STD_F2003, "IMPORT statement at %C"))
+    return MATCH_ERROR;
+
+  if (gfc_match_eos () == MATCH_YES)
+    {
+      /* All host variables should be imported.  */
+      gfc_current_ns->has_import_set = 1;
+      return MATCH_YES;
+    }
+
+  if (gfc_match (" ::") == MATCH_YES)
+    {
+      if (gfc_match_eos () == MATCH_YES)
+	{
+	   gfc_error ("Expecting list of named entities at %C");
+	   return MATCH_ERROR;
+	}
+    }
+
+  for(;;)
+    {
+      sym = NULL;
+      m = gfc_match (" %n", name);
+      switch (m)
+	{
+	case MATCH_YES:
+	  if (gfc_current_ns->parent !=  NULL
+	      && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
+	    {
+	       gfc_error ("Type name '%s' at %C is ambiguous", name);
+	       return MATCH_ERROR;
+	    }
+	  else if (!sym && gfc_current_ns->proc_name->ns->parent !=  NULL
+		   && gfc_find_symbol (name,
+				       gfc_current_ns->proc_name->ns->parent,
+				       1, &sym))
+	    {
+	       gfc_error ("Type name '%s' at %C is ambiguous", name);
+	       return MATCH_ERROR;
+	    }
+
+	  if (sym == NULL)
+	    {
+	      gfc_error ("Cannot IMPORT '%s' from host scoping unit "
+			 "at %C - does not exist.", name);
+	      return MATCH_ERROR;
+	    }
+
+	  if (gfc_find_symtree (gfc_current_ns->sym_root, name))
+	    {
+	      gfc_warning ("'%s' is already IMPORTed from host scoping unit "
+			   "at %C.", name);
+	      goto next_item;
+	    }
+
+	  st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
+	  st->n.sym = sym;
+	  sym->refs++;
+	  sym->attr.imported = 1;
+
+	  if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym)))
+	    {
+	      /* The actual derived type is stored in a symtree with the first
+		 letter of the name capitalized; the symtree with the all
+		 lower-case name contains the associated generic function. */
+	      st = gfc_new_symtree (&gfc_current_ns->sym_root,
+			gfc_get_string ("%c%s",
+				(char) TOUPPER ((unsigned char) name[0]),
+				&name[1]));
+	      st->n.sym = sym;
+	      sym->refs++;
+	      sym->attr.imported = 1;
+	    }
+
+	  goto next_item;
+
+	case MATCH_NO:
+	  break;
+
+	case MATCH_ERROR:
+	  return MATCH_ERROR;
+	}
+
+    next_item:
+      if (gfc_match_eos () == MATCH_YES)
+	break;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+    }
+
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in IMPORT statement at %C");
+  return MATCH_ERROR;
+}
+
+
+/* A minimal implementation of gfc_match without whitespace, escape
+   characters or variable arguments.  Returns true if the next
+   characters match the TARGET template exactly.  */
+
+static bool
+match_string_p (const char *target)
+{
+  const char *p;
+
+  for (p = target; *p; p++)
+    if ((char) gfc_next_ascii_char () != *p)
+      return false;
+  return true;
+}
+
+/* Matches an attribute specification including array specs.  If
+   successful, leaves the variables current_attr and current_as
+   holding the specification.  Also sets the colon_seen variable for
+   later use by matchers associated with initializations.
+
+   This subroutine is a little tricky in the sense that we don't know
+   if we really have an attr-spec until we hit the double colon.
+   Until that time, we can only return MATCH_NO.  This forces us to
+   check for duplicate specification at this level.  */
+
+static match
+match_attr_spec (void)
+{
+  /* Modifiers that can exist in a type statement.  */
+  enum
+  { GFC_DECL_BEGIN = 0,
+    DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
+    DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
+    DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
+    DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
+    DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS,
+    DECL_NONE, GFC_DECL_END /* Sentinel */
+  };
+
+/* GFC_DECL_END is the sentinel, index starts at 0.  */
+#define NUM_DECL GFC_DECL_END
+
+  locus start, seen_at[NUM_DECL];
+  int seen[NUM_DECL];
+  unsigned int d;
+  const char *attr;
+  match m;
+  bool t;
+
+  gfc_clear_attr (&current_attr);
+  start = gfc_current_locus;
+
+  current_as = NULL;
+  colon_seen = 0;
+
+  /* See if we get all of the keywords up to the final double colon.  */
+  for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
+    seen[d] = 0;
+
+  for (;;)
+    {
+      char ch;
+
+      d = DECL_NONE;
+      gfc_gobble_whitespace ();
+
+      ch = gfc_next_ascii_char ();
+      if (ch == ':')
+	{
+	  /* This is the successful exit condition for the loop.  */
+	  if (gfc_next_ascii_char () == ':')
+	    break;
+	}
+      else if (ch == ',')
+	{
+	  gfc_gobble_whitespace ();
+	  switch (gfc_peek_ascii_char ())
+	    {
+	    case 'a':
+	      gfc_next_ascii_char ();
+	      switch (gfc_next_ascii_char ())
+		{
+		case 'l':
+		  if (match_string_p ("locatable"))
+		    {
+		      /* Matched "allocatable".  */
+		      d = DECL_ALLOCATABLE;
+		    }
+		  break;
+
+		case 's':
+		  if (match_string_p ("ynchronous"))
+		    {
+		      /* Matched "asynchronous".  */
+		      d = DECL_ASYNCHRONOUS;
+		    }
+		  break;
+		}
+	      break;
+
+	    case 'b':
+	      /* Try and match the bind(c).  */
+	      m = gfc_match_bind_c (NULL, true);
+	      if (m == MATCH_YES)
+		d = DECL_IS_BIND_C;
+	      else if (m == MATCH_ERROR)
+		goto cleanup;
+	      break;
+
+	    case 'c':
+	      gfc_next_ascii_char ();
+	      if ('o' != gfc_next_ascii_char ())
+		break;
+	      switch (gfc_next_ascii_char ())
+		{
+		case 'd':
+		  if (match_string_p ("imension"))
+		    {
+		      d = DECL_CODIMENSION;
+		      break;
+		    }
+		case 'n':
+		  if (match_string_p ("tiguous"))
+		    {
+		      d = DECL_CONTIGUOUS;
+		      break;
+		    }
+		}
+	      break;
+
+	    case 'd':
+	      if (match_string_p ("dimension"))
+		d = DECL_DIMENSION;
+	      break;
+
+	    case 'e':
+	      if (match_string_p ("external"))
+		d = DECL_EXTERNAL;
+	      break;
+
+	    case 'i':
+	      if (match_string_p ("int"))
+		{
+		  ch = gfc_next_ascii_char ();
+		  if (ch == 'e')
+		    {
+		      if (match_string_p ("nt"))
+			{
+			  /* Matched "intent".  */
+			  /* TODO: Call match_intent_spec from here.  */
+			  if (gfc_match (" ( in out )") == MATCH_YES)
+			    d = DECL_INOUT;
+			  else if (gfc_match (" ( in )") == MATCH_YES)
+			    d = DECL_IN;
+			  else if (gfc_match (" ( out )") == MATCH_YES)
+			    d = DECL_OUT;
+			}
+		    }
+		  else if (ch == 'r')
+		    {
+		      if (match_string_p ("insic"))
+			{
+			  /* Matched "intrinsic".  */
+			  d = DECL_INTRINSIC;
+			}
+		    }
+		}
+	      break;
+
+	    case 'o':
+	      if (match_string_p ("optional"))
+		d = DECL_OPTIONAL;
+	      break;
+
+	    case 'p':
+	      gfc_next_ascii_char ();
+	      switch (gfc_next_ascii_char ())
+		{
+		case 'a':
+		  if (match_string_p ("rameter"))
+		    {
+		      /* Matched "parameter".  */
+		      d = DECL_PARAMETER;
+		    }
+		  break;
+
+		case 'o':
+		  if (match_string_p ("inter"))
+		    {
+		      /* Matched "pointer".  */
+		      d = DECL_POINTER;
+		    }
+		  break;
+
+		case 'r':
+		  ch = gfc_next_ascii_char ();
+		  if (ch == 'i')
+		    {
+		      if (match_string_p ("vate"))
+			{
+			  /* Matched "private".  */
+			  d = DECL_PRIVATE;
+			}
+		    }
+		  else if (ch == 'o')
+		    {
+		      if (match_string_p ("tected"))
+			{
+			  /* Matched "protected".  */
+			  d = DECL_PROTECTED;
+			}
+		    }
+		  break;
+
+		case 'u':
+		  if (match_string_p ("blic"))
+		    {
+		      /* Matched "public".  */
+		      d = DECL_PUBLIC;
+		    }
+		  break;
+		}
+	      break;
+
+	    case 's':
+	      if (match_string_p ("save"))
+		d = DECL_SAVE;
+	      break;
+
+	    case 't':
+	      if (match_string_p ("target"))
+		d = DECL_TARGET;
+	      break;
+
+	    case 'v':
+	      gfc_next_ascii_char ();
+	      ch = gfc_next_ascii_char ();
+	      if (ch == 'a')
+		{
+		  if (match_string_p ("lue"))
+		    {
+		      /* Matched "value".  */
+		      d = DECL_VALUE;
+		    }
+		}
+	      else if (ch == 'o')
+		{
+		  if (match_string_p ("latile"))
+		    {
+		      /* Matched "volatile".  */
+		      d = DECL_VOLATILE;
+		    }
+		}
+	      break;
+	    }
+	}
+
+      /* No double colon and no recognizable decl_type, so assume that
+	 we've been looking at something else the whole time.  */
+      if (d == DECL_NONE)
+	{
+	  m = MATCH_NO;
+	  goto cleanup;
+	}
+
+      /* Check to make sure any parens are paired up correctly.  */
+      if (gfc_match_parens () == MATCH_ERROR)
+	{
+	  m = MATCH_ERROR;
+	  goto cleanup;
+	}
+
+      seen[d]++;
+      seen_at[d] = gfc_current_locus;
+
+      if (d == DECL_DIMENSION || d == DECL_CODIMENSION)
+	{
+	  gfc_array_spec *as = NULL;
+
+	  m = gfc_match_array_spec (&as, d == DECL_DIMENSION,
+				    d == DECL_CODIMENSION);
+
+	  if (current_as == NULL)
+	    current_as = as;
+	  else if (m == MATCH_YES)
+	    {
+	      if (!merge_array_spec (as, current_as, false))
+		m = MATCH_ERROR;
+	      free (as);
+	    }
+
+	  if (m == MATCH_NO)
+	    {
+	      if (d == DECL_CODIMENSION)
+		gfc_error ("Missing codimension specification at %C");
+	      else
+		gfc_error ("Missing dimension specification at %C");
+	      m = MATCH_ERROR;
+	    }
+
+	  if (m == MATCH_ERROR)
+	    goto cleanup;
+	}
+    }
+
+  /* Since we've seen a double colon, we have to be looking at an
+     attr-spec.  This means that we can now issue errors.  */
+  for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
+    if (seen[d] > 1)
+      {
+	switch (d)
+	  {
+	  case DECL_ALLOCATABLE:
+	    attr = "ALLOCATABLE";
+	    break;
+	  case DECL_ASYNCHRONOUS:
+	    attr = "ASYNCHRONOUS";
+	    break;
+	  case DECL_CODIMENSION:
+	    attr = "CODIMENSION";
+	    break;
+	  case DECL_CONTIGUOUS:
+	    attr = "CONTIGUOUS";
+	    break;
+	  case DECL_DIMENSION:
+	    attr = "DIMENSION";
+	    break;
+	  case DECL_EXTERNAL:
+	    attr = "EXTERNAL";
+	    break;
+	  case DECL_IN:
+	    attr = "INTENT (IN)";
+	    break;
+	  case DECL_OUT:
+	    attr = "INTENT (OUT)";
+	    break;
+	  case DECL_INOUT:
+	    attr = "INTENT (IN OUT)";
+	    break;
+	  case DECL_INTRINSIC:
+	    attr = "INTRINSIC";
+	    break;
+	  case DECL_OPTIONAL:
+	    attr = "OPTIONAL";
+	    break;
+	  case DECL_PARAMETER:
+	    attr = "PARAMETER";
+	    break;
+	  case DECL_POINTER:
+	    attr = "POINTER";
+	    break;
+	  case DECL_PROTECTED:
+	    attr = "PROTECTED";
+	    break;
+	  case DECL_PRIVATE:
+	    attr = "PRIVATE";
+	    break;
+	  case DECL_PUBLIC:
+	    attr = "PUBLIC";
+	    break;
+	  case DECL_SAVE:
+	    attr = "SAVE";
+	    break;
+	  case DECL_TARGET:
+	    attr = "TARGET";
+	    break;
+          case DECL_IS_BIND_C:
+            attr = "IS_BIND_C";
+            break;
+          case DECL_VALUE:
+            attr = "VALUE";
+            break;
+	  case DECL_VOLATILE:
+	    attr = "VOLATILE";
+	    break;
+	  default:
+	    attr = NULL;	/* This shouldn't happen.  */
+	  }
+
+	gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
+	m = MATCH_ERROR;
+	goto cleanup;
+      }
+
+  /* Now that we've dealt with duplicate attributes, add the attributes
+     to the current attribute.  */
+  for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
+    {
+      if (seen[d] == 0)
+	continue;
+
+      if (gfc_current_state () == COMP_DERIVED
+	  && d != DECL_DIMENSION && d != DECL_CODIMENSION
+	  && d != DECL_POINTER   && d != DECL_PRIVATE
+	  && d != DECL_PUBLIC && d != DECL_CONTIGUOUS && d != DECL_NONE)
+	{
+	  if (d == DECL_ALLOCATABLE)
+	    {
+	      if (!gfc_notify_std (GFC_STD_F2003, "ALLOCATABLE "
+				   "attribute at %C in a TYPE definition"))
+		{
+		  m = MATCH_ERROR;
+		  goto cleanup;
+		}
+	    }
+	  else
+	    {
+	      gfc_error ("Attribute at %L is not allowed in a TYPE definition",
+			 &seen_at[d]);
+	      m = MATCH_ERROR;
+	      goto cleanup;
+	    }
+	}
+
+      if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
+	  && gfc_current_state () != COMP_MODULE)
+	{
+	  if (d == DECL_PRIVATE)
+	    attr = "PRIVATE";
+	  else
+	    attr = "PUBLIC";
+	  if (gfc_current_state () == COMP_DERIVED
+	      && gfc_state_stack->previous
+	      && gfc_state_stack->previous->state == COMP_MODULE)
+	    {
+	      if (!gfc_notify_std (GFC_STD_F2003, "Attribute %s "
+				   "at %L in a TYPE definition", attr, 
+				   &seen_at[d]))
+		{
+		  m = MATCH_ERROR;
+		  goto cleanup;
+		}
+	    }
+	  else
+	    {
+	      gfc_error ("%s attribute at %L is not allowed outside of the "
+			 "specification part of a module", attr, &seen_at[d]);
+	      m = MATCH_ERROR;
+	      goto cleanup;
+	    }
+	}
+
+      switch (d)
+	{
+	case DECL_ALLOCATABLE:
+	  t = gfc_add_allocatable (&current_attr, &seen_at[d]);
+	  break;
+
+	case DECL_ASYNCHRONOUS:
+	  if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS attribute at %C"))
+	    t = false;
+	  else
+	    t = gfc_add_asynchronous (&current_attr, NULL, &seen_at[d]);
+	  break;
+
+	case DECL_CODIMENSION:
+	  t = gfc_add_codimension (&current_attr, NULL, &seen_at[d]);
+	  break;
+
+	case DECL_CONTIGUOUS:
+	  if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS attribute at %C"))
+	    t = false;
+	  else
+	    t = gfc_add_contiguous (&current_attr, NULL, &seen_at[d]);
+	  break;
+
+	case DECL_DIMENSION:
+	  t = gfc_add_dimension (&current_attr, NULL, &seen_at[d]);
+	  break;
+
+	case DECL_EXTERNAL:
+	  t = gfc_add_external (&current_attr, &seen_at[d]);
+	  break;
+
+	case DECL_IN:
+	  t = gfc_add_intent (&current_attr, INTENT_IN, &seen_at[d]);
+	  break;
+
+	case DECL_OUT:
+	  t = gfc_add_intent (&current_attr, INTENT_OUT, &seen_at[d]);
+	  break;
+
+	case DECL_INOUT:
+	  t = gfc_add_intent (&current_attr, INTENT_INOUT, &seen_at[d]);
+	  break;
+
+	case DECL_INTRINSIC:
+	  t = gfc_add_intrinsic (&current_attr, &seen_at[d]);
+	  break;
+
+	case DECL_OPTIONAL:
+	  t = gfc_add_optional (&current_attr, &seen_at[d]);
+	  break;
+
+	case DECL_PARAMETER:
+	  t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, &seen_at[d]);
+	  break;
+
+	case DECL_POINTER:
+	  t = gfc_add_pointer (&current_attr, &seen_at[d]);
+	  break;
+
+	case DECL_PROTECTED:
+	  if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
+	    {
+	       gfc_error ("PROTECTED at %C only allowed in specification "
+			  "part of a module");
+	       t = false;
+	       break;
+	    }
+
+	  if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED attribute at %C"))
+	    t = false;
+	  else
+	    t = gfc_add_protected (&current_attr, NULL, &seen_at[d]);
+	  break;
+
+	case DECL_PRIVATE:
+	  t = gfc_add_access (&current_attr, ACCESS_PRIVATE, NULL,
+			      &seen_at[d]);
+	  break;
+
+	case DECL_PUBLIC:
+	  t = gfc_add_access (&current_attr, ACCESS_PUBLIC, NULL,
+			      &seen_at[d]);
+	  break;
+
+	case DECL_SAVE:
+	  t = gfc_add_save (&current_attr, SAVE_EXPLICIT, NULL, &seen_at[d]);
+	  break;
+
+	case DECL_TARGET:
+	  t = gfc_add_target (&current_attr, &seen_at[d]);
+	  break;
+
+        case DECL_IS_BIND_C:
+           t = gfc_add_is_bind_c(&current_attr, NULL, &seen_at[d], 0);
+           break;
+
+	case DECL_VALUE:
+	  if (!gfc_notify_std (GFC_STD_F2003, "VALUE attribute at %C"))
+	    t = false;
+	  else
+	    t = gfc_add_value (&current_attr, NULL, &seen_at[d]);
+	  break;
+
+	case DECL_VOLATILE:
+	  if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE attribute at %C"))
+	    t = false;
+	  else
+	    t = gfc_add_volatile (&current_attr, NULL, &seen_at[d]);
+	  break;
+
+	default:
+	  gfc_internal_error ("match_attr_spec(): Bad attribute");
+	}
+
+      if (!t)
+	{
+	  m = MATCH_ERROR;
+	  goto cleanup;
+	}
+    }
+
+  /* Since Fortran 2008 module variables implicitly have the SAVE attribute.  */
+  if (gfc_current_state () == COMP_MODULE && !current_attr.save
+      && (gfc_option.allow_std & GFC_STD_F2008) != 0)
+    current_attr.save = SAVE_IMPLICIT;
+
+  colon_seen = 1;
+  return MATCH_YES;
+
+cleanup:
+  gfc_current_locus = start;
+  gfc_free_array_spec (current_as);
+  current_as = NULL;
+  return m;
+}
+
+
+/* Set the binding label, dest_label, either with the binding label
+   stored in the given gfc_typespec, ts, or if none was provided, it
+   will be the symbol name in all lower case, as required by the draft
+   (J3/04-007, section 15.4.1).  If a binding label was given and
+   there is more than one argument (num_idents), it is an error.  */
+
+static bool
+set_binding_label (const char **dest_label, const char *sym_name,
+		   int num_idents)
+{
+  if (num_idents > 1 && has_name_equals)
+    {
+      gfc_error ("Multiple identifiers provided with "
+		 "single NAME= specifier at %C");
+      return false;
+    }
+
+  if (curr_binding_label)
+    /* Binding label given; store in temp holder till have sym.  */
+    *dest_label = curr_binding_label;
+  else
+    {
+      /* No binding label given, and the NAME= specifier did not exist,
+         which means there was no NAME="".  */
+      if (sym_name != NULL && has_name_equals == 0)
+        *dest_label = IDENTIFIER_POINTER (get_identifier (sym_name));
+    }
+
+  return true;
+}
+
+
+/* Set the status of the given common block as being BIND(C) or not,
+   depending on the given parameter, is_bind_c.  */
+
+void
+set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c)
+{
+  com_block->is_bind_c = is_bind_c;
+  return;
+}
+
+
+/* Verify that the given gfc_typespec is for a C interoperable type.  */
+
+bool
+gfc_verify_c_interop (gfc_typespec *ts)
+{
+  if (ts->type == BT_DERIVED && ts->u.derived != NULL)
+    return (ts->u.derived->ts.is_c_interop || ts->u.derived->attr.is_bind_c)
+	   ? true : false;
+  else if (ts->type == BT_CLASS)
+    return false;
+  else if (ts->is_c_interop != 1 && ts->type != BT_ASSUMED)
+    return false;
+
+  return true;
+}
+
+
+/* Verify that the variables of a given common block, which has been
+   defined with the attribute specifier bind(c), to be of a C
+   interoperable type.  Errors will be reported here, if
+   encountered.  */
+
+bool
+verify_com_block_vars_c_interop (gfc_common_head *com_block)
+{
+  gfc_symbol *curr_sym = NULL;
+  bool retval = true;
+
+  curr_sym = com_block->head;
+
+  /* Make sure we have at least one symbol.  */
+  if (curr_sym == NULL)
+    return retval;
+
+  /* Here we know we have a symbol, so we'll execute this loop
+     at least once.  */
+  do
+    {
+      /* The second to last param, 1, says this is in a common block.  */
+      retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block);
+      curr_sym = curr_sym->common_next;
+    } while (curr_sym != NULL);
+
+  return retval;
+}
+
+
+/* Verify that a given BIND(C) symbol is C interoperable.  If it is not,
+   an appropriate error message is reported.  */
+
+bool
+verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
+                   int is_in_common, gfc_common_head *com_block)
+{
+  bool bind_c_function = false;
+  bool retval = true;
+
+  if (tmp_sym->attr.function && tmp_sym->attr.is_bind_c)
+    bind_c_function = true;
+
+  if (tmp_sym->attr.function && tmp_sym->result != NULL)
+    {
+      tmp_sym = tmp_sym->result;
+      /* Make sure it wasn't an implicitly typed result.  */
+      if (tmp_sym->attr.implicit_type && gfc_option.warn_c_binding_type)
+	{
+	  gfc_warning ("Implicitly declared BIND(C) function '%s' at "
+                       "%L may not be C interoperable", tmp_sym->name,
+                       &tmp_sym->declared_at);
+	  tmp_sym->ts.f90_type = tmp_sym->ts.type;
+	  /* Mark it as C interoperable to prevent duplicate warnings.	*/
+	  tmp_sym->ts.is_c_interop = 1;
+	  tmp_sym->attr.is_c_interop = 1;
+	}
+    }
+
+  /* Here, we know we have the bind(c) attribute, so if we have
+     enough type info, then verify that it's a C interop kind.
+     The info could be in the symbol already, or possibly still in
+     the given ts (current_ts), so look in both.  */
+  if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN)
+    {
+      if (!gfc_verify_c_interop (&(tmp_sym->ts)))
+	{
+	  /* See if we're dealing with a sym in a common block or not.	*/
+	  if (is_in_common == 1 && gfc_option.warn_c_binding_type)
+	    {
+	      gfc_warning ("Variable '%s' in common block '%s' at %L "
+                           "may not be a C interoperable "
+                           "kind though common block '%s' is BIND(C)",
+                           tmp_sym->name, com_block->name,
+                           &(tmp_sym->declared_at), com_block->name);
+	    }
+	  else
+	    {
+              if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED)
+                gfc_error ("Type declaration '%s' at %L is not C "
+                           "interoperable but it is BIND(C)",
+                           tmp_sym->name, &(tmp_sym->declared_at));
+              else if (gfc_option.warn_c_binding_type)
+                gfc_warning ("Variable '%s' at %L "
+                             "may not be a C interoperable "
+                             "kind but it is bind(c)",
+                             tmp_sym->name, &(tmp_sym->declared_at));
+	    }
+	}
+
+      /* Variables declared w/in a common block can't be bind(c)
+	 since there's no way for C to see these variables, so there's
+	 semantically no reason for the attribute.  */
+      if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1)
+	{
+	  gfc_error ("Variable '%s' in common block '%s' at "
+		     "%L cannot be declared with BIND(C) "
+		     "since it is not a global",
+		     tmp_sym->name, com_block->name,
+		     &(tmp_sym->declared_at));
+	  retval = false;
+	}
+
+      /* Scalar variables that are bind(c) can not have the pointer
+	 or allocatable attributes.  */
+      if (tmp_sym->attr.is_bind_c == 1)
+	{
+	  if (tmp_sym->attr.pointer == 1)
+	    {
+	      gfc_error ("Variable '%s' at %L cannot have both the "
+			 "POINTER and BIND(C) attributes",
+			 tmp_sym->name, &(tmp_sym->declared_at));
+	      retval = false;
+	    }
+
+	  if (tmp_sym->attr.allocatable == 1)
+	    {
+	      gfc_error ("Variable '%s' at %L cannot have both the "
+			 "ALLOCATABLE and BIND(C) attributes",
+			 tmp_sym->name, &(tmp_sym->declared_at));
+	      retval = false;
+	    }
+
+        }
+
+      /* If it is a BIND(C) function, make sure the return value is a
+	 scalar value.  The previous tests in this function made sure
+	 the type is interoperable.  */
+      if (bind_c_function && tmp_sym->as != NULL)
+	gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
+		   "be an array", tmp_sym->name, &(tmp_sym->declared_at));
+
+      /* BIND(C) functions can not return a character string.  */
+      if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER)
+	if (tmp_sym->ts.u.cl == NULL || tmp_sym->ts.u.cl->length == NULL
+	    || tmp_sym->ts.u.cl->length->expr_type != EXPR_CONSTANT
+	    || mpz_cmp_si (tmp_sym->ts.u.cl->length->value.integer, 1) != 0)
+	  gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
+			 "be a character string", tmp_sym->name,
+			 &(tmp_sym->declared_at));
+    }
+
+  /* See if the symbol has been marked as private.  If it has, make sure
+     there is no binding label and warn the user if there is one.  */
+  if (tmp_sym->attr.access == ACCESS_PRIVATE
+      && tmp_sym->binding_label)
+      /* Use gfc_warning_now because we won't say that the symbol fails
+	 just because of this.	*/
+      gfc_warning_now ("Symbol '%s' at %L is marked PRIVATE but has been "
+		       "given the binding label '%s'", tmp_sym->name,
+		       &(tmp_sym->declared_at), tmp_sym->binding_label);
+
+  return retval;
+}
+
+
+/* Set the appropriate fields for a symbol that's been declared as
+   BIND(C) (the is_bind_c flag and the binding label), and verify that
+   the type is C interoperable.  Errors are reported by the functions
+   used to set/test these fields.  */
+
+bool
+set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
+{
+  bool retval = true;
+
+  /* TODO: Do we need to make sure the vars aren't marked private?  */
+
+  /* Set the is_bind_c bit in symbol_attribute.  */
+  gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0);
+
+  if (!set_binding_label (&tmp_sym->binding_label, tmp_sym->name, num_idents))
+    return false;
+
+  return retval;
+}
+
+
+/* Set the fields marking the given common block as BIND(C), including
+   a binding label, and report any errors encountered.  */
+
+bool
+set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
+{
+  bool retval = true;
+
+  /* destLabel, common name, typespec (which may have binding label).  */
+  if (!set_binding_label (&com_block->binding_label, com_block->name, 
+			  num_idents))
+    return false;
+
+  /* Set the given common block (com_block) to being bind(c) (1).  */
+  set_com_block_bind_c (com_block, 1);
+
+  return retval;
+}
+
+
+/* Retrieve the list of one or more identifiers that the given bind(c)
+   attribute applies to.  */
+
+bool
+get_bind_c_idents (void)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  int num_idents = 0;
+  gfc_symbol *tmp_sym = NULL;
+  match found_id;
+  gfc_common_head *com_block = NULL;
+
+  if (gfc_match_name (name) == MATCH_YES)
+    {
+      found_id = MATCH_YES;
+      gfc_get_ha_symbol (name, &tmp_sym);
+    }
+  else if (match_common_name (name) == MATCH_YES)
+    {
+      found_id = MATCH_YES;
+      com_block = gfc_get_common (name, 0);
+    }
+  else
+    {
+      gfc_error ("Need either entity or common block name for "
+		 "attribute specification statement at %C");
+      return false;
+    }
+
+  /* Save the current identifier and look for more.  */
+  do
+    {
+      /* Increment the number of identifiers found for this spec stmt.  */
+      num_idents++;
+
+      /* Make sure we have a sym or com block, and verify that it can
+	 be bind(c).  Set the appropriate field(s) and look for more
+	 identifiers.  */
+      if (tmp_sym != NULL || com_block != NULL)
+        {
+	  if (tmp_sym != NULL)
+	    {
+	      if (!set_verify_bind_c_sym (tmp_sym, num_idents))
+		return false;
+	    }
+	  else
+	    {
+	      if (!set_verify_bind_c_com_block (com_block, num_idents))
+		return false;
+	    }
+
+	  /* Look to see if we have another identifier.  */
+	  tmp_sym = NULL;
+	  if (gfc_match_eos () == MATCH_YES)
+	    found_id = MATCH_NO;
+	  else if (gfc_match_char (',') != MATCH_YES)
+	    found_id = MATCH_NO;
+	  else if (gfc_match_name (name) == MATCH_YES)
+	    {
+	      found_id = MATCH_YES;
+	      gfc_get_ha_symbol (name, &tmp_sym);
+	    }
+	  else if (match_common_name (name) == MATCH_YES)
+	    {
+	      found_id = MATCH_YES;
+	      com_block = gfc_get_common (name, 0);
+	    }
+	  else
+	    {
+	      gfc_error ("Missing entity or common block name for "
+			 "attribute specification statement at %C");
+	      return false;
+	    }
+	}
+      else
+	{
+	  gfc_internal_error ("Missing symbol");
+	}
+    } while (found_id == MATCH_YES);
+
+  /* if we get here we were successful */
+  return true;
+}
+
+
+/* Try and match a BIND(C) attribute specification statement.  */
+
+match
+gfc_match_bind_c_stmt (void)
+{
+  match found_match = MATCH_NO;
+  gfc_typespec *ts;
+
+  ts = &current_ts;
+
+  /* This may not be necessary.  */
+  gfc_clear_ts (ts);
+  /* Clear the temporary binding label holder.  */
+  curr_binding_label = NULL;
+
+  /* Look for the bind(c).  */
+  found_match = gfc_match_bind_c (NULL, true);
+
+  if (found_match == MATCH_YES)
+    {
+      if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) statement at %C"))
+	return MATCH_ERROR;
+
+      /* Look for the :: now, but it is not required.  */
+      gfc_match (" :: ");
+
+      /* Get the identifier(s) that needs to be updated.  This may need to
+	 change to hand the flag(s) for the attr specified so all identifiers
+	 found can have all appropriate parts updated (assuming that the same
+	 spec stmt can have multiple attrs, such as both bind(c) and
+	 allocatable...).  */
+      if (!get_bind_c_idents ())
+	/* Error message should have printed already.  */
+	return MATCH_ERROR;
+    }
+
+  return found_match;
+}
+
+
+/* Match a data declaration statement.  */
+
+match
+gfc_match_data_decl (void)
+{
+  gfc_symbol *sym;
+  match m;
+  int elem;
+
+  num_idents_on_line = 0;
+
+  m = gfc_match_decl_type_spec (&current_ts, 0);
+  if (m != MATCH_YES)
+    return m;
+
+  if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
+	&& gfc_current_state () != COMP_DERIVED)
+    {
+      sym = gfc_use_derived (current_ts.u.derived);
+
+      if (sym == NULL)
+	{
+	  m = MATCH_ERROR;
+	  goto cleanup;
+	}
+
+      current_ts.u.derived = sym;
+    }
+
+  m = match_attr_spec ();
+  if (m == MATCH_ERROR)
+    {
+      m = MATCH_NO;
+      goto cleanup;
+    }
+
+  if (current_ts.type == BT_CLASS
+	&& current_ts.u.derived->attr.unlimited_polymorphic)
+    goto ok;
+
+  if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
+      && current_ts.u.derived->components == NULL
+      && !current_ts.u.derived->attr.zero_comp)
+    {
+
+      if (current_attr.pointer && gfc_current_state () == COMP_DERIVED)
+	goto ok;
+
+      gfc_find_symbol (current_ts.u.derived->name,
+		       current_ts.u.derived->ns, 1, &sym);
+
+      /* Any symbol that we find had better be a type definition
+	 which has its components defined.  */
+      if (sym != NULL && sym->attr.flavor == FL_DERIVED
+	  && (current_ts.u.derived->components != NULL
+	      || current_ts.u.derived->attr.zero_comp))
+	goto ok;
+
+      gfc_error ("Derived type at %C has not been previously defined "
+		 "and so cannot appear in a derived type definition");
+      m = MATCH_ERROR;
+      goto cleanup;
+    }
+
+ok:
+  /* If we have an old-style character declaration, and no new-style
+     attribute specifications, then there a comma is optional between
+     the type specification and the variable list.  */
+  if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
+    gfc_match_char (',');
+
+  /* Give the types/attributes to symbols that follow. Give the element
+     a number so that repeat character length expressions can be copied.  */
+  elem = 1;
+  for (;;)
+    {
+      num_idents_on_line++;
+      m = variable_decl (elem++);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_NO)
+	break;
+
+      if (gfc_match_eos () == MATCH_YES)
+	goto cleanup;
+      if (gfc_match_char (',') != MATCH_YES)
+	break;
+    }
+
+  if (gfc_error_flag_test () == 0)
+    gfc_error ("Syntax error in data declaration at %C");
+  m = MATCH_ERROR;
+
+  gfc_free_data_all (gfc_current_ns);
+
+cleanup:
+  gfc_free_array_spec (current_as);
+  current_as = NULL;
+  return m;
+}
+
+
+/* Match a prefix associated with a function or subroutine
+   declaration.  If the typespec pointer is nonnull, then a typespec
+   can be matched.  Note that if nothing matches, MATCH_YES is
+   returned (the null string was matched).  */
+
+match
+gfc_match_prefix (gfc_typespec *ts)
+{
+  bool seen_type;
+  bool seen_impure;
+  bool found_prefix;
+
+  gfc_clear_attr (&current_attr);
+  seen_type = false;
+  seen_impure = false;
+
+  gcc_assert (!gfc_matching_prefix);
+  gfc_matching_prefix = true;
+
+  do
+    {
+      found_prefix = false;
+
+      if (!seen_type && ts != NULL
+	  && gfc_match_decl_type_spec (ts, 0) == MATCH_YES
+	  && gfc_match_space () == MATCH_YES)
+	{
+
+	  seen_type = true;
+	  found_prefix = true;
+	}
+
+      if (gfc_match ("elemental% ") == MATCH_YES)
+	{
+	  if (!gfc_add_elemental (&current_attr, NULL))
+	    goto error;
+
+	  found_prefix = true;
+	}
+
+      if (gfc_match ("pure% ") == MATCH_YES)
+	{
+	  if (!gfc_add_pure (&current_attr, NULL))
+	    goto error;
+
+	  found_prefix = true;
+	}
+
+      if (gfc_match ("recursive% ") == MATCH_YES)
+	{
+	  if (!gfc_add_recursive (&current_attr, NULL))
+	    goto error;
+
+	  found_prefix = true;
+	}
+
+      /* IMPURE is a somewhat special case, as it needs not set an actual
+	 attribute but rather only prevents ELEMENTAL routines from being
+	 automatically PURE.  */
+      if (gfc_match ("impure% ") == MATCH_YES)
+	{
+	  if (!gfc_notify_std (GFC_STD_F2008, "IMPURE procedure at %C"))
+	    goto error;
+
+	  seen_impure = true;
+	  found_prefix = true;
+	}
+    }
+  while (found_prefix);
+
+  /* IMPURE and PURE must not both appear, of course.  */
+  if (seen_impure && current_attr.pure)
+    {
+      gfc_error ("PURE and IMPURE must not appear both at %C");
+      goto error;
+    }
+
+  /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE.  */
+  if (!seen_impure && current_attr.elemental && !current_attr.pure)
+    {
+      if (!gfc_add_pure (&current_attr, NULL))
+	goto error;
+    }
+
+  /* At this point, the next item is not a prefix.  */
+  gcc_assert (gfc_matching_prefix);
+  gfc_matching_prefix = false;
+  return MATCH_YES;
+
+error:
+  gcc_assert (gfc_matching_prefix);
+  gfc_matching_prefix = false;
+  return MATCH_ERROR;
+}
+
+
+/* Copy attributes matched by gfc_match_prefix() to attributes on a symbol.  */
+
+static bool
+copy_prefix (symbol_attribute *dest, locus *where)
+{
+  if (current_attr.pure && !gfc_add_pure (dest, where))
+    return false;
+
+  if (current_attr.elemental && !gfc_add_elemental (dest, where))
+    return false;
+
+  if (current_attr.recursive && !gfc_add_recursive (dest, where))
+    return false;
+
+  return true;
+}
+
+
+/* Match a formal argument list.  */
+
+match
+gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, int null_flag)
+{
+  gfc_formal_arglist *head, *tail, *p, *q;
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_symbol *sym;
+  match m;
+
+  head = tail = NULL;
+
+  if (gfc_match_char ('(') != MATCH_YES)
+    {
+      if (null_flag)
+	goto ok;
+      return MATCH_NO;
+    }
+
+  if (gfc_match_char (')') == MATCH_YES)
+    goto ok;
+
+  for (;;)
+    {
+      if (gfc_match_char ('*') == MATCH_YES)
+	{
+	  sym = NULL;
+	  if (!gfc_notify_std (GFC_STD_F95_OBS, "Alternate-return argument "
+			       "at %C"))
+	    {
+	      m = MATCH_ERROR;
+	      goto cleanup;
+	    }
+	}
+      else
+	{
+	  m = gfc_match_name (name);
+	  if (m != MATCH_YES)
+	    goto cleanup;
+
+	  if (gfc_get_symbol (name, NULL, &sym))
+	    goto cleanup;
+	}
+
+      p = gfc_get_formal_arglist ();
+
+      if (head == NULL)
+	head = tail = p;
+      else
+	{
+	  tail->next = p;
+	  tail = p;
+	}
+
+      tail->sym = sym;
+
+      /* We don't add the VARIABLE flavor because the name could be a
+	 dummy procedure.  We don't apply these attributes to formal
+	 arguments of statement functions.  */
+      if (sym != NULL && !st_flag
+	  && (!gfc_add_dummy(&sym->attr, sym->name, NULL)
+	      || !gfc_missing_attr (&sym->attr, NULL)))
+	{
+	  m = MATCH_ERROR;
+	  goto cleanup;
+	}
+
+      /* The name of a program unit can be in a different namespace,
+	 so check for it explicitly.  After the statement is accepted,
+	 the name is checked for especially in gfc_get_symbol().  */
+      if (gfc_new_block != NULL && sym != NULL
+	  && strcmp (sym->name, gfc_new_block->name) == 0)
+	{
+	  gfc_error ("Name '%s' at %C is the name of the procedure",
+		     sym->name);
+	  m = MATCH_ERROR;
+	  goto cleanup;
+	}
+
+      if (gfc_match_char (')') == MATCH_YES)
+	goto ok;
+
+      m = gfc_match_char (',');
+      if (m != MATCH_YES)
+	{
+	  gfc_error ("Unexpected junk in formal argument list at %C");
+	  goto cleanup;
+	}
+    }
+
+ok:
+  /* Check for duplicate symbols in the formal argument list.  */
+  if (head != NULL)
+    {
+      for (p = head; p->next; p = p->next)
+	{
+	  if (p->sym == NULL)
+	    continue;
+
+	  for (q = p->next; q; q = q->next)
+	    if (p->sym == q->sym)
+	      {
+		gfc_error ("Duplicate symbol '%s' in formal argument list "
+			   "at %C", p->sym->name);
+
+		m = MATCH_ERROR;
+		goto cleanup;
+	      }
+	}
+    }
+
+  if (!gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL))
+    {
+      m = MATCH_ERROR;
+      goto cleanup;
+    }
+
+  return MATCH_YES;
+
+cleanup:
+  gfc_free_formal_arglist (head);
+  return m;
+}
+
+
+/* Match a RESULT specification following a function declaration or
+   ENTRY statement.  Also matches the end-of-statement.  */
+
+static match
+match_result (gfc_symbol *function, gfc_symbol **result)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_symbol *r;
+  match m;
+
+  if (gfc_match (" result (") != MATCH_YES)
+    return MATCH_NO;
+
+  m = gfc_match_name (name);
+  if (m != MATCH_YES)
+    return m;
+
+  /* Get the right paren, and that's it because there could be the
+     bind(c) attribute after the result clause.  */
+  if (gfc_match_char (')') != MATCH_YES)
+    {
+     /* TODO: should report the missing right paren here.  */
+      return MATCH_ERROR;
+    }
+
+  if (strcmp (function->name, name) == 0)
+    {
+      gfc_error ("RESULT variable at %C must be different than function name");
+      return MATCH_ERROR;
+    }
+
+  if (gfc_get_symbol (name, NULL, &r))
+    return MATCH_ERROR;
+
+  if (!gfc_add_result (&r->attr, r->name, NULL))
+    return MATCH_ERROR;
+
+  *result = r;
+
+  return MATCH_YES;
+}
+
+
+/* Match a function suffix, which could be a combination of a result
+   clause and BIND(C), either one, or neither.  The draft does not
+   require them to come in a specific order.  */
+
+match
+gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
+{
+  match is_bind_c;   /* Found bind(c).  */
+  match is_result;   /* Found result clause.  */
+  match found_match; /* Status of whether we've found a good match.  */
+  char peek_char;    /* Character we're going to peek at.  */
+  bool allow_binding_name;
+
+  /* Initialize to having found nothing.  */
+  found_match = MATCH_NO;
+  is_bind_c = MATCH_NO;
+  is_result = MATCH_NO;
+
+  /* Get the next char to narrow between result and bind(c).  */
+  gfc_gobble_whitespace ();
+  peek_char = gfc_peek_ascii_char ();
+
+  /* C binding names are not allowed for internal procedures.  */
+  if (gfc_current_state () == COMP_CONTAINS
+      && sym->ns->proc_name->attr.flavor != FL_MODULE)
+    allow_binding_name = false;
+  else
+    allow_binding_name = true;
+
+  switch (peek_char)
+    {
+    case 'r':
+      /* Look for result clause.  */
+      is_result = match_result (sym, result);
+      if (is_result == MATCH_YES)
+	{
+	  /* Now see if there is a bind(c) after it.  */
+	  is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
+	  /* We've found the result clause and possibly bind(c).  */
+	  found_match = MATCH_YES;
+	}
+      else
+	/* This should only be MATCH_ERROR.  */
+	found_match = is_result;
+      break;
+    case 'b':
+      /* Look for bind(c) first.  */
+      is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
+      if (is_bind_c == MATCH_YES)
+	{
+	  /* Now see if a result clause followed it.  */
+	  is_result = match_result (sym, result);
+	  found_match = MATCH_YES;
+	}
+      else
+	{
+	  /* Should only be a MATCH_ERROR if we get here after seeing 'b'.  */
+	  found_match = MATCH_ERROR;
+	}
+      break;
+    default:
+      gfc_error ("Unexpected junk after function declaration at %C");
+      found_match = MATCH_ERROR;
+      break;
+    }
+
+  if (is_bind_c == MATCH_YES)
+    {
+      /* Fortran 2008 draft allows BIND(C) for internal procedures.  */
+      if (gfc_current_state () == COMP_CONTAINS
+	  && sym->ns->proc_name->attr.flavor != FL_MODULE
+	  && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
+			      "at %L may not be specified for an internal "
+			      "procedure", &gfc_current_locus))
+	return MATCH_ERROR;
+
+      if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1))
+     	return MATCH_ERROR;
+    }
+
+  return found_match;
+}
+
+
+/* Procedure pointer return value without RESULT statement:
+   Add "hidden" result variable named "ppr@".  */
+
+static bool
+add_hidden_procptr_result (gfc_symbol *sym)
+{
+  bool case1,case2;
+
+  if (gfc_notification_std (GFC_STD_F2003) == ERROR)
+    return false;
+
+  /* First usage case: PROCEDURE and EXTERNAL statements.  */
+  case1 = gfc_current_state () == COMP_FUNCTION && gfc_current_block ()
+	  && strcmp (gfc_current_block ()->name, sym->name) == 0
+	  && sym->attr.external;
+  /* Second usage case: INTERFACE statements.  */
+  case2 = gfc_current_state () == COMP_INTERFACE && gfc_state_stack->previous
+	  && gfc_state_stack->previous->state == COMP_FUNCTION
+	  && strcmp (gfc_state_stack->previous->sym->name, sym->name) == 0;
+
+  if (case1 || case2)
+    {
+      gfc_symtree *stree;
+      if (case1)
+	gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree, false);
+      else if (case2)
+	{
+	  gfc_symtree *st2;
+	  gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree, false);
+	  st2 = gfc_new_symtree (&gfc_current_ns->sym_root, "ppr@");
+	  st2->n.sym = stree->n.sym;
+	}
+      sym->result = stree->n.sym;
+
+      sym->result->attr.proc_pointer = sym->attr.proc_pointer;
+      sym->result->attr.pointer = sym->attr.pointer;
+      sym->result->attr.external = sym->attr.external;
+      sym->result->attr.referenced = sym->attr.referenced;
+      sym->result->ts = sym->ts;
+      sym->attr.proc_pointer = 0;
+      sym->attr.pointer = 0;
+      sym->attr.external = 0;
+      if (sym->result->attr.external && sym->result->attr.pointer)
+	{
+	  sym->result->attr.pointer = 0;
+	  sym->result->attr.proc_pointer = 1;
+	}
+
+      return gfc_add_result (&sym->result->attr, sym->result->name, NULL);
+    }
+  /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement.  */
+  else if (sym->attr.function && !sym->attr.external && sym->attr.pointer
+	   && sym->result && sym->result != sym && sym->result->attr.external
+	   && sym == gfc_current_ns->proc_name
+	   && sym == sym->result->ns->proc_name
+	   && strcmp ("ppr@", sym->result->name) == 0)
+    {
+      sym->result->attr.proc_pointer = 1;
+      sym->attr.pointer = 0;
+      return true;
+    }
+  else
+    return false;
+}
+
+
+/* Match the interface for a PROCEDURE declaration,
+   including brackets (R1212).  */
+
+static match
+match_procedure_interface (gfc_symbol **proc_if)
+{
+  match m;
+  gfc_symtree *st;
+  locus old_loc, entry_loc;
+  gfc_namespace *old_ns = gfc_current_ns;
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+
+  old_loc = entry_loc = gfc_current_locus;
+  gfc_clear_ts (&current_ts);
+
+  if (gfc_match (" (") != MATCH_YES)
+    {
+      gfc_current_locus = entry_loc;
+      return MATCH_NO;
+    }
+
+  /* Get the type spec. for the procedure interface.  */
+  old_loc = gfc_current_locus;
+  m = gfc_match_decl_type_spec (&current_ts, 0);
+  gfc_gobble_whitespace ();
+  if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_ascii_char () == ')'))
+    goto got_ts;
+
+  if (m == MATCH_ERROR)
+    return m;
+
+  /* Procedure interface is itself a procedure.  */
+  gfc_current_locus = old_loc;
+  m = gfc_match_name (name);
+
+  /* First look to see if it is already accessible in the current
+     namespace because it is use associated or contained.  */
+  st = NULL;
+  if (gfc_find_sym_tree (name, NULL, 0, &st))
+    return MATCH_ERROR;
+
+  /* If it is still not found, then try the parent namespace, if it
+     exists and create the symbol there if it is still not found.  */
+  if (gfc_current_ns->parent)
+    gfc_current_ns = gfc_current_ns->parent;
+  if (st == NULL && gfc_get_ha_sym_tree (name, &st))
+    return MATCH_ERROR;
+
+  gfc_current_ns = old_ns;
+  *proc_if = st->n.sym;
+
+  if (*proc_if)
+    {
+      (*proc_if)->refs++;
+      /* Resolve interface if possible. That way, attr.procedure is only set
+	 if it is declared by a later procedure-declaration-stmt, which is
+	 invalid per F08:C1216 (cf. resolve_procedure_interface).  */
+      while ((*proc_if)->ts.interface)
+	*proc_if = (*proc_if)->ts.interface;
+
+      if ((*proc_if)->attr.flavor == FL_UNKNOWN
+	  && (*proc_if)->ts.type == BT_UNKNOWN
+	  && !gfc_add_flavor (&(*proc_if)->attr, FL_PROCEDURE, 
+			      (*proc_if)->name, NULL))
+	return MATCH_ERROR;
+    }
+
+got_ts:
+  if (gfc_match (" )") != MATCH_YES)
+    {
+      gfc_current_locus = entry_loc;
+      return MATCH_NO;
+    }
+
+  return MATCH_YES;
+}
+
+
+/* Match a PROCEDURE declaration (R1211).  */
+
+static match
+match_procedure_decl (void)
+{
+  match m;
+  gfc_symbol *sym, *proc_if = NULL;
+  int num;
+  gfc_expr *initializer = NULL;
+
+  /* Parse interface (with brackets). */
+  m = match_procedure_interface (&proc_if);
+  if (m != MATCH_YES)
+    return m;
+
+  /* Parse attributes (with colons).  */
+  m = match_attr_spec();
+  if (m == MATCH_ERROR)
+    return MATCH_ERROR;
+
+  if (proc_if && proc_if->attr.is_bind_c && !current_attr.is_bind_c)
+    {
+      current_attr.is_bind_c = 1;
+      has_name_equals = 0;
+      curr_binding_label = NULL;
+    }
+
+  /* Get procedure symbols.  */
+  for(num=1;;num++)
+    {
+      m = gfc_match_symbol (&sym, 0);
+      if (m == MATCH_NO)
+	goto syntax;
+      else if (m == MATCH_ERROR)
+	return m;
+
+      /* Add current_attr to the symbol attributes.  */
+      if (!gfc_copy_attr (&sym->attr, &current_attr, NULL))
+	return MATCH_ERROR;
+
+      if (sym->attr.is_bind_c)
+	{
+	  /* Check for C1218.  */
+	  if (!proc_if || !proc_if->attr.is_bind_c)
+	    {
+	      gfc_error ("BIND(C) attribute at %C requires "
+			"an interface with BIND(C)");
+	      return MATCH_ERROR;
+	    }
+	  /* Check for C1217.  */
+	  if (has_name_equals && sym->attr.pointer)
+	    {
+	      gfc_error ("BIND(C) procedure with NAME may not have "
+			"POINTER attribute at %C");
+	      return MATCH_ERROR;
+	    }
+	  if (has_name_equals && sym->attr.dummy)
+	    {
+	      gfc_error ("Dummy procedure at %C may not have "
+			"BIND(C) attribute with NAME");
+	      return MATCH_ERROR;
+	    }
+	  /* Set binding label for BIND(C).  */
+	  if (!set_binding_label (&sym->binding_label, sym->name, num))
+	    return MATCH_ERROR;
+	}
+
+      if (!gfc_add_external (&sym->attr, NULL))
+	return MATCH_ERROR;
+
+      if (add_hidden_procptr_result (sym))
+	sym = sym->result;
+
+      if (!gfc_add_proc (&sym->attr, sym->name, NULL))
+	return MATCH_ERROR;
+
+      /* Set interface.  */
+      if (proc_if != NULL)
+	{
+          if (sym->ts.type != BT_UNKNOWN)
+	    {
+	      gfc_error ("Procedure '%s' at %L already has basic type of %s",
+			 sym->name, &gfc_current_locus,
+			 gfc_basic_typename (sym->ts.type));
+	      return MATCH_ERROR;
+	    }
+	  sym->ts.interface = proc_if;
+	  sym->attr.untyped = 1;
+	  sym->attr.if_source = IFSRC_IFBODY;
+	}
+      else if (current_ts.type != BT_UNKNOWN)
+	{
+	  if (!gfc_add_type (sym, &current_ts, &gfc_current_locus))
+	    return MATCH_ERROR;
+	  sym->ts.interface = gfc_new_symbol ("", gfc_current_ns);
+	  sym->ts.interface->ts = current_ts;
+	  sym->ts.interface->attr.flavor = FL_PROCEDURE;
+	  sym->ts.interface->attr.function = 1;
+	  sym->attr.function = 1;
+	  sym->attr.if_source = IFSRC_UNKNOWN;
+	}
+
+      if (gfc_match (" =>") == MATCH_YES)
+	{
+	  if (!current_attr.pointer)
+	    {
+	      gfc_error ("Initialization at %C isn't for a pointer variable");
+	      m = MATCH_ERROR;
+	      goto cleanup;
+	    }
+
+	  m = match_pointer_init (&initializer, 1);
+	  if (m != MATCH_YES)
+	    goto cleanup;
+
+	  if (!add_init_expr_to_sym (sym->name, &initializer, &gfc_current_locus))
+	    goto cleanup;
+
+	}
+
+      if (gfc_match_eos () == MATCH_YES)
+	return MATCH_YES;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+    }
+
+syntax:
+  gfc_error ("Syntax error in PROCEDURE statement at %C");
+  return MATCH_ERROR;
+
+cleanup:
+  /* Free stuff up and return.  */
+  gfc_free_expr (initializer);
+  return m;
+}
+
+
+static match
+match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc);
+
+
+/* Match a procedure pointer component declaration (R445).  */
+
+static match
+match_ppc_decl (void)
+{
+  match m;
+  gfc_symbol *proc_if = NULL;
+  gfc_typespec ts;
+  int num;
+  gfc_component *c;
+  gfc_expr *initializer = NULL;
+  gfc_typebound_proc* tb;
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+
+  /* Parse interface (with brackets).  */
+  m = match_procedure_interface (&proc_if);
+  if (m != MATCH_YES)
+    goto syntax;
+
+  /* Parse attributes.  */
+  tb = XCNEW (gfc_typebound_proc);
+  tb->where = gfc_current_locus;
+  m = match_binding_attributes (tb, false, true);
+  if (m == MATCH_ERROR)
+    return m;
+
+  gfc_clear_attr (&current_attr);
+  current_attr.procedure = 1;
+  current_attr.proc_pointer = 1;
+  current_attr.access = tb->access;
+  current_attr.flavor = FL_PROCEDURE;
+
+  /* Match the colons (required).  */
+  if (gfc_match (" ::") != MATCH_YES)
+    {
+      gfc_error ("Expected '::' after binding-attributes at %C");
+      return MATCH_ERROR;
+    }
+
+  /* Check for C450.  */
+  if (!tb->nopass && proc_if == NULL)
+    {
+      gfc_error("NOPASS or explicit interface required at %C");
+      return MATCH_ERROR;
+    }
+
+  if (!gfc_notify_std (GFC_STD_F2003, "Procedure pointer component at %C"))
+    return MATCH_ERROR;
+
+  /* Match PPC names.  */
+  ts = current_ts;
+  for(num=1;;num++)
+    {
+      m = gfc_match_name (name);
+      if (m == MATCH_NO)
+	goto syntax;
+      else if (m == MATCH_ERROR)
+	return m;
+
+      if (!gfc_add_component (gfc_current_block(), name, &c))
+	return MATCH_ERROR;
+
+      /* Add current_attr to the symbol attributes.  */
+      if (!gfc_copy_attr (&c->attr, &current_attr, NULL))
+	return MATCH_ERROR;
+
+      if (!gfc_add_external (&c->attr, NULL))
+	return MATCH_ERROR;
+
+      if (!gfc_add_proc (&c->attr, name, NULL))
+	return MATCH_ERROR;
+
+      if (num == 1)
+	c->tb = tb;
+      else
+	{
+	  c->tb = XCNEW (gfc_typebound_proc);
+	  c->tb->where = gfc_current_locus;
+	  *c->tb = *tb;
+	}
+
+      /* Set interface.  */
+      if (proc_if != NULL)
+	{
+	  c->ts.interface = proc_if;
+	  c->attr.untyped = 1;
+	  c->attr.if_source = IFSRC_IFBODY;
+	}
+      else if (ts.type != BT_UNKNOWN)
+	{
+	  c->ts = ts;
+	  c->ts.interface = gfc_new_symbol ("", gfc_current_ns);
+	  c->ts.interface->result = c->ts.interface;
+	  c->ts.interface->ts = ts;
+	  c->ts.interface->attr.flavor = FL_PROCEDURE;
+	  c->ts.interface->attr.function = 1;
+	  c->attr.function = 1;
+	  c->attr.if_source = IFSRC_UNKNOWN;
+	}
+
+      if (gfc_match (" =>") == MATCH_YES)
+	{
+	  m = match_pointer_init (&initializer, 1);
+	  if (m != MATCH_YES)
+	    {
+	      gfc_free_expr (initializer);
+	      return m;
+	    }
+	  c->initializer = initializer;
+	}
+
+      if (gfc_match_eos () == MATCH_YES)
+	return MATCH_YES;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+    }
+
+syntax:
+  gfc_error ("Syntax error in procedure pointer component at %C");
+  return MATCH_ERROR;
+}
+
+
+/* Match a PROCEDURE declaration inside an interface (R1206).  */
+
+static match
+match_procedure_in_interface (void)
+{
+  match m;
+  gfc_symbol *sym;
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  locus old_locus;
+
+  if (current_interface.type == INTERFACE_NAMELESS
+      || current_interface.type == INTERFACE_ABSTRACT)
+    {
+      gfc_error ("PROCEDURE at %C must be in a generic interface");
+      return MATCH_ERROR;
+    }
+
+  /* Check if the F2008 optional double colon appears.  */
+  gfc_gobble_whitespace ();
+  old_locus = gfc_current_locus;
+  if (gfc_match ("::") == MATCH_YES)
+    {
+      if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
+			   "MODULE PROCEDURE statement at %L", &old_locus))
+	return MATCH_ERROR;
+    }
+  else
+    gfc_current_locus = old_locus;
+
+  for(;;)
+    {
+      m = gfc_match_name (name);
+      if (m == MATCH_NO)
+	goto syntax;
+      else if (m == MATCH_ERROR)
+	return m;
+      if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
+	return MATCH_ERROR;
+
+      if (!gfc_add_interface (sym))
+	return MATCH_ERROR;
+
+      if (gfc_match_eos () == MATCH_YES)
+	break;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+    }
+
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in PROCEDURE statement at %C");
+  return MATCH_ERROR;
+}
+
+
+/* General matcher for PROCEDURE declarations.  */
+
+static match match_procedure_in_type (void);
+
+match
+gfc_match_procedure (void)
+{
+  match m;
+
+  switch (gfc_current_state ())
+    {
+    case COMP_NONE:
+    case COMP_PROGRAM:
+    case COMP_MODULE:
+    case COMP_SUBROUTINE:
+    case COMP_FUNCTION:
+    case COMP_BLOCK:
+      m = match_procedure_decl ();
+      break;
+    case COMP_INTERFACE:
+      m = match_procedure_in_interface ();
+      break;
+    case COMP_DERIVED:
+      m = match_ppc_decl ();
+      break;
+    case COMP_DERIVED_CONTAINS:
+      m = match_procedure_in_type ();
+      break;
+    default:
+      return MATCH_NO;
+    }
+
+  if (m != MATCH_YES)
+    return m;
+
+  if (!gfc_notify_std (GFC_STD_F2003, "PROCEDURE statement at %C"))
+    return MATCH_ERROR;
+
+  return m;
+}
+
+
+/* Warn if a matched procedure has the same name as an intrinsic; this is
+   simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
+   parser-state-stack to find out whether we're in a module.  */
+
+static void
+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_warn_intrinsic_shadow (sym, in_module, func);
+}
+
+
+/* Match a function declaration.  */
+
+match
+gfc_match_function_decl (void)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_symbol *sym, *result;
+  locus old_loc;
+  match m;
+  match suffix_match;
+  match found_match; /* Status returned by match func.  */
+
+  if (gfc_current_state () != COMP_NONE
+      && gfc_current_state () != COMP_INTERFACE
+      && gfc_current_state () != COMP_CONTAINS)
+    return MATCH_NO;
+
+  gfc_clear_ts (&current_ts);
+
+  old_loc = gfc_current_locus;
+
+  m = gfc_match_prefix (&current_ts);
+  if (m != MATCH_YES)
+    {
+      gfc_current_locus = old_loc;
+      return m;
+    }
+
+  if (gfc_match ("function% %n", name) != MATCH_YES)
+    {
+      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;
+
+  gfc_new_block = sym;
+
+  m = gfc_match_formal_arglist (sym, 0, 0);
+  if (m == MATCH_NO)
+    {
+      gfc_error ("Expected formal argument list in function "
+		 "definition at %C");
+      m = MATCH_ERROR;
+      goto cleanup;
+    }
+  else if (m == MATCH_ERROR)
+    goto cleanup;
+
+  result = NULL;
+
+  /* According to the draft, the bind(c) and result clause can
+     come in either order after the formal_arg_list (i.e., either
+     can be first, both can exist together or by themselves or neither
+     one).  Therefore, the match_result can't match the end of the
+     string, and check for the bind(c) or result clause in either order.  */
+  found_match = gfc_match_eos ();
+
+  /* Make sure that it isn't already declared as BIND(C).  If it is, it
+     must have been marked BIND(C) with a BIND(C) attribute and that is
+     not allowed for procedures.  */
+  if (sym->attr.is_bind_c == 1)
+    {
+      sym->attr.is_bind_c = 0;
+      if (sym->old_symbol != NULL)
+        gfc_error_now ("BIND(C) attribute at %L can only be used for "
+                       "variables or common blocks",
+                       &(sym->old_symbol->declared_at));
+      else
+        gfc_error_now ("BIND(C) attribute at %L can only be used for "
+                       "variables or common blocks", &gfc_current_locus);
+    }
+
+  if (found_match != MATCH_YES)
+    {
+      /* If we haven't found the end-of-statement, look for a suffix.  */
+      suffix_match = gfc_match_suffix (sym, &result);
+      if (suffix_match == MATCH_YES)
+        /* Need to get the eos now.  */
+        found_match = gfc_match_eos ();
+      else
+	found_match = suffix_match;
+    }
+
+  if(found_match != MATCH_YES)
+    m = MATCH_ERROR;
+  else
+    {
+      /* Make changes to the symbol.  */
+      m = MATCH_ERROR;
+
+      if (!gfc_add_function (&sym->attr, sym->name, NULL))
+	goto cleanup;
+
+      if (!gfc_missing_attr (&sym->attr, NULL)
+	  || !copy_prefix (&sym->attr, &sym->declared_at))
+	goto cleanup;
+
+      /* Delay matching the function characteristics until after the
+	 specification block by signalling kind=-1.  */
+      sym->declared_at = old_loc;
+      if (current_ts.type != BT_UNKNOWN)
+	current_ts.kind = -1;
+      else
+	current_ts.kind = 0;
+
+      if (result == NULL)
+	{
+          if (current_ts.type != BT_UNKNOWN
+	      && !gfc_add_type (sym, &current_ts, &gfc_current_locus))
+	    goto cleanup;
+	  sym->result = sym;
+	}
+      else
+	{
+          if (current_ts.type != BT_UNKNOWN
+	      && !gfc_add_type (result, &current_ts, &gfc_current_locus))
+	    goto cleanup;
+	  sym->result = result;
+	}
+
+      /* Warn if this procedure has the same name as an intrinsic.  */
+      warn_intrinsic_shadow (sym, true);
+
+      return MATCH_YES;
+    }
+
+cleanup:
+  gfc_current_locus = old_loc;
+  return m;
+}
+
+
+/* This is mostly a copy of parse.c(add_global_procedure) but modified to
+   pass the name of the entry, rather than the gfc_current_block name, and
+   to return false upon finding an existing global entry.  */
+
+static bool
+add_global_entry (const char *name, const char *binding_label, bool sub,
+		  locus *where)
+{
+  gfc_gsymbol *s;
+  enum gfc_symbol_type type;
+
+  type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
+
+  /* Only in Fortran 2003: For procedures with a binding label also the Fortran
+     name is a global identifier.  */
+  if (!binding_label || gfc_notification_std (GFC_STD_F2008))
+    {
+      s = gfc_get_gsymbol (name);
+
+      if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
+	{
+	  gfc_global_used (s, where);
+	  return false;
+	}
+      else
+	{
+	  s->type = type;
+	  s->sym_name = name;
+	  s->where = *where;
+	  s->defined = 1;
+	  s->ns = gfc_current_ns;
+	}
+    }
+
+  /* Don't add the symbol multiple times.  */
+  if (binding_label
+      && (!gfc_notification_std (GFC_STD_F2008)
+	  || strcmp (name, binding_label) != 0))
+    {
+      s = gfc_get_gsymbol (binding_label);
+
+      if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
+	{
+	  gfc_global_used (s, where);
+	  return false;
+	}
+      else
+	{
+	  s->type = type;
+	  s->sym_name = name;
+	  s->binding_label = binding_label;
+	  s->where = *where;
+	  s->defined = 1;
+	  s->ns = gfc_current_ns;
+	}
+    }
+
+  return true;
+}
+
+
+/* Match an ENTRY statement.  */
+
+match
+gfc_match_entry (void)
+{
+  gfc_symbol *proc;
+  gfc_symbol *result;
+  gfc_symbol *entry;
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_compile_state state;
+  match m;
+  gfc_entry_list *el;
+  locus old_loc;
+  bool module_procedure;
+  char peek_char;
+  match is_bind_c;
+
+  m = gfc_match_name (name);
+  if (m != MATCH_YES)
+    return m;
+
+  if (!gfc_notify_std (GFC_STD_F2008_OBS, "ENTRY statement at %C"))
+    return MATCH_ERROR;
+
+  state = gfc_current_state ();
+  if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
+    {
+      switch (state)
+	{
+	  case COMP_PROGRAM:
+	    gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
+	    break;
+	  case COMP_MODULE:
+	    gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
+	    break;
+	  case COMP_BLOCK_DATA:
+	    gfc_error ("ENTRY statement at %C cannot appear within "
+		       "a BLOCK DATA");
+	    break;
+	  case COMP_INTERFACE:
+	    gfc_error ("ENTRY statement at %C cannot appear within "
+		       "an INTERFACE");
+	    break;
+	  case COMP_DERIVED:
+	    gfc_error ("ENTRY statement at %C cannot appear within "
+		       "a DERIVED TYPE block");
+	    break;
+	  case COMP_IF:
+	    gfc_error ("ENTRY statement at %C cannot appear within "
+		       "an IF-THEN block");
+	    break;
+	  case COMP_DO:
+	  case COMP_DO_CONCURRENT:
+	    gfc_error ("ENTRY statement at %C cannot appear within "
+		       "a DO block");
+	    break;
+	  case COMP_SELECT:
+	    gfc_error ("ENTRY statement at %C cannot appear within "
+		       "a SELECT block");
+	    break;
+	  case COMP_FORALL:
+	    gfc_error ("ENTRY statement at %C cannot appear within "
+		       "a FORALL block");
+	    break;
+	  case COMP_WHERE:
+	    gfc_error ("ENTRY statement at %C cannot appear within "
+		       "a WHERE block");
+	    break;
+	  case COMP_CONTAINS:
+	    gfc_error ("ENTRY statement at %C cannot appear within "
+		       "a contained subprogram");
+	    break;
+	  default:
+	    gfc_internal_error ("gfc_match_entry(): Bad state");
+	}
+      return MATCH_ERROR;
+    }
+
+  module_procedure = gfc_current_ns->parent != NULL
+		   && gfc_current_ns->parent->proc_name
+		   && gfc_current_ns->parent->proc_name->attr.flavor
+		      == FL_MODULE;
+
+  if (gfc_current_ns->parent != NULL
+      && gfc_current_ns->parent->proc_name
+      && !module_procedure)
+    {
+      gfc_error("ENTRY statement at %C cannot appear in a "
+		"contained procedure");
+      return MATCH_ERROR;
+    }
+
+  /* Module function entries need special care in get_proc_name
+     because previous references within the function will have
+     created symbols attached to the current namespace.  */
+  if (get_proc_name (name, &entry,
+		     gfc_current_ns->parent != NULL
+		     && module_procedure))
+    return MATCH_ERROR;
+
+  proc = gfc_current_block ();
+
+  /* Make sure that it isn't already declared as BIND(C).  If it is, it
+     must have been marked BIND(C) with a BIND(C) attribute and that is
+     not allowed for procedures.  */
+  if (entry->attr.is_bind_c == 1)
+    {
+      entry->attr.is_bind_c = 0;
+      if (entry->old_symbol != NULL)
+        gfc_error_now ("BIND(C) attribute at %L can only be used for "
+                       "variables or common blocks",
+                       &(entry->old_symbol->declared_at));
+      else
+        gfc_error_now ("BIND(C) attribute at %L can only be used for "
+                       "variables or common blocks", &gfc_current_locus);
+    }
+
+  /* Check what next non-whitespace character is so we can tell if there
+     is the required parens if we have a BIND(C).  */
+  old_loc = gfc_current_locus;
+  gfc_gobble_whitespace ();
+  peek_char = gfc_peek_ascii_char ();
+
+  if (state == COMP_SUBROUTINE)
+    {
+      m = gfc_match_formal_arglist (entry, 0, 1);
+      if (m != MATCH_YES)
+	return MATCH_ERROR;
+
+      /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
+	 never be an internal procedure.  */
+      is_bind_c = gfc_match_bind_c (entry, true);
+      if (is_bind_c == MATCH_ERROR)
+	return MATCH_ERROR;
+      if (is_bind_c == MATCH_YES)
+	{
+	  if (peek_char != '(')
+	    {
+	      gfc_error ("Missing required parentheses before BIND(C) at %C");
+	      return MATCH_ERROR;
+	    }
+	    if (!gfc_add_is_bind_c (&(entry->attr), entry->name, 
+				    &(entry->declared_at), 1))
+	      return MATCH_ERROR;
+	}
+
+      if (!gfc_current_ns->parent
+	  && !add_global_entry (name, entry->binding_label, true,
+				&old_loc))
+	return MATCH_ERROR;
+
+      /* An entry in a subroutine.  */
+      if (!gfc_add_entry (&entry->attr, entry->name, NULL)
+	  || !gfc_add_subroutine (&entry->attr, entry->name, NULL))
+	return MATCH_ERROR;
+    }
+  else
+    {
+      /* An entry in a function.
+	 We need to take special care because writing
+	    ENTRY f()
+	 as
+	    ENTRY f
+	 is allowed, whereas
+	    ENTRY f() RESULT (r)
+	 can't be written as
+	    ENTRY f RESULT (r).  */
+      if (gfc_match_eos () == MATCH_YES)
+	{
+	  gfc_current_locus = old_loc;
+	  /* Match the empty argument list, and add the interface to
+	     the symbol.  */
+	  m = gfc_match_formal_arglist (entry, 0, 1);
+	}
+      else
+	m = gfc_match_formal_arglist (entry, 0, 0);
+
+      if (m != MATCH_YES)
+	return MATCH_ERROR;
+
+      result = NULL;
+
+      if (gfc_match_eos () == MATCH_YES)
+	{
+	  if (!gfc_add_entry (&entry->attr, entry->name, NULL)
+	      || !gfc_add_function (&entry->attr, entry->name, NULL))
+	    return MATCH_ERROR;
+
+	  entry->result = entry;
+	}
+      else
+	{
+	  m = gfc_match_suffix (entry, &result);
+	  if (m == MATCH_NO)
+	    gfc_syntax_error (ST_ENTRY);
+	  if (m != MATCH_YES)
+	    return MATCH_ERROR;
+
+          if (result)
+	    {
+	      if (!gfc_add_result (&result->attr, result->name, NULL)
+		  || !gfc_add_entry (&entry->attr, result->name, NULL)
+		  || !gfc_add_function (&entry->attr, result->name, NULL))
+	        return MATCH_ERROR;
+	      entry->result = result;
+	    }
+	  else
+	    {
+	      if (!gfc_add_entry (&entry->attr, entry->name, NULL)
+		  || !gfc_add_function (&entry->attr, entry->name, NULL))
+		return MATCH_ERROR;
+	      entry->result = entry;
+	    }
+	}
+
+      if (!gfc_current_ns->parent
+	  && !add_global_entry (name, entry->binding_label, false,
+				&old_loc))
+	return MATCH_ERROR;
+    }
+
+  if (gfc_match_eos () != MATCH_YES)
+    {
+      gfc_syntax_error (ST_ENTRY);
+      return MATCH_ERROR;
+    }
+
+  entry->attr.recursive = proc->attr.recursive;
+  entry->attr.elemental = proc->attr.elemental;
+  entry->attr.pure = proc->attr.pure;
+
+  el = gfc_get_entry_list ();
+  el->sym = entry;
+  el->next = gfc_current_ns->entries;
+  gfc_current_ns->entries = el;
+  if (el->next)
+    el->id = el->next->id + 1;
+  else
+    el->id = 1;
+
+  new_st.op = EXEC_ENTRY;
+  new_st.ext.entry = el;
+
+  return MATCH_YES;
+}
+
+
+/* Match a subroutine statement, including optional prefixes.  */
+
+match
+gfc_match_subroutine (void)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_symbol *sym;
+  match m;
+  match is_bind_c;
+  char peek_char;
+  bool allow_binding_name;
+
+  if (gfc_current_state () != COMP_NONE
+      && gfc_current_state () != COMP_INTERFACE
+      && gfc_current_state () != COMP_CONTAINS)
+    return MATCH_NO;
+
+  m = gfc_match_prefix (NULL);
+  if (m != MATCH_YES)
+    return m;
+
+  m = gfc_match ("subroutine% %n", name);
+  if (m != MATCH_YES)
+    return m;
+
+  if (get_proc_name (name, &sym, false))
+    return MATCH_ERROR;
+
+  /* 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 (add_hidden_procptr_result (sym))
+    sym = sym->result;
+
+  gfc_new_block = sym;
+
+  /* Check what next non-whitespace character is so we can tell if there
+     is the required parens if we have a BIND(C).  */
+  gfc_gobble_whitespace ();
+  peek_char = gfc_peek_ascii_char ();
+
+  if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
+    return MATCH_ERROR;
+
+  if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
+    return MATCH_ERROR;
+
+  /* Make sure that it isn't already declared as BIND(C).  If it is, it
+     must have been marked BIND(C) with a BIND(C) attribute and that is
+     not allowed for procedures.  */
+  if (sym->attr.is_bind_c == 1)
+    {
+      sym->attr.is_bind_c = 0;
+      if (sym->old_symbol != NULL)
+        gfc_error_now ("BIND(C) attribute at %L can only be used for "
+                       "variables or common blocks",
+                       &(sym->old_symbol->declared_at));
+      else
+        gfc_error_now ("BIND(C) attribute at %L can only be used for "
+                       "variables or common blocks", &gfc_current_locus);
+    }
+
+  /* C binding names are not allowed for internal procedures.  */
+  if (gfc_current_state () == COMP_CONTAINS
+      && sym->ns->proc_name->attr.flavor != FL_MODULE)
+    allow_binding_name = false;
+  else
+    allow_binding_name = true;
+
+  /* Here, we are just checking if it has the bind(c) attribute, and if
+     so, then we need to make sure it's all correct.  If it doesn't,
+     we still need to continue matching the rest of the subroutine line.  */
+  is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
+  if (is_bind_c == MATCH_ERROR)
+    {
+      /* There was an attempt at the bind(c), but it was wrong.	 An
+	 error message should have been printed w/in the gfc_match_bind_c
+	 so here we'll just return the MATCH_ERROR.  */
+      return MATCH_ERROR;
+    }
+
+  if (is_bind_c == MATCH_YES)
+    {
+      /* The following is allowed in the Fortran 2008 draft.  */
+      if (gfc_current_state () == COMP_CONTAINS
+	  && sym->ns->proc_name->attr.flavor != FL_MODULE
+	  && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
+			      "at %L may not be specified for an internal "
+			      "procedure", &gfc_current_locus))
+	return MATCH_ERROR;
+
+      if (peek_char != '(')
+        {
+          gfc_error ("Missing required parentheses before BIND(C) at %C");
+          return MATCH_ERROR;
+        }
+      if (!gfc_add_is_bind_c (&(sym->attr), sym->name, 
+			      &(sym->declared_at), 1))
+        return MATCH_ERROR;
+    }
+
+  if (gfc_match_eos () != MATCH_YES)
+    {
+      gfc_syntax_error (ST_SUBROUTINE);
+      return MATCH_ERROR;
+    }
+
+  if (!copy_prefix (&sym->attr, &sym->declared_at))
+    return MATCH_ERROR;
+
+  /* Warn if it has the same name as an intrinsic.  */
+  warn_intrinsic_shadow (sym, false);
+
+  return MATCH_YES;
+}
+
+
+/* Match a BIND(C) specifier, with the optional 'name=' specifier if
+   given, and set the binding label in either the given symbol (if not
+   NULL), or in the current_ts.  The symbol may be NULL because we may
+   encounter the BIND(C) before the declaration itself.  Return
+   MATCH_NO if what we're looking at isn't a BIND(C) specifier,
+   MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
+   or MATCH_YES if the specifier was correct and the binding label and
+   bind(c) fields were set correctly for the given symbol or the
+   current_ts. If allow_binding_name is false, no binding name may be
+   given.  */
+
+match
+gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name)
+{
+  /* binding label, if exists */
+  const char* binding_label = NULL;
+  match double_quote;
+  match single_quote;
+
+  /* Initialize the flag that specifies whether we encountered a NAME=
+     specifier or not.  */
+  has_name_equals = 0;
+
+  /* This much we have to be able to match, in this order, if
+     there is a bind(c) label.	*/
+  if (gfc_match (" bind ( c ") != MATCH_YES)
+    return MATCH_NO;
+
+  /* Now see if there is a binding label, or if we've reached the
+     end of the bind(c) attribute without one.	*/
+  if (gfc_match_char (',') == MATCH_YES)
+    {
+      if (gfc_match (" name = ") != MATCH_YES)
+        {
+          gfc_error ("Syntax error in NAME= specifier for binding label "
+                     "at %C");
+          /* should give an error message here */
+          return MATCH_ERROR;
+        }
+
+      has_name_equals = 1;
+
+      /* Get the opening quote.  */
+      double_quote = MATCH_YES;
+      single_quote = MATCH_YES;
+      double_quote = gfc_match_char ('"');
+      if (double_quote != MATCH_YES)
+	single_quote = gfc_match_char ('\'');
+      if (double_quote != MATCH_YES && single_quote != MATCH_YES)
+        {
+          gfc_error ("Syntax error in NAME= specifier for binding label "
+                     "at %C");
+          return MATCH_ERROR;
+        }
+
+      /* Grab the binding label, using functions that will not lower
+	 case the names automatically.	*/
+      if (gfc_match_name_C (&binding_label) != MATCH_YES)
+	 return MATCH_ERROR;
+
+      /* Get the closing quotation.  */
+      if (double_quote == MATCH_YES)
+	{
+	  if (gfc_match_char ('"') != MATCH_YES)
+            {
+              gfc_error ("Missing closing quote '\"' for binding label at %C");
+              /* User started string with '"' so looked to match it.  */
+              return MATCH_ERROR;
+            }
+	}
+      else
+	{
+	  if (gfc_match_char ('\'') != MATCH_YES)
+            {
+              gfc_error ("Missing closing quote '\'' for binding label at %C");
+              /* User started string with "'" char.  */
+              return MATCH_ERROR;
+            }
+	}
+   }
+
+  /* Get the required right paren.  */
+  if (gfc_match_char (')') != MATCH_YES)
+    {
+      gfc_error ("Missing closing paren for binding label at %C");
+      return MATCH_ERROR;
+    }
+
+  if (has_name_equals && !allow_binding_name)
+    {
+      gfc_error ("No binding name is allowed in BIND(C) at %C");
+      return MATCH_ERROR;
+    }
+
+  if (has_name_equals && sym != NULL && sym->attr.dummy)
+    {
+      gfc_error ("For dummy procedure %s, no binding name is "
+		 "allowed in BIND(C) at %C", sym->name);
+      return MATCH_ERROR;
+    }
+
+
+  /* Save the binding label to the symbol.  If sym is null, we're
+     probably matching the typespec attributes of a declaration and
+     haven't gotten the name yet, and therefore, no symbol yet.	 */
+  if (binding_label)
+    {
+      if (sym != NULL)
+	sym->binding_label = binding_label;
+      else
+	curr_binding_label = binding_label;
+    }
+  else if (allow_binding_name)
+    {
+      /* No binding label, but if symbol isn't null, we
+	 can set the label for it here.
+	 If name="" or allow_binding_name is false, no C binding name is
+	 created. */
+      if (sym != NULL && sym->name != NULL && has_name_equals == 0)
+	sym->binding_label = IDENTIFIER_POINTER (get_identifier (sym->name));
+    }
+
+  if (has_name_equals && gfc_current_state () == COMP_INTERFACE
+      && current_interface.type == INTERFACE_ABSTRACT)
+    {
+      gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
+      return MATCH_ERROR;
+    }
+
+  return MATCH_YES;
+}
+
+
+/* Return nonzero if we're currently compiling a contained procedure.  */
+
+static int
+contained_procedure (void)
+{
+  gfc_state_data *s = gfc_state_stack;
+
+  if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
+      && s->previous != NULL && s->previous->state == COMP_CONTAINS)
+    return 1;
+
+  return 0;
+}
+
+/* Set the kind of each enumerator.  The kind is selected such that it is
+   interoperable with the corresponding C enumeration type, making
+   sure that -fshort-enums is honored.  */
+
+static void
+set_enum_kind(void)
+{
+  enumerator_history *current_history = NULL;
+  int kind;
+  int i;
+
+  if (max_enum == NULL || enum_history == NULL)
+    return;
+
+  if (!flag_short_enums)
+    return;
+
+  i = 0;
+  do
+    {
+      kind = gfc_integer_kinds[i++].kind;
+    }
+  while (kind < gfc_c_int_kind
+	 && gfc_check_integer_range (max_enum->initializer->value.integer,
+				     kind) != ARITH_OK);
+
+  current_history = enum_history;
+  while (current_history != NULL)
+    {
+      current_history->sym->ts.kind = kind;
+      current_history = current_history->next;
+    }
+}
+
+
+/* Match any of the various end-block statements.  Returns the type of
+   END to the caller.  The END INTERFACE, END IF, END DO, END SELECT
+   and END BLOCK statements cannot be replaced by a single END statement.  */
+
+match
+gfc_match_end (gfc_statement *st)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_compile_state state;
+  locus old_loc;
+  const char *block_name;
+  const char *target;
+  int eos_ok;
+  match m;
+  gfc_namespace *parent_ns, *ns, *prev_ns;
+  gfc_namespace **nsp;
+
+  old_loc = gfc_current_locus;
+  if (gfc_match ("end") != MATCH_YES)
+    return MATCH_NO;
+
+  state = gfc_current_state ();
+  block_name = gfc_current_block () == NULL
+	     ? NULL : gfc_current_block ()->name;
+
+  switch (state)
+    {
+    case COMP_ASSOCIATE:
+    case COMP_BLOCK:
+      if (!strncmp (block_name, "block@", strlen("block@")))
+	block_name = NULL;
+      break;
+
+    case COMP_CONTAINS:
+    case COMP_DERIVED_CONTAINS:
+      state = gfc_state_stack->previous->state;
+      block_name = gfc_state_stack->previous->sym == NULL
+		 ? NULL : gfc_state_stack->previous->sym->name;
+      break;
+
+    default:
+      break;
+    }
+
+  switch (state)
+    {
+    case COMP_NONE:
+    case COMP_PROGRAM:
+      *st = ST_END_PROGRAM;
+      target = " program";
+      eos_ok = 1;
+      break;
+
+    case COMP_SUBROUTINE:
+      *st = ST_END_SUBROUTINE;
+      target = " subroutine";
+      eos_ok = !contained_procedure ();
+      break;
+
+    case COMP_FUNCTION:
+      *st = ST_END_FUNCTION;
+      target = " function";
+      eos_ok = !contained_procedure ();
+      break;
+
+    case COMP_BLOCK_DATA:
+      *st = ST_END_BLOCK_DATA;
+      target = " block data";
+      eos_ok = 1;
+      break;
+
+    case COMP_MODULE:
+      *st = ST_END_MODULE;
+      target = " module";
+      eos_ok = 1;
+      break;
+
+    case COMP_INTERFACE:
+      *st = ST_END_INTERFACE;
+      target = " interface";
+      eos_ok = 0;
+      break;
+
+    case COMP_DERIVED:
+    case COMP_DERIVED_CONTAINS:
+      *st = ST_END_TYPE;
+      target = " type";
+      eos_ok = 0;
+      break;
+
+    case COMP_ASSOCIATE:
+      *st = ST_END_ASSOCIATE;
+      target = " associate";
+      eos_ok = 0;
+      break;
+
+    case COMP_BLOCK:
+      *st = ST_END_BLOCK;
+      target = " block";
+      eos_ok = 0;
+      break;
+
+    case COMP_IF:
+      *st = ST_ENDIF;
+      target = " if";
+      eos_ok = 0;
+      break;
+
+    case COMP_DO:
+    case COMP_DO_CONCURRENT:
+      *st = ST_ENDDO;
+      target = " do";
+      eos_ok = 0;
+      break;
+
+    case COMP_CRITICAL:
+      *st = ST_END_CRITICAL;
+      target = " critical";
+      eos_ok = 0;
+      break;
+
+    case COMP_SELECT:
+    case COMP_SELECT_TYPE:
+      *st = ST_END_SELECT;
+      target = " select";
+      eos_ok = 0;
+      break;
+
+    case COMP_FORALL:
+      *st = ST_END_FORALL;
+      target = " forall";
+      eos_ok = 0;
+      break;
+
+    case COMP_WHERE:
+      *st = ST_END_WHERE;
+      target = " where";
+      eos_ok = 0;
+      break;
+
+    case COMP_ENUM:
+      *st = ST_END_ENUM;
+      target = " enum";
+      eos_ok = 0;
+      last_initializer = NULL;
+      set_enum_kind ();
+      gfc_free_enum_history ();
+      break;
+
+    default:
+      gfc_error ("Unexpected END statement at %C");
+      goto cleanup;
+    }
+
+  old_loc = gfc_current_locus;
+  if (gfc_match_eos () == MATCH_YES)
+    {
+      if (!eos_ok && (*st == ST_END_SUBROUTINE || *st == ST_END_FUNCTION))
+	{
+	  if (!gfc_notify_std (GFC_STD_F2008, "END statement "
+			       "instead of %s statement at %L", 
+			       gfc_ascii_statement(*st), &old_loc))
+	    goto cleanup;
+	}
+      else if (!eos_ok)
+	{
+	  /* We would have required END [something].  */
+	  gfc_error ("%s statement expected at %L",
+		     gfc_ascii_statement (*st), &old_loc);
+	  goto cleanup;
+	}
+
+      return MATCH_YES;
+    }
+
+  /* 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);
+      goto cleanup;
+    }
+
+  old_loc = gfc_current_locus;
+  /* If we're at the end, make sure a block name wasn't required.  */
+  if (gfc_match_eos () == MATCH_YES)
+    {
+
+      if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
+	  && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK
+	  && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL)
+	return MATCH_YES;
+
+      if (!block_name)
+	return MATCH_YES;
+
+      gfc_error ("Expected block name of '%s' in %s statement at %L",
+		 block_name, gfc_ascii_statement (*st), &old_loc);
+
+      return MATCH_ERROR;
+    }
+
+  /* END INTERFACE has a special handler for its several possible endings.  */
+  if (*st == ST_END_INTERFACE)
+    return gfc_match_end_interface ();
+
+  /* We haven't hit the end of statement, so what is left must be an
+     end-name.  */
+  m = gfc_match_space ();
+  if (m == MATCH_YES)
+    m = gfc_match_name (name);
+
+  if (m == MATCH_NO)
+    gfc_error ("Expected terminating name at %C");
+  if (m != MATCH_YES)
+    goto cleanup;
+
+  if (block_name == NULL)
+    goto syntax;
+
+  if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0)
+    {
+      gfc_error ("Expected label '%s' for %s statement at %C", block_name,
+		 gfc_ascii_statement (*st));
+      goto cleanup;
+    }
+  /* Procedure pointer as function result.  */
+  else if (strcmp (block_name, "ppr@") == 0
+	   && strcmp (name, gfc_current_block ()->ns->proc_name->name) != 0)
+    {
+      gfc_error ("Expected label '%s' for %s statement at %C",
+		 gfc_current_block ()->ns->proc_name->name,
+		 gfc_ascii_statement (*st));
+      goto cleanup;
+    }
+
+  if (gfc_match_eos () == MATCH_YES)
+    return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (*st);
+
+cleanup:
+  gfc_current_locus = old_loc;
+
+  /* If we are missing an END BLOCK, we created a half-ready namespace.
+     Remove it from the parent namespace's sibling list.  */
+
+  if (state == COMP_BLOCK)
+    {
+      parent_ns = gfc_current_ns->parent;
+
+      nsp = &(gfc_state_stack->previous->tail->ext.block.ns);
+
+      prev_ns = NULL;
+      ns = *nsp;
+      while (ns)
+	{
+	  if (ns == gfc_current_ns)
+	    {
+	      if (prev_ns == NULL)
+		*nsp = NULL;
+	      else
+		prev_ns->sibling = ns->sibling;
+	    }
+	  prev_ns = ns;
+	  ns = ns->sibling;
+	}
+  
+      gfc_free_namespace (gfc_current_ns);
+      gfc_current_ns = parent_ns;
+    }
+
+  return MATCH_ERROR;
+}
+
+
+
+/***************** Attribute declaration statements ****************/
+
+/* Set the attribute of a single variable.  */
+
+static match
+attr_decl1 (void)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_array_spec *as;
+  gfc_symbol *sym;
+  locus var_locus;
+  match m;
+
+  as = NULL;
+
+  m = gfc_match_name (name);
+  if (m != MATCH_YES)
+    goto cleanup;
+
+  if (find_special (name, &sym, false))
+    return MATCH_ERROR;
+
+  if (!check_function_name (name))
+    {
+      m = MATCH_ERROR;
+      goto cleanup;
+    }
+
+  var_locus = gfc_current_locus;
+
+  /* Deal with possible array specification for certain attributes.  */
+  if (current_attr.dimension
+      || current_attr.codimension
+      || current_attr.allocatable
+      || current_attr.pointer
+      || current_attr.target)
+    {
+      m = gfc_match_array_spec (&as, !current_attr.codimension,
+				!current_attr.dimension
+				&& !current_attr.pointer
+				&& !current_attr.target);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+
+      if (current_attr.dimension && m == MATCH_NO)
+	{
+	  gfc_error ("Missing array specification at %L in DIMENSION "
+		     "statement", &var_locus);
+	  m = MATCH_ERROR;
+	  goto cleanup;
+	}
+
+      if (current_attr.dimension && sym->value)
+	{
+	  gfc_error ("Dimensions specified for %s at %L after its "
+		     "initialisation", sym->name, &var_locus);
+	  m = MATCH_ERROR;
+	  goto cleanup;
+	}
+
+      if (current_attr.codimension && m == MATCH_NO)
+	{
+	  gfc_error ("Missing array specification at %L in CODIMENSION "
+		     "statement", &var_locus);
+	  m = MATCH_ERROR;
+	  goto cleanup;
+	}
+
+      if ((current_attr.allocatable || current_attr.pointer)
+	  && (m == MATCH_YES) && (as->type != AS_DEFERRED))
+	{
+	  gfc_error ("Array specification must be deferred at %L", &var_locus);
+	  m = MATCH_ERROR;
+	  goto cleanup;
+	}
+    }
+
+  /* Update symbol table.  DIMENSION attribute is set in
+     gfc_set_array_spec().  For CLASS variables, this must be applied
+     to the first component, or '_data' field.  */
+  if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class)
+    {
+      if (!gfc_copy_attr (&CLASS_DATA(sym)->attr, &current_attr, &var_locus))
+	{
+	  m = MATCH_ERROR;
+	  goto cleanup;
+	}
+    }
+  else
+    {
+      if (current_attr.dimension == 0 && current_attr.codimension == 0
+	  && !gfc_copy_attr (&sym->attr, &current_attr, &var_locus))
+	{
+	  m = MATCH_ERROR;
+	  goto cleanup;
+	}
+    }
+
+  if (sym->ts.type == BT_CLASS
+      && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
+    {
+      m = MATCH_ERROR;
+      goto cleanup;
+    }
+
+  if (!gfc_set_array_spec (sym, as, &var_locus))
+    {
+      m = MATCH_ERROR;
+      goto cleanup;
+    }
+
+  if (sym->attr.cray_pointee && sym->as != NULL)
+    {
+      /* Fix the array spec.  */
+      m = gfc_mod_pointee_as (sym->as);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+    }
+
+  if (!gfc_add_attribute (&sym->attr, &var_locus))
+    {
+      m = MATCH_ERROR;
+      goto cleanup;
+    }
+
+  if ((current_attr.external || current_attr.intrinsic)
+      && sym->attr.flavor != FL_PROCEDURE
+      && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
+    {
+      m = MATCH_ERROR;
+      goto cleanup;
+    }
+
+  add_hidden_procptr_result (sym);
+
+  return MATCH_YES;
+
+cleanup:
+  gfc_free_array_spec (as);
+  return m;
+}
+
+
+/* Generic attribute declaration subroutine.  Used for attributes that
+   just have a list of names.  */
+
+static match
+attr_decl (void)
+{
+  match m;
+
+  /* Gobble the optional double colon, by simply ignoring the result
+     of gfc_match().  */
+  gfc_match (" ::");
+
+  for (;;)
+    {
+      m = attr_decl1 ();
+      if (m != MATCH_YES)
+	break;
+
+      if (gfc_match_eos () == MATCH_YES)
+	{
+	  m = MATCH_YES;
+	  break;
+	}
+
+      if (gfc_match_char (',') != MATCH_YES)
+	{
+	  gfc_error ("Unexpected character in variable list at %C");
+	  m = MATCH_ERROR;
+	  break;
+	}
+    }
+
+  return m;
+}
+
+
+/* This routine matches Cray Pointer declarations of the form:
+   pointer ( <pointer>, <pointee> )
+   or
+   pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
+   The pointer, if already declared, should be an integer.  Otherwise, we
+   set it as BT_INTEGER with kind gfc_index_integer_kind.  The pointee may
+   be either a scalar, or an array declaration.  No space is allocated for
+   the pointee.  For the statement
+   pointer (ipt, ar(10))
+   any subsequent uses of ar will be translated (in C-notation) as
+   ar(i) => ((<type> *) ipt)(i)
+   After gimplification, pointee variable will disappear in the code.  */
+
+static match
+cray_pointer_decl (void)
+{
+  match m;
+  gfc_array_spec *as = NULL;
+  gfc_symbol *cptr; /* Pointer symbol.  */
+  gfc_symbol *cpte; /* Pointee symbol.  */
+  locus var_locus;
+  bool done = false;
+
+  while (!done)
+    {
+      if (gfc_match_char ('(') != MATCH_YES)
+	{
+	  gfc_error ("Expected '(' at %C");
+	  return MATCH_ERROR;
+	}
+
+      /* Match pointer.  */
+      var_locus = gfc_current_locus;
+      gfc_clear_attr (&current_attr);
+      gfc_add_cray_pointer (&current_attr, &var_locus);
+      current_ts.type = BT_INTEGER;
+      current_ts.kind = gfc_index_integer_kind;
+
+      m = gfc_match_symbol (&cptr, 0);
+      if (m != MATCH_YES)
+	{
+	  gfc_error ("Expected variable name at %C");
+	  return m;
+	}
+
+      if (!gfc_add_cray_pointer (&cptr->attr, &var_locus))
+	return MATCH_ERROR;
+
+      gfc_set_sym_referenced (cptr);
+
+      if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary.  */
+	{
+	  cptr->ts.type = BT_INTEGER;
+	  cptr->ts.kind = gfc_index_integer_kind;
+	}
+      else if (cptr->ts.type != BT_INTEGER)
+	{
+	  gfc_error ("Cray pointer at %C must be an integer");
+	  return MATCH_ERROR;
+	}
+      else if (cptr->ts.kind < gfc_index_integer_kind)
+	gfc_warning ("Cray pointer at %C has %d bytes of precision;"
+		     " memory addresses require %d bytes",
+		     cptr->ts.kind, gfc_index_integer_kind);
+
+      if (gfc_match_char (',') != MATCH_YES)
+	{
+	  gfc_error ("Expected \",\" at %C");
+	  return MATCH_ERROR;
+	}
+
+      /* Match Pointee.  */
+      var_locus = gfc_current_locus;
+      gfc_clear_attr (&current_attr);
+      gfc_add_cray_pointee (&current_attr, &var_locus);
+      current_ts.type = BT_UNKNOWN;
+      current_ts.kind = 0;
+
+      m = gfc_match_symbol (&cpte, 0);
+      if (m != MATCH_YES)
+	{
+	  gfc_error ("Expected variable name at %C");
+	  return m;
+	}
+
+      /* Check for an optional array spec.  */
+      m = gfc_match_array_spec (&as, true, false);
+      if (m == MATCH_ERROR)
+	{
+	  gfc_free_array_spec (as);
+	  return m;
+	}
+      else if (m == MATCH_NO)
+	{
+	  gfc_free_array_spec (as);
+	  as = NULL;
+	}
+
+      if (!gfc_add_cray_pointee (&cpte->attr, &var_locus))
+	return MATCH_ERROR;
+
+      gfc_set_sym_referenced (cpte);
+
+      if (cpte->as == NULL)
+	{
+	  if (!gfc_set_array_spec (cpte, as, &var_locus))
+	    gfc_internal_error ("Couldn't set Cray pointee array spec.");
+	}
+      else if (as != NULL)
+	{
+	  gfc_error ("Duplicate array spec for Cray pointee at %C");
+	  gfc_free_array_spec (as);
+	  return MATCH_ERROR;
+	}
+
+      as = NULL;
+
+      if (cpte->as != NULL)
+	{
+	  /* Fix array spec.  */
+	  m = gfc_mod_pointee_as (cpte->as);
+	  if (m == MATCH_ERROR)
+	    return m;
+	}
+
+      /* Point the Pointee at the Pointer.  */
+      cpte->cp_pointer = cptr;
+
+      if (gfc_match_char (')') != MATCH_YES)
+	{
+	  gfc_error ("Expected \")\" at %C");
+	  return MATCH_ERROR;
+	}
+      m = gfc_match_char (',');
+      if (m != MATCH_YES)
+	done = true; /* Stop searching for more declarations.  */
+
+    }
+
+  if (m == MATCH_ERROR /* Failed when trying to find ',' above.  */
+      || gfc_match_eos () != MATCH_YES)
+    {
+      gfc_error ("Expected \",\" or end of statement at %C");
+      return MATCH_ERROR;
+    }
+  return MATCH_YES;
+}
+
+
+match
+gfc_match_external (void)
+{
+
+  gfc_clear_attr (&current_attr);
+  current_attr.external = 1;
+
+  return attr_decl ();
+}
+
+
+match
+gfc_match_intent (void)
+{
+  sym_intent intent;
+
+  /* This is not allowed within a BLOCK construct!  */
+  if (gfc_current_state () == COMP_BLOCK)
+    {
+      gfc_error ("INTENT is not allowed inside of BLOCK at %C");
+      return MATCH_ERROR;
+    }
+
+  intent = match_intent_spec ();
+  if (intent == INTENT_UNKNOWN)
+    return MATCH_ERROR;
+
+  gfc_clear_attr (&current_attr);
+  current_attr.intent = intent;
+
+  return attr_decl ();
+}
+
+
+match
+gfc_match_intrinsic (void)
+{
+
+  gfc_clear_attr (&current_attr);
+  current_attr.intrinsic = 1;
+
+  return attr_decl ();
+}
+
+
+match
+gfc_match_optional (void)
+{
+  /* This is not allowed within a BLOCK construct!  */
+  if (gfc_current_state () == COMP_BLOCK)
+    {
+      gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
+      return MATCH_ERROR;
+    }
+
+  gfc_clear_attr (&current_attr);
+  current_attr.optional = 1;
+
+  return attr_decl ();
+}
+
+
+match
+gfc_match_pointer (void)
+{
+  gfc_gobble_whitespace ();
+  if (gfc_peek_ascii_char () == '(')
+    {
+      if (!gfc_option.flag_cray_pointer)
+	{
+	  gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
+		     "flag");
+	  return MATCH_ERROR;
+	}
+      return cray_pointer_decl ();
+    }
+  else
+    {
+      gfc_clear_attr (&current_attr);
+      current_attr.pointer = 1;
+
+      return attr_decl ();
+    }
+}
+
+
+match
+gfc_match_allocatable (void)
+{
+  gfc_clear_attr (&current_attr);
+  current_attr.allocatable = 1;
+
+  return attr_decl ();
+}
+
+
+match
+gfc_match_codimension (void)
+{
+  gfc_clear_attr (&current_attr);
+  current_attr.codimension = 1;
+
+  return attr_decl ();
+}
+
+
+match
+gfc_match_contiguous (void)
+{
+  if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS statement at %C"))
+    return MATCH_ERROR;
+
+  gfc_clear_attr (&current_attr);
+  current_attr.contiguous = 1;
+
+  return attr_decl ();
+}
+
+
+match
+gfc_match_dimension (void)
+{
+  gfc_clear_attr (&current_attr);
+  current_attr.dimension = 1;
+
+  return attr_decl ();
+}
+
+
+match
+gfc_match_target (void)
+{
+  gfc_clear_attr (&current_attr);
+  current_attr.target = 1;
+
+  return attr_decl ();
+}
+
+
+/* Match the list of entities being specified in a PUBLIC or PRIVATE
+   statement.  */
+
+static match
+access_attr_decl (gfc_statement st)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  interface_type type;
+  gfc_user_op *uop;
+  gfc_symbol *sym, *dt_sym;
+  gfc_intrinsic_op op;
+  match m;
+
+  if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
+    goto done;
+
+  for (;;)
+    {
+      m = gfc_match_generic_spec (&type, name, &op);
+      if (m == MATCH_NO)
+	goto syntax;
+      if (m == MATCH_ERROR)
+	return MATCH_ERROR;
+
+      switch (type)
+	{
+	case INTERFACE_NAMELESS:
+	case INTERFACE_ABSTRACT:
+	  goto syntax;
+
+	case INTERFACE_GENERIC:
+	  if (gfc_get_symbol (name, NULL, &sym))
+	    goto done;
+
+	  if (!gfc_add_access (&sym->attr, 
+			       (st == ST_PUBLIC) 
+			       ? ACCESS_PUBLIC : ACCESS_PRIVATE, 
+			       sym->name, NULL))
+	    return MATCH_ERROR;
+
+	  if (sym->attr.generic && (dt_sym = gfc_find_dt_in_generic (sym))
+	      && !gfc_add_access (&dt_sym->attr, 
+				  (st == ST_PUBLIC) 
+				  ? ACCESS_PUBLIC : ACCESS_PRIVATE, 
+				  sym->name, NULL))
+	    return MATCH_ERROR;
+
+	  break;
+
+	case INTERFACE_INTRINSIC_OP:
+	  if (gfc_current_ns->operator_access[op] == ACCESS_UNKNOWN)
+	    {
+	      gfc_intrinsic_op other_op;
+
+	      gfc_current_ns->operator_access[op] =
+		(st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
+
+	      /* Handle the case if there is another op with the same
+		 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on.  */
+	      other_op = gfc_equivalent_op (op);
+
+	      if (other_op != INTRINSIC_NONE)
+		gfc_current_ns->operator_access[other_op] =
+		  (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
+
+	    }
+	  else
+	    {
+	      gfc_error ("Access specification of the %s operator at %C has "
+			 "already been specified", gfc_op2string (op));
+	      goto done;
+	    }
+
+	  break;
+
+	case INTERFACE_USER_OP:
+	  uop = gfc_get_uop (name);
+
+	  if (uop->access == ACCESS_UNKNOWN)
+	    {
+	      uop->access = (st == ST_PUBLIC)
+			  ? ACCESS_PUBLIC : ACCESS_PRIVATE;
+	    }
+	  else
+	    {
+	      gfc_error ("Access specification of the .%s. operator at %C "
+			 "has already been specified", sym->name);
+	      goto done;
+	    }
+
+	  break;
+	}
+
+      if (gfc_match_char (',') == MATCH_NO)
+	break;
+    }
+
+  if (gfc_match_eos () != MATCH_YES)
+    goto syntax;
+  return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (st);
+
+done:
+  return MATCH_ERROR;
+}
+
+
+match
+gfc_match_protected (void)
+{
+  gfc_symbol *sym;
+  match m;
+
+  if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
+    {
+       gfc_error ("PROTECTED at %C only allowed in specification "
+		  "part of a module");
+       return MATCH_ERROR;
+
+    }
+
+  if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED statement at %C"))
+    return MATCH_ERROR;
+
+  if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
+    {
+      return MATCH_ERROR;
+    }
+
+  if (gfc_match_eos () == MATCH_YES)
+    goto syntax;
+
+  for(;;)
+    {
+      m = gfc_match_symbol (&sym, 0);
+      switch (m)
+	{
+	case MATCH_YES:
+	  if (!gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus))
+	    return MATCH_ERROR;
+	  goto next_item;
+
+	case MATCH_NO:
+	  break;
+
+	case MATCH_ERROR:
+	  return MATCH_ERROR;
+	}
+
+    next_item:
+      if (gfc_match_eos () == MATCH_YES)
+	break;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+    }
+
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in PROTECTED statement at %C");
+  return MATCH_ERROR;
+}
+
+
+/* The PRIVATE statement is a bit weird in that it can be an attribute
+   declaration, but also works as a standalone statement inside of a
+   type declaration or a module.  */
+
+match
+gfc_match_private (gfc_statement *st)
+{
+
+  if (gfc_match ("private") != MATCH_YES)
+    return MATCH_NO;
+
+  if (gfc_current_state () != COMP_MODULE
+      && !(gfc_current_state () == COMP_DERIVED
+	   && gfc_state_stack->previous
+	   && gfc_state_stack->previous->state == COMP_MODULE)
+      && !(gfc_current_state () == COMP_DERIVED_CONTAINS
+	   && gfc_state_stack->previous && gfc_state_stack->previous->previous
+	   && gfc_state_stack->previous->previous->state == COMP_MODULE))
+    {
+      gfc_error ("PRIVATE statement at %C is only allowed in the "
+		 "specification part of a module");
+      return MATCH_ERROR;
+    }
+
+  if (gfc_current_state () == COMP_DERIVED)
+    {
+      if (gfc_match_eos () == MATCH_YES)
+	{
+	  *st = ST_PRIVATE;
+	  return MATCH_YES;
+	}
+
+      gfc_syntax_error (ST_PRIVATE);
+      return MATCH_ERROR;
+    }
+
+  if (gfc_match_eos () == MATCH_YES)
+    {
+      *st = ST_PRIVATE;
+      return MATCH_YES;
+    }
+
+  *st = ST_ATTR_DECL;
+  return access_attr_decl (ST_PRIVATE);
+}
+
+
+match
+gfc_match_public (gfc_statement *st)
+{
+
+  if (gfc_match ("public") != MATCH_YES)
+    return MATCH_NO;
+
+  if (gfc_current_state () != COMP_MODULE)
+    {
+      gfc_error ("PUBLIC statement at %C is only allowed in the "
+		 "specification part of a module");
+      return MATCH_ERROR;
+    }
+
+  if (gfc_match_eos () == MATCH_YES)
+    {
+      *st = ST_PUBLIC;
+      return MATCH_YES;
+    }
+
+  *st = ST_ATTR_DECL;
+  return access_attr_decl (ST_PUBLIC);
+}
+
+
+/* Workhorse for gfc_match_parameter.  */
+
+static match
+do_parm (void)
+{
+  gfc_symbol *sym;
+  gfc_expr *init;
+  match m;
+  bool t;
+
+  m = gfc_match_symbol (&sym, 0);
+  if (m == MATCH_NO)
+    gfc_error ("Expected variable name at %C in PARAMETER statement");
+
+  if (m != MATCH_YES)
+    return m;
+
+  if (gfc_match_char ('=') == MATCH_NO)
+    {
+      gfc_error ("Expected = sign in PARAMETER statement at %C");
+      return MATCH_ERROR;
+    }
+
+  m = gfc_match_init_expr (&init);
+  if (m == MATCH_NO)
+    gfc_error ("Expected expression at %C in PARAMETER statement");
+  if (m != MATCH_YES)
+    return m;
+
+  if (sym->ts.type == BT_UNKNOWN
+      && !gfc_set_default_type (sym, 1, NULL))
+    {
+      m = MATCH_ERROR;
+      goto cleanup;
+    }
+
+  if (!gfc_check_assign_symbol (sym, NULL, init)
+      || !gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL))
+    {
+      m = MATCH_ERROR;
+      goto cleanup;
+    }
+
+  if (sym->value)
+    {
+      gfc_error ("Initializing already initialized variable at %C");
+      m = MATCH_ERROR;
+      goto cleanup;
+    }
+
+  t = add_init_expr_to_sym (sym->name, &init, &gfc_current_locus);
+  return (t) ? MATCH_YES : MATCH_ERROR;
+
+cleanup:
+  gfc_free_expr (init);
+  return m;
+}
+
+
+/* Match a parameter statement, with the weird syntax that these have.  */
+
+match
+gfc_match_parameter (void)
+{
+  match m;
+
+  if (gfc_match_char ('(') == MATCH_NO)
+    return MATCH_NO;
+
+  for (;;)
+    {
+      m = do_parm ();
+      if (m != MATCH_YES)
+	break;
+
+      if (gfc_match (" )%t") == MATCH_YES)
+	break;
+
+      if (gfc_match_char (',') != MATCH_YES)
+	{
+	  gfc_error ("Unexpected characters in PARAMETER statement at %C");
+	  m = MATCH_ERROR;
+	  break;
+	}
+    }
+
+  return m;
+}
+
+
+/* Save statements have a special syntax.  */
+
+match
+gfc_match_save (void)
+{
+  char n[GFC_MAX_SYMBOL_LEN+1];
+  gfc_common_head *c;
+  gfc_symbol *sym;
+  match m;
+
+  if (gfc_match_eos () == MATCH_YES)
+    {
+      if (gfc_current_ns->seen_save)
+	{
+	  if (!gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C "
+			       "follows previous SAVE statement"))
+	    return MATCH_ERROR;
+	}
+
+      gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
+      return MATCH_YES;
+    }
+
+  if (gfc_current_ns->save_all)
+    {
+      if (!gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows "
+			   "blanket SAVE statement"))
+	return MATCH_ERROR;
+    }
+
+  gfc_match (" ::");
+
+  for (;;)
+    {
+      m = gfc_match_symbol (&sym, 0);
+      switch (m)
+	{
+	case MATCH_YES:
+	  if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, 
+			     &gfc_current_locus))
+	    return MATCH_ERROR;
+	  goto next_item;
+
+	case MATCH_NO:
+	  break;
+
+	case MATCH_ERROR:
+	  return MATCH_ERROR;
+	}
+
+      m = gfc_match (" / %n /", &n);
+      if (m == MATCH_ERROR)
+	return MATCH_ERROR;
+      if (m == MATCH_NO)
+	goto syntax;
+
+      c = gfc_get_common (n, 0);
+      c->saved = 1;
+
+      gfc_current_ns->seen_save = 1;
+
+    next_item:
+      if (gfc_match_eos () == MATCH_YES)
+	break;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+    }
+
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in SAVE statement at %C");
+  return MATCH_ERROR;
+}
+
+
+match
+gfc_match_value (void)
+{
+  gfc_symbol *sym;
+  match m;
+
+  /* This is not allowed within a BLOCK construct!  */
+  if (gfc_current_state () == COMP_BLOCK)
+    {
+      gfc_error ("VALUE is not allowed inside of BLOCK at %C");
+      return MATCH_ERROR;
+    }
+
+  if (!gfc_notify_std (GFC_STD_F2003, "VALUE statement at %C"))
+    return MATCH_ERROR;
+
+  if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
+    {
+      return MATCH_ERROR;
+    }
+
+  if (gfc_match_eos () == MATCH_YES)
+    goto syntax;
+
+  for(;;)
+    {
+      m = gfc_match_symbol (&sym, 0);
+      switch (m)
+	{
+	case MATCH_YES:
+	  if (!gfc_add_value (&sym->attr, sym->name, &gfc_current_locus))
+	    return MATCH_ERROR;
+	  goto next_item;
+
+	case MATCH_NO:
+	  break;
+
+	case MATCH_ERROR:
+	  return MATCH_ERROR;
+	}
+
+    next_item:
+      if (gfc_match_eos () == MATCH_YES)
+	break;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+    }
+
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in VALUE statement at %C");
+  return MATCH_ERROR;
+}
+
+
+match
+gfc_match_volatile (void)
+{
+  gfc_symbol *sym;
+  match m;
+
+  if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE statement at %C"))
+    return MATCH_ERROR;
+
+  if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
+    {
+      return MATCH_ERROR;
+    }
+
+  if (gfc_match_eos () == MATCH_YES)
+    goto syntax;
+
+  for(;;)
+    {
+      /* VOLATILE is special because it can be added to host-associated
+	 symbols locally. Except for coarrays. */
+      m = gfc_match_symbol (&sym, 1);
+      switch (m)
+	{
+	case MATCH_YES:
+	  /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
+	     for variable in a BLOCK which is defined outside of the BLOCK.  */
+	  if (sym->ns != gfc_current_ns && sym->attr.codimension)
+	    {
+	      gfc_error ("Specifying VOLATILE for coarray variable '%s' at "
+			 "%C, which is use-/host-associated", sym->name);
+	      return MATCH_ERROR;
+	    }
+	  if (!gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus))
+	    return MATCH_ERROR;
+	  goto next_item;
+
+	case MATCH_NO:
+	  break;
+
+	case MATCH_ERROR:
+	  return MATCH_ERROR;
+	}
+
+    next_item:
+      if (gfc_match_eos () == MATCH_YES)
+	break;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+    }
+
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in VOLATILE statement at %C");
+  return MATCH_ERROR;
+}
+
+
+match
+gfc_match_asynchronous (void)
+{
+  gfc_symbol *sym;
+  match m;
+
+  if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS statement at %C"))
+    return MATCH_ERROR;
+
+  if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
+    {
+      return MATCH_ERROR;
+    }
+
+  if (gfc_match_eos () == MATCH_YES)
+    goto syntax;
+
+  for(;;)
+    {
+      /* ASYNCHRONOUS is special because it can be added to host-associated
+	 symbols locally.  */
+      m = gfc_match_symbol (&sym, 1);
+      switch (m)
+	{
+	case MATCH_YES:
+	  if (!gfc_add_asynchronous (&sym->attr, sym->name, &gfc_current_locus))
+	    return MATCH_ERROR;
+	  goto next_item;
+
+	case MATCH_NO:
+	  break;
+
+	case MATCH_ERROR:
+	  return MATCH_ERROR;
+	}
+
+    next_item:
+      if (gfc_match_eos () == MATCH_YES)
+	break;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+    }
+
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
+  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.  */
+
+match
+gfc_match_modproc (void)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_symbol *sym;
+  match m;
+  locus old_locus;
+  gfc_namespace *module_ns;
+  gfc_interface *old_interface_head, *interface;
+
+  if (gfc_state_stack->state != COMP_INTERFACE
+      || gfc_state_stack->previous == NULL
+      || current_interface.type == INTERFACE_NAMELESS
+      || current_interface.type == INTERFACE_ABSTRACT)
+    {
+      gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
+		 "interface");
+      return MATCH_ERROR;
+    }
+
+  module_ns = gfc_current_ns->parent;
+  for (; module_ns; module_ns = module_ns->parent)
+    if (module_ns->proc_name->attr.flavor == FL_MODULE
+	|| module_ns->proc_name->attr.flavor == FL_PROGRAM
+	|| (module_ns->proc_name->attr.flavor == FL_PROCEDURE
+	    && !module_ns->proc_name->attr.contained))
+      break;
+
+  if (module_ns == NULL)
+    return MATCH_ERROR;
+
+  /* Store the current state of the interface. We will need it if we
+     end up with a syntax error and need to recover.  */
+  old_interface_head = gfc_current_interface_head ();
+
+  /* Check if the F2008 optional double colon appears.  */
+  gfc_gobble_whitespace ();
+  old_locus = gfc_current_locus;
+  if (gfc_match ("::") == MATCH_YES)
+    {
+      if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
+			   "MODULE PROCEDURE statement at %L", &old_locus))
+	return MATCH_ERROR;
+    }
+  else
+    gfc_current_locus = old_locus;
+
+  for (;;)
+    {
+      bool last = false;
+      old_locus = gfc_current_locus;
+
+      m = gfc_match_name (name);
+      if (m == MATCH_NO)
+	goto syntax;
+      if (m != MATCH_YES)
+	return MATCH_ERROR;
+
+      /* Check for syntax error before starting to add symbols to the
+	 current namespace.  */
+      if (gfc_match_eos () == MATCH_YES)
+	last = true;
+
+      if (!last && gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+
+      /* Now we're sure the syntax is valid, we process this item
+	 further.  */
+      if (gfc_get_symbol (name, module_ns, &sym))
+	return MATCH_ERROR;
+
+      if (sym->attr.intrinsic)
+	{
+	  gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
+		     "PROCEDURE", &old_locus);
+	  return MATCH_ERROR;
+	}
+
+      if (sym->attr.proc != PROC_MODULE
+	  && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
+	return MATCH_ERROR;
+
+      if (!gfc_add_interface (sym))
+	return MATCH_ERROR;
+
+      sym->attr.mod_proc = 1;
+      sym->declared_at = old_locus;
+
+      if (last)
+	break;
+    }
+
+  return MATCH_YES;
+
+syntax:
+  /* Restore the previous state of the interface.  */
+  interface = gfc_current_interface_head ();
+  gfc_set_current_interface_head (old_interface_head);
+
+  /* Free the new interfaces.  */
+  while (interface != old_interface_head)
+  {
+    gfc_interface *i = interface->next;
+    free (interface);
+    interface = i;
+  }
+
+  /* And issue a syntax error.  */
+  gfc_syntax_error (ST_MODULE_PROC);
+  return MATCH_ERROR;
+}
+
+
+/* Check a derived type that is being extended.  */
+
+static gfc_symbol*
+check_extended_derived_type (char *name)
+{
+  gfc_symbol *extended;
+
+  if (gfc_find_symbol (name, gfc_current_ns, 1, &extended))
+    {
+      gfc_error ("Ambiguous symbol in TYPE definition at %C");
+      return NULL;
+    }
+
+  extended = gfc_find_dt_in_generic (extended);
+
+  /* F08:C428.  */
+  if (!extended)
+    {
+      gfc_error ("Symbol '%s' at %C has not been previously defined", name);
+      return NULL;
+    }
+
+  if (extended->attr.flavor != FL_DERIVED)
+    {
+      gfc_error ("'%s' in EXTENDS expression at %C is not a "
+		 "derived type", name);
+      return NULL;
+    }
+
+  if (extended->attr.is_bind_c)
+    {
+      gfc_error ("'%s' cannot be extended at %C because it "
+		 "is BIND(C)", extended->name);
+      return NULL;
+    }
+
+  if (extended->attr.sequence)
+    {
+      gfc_error ("'%s' cannot be extended at %C because it "
+		 "is a SEQUENCE type", extended->name);
+      return NULL;
+    }
+
+  return extended;
+}
+
+
+/* Match the optional attribute specifiers for a type declaration.
+   Return MATCH_ERROR if an error is encountered in one of the handled
+   attributes (public, private, bind(c)), MATCH_NO if what's found is
+   not a handled attribute, and MATCH_YES otherwise.  TODO: More error
+   checking on attribute conflicts needs to be done.  */
+
+match
+gfc_get_type_attr_spec (symbol_attribute *attr, char *name)
+{
+  /* See if the derived type is marked as private.  */
+  if (gfc_match (" , private") == MATCH_YES)
+    {
+      if (gfc_current_state () != COMP_MODULE)
+	{
+	  gfc_error ("Derived type at %C can only be PRIVATE in the "
+		     "specification part of a module");
+	  return MATCH_ERROR;
+	}
+
+      if (!gfc_add_access (attr, ACCESS_PRIVATE, NULL, NULL))
+	return MATCH_ERROR;
+    }
+  else if (gfc_match (" , public") == MATCH_YES)
+    {
+      if (gfc_current_state () != COMP_MODULE)
+	{
+	  gfc_error ("Derived type at %C can only be PUBLIC in the "
+		     "specification part of a module");
+	  return MATCH_ERROR;
+	}
+
+      if (!gfc_add_access (attr, ACCESS_PUBLIC, NULL, NULL))
+	return MATCH_ERROR;
+    }
+  else if (gfc_match (" , bind ( c )") == MATCH_YES)
+    {
+      /* If the type is defined to be bind(c) it then needs to make
+	 sure that all fields are interoperable.  This will
+	 need to be a semantic check on the finished derived type.
+	 See 15.2.3 (lines 9-12) of F2003 draft.  */
+      if (!gfc_add_is_bind_c (attr, NULL, &gfc_current_locus, 0))
+	return MATCH_ERROR;
+
+      /* TODO: attr conflicts need to be checked, probably in symbol.c.  */
+    }
+  else if (gfc_match (" , abstract") == MATCH_YES)
+    {
+      if (!gfc_notify_std (GFC_STD_F2003, "ABSTRACT type at %C"))
+	return MATCH_ERROR;
+
+      if (!gfc_add_abstract (attr, &gfc_current_locus))
+	return MATCH_ERROR;
+    }
+  else if (name && gfc_match (" , extends ( %n )", name) == MATCH_YES)
+    {
+      if (!gfc_add_extension (attr, &gfc_current_locus))
+	return MATCH_ERROR;
+    }
+  else
+    return MATCH_NO;
+
+  /* If we get here, something matched.  */
+  return MATCH_YES;
+}
+
+
+/* Match the beginning of a derived type declaration.  If a type name
+   was the result of a function, then it is possible to have a symbol
+   already to be known as a derived type yet have no components.  */
+
+match
+gfc_match_derived_decl (void)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  char parent[GFC_MAX_SYMBOL_LEN + 1];
+  symbol_attribute attr;
+  gfc_symbol *sym, *gensym;
+  gfc_symbol *extended;
+  match m;
+  match is_type_attr_spec = MATCH_NO;
+  bool seen_attr = false;
+  gfc_interface *intr = NULL, *head;
+
+  if (gfc_current_state () == COMP_DERIVED)
+    return MATCH_NO;
+
+  name[0] = '\0';
+  parent[0] = '\0';
+  gfc_clear_attr (&attr);
+  extended = NULL;
+
+  do
+    {
+      is_type_attr_spec = gfc_get_type_attr_spec (&attr, parent);
+      if (is_type_attr_spec == MATCH_ERROR)
+	return MATCH_ERROR;
+      if (is_type_attr_spec == MATCH_YES)
+	seen_attr = true;
+    } while (is_type_attr_spec == MATCH_YES);
+
+  /* Deal with derived type extensions.  The extension attribute has
+     been added to 'attr' but now the parent type must be found and
+     checked.  */
+  if (parent[0])
+    extended = check_extended_derived_type (parent);
+
+  if (parent[0] && !extended)
+    return MATCH_ERROR;
+
+  if (gfc_match (" ::") != MATCH_YES && seen_attr)
+    {
+      gfc_error ("Expected :: in TYPE definition at %C");
+      return MATCH_ERROR;
+    }
+
+  m = gfc_match (" %n%t", name);
+  if (m != MATCH_YES)
+    return m;
+
+  /* Make sure the name is not the name of an intrinsic type.  */
+  if (gfc_is_intrinsic_typename (name))
+    {
+      gfc_error ("Type name '%s' at %C cannot be the same as an intrinsic "
+		 "type", name);
+      return MATCH_ERROR;
+    }
+
+  if (gfc_get_symbol (name, NULL, &gensym))
+    return MATCH_ERROR;
+
+  if (!gensym->attr.generic && gensym->ts.type != BT_UNKNOWN)
+    {
+      gfc_error ("Derived type name '%s' at %C already has a basic type "
+		 "of %s", gensym->name, gfc_typename (&gensym->ts));
+      return MATCH_ERROR;
+    }
+
+  if (!gensym->attr.generic
+      && !gfc_add_generic (&gensym->attr, gensym->name, NULL))
+    return MATCH_ERROR;
+
+  if (!gensym->attr.function
+      && !gfc_add_function (&gensym->attr, gensym->name, NULL))
+    return MATCH_ERROR;
+
+  sym = gfc_find_dt_in_generic (gensym);
+
+  if (sym && (sym->components != NULL || sym->attr.zero_comp))
+    {
+      gfc_error ("Derived type definition of '%s' at %C has already been "
+                 "defined", sym->name);
+      return MATCH_ERROR;
+    }
+
+  if (!sym)
+    {
+      /* Use upper case to save the actual derived-type symbol.  */
+      gfc_get_symbol (gfc_get_string ("%c%s",
+			(char) TOUPPER ((unsigned char) gensym->name[0]),
+			&gensym->name[1]), NULL, &sym);
+      sym->name = gfc_get_string (gensym->name);
+      head = gensym->generic;
+      intr = gfc_get_interface ();
+      intr->sym = sym;
+      intr->where = gfc_current_locus;
+      intr->sym->declared_at = gfc_current_locus;
+      intr->next = head;
+      gensym->generic = intr;
+      gensym->attr.if_source = IFSRC_DECL;
+    }
+
+  /* The symbol may already have the derived attribute without the
+     components.  The ways this can happen is via a function
+     definition, an INTRINSIC statement or a subtype in another
+     derived type that is a pointer.  The first part of the AND clause
+     is true if the symbol is not the return value of a function.  */
+  if (sym->attr.flavor != FL_DERIVED
+      && !gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL))
+    return MATCH_ERROR;
+
+  if (attr.access != ACCESS_UNKNOWN
+      && !gfc_add_access (&sym->attr, attr.access, sym->name, NULL))
+    return MATCH_ERROR;
+  else if (sym->attr.access == ACCESS_UNKNOWN
+	   && gensym->attr.access != ACCESS_UNKNOWN
+	   && !gfc_add_access (&sym->attr, gensym->attr.access, 
+			       sym->name, NULL))
+    return MATCH_ERROR;
+
+  if (sym->attr.access != ACCESS_UNKNOWN
+      && gensym->attr.access == ACCESS_UNKNOWN)
+    gensym->attr.access = sym->attr.access;
+
+  /* See if the derived type was labeled as bind(c).  */
+  if (attr.is_bind_c != 0)
+    sym->attr.is_bind_c = attr.is_bind_c;
+
+  /* Construct the f2k_derived namespace if it is not yet there.  */
+  if (!sym->f2k_derived)
+    sym->f2k_derived = gfc_get_namespace (NULL, 0);
+
+  if (extended && !sym->components)
+    {
+      gfc_component *p;
+      gfc_symtree *st;
+
+      /* Add the extended derived type as the first component.  */
+      gfc_add_component (sym, parent, &p);
+      extended->refs++;
+      gfc_set_sym_referenced (extended);
+
+      p->ts.type = BT_DERIVED;
+      p->ts.u.derived = extended;
+      p->initializer = gfc_default_initializer (&p->ts);
+
+      /* Set extension level.  */
+      if (extended->attr.extension == 255)
+	{
+	  /* Since the extension field is 8 bit wide, we can only have
+	     up to 255 extension levels.  */
+	  gfc_error ("Maximum extension level reached with type '%s' at %L",
+		     extended->name, &extended->declared_at);
+	  return MATCH_ERROR;
+	}
+      sym->attr.extension = extended->attr.extension + 1;
+
+      /* Provide the links between the extended type and its extension.  */
+      if (!extended->f2k_derived)
+	extended->f2k_derived = gfc_get_namespace (NULL, 0);
+      st = gfc_new_symtree (&extended->f2k_derived->sym_root, sym->name);
+      st->n.sym = sym;
+    }
+
+  if (!sym->hash_value)
+    /* Set the hash for the compound name for this type.  */
+    sym->hash_value = gfc_hash_value (sym);
+
+  /* Take over the ABSTRACT attribute.  */
+  sym->attr.abstract = attr.abstract;
+
+  gfc_new_block = sym;
+
+  return MATCH_YES;
+}
+
+
+/* Cray Pointees can be declared as:
+      pointer (ipt, a (n,m,...,*))  */
+
+match
+gfc_mod_pointee_as (gfc_array_spec *as)
+{
+  as->cray_pointee = true; /* This will be useful to know later.  */
+  if (as->type == AS_ASSUMED_SIZE)
+    as->cp_was_assumed = true;
+  else if (as->type == AS_ASSUMED_SHAPE)
+    {
+      gfc_error ("Cray Pointee at %C cannot be assumed shape array");
+      return MATCH_ERROR;
+    }
+  return MATCH_YES;
+}
+
+
+/* Match the enum definition statement, here we are trying to match
+   the first line of enum definition statement.
+   Returns MATCH_YES if match is found.  */
+
+match
+gfc_match_enum (void)
+{
+  match m;
+
+  m = gfc_match_eos ();
+  if (m != MATCH_YES)
+    return m;
+
+  if (!gfc_notify_std (GFC_STD_F2003, "ENUM and ENUMERATOR at %C"))
+    return MATCH_ERROR;
+
+  return MATCH_YES;
+}
+
+
+/* Returns an initializer whose value is one higher than the value of the
+   LAST_INITIALIZER argument.  If the argument is NULL, the
+   initializers value will be set to zero.  The initializer's kind
+   will be set to gfc_c_int_kind.
+
+   If -fshort-enums is given, the appropriate kind will be selected
+   later after all enumerators have been parsed.  A warning is issued
+   here if an initializer exceeds gfc_c_int_kind.  */
+
+static gfc_expr *
+enum_initializer (gfc_expr *last_initializer, locus where)
+{
+  gfc_expr *result;
+  result = gfc_get_constant_expr (BT_INTEGER, gfc_c_int_kind, &where);
+
+  mpz_init (result->value.integer);
+
+  if (last_initializer != NULL)
+    {
+      mpz_add_ui (result->value.integer, last_initializer->value.integer, 1);
+      result->where = last_initializer->where;
+
+      if (gfc_check_integer_range (result->value.integer,
+	     gfc_c_int_kind) != ARITH_OK)
+	{
+	  gfc_error ("Enumerator exceeds the C integer type at %C");
+	  return NULL;
+	}
+    }
+  else
+    {
+      /* Control comes here, if it's the very first enumerator and no
+	 initializer has been given.  It will be initialized to zero.  */
+      mpz_set_si (result->value.integer, 0);
+    }
+
+  return result;
+}
+
+
+/* Match a variable name with an optional initializer.  When this
+   subroutine is called, a variable is expected to be parsed next.
+   Depending on what is happening at the moment, updates either the
+   symbol table or the current interface.  */
+
+static match
+enumerator_decl (void)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_expr *initializer;
+  gfc_array_spec *as = NULL;
+  gfc_symbol *sym;
+  locus var_locus;
+  match m;
+  bool t;
+  locus old_locus;
+
+  initializer = NULL;
+  old_locus = gfc_current_locus;
+
+  /* When we get here, we've just matched a list of attributes and
+     maybe a type and a double colon.  The next thing we expect to see
+     is the name of the symbol.  */
+  m = gfc_match_name (name);
+  if (m != MATCH_YES)
+    goto cleanup;
+
+  var_locus = gfc_current_locus;
+
+  /* OK, we've successfully matched the declaration.  Now put the
+     symbol in the current namespace. If we fail to create the symbol,
+     bail out.  */
+  if (!build_sym (name, NULL, false, &as, &var_locus))
+    {
+      m = MATCH_ERROR;
+      goto cleanup;
+    }
+
+  /* The double colon must be present in order to have initializers.
+     Otherwise the statement is ambiguous with an assignment statement.  */
+  if (colon_seen)
+    {
+      if (gfc_match_char ('=') == MATCH_YES)
+	{
+	  m = gfc_match_init_expr (&initializer);
+	  if (m == MATCH_NO)
+	    {
+	      gfc_error ("Expected an initialization expression at %C");
+	      m = MATCH_ERROR;
+	    }
+
+	  if (m != MATCH_YES)
+	    goto cleanup;
+	}
+    }
+
+  /* If we do not have an initializer, the initialization value of the
+     previous enumerator (stored in last_initializer) is incremented
+     by 1 and is used to initialize the current enumerator.  */
+  if (initializer == NULL)
+    initializer = enum_initializer (last_initializer, old_locus);
+
+  if (initializer == NULL || initializer->ts.type != BT_INTEGER)
+    {
+      gfc_error ("ENUMERATOR %L not initialized with integer expression",
+		 &var_locus);
+      m = MATCH_ERROR;
+      goto cleanup;
+    }
+
+  /* Store this current initializer, for the next enumerator variable
+     to be parsed.  add_init_expr_to_sym() zeros initializer, so we
+     use last_initializer below.  */
+  last_initializer = initializer;
+  t = add_init_expr_to_sym (name, &initializer, &var_locus);
+
+  /* Maintain enumerator history.  */
+  gfc_find_symbol (name, NULL, 0, &sym);
+  create_enum_history (sym, last_initializer);
+
+  return (t) ? MATCH_YES : MATCH_ERROR;
+
+cleanup:
+  /* Free stuff up and return.  */
+  gfc_free_expr (initializer);
+
+  return m;
+}
+
+
+/* Match the enumerator definition statement.  */
+
+match
+gfc_match_enumerator_def (void)
+{
+  match m;
+  bool t;
+
+  gfc_clear_ts (&current_ts);
+
+  m = gfc_match (" enumerator");
+  if (m != MATCH_YES)
+    return m;
+
+  m = gfc_match (" :: ");
+  if (m == MATCH_ERROR)
+    return m;
+
+  colon_seen = (m == MATCH_YES);
+
+  if (gfc_current_state () != COMP_ENUM)
+    {
+      gfc_error ("ENUM definition statement expected before %C");
+      gfc_free_enum_history ();
+      return MATCH_ERROR;
+    }
+
+  (&current_ts)->type = BT_INTEGER;
+  (&current_ts)->kind = gfc_c_int_kind;
+
+  gfc_clear_attr (&current_attr);
+  t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, NULL);
+  if (!t)
+    {
+      m = MATCH_ERROR;
+      goto cleanup;
+    }
+
+  for (;;)
+    {
+      m = enumerator_decl ();
+      if (m == MATCH_ERROR)
+	{
+	  gfc_free_enum_history ();
+	  goto cleanup;
+	}
+      if (m == MATCH_NO)
+	break;
+
+      if (gfc_match_eos () == MATCH_YES)
+	goto cleanup;
+      if (gfc_match_char (',') != MATCH_YES)
+	break;
+    }
+
+  if (gfc_current_state () == COMP_ENUM)
+    {
+      gfc_free_enum_history ();
+      gfc_error ("Syntax error in ENUMERATOR definition at %C");
+      m = MATCH_ERROR;
+    }
+
+cleanup:
+  gfc_free_array_spec (current_as);
+  current_as = NULL;
+  return m;
+
+}
+
+
+/* Match binding attributes.  */
+
+static match
+match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc)
+{
+  bool found_passing = false;
+  bool seen_ptr = false;
+  match m = MATCH_YES;
+
+  /* Initialize to defaults.  Do so even before the MATCH_NO check so that in
+     this case the defaults are in there.  */
+  ba->access = ACCESS_UNKNOWN;
+  ba->pass_arg = NULL;
+  ba->pass_arg_num = 0;
+  ba->nopass = 0;
+  ba->non_overridable = 0;
+  ba->deferred = 0;
+  ba->ppc = ppc;
+
+  /* If we find a comma, we believe there are binding attributes.  */
+  m = gfc_match_char (',');
+  if (m == MATCH_NO)
+    goto done;
+
+  do
+    {
+      /* Access specifier.  */
+
+      m = gfc_match (" public");
+      if (m == MATCH_ERROR)
+	goto error;
+      if (m == MATCH_YES)
+	{
+	  if (ba->access != ACCESS_UNKNOWN)
+	    {
+	      gfc_error ("Duplicate access-specifier at %C");
+	      goto error;
+	    }
+
+	  ba->access = ACCESS_PUBLIC;
+	  continue;
+	}
+
+      m = gfc_match (" private");
+      if (m == MATCH_ERROR)
+	goto error;
+      if (m == MATCH_YES)
+	{
+	  if (ba->access != ACCESS_UNKNOWN)
+	    {
+	      gfc_error ("Duplicate access-specifier at %C");
+	      goto error;
+	    }
+
+	  ba->access = ACCESS_PRIVATE;
+	  continue;
+	}
+
+      /* If inside GENERIC, the following is not allowed.  */
+      if (!generic)
+	{
+
+	  /* NOPASS flag.  */
+	  m = gfc_match (" nopass");
+	  if (m == MATCH_ERROR)
+	    goto error;
+	  if (m == MATCH_YES)
+	    {
+	      if (found_passing)
+		{
+		  gfc_error ("Binding attributes already specify passing,"
+			     " illegal NOPASS at %C");
+		  goto error;
+		}
+
+	      found_passing = true;
+	      ba->nopass = 1;
+	      continue;
+	    }
+
+	  /* PASS possibly including argument.  */
+	  m = gfc_match (" pass");
+	  if (m == MATCH_ERROR)
+	    goto error;
+	  if (m == MATCH_YES)
+	    {
+	      char arg[GFC_MAX_SYMBOL_LEN + 1];
+
+	      if (found_passing)
+		{
+		  gfc_error ("Binding attributes already specify passing,"
+			     " illegal PASS at %C");
+		  goto error;
+		}
+
+	      m = gfc_match (" ( %n )", arg);
+	      if (m == MATCH_ERROR)
+		goto error;
+	      if (m == MATCH_YES)
+		ba->pass_arg = gfc_get_string (arg);
+	      gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL));
+
+	      found_passing = true;
+	      ba->nopass = 0;
+	      continue;
+	    }
+
+	  if (ppc)
+	    {
+	      /* POINTER flag.  */
+	      m = gfc_match (" pointer");
+	      if (m == MATCH_ERROR)
+		goto error;
+	      if (m == MATCH_YES)
+		{
+		  if (seen_ptr)
+		    {
+		      gfc_error ("Duplicate POINTER attribute at %C");
+		      goto error;
+		    }
+
+		  seen_ptr = true;
+        	  continue;
+		}
+	    }
+	  else
+	    {
+	      /* NON_OVERRIDABLE flag.  */
+	      m = gfc_match (" non_overridable");
+	      if (m == MATCH_ERROR)
+		goto error;
+	      if (m == MATCH_YES)
+		{
+		  if (ba->non_overridable)
+		    {
+		      gfc_error ("Duplicate NON_OVERRIDABLE at %C");
+		      goto error;
+		    }
+
+		  ba->non_overridable = 1;
+		  continue;
+		}
+
+	      /* DEFERRED flag.  */
+	      m = gfc_match (" deferred");
+	      if (m == MATCH_ERROR)
+		goto error;
+	      if (m == MATCH_YES)
+		{
+		  if (ba->deferred)
+		    {
+		      gfc_error ("Duplicate DEFERRED at %C");
+		      goto error;
+		    }
+
+		  ba->deferred = 1;
+		  continue;
+		}
+	    }
+
+	}
+
+      /* Nothing matching found.  */
+      if (generic)
+	gfc_error ("Expected access-specifier at %C");
+      else
+	gfc_error ("Expected binding attribute at %C");
+      goto error;
+    }
+  while (gfc_match_char (',') == MATCH_YES);
+
+  /* NON_OVERRIDABLE and DEFERRED exclude themselves.  */
+  if (ba->non_overridable && ba->deferred)
+    {
+      gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
+      goto error;
+    }
+
+  m = MATCH_YES;
+
+done:
+  if (ba->access == ACCESS_UNKNOWN)
+    ba->access = gfc_typebound_default_access;
+
+  if (ppc && !seen_ptr)
+    {
+      gfc_error ("POINTER attribute is required for procedure pointer component"
+                 " at %C");
+      goto error;
+    }
+
+  return m;
+
+error:
+  return MATCH_ERROR;
+}
+
+
+/* Match a PROCEDURE specific binding inside a derived type.  */
+
+static match
+match_procedure_in_type (void)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  char target_buf[GFC_MAX_SYMBOL_LEN + 1];
+  char* target = NULL, *ifc = NULL;
+  gfc_typebound_proc tb;
+  bool seen_colons;
+  bool seen_attrs;
+  match m;
+  gfc_symtree* stree;
+  gfc_namespace* ns;
+  gfc_symbol* block;
+  int num;
+
+  /* Check current state.  */
+  gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS);
+  block = gfc_state_stack->previous->sym;
+  gcc_assert (block);
+
+  /* Try to match PROCEDURE(interface).  */
+  if (gfc_match (" (") == MATCH_YES)
+    {
+      m = gfc_match_name (target_buf);
+      if (m == MATCH_ERROR)
+	return m;
+      if (m != MATCH_YES)
+	{
+	  gfc_error ("Interface-name expected after '(' at %C");
+	  return MATCH_ERROR;
+	}
+
+      if (gfc_match (" )") != MATCH_YES)
+	{
+	  gfc_error ("')' expected at %C");
+	  return MATCH_ERROR;
+	}
+
+      ifc = target_buf;
+    }
+
+  /* Construct the data structure.  */
+  memset (&tb, 0, sizeof (tb));
+  tb.where = gfc_current_locus;
+
+  /* Match binding attributes.  */
+  m = match_binding_attributes (&tb, false, false);
+  if (m == MATCH_ERROR)
+    return m;
+  seen_attrs = (m == MATCH_YES);
+
+  /* Check that attribute DEFERRED is given if an interface is specified.  */
+  if (tb.deferred && !ifc)
+    {
+      gfc_error ("Interface must be specified for DEFERRED binding at %C");
+      return MATCH_ERROR;
+    }
+  if (ifc && !tb.deferred)
+    {
+      gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
+      return MATCH_ERROR;
+    }
+
+  /* Match the colons.  */
+  m = gfc_match (" ::");
+  if (m == MATCH_ERROR)
+    return m;
+  seen_colons = (m == MATCH_YES);
+  if (seen_attrs && !seen_colons)
+    {
+      gfc_error ("Expected '::' after binding-attributes at %C");
+      return MATCH_ERROR;
+    }
+
+  /* Match the binding names.  */
+  for(num=1;;num++)
+    {
+      m = gfc_match_name (name);
+      if (m == MATCH_ERROR)
+	return m;
+      if (m == MATCH_NO)
+	{
+	  gfc_error ("Expected binding name at %C");
+	  return MATCH_ERROR;
+	}
+
+      if (num>1 && !gfc_notify_std (GFC_STD_F2008, "PROCEDURE list at %C"))
+	return MATCH_ERROR;
+
+      /* Try to match the '=> target', if it's there.  */
+      target = ifc;
+      m = gfc_match (" =>");
+      if (m == MATCH_ERROR)
+	return m;
+      if (m == MATCH_YES)
+	{
+	  if (tb.deferred)
+	    {
+	      gfc_error ("'=> target' is invalid for DEFERRED binding at %C");
+	      return MATCH_ERROR;
+	    }
+
+	  if (!seen_colons)
+	    {
+	      gfc_error ("'::' needed in PROCEDURE binding with explicit target"
+			 " at %C");
+	      return MATCH_ERROR;
+	    }
+
+	  m = gfc_match_name (target_buf);
+	  if (m == MATCH_ERROR)
+	    return m;
+	  if (m == MATCH_NO)
+	    {
+	      gfc_error ("Expected binding target after '=>' at %C");
+	      return MATCH_ERROR;
+	    }
+	  target = target_buf;
+	}
+
+      /* If no target was found, it has the same name as the binding.  */
+      if (!target)
+	target = name;
+
+      /* Get the namespace to insert the symbols into.  */
+      ns = block->f2k_derived;
+      gcc_assert (ns);
+
+      /* If the binding is DEFERRED, check that the containing type is ABSTRACT.  */
+      if (tb.deferred && !block->attr.abstract)
+	{
+	  gfc_error ("Type '%s' containing DEFERRED binding at %C "
+		     "is not ABSTRACT", block->name);
+	  return MATCH_ERROR;
+	}
+
+      /* See if we already have a binding with this name in the symtree which
+	 would be an error.  If a GENERIC already targeted this binding, it may
+	 be already there but then typebound is still NULL.  */
+      stree = gfc_find_symtree (ns->tb_sym_root, name);
+      if (stree && stree->n.tb)
+	{
+	  gfc_error ("There is already a procedure with binding name '%s' for "
+		     "the derived type '%s' at %C", name, block->name);
+	  return MATCH_ERROR;
+	}
+
+      /* Insert it and set attributes.  */
+
+      if (!stree)
+	{
+	  stree = gfc_new_symtree (&ns->tb_sym_root, name);
+	  gcc_assert (stree);
+	}
+      stree->n.tb = gfc_get_typebound_proc (&tb);
+
+      if (gfc_get_sym_tree (target, gfc_current_ns, &stree->n.tb->u.specific,
+			    false))
+	return MATCH_ERROR;
+      gfc_set_sym_referenced (stree->n.tb->u.specific->n.sym);
+
+      if (gfc_match_eos () == MATCH_YES)
+	return MATCH_YES;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+    }
+
+syntax:
+  gfc_error ("Syntax error in PROCEDURE statement at %C");
+  return MATCH_ERROR;
+}
+
+
+/* Match a GENERIC procedure binding inside a derived type.  */
+
+match
+gfc_match_generic (void)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  char bind_name[GFC_MAX_SYMBOL_LEN + 16]; /* Allow space for OPERATOR(...).  */
+  gfc_symbol* block;
+  gfc_typebound_proc tbattr; /* Used for match_binding_attributes.  */
+  gfc_typebound_proc* tb;
+  gfc_namespace* ns;
+  interface_type op_type;
+  gfc_intrinsic_op op;
+  match m;
+
+  /* Check current state.  */
+  if (gfc_current_state () == COMP_DERIVED)
+    {
+      gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
+      return MATCH_ERROR;
+    }
+  if (gfc_current_state () != COMP_DERIVED_CONTAINS)
+    return MATCH_NO;
+  block = gfc_state_stack->previous->sym;
+  ns = block->f2k_derived;
+  gcc_assert (block && ns);
+
+  memset (&tbattr, 0, sizeof (tbattr));
+  tbattr.where = gfc_current_locus;
+
+  /* See if we get an access-specifier.  */
+  m = match_binding_attributes (&tbattr, true, false);
+  if (m == MATCH_ERROR)
+    goto error;
+
+  /* Now the colons, those are required.  */
+  if (gfc_match (" ::") != MATCH_YES)
+    {
+      gfc_error ("Expected '::' at %C");
+      goto error;
+    }
+
+  /* Match the binding name; depending on type (operator / generic) format
+     it for future error messages into bind_name.  */
+
+  m = gfc_match_generic_spec (&op_type, name, &op);
+  if (m == MATCH_ERROR)
+    return MATCH_ERROR;
+  if (m == MATCH_NO)
+    {
+      gfc_error ("Expected generic name or operator descriptor at %C");
+      goto error;
+    }
+
+  switch (op_type)
+    {
+    case INTERFACE_GENERIC:
+      snprintf (bind_name, sizeof (bind_name), "%s", name);
+      break;
+
+    case INTERFACE_USER_OP:
+      snprintf (bind_name, sizeof (bind_name), "OPERATOR(.%s.)", name);
+      break;
+
+    case INTERFACE_INTRINSIC_OP:
+      snprintf (bind_name, sizeof (bind_name), "OPERATOR(%s)",
+		gfc_op2string (op));
+      break;
+
+    default:
+      gcc_unreachable ();
+    }
+
+  /* Match the required =>.  */
+  if (gfc_match (" =>") != MATCH_YES)
+    {
+      gfc_error ("Expected '=>' at %C");
+      goto error;
+    }
+
+  /* Try to find existing GENERIC binding with this name / for this operator;
+     if there is something, check that it is another GENERIC and then extend
+     it rather than building a new node.  Otherwise, create it and put it
+     at the right position.  */
+
+  switch (op_type)
+    {
+    case INTERFACE_USER_OP:
+    case INTERFACE_GENERIC:
+      {
+	const bool is_op = (op_type == INTERFACE_USER_OP);
+	gfc_symtree* st;
+
+	st = gfc_find_symtree (is_op ? ns->tb_uop_root : ns->tb_sym_root, name);
+	if (st)
+	  {
+	    tb = st->n.tb;
+	    gcc_assert (tb);
+	  }
+	else
+	  tb = NULL;
+
+	break;
+      }
+
+    case INTERFACE_INTRINSIC_OP:
+      tb = ns->tb_op[op];
+      break;
+
+    default:
+      gcc_unreachable ();
+    }
+
+  if (tb)
+    {
+      if (!tb->is_generic)
+	{
+	  gcc_assert (op_type == INTERFACE_GENERIC);
+	  gfc_error ("There's already a non-generic procedure with binding name"
+		     " '%s' for the derived type '%s' at %C",
+		     bind_name, block->name);
+	  goto error;
+	}
+
+      if (tb->access != tbattr.access)
+	{
+	  gfc_error ("Binding at %C must have the same access as already"
+		     " defined binding '%s'", bind_name);
+	  goto error;
+	}
+    }
+  else
+    {
+      tb = gfc_get_typebound_proc (NULL);
+      tb->where = gfc_current_locus;
+      tb->access = tbattr.access;
+      tb->is_generic = 1;
+      tb->u.generic = NULL;
+
+      switch (op_type)
+	{
+	case INTERFACE_GENERIC:
+	case INTERFACE_USER_OP:
+	  {
+	    const bool is_op = (op_type == INTERFACE_USER_OP);
+	    gfc_symtree* st;
+
+	    st = gfc_new_symtree (is_op ? &ns->tb_uop_root : &ns->tb_sym_root,
+				  name);
+	    gcc_assert (st);
+	    st->n.tb = tb;
+
+	    break;
+	  }
+
+	case INTERFACE_INTRINSIC_OP:
+	  ns->tb_op[op] = tb;
+	  break;
+
+	default:
+	  gcc_unreachable ();
+	}
+    }
+
+  /* Now, match all following names as specific targets.  */
+  do
+    {
+      gfc_symtree* target_st;
+      gfc_tbp_generic* target;
+
+      m = gfc_match_name (name);
+      if (m == MATCH_ERROR)
+	goto error;
+      if (m == MATCH_NO)
+	{
+	  gfc_error ("Expected specific binding name at %C");
+	  goto error;
+	}
+
+      target_st = gfc_get_tbp_symtree (&ns->tb_sym_root, name);
+
+      /* See if this is a duplicate specification.  */
+      for (target = tb->u.generic; target; target = target->next)
+	if (target_st == target->specific_st)
+	  {
+	    gfc_error ("'%s' already defined as specific binding for the"
+		       " generic '%s' at %C", name, bind_name);
+	    goto error;
+	  }
+
+      target = gfc_get_tbp_generic ();
+      target->specific_st = target_st;
+      target->specific = NULL;
+      target->next = tb->u.generic;
+      target->is_operator = ((op_type == INTERFACE_USER_OP)
+			     || (op_type == INTERFACE_INTRINSIC_OP));
+      tb->u.generic = target;
+    }
+  while (gfc_match (" ,") == MATCH_YES);
+
+  /* Here should be the end.  */
+  if (gfc_match_eos () != MATCH_YES)
+    {
+      gfc_error ("Junk after GENERIC binding at %C");
+      goto error;
+    }
+
+  return MATCH_YES;
+
+error:
+  return MATCH_ERROR;
+}
+
+
+/* Match a FINAL declaration inside a derived type.  */
+
+match
+gfc_match_final_decl (void)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_symbol* sym;
+  match m;
+  gfc_namespace* module_ns;
+  bool first, last;
+  gfc_symbol* block;
+
+  if (gfc_current_form == FORM_FREE)
+    {
+      char c = gfc_peek_ascii_char ();
+      if (!gfc_is_whitespace (c) && c != ':')
+	return MATCH_NO;
+    }
+
+  if (gfc_state_stack->state != COMP_DERIVED_CONTAINS)
+    {
+      if (gfc_current_form == FORM_FIXED)
+	return MATCH_NO;
+
+      gfc_error ("FINAL declaration at %C must be inside a derived type "
+		 "CONTAINS section");
+      return MATCH_ERROR;
+    }
+
+  block = gfc_state_stack->previous->sym;
+  gcc_assert (block);
+
+  if (!gfc_state_stack->previous || !gfc_state_stack->previous->previous
+      || gfc_state_stack->previous->previous->state != COMP_MODULE)
+    {
+      gfc_error ("Derived type declaration with FINAL at %C must be in the"
+		 " specification part of a MODULE");
+      return MATCH_ERROR;
+    }
+
+  module_ns = gfc_current_ns;
+  gcc_assert (module_ns);
+  gcc_assert (module_ns->proc_name->attr.flavor == FL_MODULE);
+
+  /* Match optional ::, don't care about MATCH_YES or MATCH_NO.  */
+  if (gfc_match (" ::") == MATCH_ERROR)
+    return MATCH_ERROR;
+
+  /* Match the sequence of procedure names.  */
+  first = true;
+  last = false;
+  do
+    {
+      gfc_finalizer* f;
+
+      if (first && gfc_match_eos () == MATCH_YES)
+	{
+	  gfc_error ("Empty FINAL at %C");
+	  return MATCH_ERROR;
+	}
+
+      m = gfc_match_name (name);
+      if (m == MATCH_NO)
+	{
+	  gfc_error ("Expected module procedure name at %C");
+	  return MATCH_ERROR;
+	}
+      else if (m != MATCH_YES)
+	return MATCH_ERROR;
+
+      if (gfc_match_eos () == MATCH_YES)
+	last = true;
+      if (!last && gfc_match_char (',') != MATCH_YES)
+	{
+	  gfc_error ("Expected ',' at %C");
+	  return MATCH_ERROR;
+	}
+
+      if (gfc_get_symbol (name, module_ns, &sym))
+	{
+	  gfc_error ("Unknown procedure name \"%s\" at %C", name);
+	  return MATCH_ERROR;
+	}
+
+      /* Mark the symbol as module procedure.  */
+      if (sym->attr.proc != PROC_MODULE
+	  && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
+	return MATCH_ERROR;
+
+      /* Check if we already have this symbol in the list, this is an error.  */
+      for (f = block->f2k_derived->finalizers; f; f = f->next)
+	if (f->proc_sym == sym)
+	  {
+	    gfc_error ("'%s' at %C is already defined as FINAL procedure!",
+		       name);
+	    return MATCH_ERROR;
+	  }
+
+      /* Add this symbol to the list of finalizers.  */
+      gcc_assert (block->f2k_derived);
+      ++sym->refs;
+      f = XCNEW (gfc_finalizer);
+      f->proc_sym = sym;
+      f->proc_tree = NULL;
+      f->where = gfc_current_locus;
+      f->next = block->f2k_derived->finalizers;
+      block->f2k_derived->finalizers = f;
+
+      first = false;
+    }
+  while (!last);
+
+  return MATCH_YES;
+}
+
+
+const ext_attr_t ext_attr_list[] = {
+  { "dllimport",    EXT_ATTR_DLLIMPORT,    "dllimport" },
+  { "dllexport",    EXT_ATTR_DLLEXPORT,    "dllexport" },
+  { "cdecl",        EXT_ATTR_CDECL,        "cdecl"     },
+  { "stdcall",      EXT_ATTR_STDCALL,      "stdcall"   },
+  { "fastcall",     EXT_ATTR_FASTCALL,     "fastcall"  },
+  { "no_arg_check", EXT_ATTR_NO_ARG_CHECK, NULL        },
+  { NULL,           EXT_ATTR_LAST,         NULL        }
+};
+
+/* Match a !GCC$ ATTRIBUTES statement of the form:
+      !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
+   When we come here, we have already matched the !GCC$ ATTRIBUTES string.
+
+   TODO: We should support all GCC attributes using the same syntax for
+   the attribute list, i.e. the list in C
+      __attributes(( attribute-list ))
+   matches then
+      !GCC$ ATTRIBUTES attribute-list ::
+   Cf. c-parser.c's c_parser_attributes; the data can then directly be
+   saved into a TREE.
+
+   As there is absolutely no risk of confusion, we should never return
+   MATCH_NO.  */
+match
+gfc_match_gcc_attributes (void)
+{
+  symbol_attribute attr;
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  unsigned id;
+  gfc_symbol *sym;
+  match m;
+
+  gfc_clear_attr (&attr);
+  for(;;)
+    {
+      char ch;
+
+      if (gfc_match_name (name) != MATCH_YES)
+	return MATCH_ERROR;
+
+      for (id = 0; id < EXT_ATTR_LAST; id++)
+	if (strcmp (name, ext_attr_list[id].name) == 0)
+	  break;
+
+      if (id == EXT_ATTR_LAST)
+	{
+	  gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
+	  return MATCH_ERROR;
+	}
+
+      if (!gfc_add_ext_attribute (&attr, (ext_attr_id_t)id, &gfc_current_locus))
+	return MATCH_ERROR;
+
+      gfc_gobble_whitespace ();
+      ch = gfc_next_ascii_char ();
+      if (ch == ':')
+        {
+          /* This is the successful exit condition for the loop.  */
+          if (gfc_next_ascii_char () == ':')
+            break;
+        }
+
+      if (ch == ',')
+	continue;
+
+      goto syntax;
+    }
+
+  if (gfc_match_eos () == MATCH_YES)
+    goto syntax;
+
+  for(;;)
+    {
+      m = gfc_match_name (name);
+      if (m != MATCH_YES)
+	return m;
+
+      if (find_special (name, &sym, true))
+	return MATCH_ERROR;
+
+      sym->attr.ext_attr |= attr.ext_attr;
+
+      if (gfc_match_eos () == MATCH_YES)
+	break;
+
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+    }
+
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
+  return MATCH_ERROR;
+}
diff --git a/gcc-4.9/gcc/fortran/dependency.c b/gcc-4.9/gcc/fortran/dependency.c
new file mode 100644
index 000000000..a24a4709e
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/dependency.c
@@ -0,0 +1,2195 @@
+/* Dependency analysis
+   Copyright (C) 2000-2014 Free Software Foundation, Inc.
+   Contributed by Paul Brook <paul@nowt.org>
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+/* dependency.c -- Expression dependency analysis code.  */
+/* There's probably quite a bit of duplication in this file.  We currently
+   have different dependency checking functions for different types
+   if dependencies.  Ideally these would probably be merged.  */
+   
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "gfortran.h"
+#include "dependency.h"
+#include "constructor.h"
+#include "arith.h"
+
+/* static declarations */
+/* Enums  */
+enum range {LHS, RHS, MID};
+
+/* Dependency types.  These must be in reverse order of priority.  */
+typedef enum
+{
+  GFC_DEP_ERROR,
+  GFC_DEP_EQUAL,	/* Identical Ranges.  */
+  GFC_DEP_FORWARD,	/* e.g., a(1:3) = a(2:4).  */
+  GFC_DEP_BACKWARD,	/* e.g. a(2:4) = a(1:3).  */
+  GFC_DEP_OVERLAP,	/* May overlap in some other way.  */
+  GFC_DEP_NODEP		/* Distinct ranges.  */
+}
+gfc_dependency;
+
+/* Macros */
+#define IS_ARRAY_EXPLICIT(as) ((as->type == AS_EXPLICIT ? 1 : 0))
+
+/* Forward declarations */
+
+static gfc_dependency check_section_vs_section (gfc_array_ref *,
+						gfc_array_ref *, int);
+
+/* Returns 1 if the expr is an integer constant value 1, 0 if it is not or
+   def if the value could not be determined.  */
+
+int
+gfc_expr_is_one (gfc_expr *expr, int def)
+{
+  gcc_assert (expr != NULL);
+
+  if (expr->expr_type != EXPR_CONSTANT)
+    return def;
+
+  if (expr->ts.type != BT_INTEGER)
+    return def;
+
+  return mpz_cmp_si (expr->value.integer, 1) == 0;
+}
+
+/* Check if two array references are known to be identical.  Calls
+   gfc_dep_compare_expr if necessary for comparing array indices.  */
+
+static bool
+identical_array_ref (gfc_array_ref *a1, gfc_array_ref *a2)
+{
+  int i;
+
+  if (a1->type == AR_FULL && a2->type == AR_FULL)
+    return true;
+
+  if (a1->type == AR_SECTION && a2->type == AR_SECTION)
+    {
+      gcc_assert (a1->dimen == a2->dimen);
+
+      for ( i = 0; i < a1->dimen; i++)
+	{
+	  /* TODO: Currently, we punt on an integer array as an index.  */
+	  if (a1->dimen_type[i] != DIMEN_RANGE
+	      || a2->dimen_type[i] != DIMEN_RANGE)
+	    return false;
+
+	  if (check_section_vs_section (a1, a2, i) != GFC_DEP_EQUAL)
+	    return false;
+	}
+      return true;
+    }
+
+  if (a1->type == AR_ELEMENT && a2->type == AR_ELEMENT)
+    {
+      gcc_assert (a1->dimen == a2->dimen);
+      for (i = 0; i < a1->dimen; i++)
+	{
+	  if (gfc_dep_compare_expr (a1->start[i], a2->start[i]) != 0)
+	    return false;
+	}
+      return true;
+    }
+  return false;
+}
+
+
+
+/* Return true for identical variables, checking for references if
+   necessary.  Calls identical_array_ref for checking array sections.  */
+
+static bool
+are_identical_variables (gfc_expr *e1, gfc_expr *e2)
+{
+  gfc_ref *r1, *r2;
+
+  if (e1->symtree->n.sym->attr.dummy && e2->symtree->n.sym->attr.dummy)
+    {
+      /* Dummy arguments: Only check for equal names.  */
+      if (e1->symtree->n.sym->name != e2->symtree->n.sym->name)
+	return false;
+    }
+  else
+    {
+      /* Check for equal symbols.  */
+      if (e1->symtree->n.sym != e2->symtree->n.sym)
+	return false;
+    }
+
+  /* Volatile variables should never compare equal to themselves.  */
+
+  if (e1->symtree->n.sym->attr.volatile_)
+    return false;
+
+  r1 = e1->ref;
+  r2 = e2->ref;
+
+  while (r1 != NULL || r2 != NULL)
+    {
+
+      /* Assume the variables are not equal if one has a reference and the
+	 other doesn't.
+	 TODO: Handle full references like comparing a(:) to a.
+      */
+
+      if (r1 == NULL || r2 == NULL)
+	return false;
+
+      if (r1->type != r2->type)
+	return false;
+
+      switch (r1->type)
+	{
+
+	case REF_ARRAY:
+	  if (!identical_array_ref (&r1->u.ar,  &r2->u.ar))
+	    return false;
+
+	  break;
+
+	case REF_COMPONENT:
+	  if (r1->u.c.component != r2->u.c.component)
+	    return false;
+	  break;
+
+	case REF_SUBSTRING:
+	  if (gfc_dep_compare_expr (r1->u.ss.start, r2->u.ss.start) != 0)
+	    return false;
+
+	  /* If both are NULL, the end length compares equal, because we
+	     are looking at the same variable. This can only happen for
+	     assumed- or deferred-length character arguments.  */ 
+
+	  if (r1->u.ss.end == NULL && r2->u.ss.end == NULL)
+	    break;
+
+	  if (gfc_dep_compare_expr (r1->u.ss.end, r2->u.ss.end) != 0)
+	    return false;
+	  
+	  break;
+
+	default:
+	  gfc_internal_error ("are_identical_variables: Bad type");
+	}
+      r1 = r1->next;
+      r2 = r2->next;
+    }
+  return true;
+}
+
+/* Compare two functions for equality.  Returns 0 if e1==e2, -2 otherwise.  If
+   impure_ok is false, only return 0 for pure functions.  */
+
+int
+gfc_dep_compare_functions (gfc_expr *e1, gfc_expr *e2, bool impure_ok)
+{
+
+  gfc_actual_arglist *args1;
+  gfc_actual_arglist *args2;
+  
+  if (e1->expr_type != EXPR_FUNCTION || e2->expr_type != EXPR_FUNCTION)
+    return -2;
+
+  if ((e1->value.function.esym && e2->value.function.esym
+       && e1->value.function.esym == e2->value.function.esym
+       && (e1->value.function.esym->result->attr.pure || impure_ok))
+       || (e1->value.function.isym && e2->value.function.isym
+	   && e1->value.function.isym == e2->value.function.isym
+	   && (e1->value.function.isym->pure || impure_ok)))
+    {
+      args1 = e1->value.function.actual;
+      args2 = e2->value.function.actual;
+
+      /* Compare the argument lists for equality.  */
+      while (args1 && args2)
+	{
+	  /*  Bitwise xor, since C has no non-bitwise xor operator.  */
+	  if ((args1->expr == NULL) ^ (args2->expr == NULL))
+	    return -2;
+	  
+	  if (args1->expr != NULL && args2->expr != NULL
+	      && gfc_dep_compare_expr (args1->expr, args2->expr) != 0)
+	    return -2;
+	  
+	  args1 = args1->next;
+	  args2 = args2->next;
+	}
+      return (args1 || args2) ? -2 : 0;
+    }
+      else
+	return -2;      
+}
+
+/* Helper function to look through parens, unary plus and widening
+   integer conversions.  */
+
+static gfc_expr*
+discard_nops (gfc_expr *e)
+{
+  gfc_actual_arglist *arglist;
+
+  if (e == NULL)
+    return NULL;
+
+  while (true)
+    {
+      if (e->expr_type == EXPR_OP
+	  && (e->value.op.op == INTRINSIC_UPLUS
+	      || e->value.op.op == INTRINSIC_PARENTHESES))
+	{
+	  e = e->value.op.op1;
+	  continue;
+	}
+
+      if (e->expr_type == EXPR_FUNCTION && e->value.function.isym
+	  && e->value.function.isym->id == GFC_ISYM_CONVERSION
+	  && e->ts.type == BT_INTEGER)
+	{
+	  arglist = e->value.function.actual;
+	  if (arglist->expr->ts.type == BT_INTEGER
+	      && e->ts.kind > arglist->expr->ts.kind)
+	    {
+	      e = arglist->expr;
+	      continue;
+	    }
+	}
+      break;
+    }
+
+  return e;
+}
+
+
+/* Compare two expressions.  Return values:
+   * +1 if e1 > e2
+   * 0 if e1 == e2
+   * -1 if e1 < e2
+   * -2 if the relationship could not be determined
+   * -3 if e1 /= e2, but we cannot tell which one is larger.
+   REAL and COMPLEX constants are only compared for equality
+   or inequality; if they are unequal, -2 is returned in all cases.  */
+
+int
+gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
+{
+  int i;
+
+  if (e1 == NULL && e2 == NULL)
+    return 0;
+
+  e1 = discard_nops (e1);
+  e2 = discard_nops (e2);
+
+  if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS)
+    {
+      /* Compare X+C vs. X, for INTEGER only.  */
+      if (e1->value.op.op2->expr_type == EXPR_CONSTANT
+	  && e1->value.op.op2->ts.type == BT_INTEGER
+	  && gfc_dep_compare_expr (e1->value.op.op1, e2) == 0)
+	return mpz_sgn (e1->value.op.op2->value.integer);
+
+      /* Compare P+Q vs. R+S.  */
+      if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
+	{
+	  int l, r;
+
+	  l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
+	  r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
+	  if (l == 0 && r == 0)
+	    return 0;
+	  if (l == 0 && r > -2)
+	    return r;
+	  if (l > -2 && r == 0)
+	    return l;
+	  if (l == 1 && r == 1)
+	    return 1;
+	  if (l == -1 && r == -1)
+	    return -1;
+
+	  l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op2);
+	  r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op1);
+	  if (l == 0 && r == 0)
+	    return 0;
+	  if (l == 0 && r > -2)
+	    return r;
+	  if (l > -2 && r == 0)
+	    return l;
+	  if (l == 1 && r == 1)
+	    return 1;
+	  if (l == -1 && r == -1)
+	    return -1;
+	}
+    }
+
+  /* Compare X vs. X+C, for INTEGER only.  */
+  if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
+    {
+      if (e2->value.op.op2->expr_type == EXPR_CONSTANT
+	  && e2->value.op.op2->ts.type == BT_INTEGER
+	  && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0)
+	return -mpz_sgn (e2->value.op.op2->value.integer);
+    }
+
+  /* Compare X-C vs. X, for INTEGER only.  */
+  if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS)
+    {
+      if (e1->value.op.op2->expr_type == EXPR_CONSTANT
+	  && e1->value.op.op2->ts.type == BT_INTEGER
+	  && gfc_dep_compare_expr (e1->value.op.op1, e2) == 0)
+	return -mpz_sgn (e1->value.op.op2->value.integer);
+
+      /* Compare P-Q vs. R-S.  */
+      if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
+	{
+	  int l, r;
+
+	  l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
+	  r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
+	  if (l == 0 && r == 0)
+	    return 0;
+	  if (l > -2 && r == 0)
+	    return l;
+	  if (l == 0 && r > -2)
+	    return -r;
+	  if (l == 1 && r == -1)
+	    return 1;
+	  if (l == -1 && r == 1)
+	    return -1;
+	}
+    }
+
+  /* Compare A // B vs. C // D.  */
+
+  if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_CONCAT
+      && e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_CONCAT)
+    {
+      int l, r;
+
+      l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
+      r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
+
+      if (l != 0)
+	return l;
+
+      /* Left expressions of // compare equal, but
+	 watch out for 'A ' // x vs. 'A' // x.  */
+      gfc_expr *e1_left = e1->value.op.op1;
+      gfc_expr *e2_left = e2->value.op.op1;
+
+      if (e1_left->expr_type == EXPR_CONSTANT
+	  && e2_left->expr_type == EXPR_CONSTANT
+	  && e1_left->value.character.length
+	  != e2_left->value.character.length)
+	return -2;
+      else
+	return r;
+    }
+
+  /* Compare X vs. X-C, for INTEGER only.  */
+  if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
+    {
+      if (e2->value.op.op2->expr_type == EXPR_CONSTANT
+	  && e2->value.op.op2->ts.type == BT_INTEGER
+	  && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0)
+	return mpz_sgn (e2->value.op.op2->value.integer);
+    }
+
+  if (e1->expr_type != e2->expr_type)
+    return -3;
+
+  switch (e1->expr_type)
+    {
+    case EXPR_CONSTANT:
+      /* Compare strings for equality.  */
+      if (e1->ts.type == BT_CHARACTER && e2->ts.type == BT_CHARACTER)
+	return gfc_compare_string (e1, e2);
+
+      /* Compare REAL and COMPLEX constants.  Because of the
+	 traps and pitfalls associated with comparing
+	 a + 1.0 with a + 0.5, check for equality only.  */
+      if (e2->expr_type == EXPR_CONSTANT)
+	{
+	  if (e1->ts.type == BT_REAL && e2->ts.type == BT_REAL)
+	    {
+	      if (mpfr_cmp (e1->value.real, e2->value.real) == 0)
+		return 0;
+	      else
+		return -2;
+	    }
+	  else if (e1->ts.type == BT_COMPLEX && e2->ts.type == BT_COMPLEX)
+	    {
+	      if (mpc_cmp (e1->value.complex, e2->value.complex) == 0)
+		return 0;
+	      else
+		return -2;
+	    }
+	}
+
+      if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER)
+	return -2;
+
+      /* For INTEGER, all cases where e2 is not constant should have
+	 been filtered out above.  */
+      gcc_assert (e2->expr_type == EXPR_CONSTANT);
+
+      i = mpz_cmp (e1->value.integer, e2->value.integer);
+      if (i == 0)
+	return 0;
+      else if (i < 0)
+	return -1;
+      return 1;
+
+    case EXPR_VARIABLE:
+      if (are_identical_variables (e1, e2))
+	return 0;
+      else
+	return -3;
+
+    case EXPR_OP:
+      /* Intrinsic operators are the same if their operands are the same.  */
+      if (e1->value.op.op != e2->value.op.op)
+	return -2;
+      if (e1->value.op.op2 == 0)
+	{
+	  i = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
+	  return i == 0 ? 0 : -2;
+	}
+      if (gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1) == 0
+	  && gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2) == 0)
+	return 0;
+      else if (e1->value.op.op == INTRINSIC_TIMES
+	       && gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op2) == 0
+	       && gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op1) == 0)
+	/* Commutativity of multiplication; addition is handled above.  */
+	return 0;
+
+      return -2;
+
+    case EXPR_FUNCTION:
+      return gfc_dep_compare_functions (e1, e2, false);
+      break;
+
+    default:
+      return -2;
+    }
+}
+
+
+/* Return the difference between two expressions.  Integer expressions of
+   the form 
+
+   X + constant, X - constant and constant + X
+
+   are handled.  Return true on success, false on failure. result is assumed
+   to be uninitialized on entry, and will be initialized on success.
+*/
+
+bool
+gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result)
+{
+  gfc_expr *e1_op1, *e1_op2, *e2_op1, *e2_op2;
+
+  if (e1 == NULL || e2 == NULL)
+    return false;
+
+  if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER)
+    return false;
+
+  e1 = discard_nops (e1);
+  e2 = discard_nops (e2);
+
+  /* Inizialize tentatively, clear if we don't return anything.  */
+  mpz_init (*result);
+
+  /* Case 1: c1 - c2 = c1 - c2, trivially.  */
+
+  if (e1->expr_type == EXPR_CONSTANT && e2->expr_type == EXPR_CONSTANT)
+    {
+      mpz_sub (*result, e1->value.integer, e2->value.integer);
+      return true;
+    }
+
+  if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS)
+    {
+      e1_op1 = discard_nops (e1->value.op.op1);
+      e1_op2 = discard_nops (e1->value.op.op2);
+
+      /* Case 2: (X + c1) - X = c1.  */
+      if (e1_op2->expr_type == EXPR_CONSTANT
+	  && gfc_dep_compare_expr (e1_op1, e2) == 0)
+	{
+	  mpz_set (*result, e1_op2->value.integer);
+	  return true;
+	}
+
+      /* Case 3: (c1 + X) - X = c1. */
+      if (e1_op1->expr_type == EXPR_CONSTANT
+	  && gfc_dep_compare_expr (e1_op2, e2) == 0)
+	{
+	  mpz_set (*result, e1_op1->value.integer);
+	  return true;
+	}
+
+      if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
+	{
+	  e2_op1 = discard_nops (e2->value.op.op1);
+	  e2_op2 = discard_nops (e2->value.op.op2);
+
+	  if (e1_op2->expr_type == EXPR_CONSTANT)
+	    {
+	      /* Case 4: X + c1 - (X + c2) = c1 - c2.  */
+	      if (e2_op2->expr_type == EXPR_CONSTANT
+		  && gfc_dep_compare_expr (e1_op1, e2_op1) == 0)
+		{
+		  mpz_sub (*result, e1_op2->value.integer,
+			   e2_op2->value.integer);
+		  return true;
+		}
+	      /* Case 5: X + c1 - (c2 + X) = c1 - c2.  */
+	      if (e2_op1->expr_type == EXPR_CONSTANT
+		  && gfc_dep_compare_expr (e1_op1, e2_op2) == 0)
+		{
+		  mpz_sub (*result, e1_op2->value.integer,
+			   e2_op1->value.integer);
+		  return true;
+		}
+	    }
+	  else if (e1_op1->expr_type == EXPR_CONSTANT)
+	    {
+	      /* Case 6: c1 + X - (X + c2) = c1 - c2.  */
+	      if (e2_op2->expr_type == EXPR_CONSTANT
+		  && gfc_dep_compare_expr (e1_op2, e2_op1) == 0)
+		{
+		  mpz_sub (*result, e1_op1->value.integer,
+			   e2_op2->value.integer);
+		  return true;
+		}
+	      /* Case 7: c1 + X - (c2 + X) = c1 - c2.  */
+	      if (e2_op1->expr_type == EXPR_CONSTANT
+		  && gfc_dep_compare_expr (e1_op2, e2_op2) == 0)
+		{
+		  mpz_sub (*result, e1_op1->value.integer,
+			   e2_op1->value.integer);
+		  return true;
+		}
+	    }
+	}
+
+      if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
+	{
+	  e2_op1 = discard_nops (e2->value.op.op1);
+	  e2_op2 = discard_nops (e2->value.op.op2);
+
+	  if (e1_op2->expr_type == EXPR_CONSTANT)
+	    {
+	      /* Case 8: X + c1 - (X - c2) = c1 + c2.  */
+	      if (e2_op2->expr_type == EXPR_CONSTANT
+		  && gfc_dep_compare_expr (e1_op1, e2_op1) == 0)
+		{
+		  mpz_add (*result, e1_op2->value.integer,
+			   e2_op2->value.integer);
+		  return true;
+		}
+	    }
+	  if (e1_op1->expr_type == EXPR_CONSTANT)
+	    {
+	      /* Case 9: c1 + X - (X - c2) = c1 + c2.  */
+	      if (e2_op2->expr_type == EXPR_CONSTANT
+		  && gfc_dep_compare_expr (e1_op2, e2_op1) == 0)
+		{
+		  mpz_add (*result, e1_op1->value.integer,
+			   e2_op2->value.integer);
+		  return true;
+		}
+	    }
+	}
+    }
+
+  if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS)
+    {
+      e1_op1 = discard_nops (e1->value.op.op1);
+      e1_op2 = discard_nops (e1->value.op.op2);
+
+      if (e1_op2->expr_type == EXPR_CONSTANT)
+	{
+	  /* Case 10: (X - c1) - X = -c1  */
+
+	  if (gfc_dep_compare_expr (e1_op1, e2) == 0)
+	    {
+	      mpz_neg (*result, e1_op2->value.integer);
+	      return true;
+	    }
+
+	  if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
+	    {
+	      e2_op1 = discard_nops (e2->value.op.op1);
+	      e2_op2 = discard_nops (e2->value.op.op2);
+
+	      /* Case 11: (X - c1) - (X + c2) = -( c1 + c2).  */
+	      if (e2_op2->expr_type == EXPR_CONSTANT
+		  && gfc_dep_compare_expr (e1_op1, e2_op1) == 0)
+		{
+		  mpz_add (*result, e1_op2->value.integer,
+			   e2_op2->value.integer);
+		  mpz_neg (*result, *result);
+		  return true;
+		}
+
+	      /* Case 12: X - c1 - (c2 + X) = - (c1 + c2).  */
+	      if (e2_op1->expr_type == EXPR_CONSTANT
+		  && gfc_dep_compare_expr (e1_op1, e2_op2) == 0)
+		{
+		  mpz_add (*result, e1_op2->value.integer,
+			   e2_op1->value.integer);
+		  mpz_neg (*result, *result);
+		  return true;
+		}
+	    }
+
+	  if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
+	    {
+	      e2_op1 = discard_nops (e2->value.op.op1);
+	      e2_op2 = discard_nops (e2->value.op.op2);
+
+	      /* Case 13: (X - c1) - (X - c2) = c2 - c1.  */
+	      if (e2_op2->expr_type == EXPR_CONSTANT
+		  && gfc_dep_compare_expr (e1_op1, e2_op1) == 0)
+		{
+		  mpz_sub (*result, e2_op2->value.integer,
+			   e1_op2->value.integer);
+		  return true;
+		}
+	    }
+	}
+      if (e1_op1->expr_type == EXPR_CONSTANT)
+	{
+	  if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
+	    {
+	      e2_op1 = discard_nops (e2->value.op.op1);
+	      e2_op2 = discard_nops (e2->value.op.op2);
+	      
+	      /* Case 14: (c1 - X) - (c2 - X) == c1 - c2.  */
+	      if (gfc_dep_compare_expr (e1_op2, e2_op2) == 0)
+		{
+		  mpz_sub (*result, e1_op1->value.integer,
+			   e2_op1->value.integer);
+		    return true;
+		}
+	    }
+
+	}
+    }
+
+  if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
+    {
+      e2_op1 = discard_nops (e2->value.op.op1);
+      e2_op2 = discard_nops (e2->value.op.op2);
+
+      /* Case 15: X - (X + c2) = -c2.  */
+      if (e2_op2->expr_type == EXPR_CONSTANT
+	  && gfc_dep_compare_expr (e1, e2_op1) == 0)
+	{
+	  mpz_neg (*result, e2_op2->value.integer);
+	  return true;
+	}
+      /* Case 16: X - (c2 + X) = -c2.  */
+      if (e2_op1->expr_type == EXPR_CONSTANT
+	  && gfc_dep_compare_expr (e1, e2_op2) == 0)
+	{
+	  mpz_neg (*result, e2_op1->value.integer);
+	  return true;
+	}
+    }
+
+  if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
+    {
+      e2_op1 = discard_nops (e2->value.op.op1);
+      e2_op2 = discard_nops (e2->value.op.op2);
+
+      /* Case 17: X - (X - c2) = c2.  */
+      if (e2_op2->expr_type == EXPR_CONSTANT
+	  && gfc_dep_compare_expr (e1, e2_op1) == 0)
+	{
+	  mpz_set (*result, e2_op2->value.integer);
+	  return true;
+	}
+    }
+
+  if (gfc_dep_compare_expr (e1, e2) == 0)
+    {
+      /* Case 18: X - X = 0.  */
+      mpz_set_si (*result, 0);
+      return true;
+    }
+
+  mpz_clear (*result);
+  return false;
+}
+
+/* Returns 1 if the two ranges are the same and 0 if they are not (or if the
+   results are indeterminate). 'n' is the dimension to compare.  */
+
+static int
+is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n)
+{
+  gfc_expr *e1;
+  gfc_expr *e2;
+  int i;
+
+  /* TODO: More sophisticated range comparison.  */
+  gcc_assert (ar1 && ar2);
+
+  gcc_assert (ar1->dimen_type[n] == ar2->dimen_type[n]);
+
+  e1 = ar1->stride[n];
+  e2 = ar2->stride[n];
+  /* Check for mismatching strides.  A NULL stride means a stride of 1.  */
+  if (e1 && !e2)
+    {
+      i = gfc_expr_is_one (e1, -1);
+      if (i == -1 || i == 0)
+	return 0;
+    }
+  else if (e2 && !e1)
+    {
+      i = gfc_expr_is_one (e2, -1);
+      if (i == -1 || i == 0)
+	return 0;
+    }
+  else if (e1 && e2)
+    {
+      i = gfc_dep_compare_expr (e1, e2);
+      if (i != 0)
+	return 0;
+    }
+  /* The strides match.  */
+
+  /* Check the range start.  */
+  e1 = ar1->start[n];
+  e2 = ar2->start[n];
+  if (e1 || e2)
+    {
+      /* Use the bound of the array if no bound is specified.  */
+      if (ar1->as && !e1)
+	e1 = ar1->as->lower[n];
+
+      if (ar2->as && !e2)
+	e2 = ar2->as->lower[n];
+
+      /* Check we have values for both.  */
+      if (!(e1 && e2))
+	return 0;
+
+      i = gfc_dep_compare_expr (e1, e2);
+      if (i != 0)
+	return 0;
+    }
+
+  /* Check the range end.  */
+  e1 = ar1->end[n];
+  e2 = ar2->end[n];
+  if (e1 || e2)
+    {
+      /* Use the bound of the array if no bound is specified.  */
+      if (ar1->as && !e1)
+	e1 = ar1->as->upper[n];
+
+      if (ar2->as && !e2)
+	e2 = ar2->as->upper[n];
+
+      /* Check we have values for both.  */
+      if (!(e1 && e2))
+	return 0;
+
+      i = gfc_dep_compare_expr (e1, e2);
+      if (i != 0)
+	return 0;
+    }
+
+  return 1;
+}
+
+
+/* Some array-returning intrinsics can be implemented by reusing the
+   data from one of the array arguments.  For example, TRANSPOSE does
+   not necessarily need to allocate new data: it can be implemented
+   by copying the original array's descriptor and simply swapping the
+   two dimension specifications.
+
+   If EXPR is a call to such an intrinsic, return the argument
+   whose data can be reused, otherwise return NULL.  */
+
+gfc_expr *
+gfc_get_noncopying_intrinsic_argument (gfc_expr *expr)
+{
+  if (expr->expr_type != EXPR_FUNCTION || !expr->value.function.isym)
+    return NULL;
+
+  switch (expr->value.function.isym->id)
+    {
+    case GFC_ISYM_TRANSPOSE:
+      return expr->value.function.actual->expr;
+
+    default:
+      return NULL;
+    }
+}
+
+
+/* Return true if the result of reference REF can only be constructed
+   using a temporary array.  */
+
+bool
+gfc_ref_needs_temporary_p (gfc_ref *ref)
+{
+  int n;
+  bool subarray_p;
+
+  subarray_p = false;
+  for (; ref; ref = ref->next)
+    switch (ref->type)
+      {
+      case REF_ARRAY:
+	/* Vector dimensions are generally not monotonic and must be
+	   handled using a temporary.  */
+	if (ref->u.ar.type == AR_SECTION)
+	  for (n = 0; n < ref->u.ar.dimen; n++)
+	    if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
+	      return true;
+
+	subarray_p = true;
+	break;
+
+      case REF_SUBSTRING:
+	/* Within an array reference, character substrings generally
+	   need a temporary.  Character array strides are expressed as
+	   multiples of the element size (consistent with other array
+	   types), not in characters.  */
+	return subarray_p;
+
+      case REF_COMPONENT:
+	break;
+      }
+
+  return false;
+}
+
+
+static int
+gfc_is_data_pointer (gfc_expr *e)
+{
+  gfc_ref *ref;
+
+  if (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION)
+    return 0;
+
+  /* No subreference if it is a function  */
+  gcc_assert (e->expr_type == EXPR_VARIABLE || !e->ref);
+
+  if (e->symtree->n.sym->attr.pointer)
+    return 1;
+
+  for (ref = e->ref; ref; ref = ref->next)
+    if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
+      return 1;
+
+  return 0;
+}
+
+
+/* Return true if array variable VAR could be passed to the same function
+   as argument EXPR without interfering with EXPR.  INTENT is the intent
+   of VAR.
+
+   This is considerably less conservative than other dependencies
+   because many function arguments will already be copied into a
+   temporary.  */
+
+static int
+gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent,
+				   gfc_expr *expr, gfc_dep_check elemental)
+{
+  gfc_expr *arg;
+
+  gcc_assert (var->expr_type == EXPR_VARIABLE);
+  gcc_assert (var->rank > 0);
+
+  switch (expr->expr_type)
+    {
+    case EXPR_VARIABLE:
+      /* In case of elemental subroutines, there is no dependency 
+         between two same-range array references.  */
+      if (gfc_ref_needs_temporary_p (expr->ref)
+	  || gfc_check_dependency (var, expr, elemental == NOT_ELEMENTAL))
+	{
+	  if (elemental == ELEM_DONT_CHECK_VARIABLE)
+	    {
+	      /* Too many false positive with pointers.  */
+	      if (!gfc_is_data_pointer (var) && !gfc_is_data_pointer (expr))
+		{
+		  /* Elemental procedures forbid unspecified intents, 
+		     and we don't check dependencies for INTENT_IN args.  */
+		  gcc_assert (intent == INTENT_OUT || intent == INTENT_INOUT);
+
+		  /* We are told not to check dependencies. 
+		     We do it, however, and issue a warning in case we find one.
+		     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 ("INTENT(%s) actual argument at %L might "
+			       "interfere with actual argument at %L.", 
+		   	       intent == INTENT_OUT ? "OUT" : "INOUT", 
+		   	       &var->where, &expr->where);
+		}
+	      return 0;
+	    }
+	  else
+	    return 1; 
+	}
+      return 0;
+
+    case EXPR_ARRAY:
+      /* the scalarizer always generates a temporary for array constructors,
+	 so there is no dependency.  */
+      return 0;
+
+    case EXPR_FUNCTION:
+      if (intent != INTENT_IN)
+	{
+	  arg = gfc_get_noncopying_intrinsic_argument (expr);
+	  if (arg != NULL)
+	    return gfc_check_argument_var_dependency (var, intent, arg,
+						      NOT_ELEMENTAL);
+	}
+
+      if (elemental != NOT_ELEMENTAL)
+	{
+	  if ((expr->value.function.esym
+	       && expr->value.function.esym->attr.elemental)
+	      || (expr->value.function.isym
+		  && expr->value.function.isym->elemental))
+	    return gfc_check_fncall_dependency (var, intent, NULL,
+						expr->value.function.actual,
+						ELEM_CHECK_VARIABLE);
+
+	  if (gfc_inline_intrinsic_function_p (expr))
+	    {
+	      /* The TRANSPOSE case should have been caught in the
+		 noncopying intrinsic case above.  */
+	      gcc_assert (expr->value.function.isym->id != GFC_ISYM_TRANSPOSE);
+
+	      return gfc_check_fncall_dependency (var, intent, NULL,
+						  expr->value.function.actual,
+						  ELEM_CHECK_VARIABLE);
+	    }
+	}
+      return 0;
+
+    case EXPR_OP:
+      /* In case of non-elemental procedures, there is no need to catch
+	 dependencies, as we will make a temporary anyway.  */
+      if (elemental)
+	{
+	  /* If the actual arg EXPR is an expression, we need to catch 
+	     a dependency between variables in EXPR and VAR, 
+	     an intent((IN)OUT) variable.  */
+	  if (expr->value.op.op1
+	      && gfc_check_argument_var_dependency (var, intent, 
+						    expr->value.op.op1, 
+						    ELEM_CHECK_VARIABLE))
+	    return 1;
+	  else if (expr->value.op.op2
+		   && gfc_check_argument_var_dependency (var, intent, 
+							 expr->value.op.op2, 
+							 ELEM_CHECK_VARIABLE))
+	    return 1;
+	}
+      return 0;
+
+    default:
+      return 0;
+    }
+}
+  
+  
+/* Like gfc_check_argument_var_dependency, but extended to any
+   array expression OTHER, not just variables.  */
+
+static int
+gfc_check_argument_dependency (gfc_expr *other, sym_intent intent,
+			       gfc_expr *expr, gfc_dep_check elemental)
+{
+  switch (other->expr_type)
+    {
+    case EXPR_VARIABLE:
+      return gfc_check_argument_var_dependency (other, intent, expr, elemental);
+
+    case EXPR_FUNCTION:
+      other = gfc_get_noncopying_intrinsic_argument (other);
+      if (other != NULL)
+	return gfc_check_argument_dependency (other, INTENT_IN, expr,
+					      NOT_ELEMENTAL);
+
+      return 0;
+
+    default:
+      return 0;
+    }
+}
+
+
+/* Like gfc_check_argument_dependency, but check all the arguments in ACTUAL.
+   FNSYM is the function being called, or NULL if not known.  */
+
+int
+gfc_check_fncall_dependency (gfc_expr *other, sym_intent intent,
+			     gfc_symbol *fnsym, gfc_actual_arglist *actual,
+			     gfc_dep_check elemental)
+{
+  gfc_formal_arglist *formal;
+  gfc_expr *expr;
+
+  formal = fnsym ? gfc_sym_get_dummy_args (fnsym) : NULL;
+  for (; actual; actual = actual->next, formal = formal ? formal->next : NULL)
+    {
+      expr = actual->expr;
+
+      /* Skip args which are not present.  */
+      if (!expr)
+	continue;
+
+      /* Skip other itself.  */
+      if (expr == other)
+	continue;
+
+      /* Skip intent(in) arguments if OTHER itself is intent(in).  */
+      if (formal && intent == INTENT_IN
+	  && formal->sym->attr.intent == INTENT_IN)
+	continue;
+
+      if (gfc_check_argument_dependency (other, intent, expr, elemental))
+	return 1;
+    }
+
+  return 0;
+}
+
+
+/* Return 1 if e1 and e2 are equivalenced arrays, either
+   directly or indirectly; i.e., equivalence (a,b) for a and b
+   or equivalence (a,c),(b,c).  This function uses the equiv_
+   lists, generated in trans-common(add_equivalences), that are
+   guaranteed to pick up indirect equivalences.  We explicitly
+   check for overlap using the offset and length of the equivalence.
+   This function is symmetric.
+   TODO: This function only checks whether the full top-level
+   symbols overlap.  An improved implementation could inspect
+   e1->ref and e2->ref to determine whether the actually accessed
+   portions of these variables/arrays potentially overlap.  */
+
+int
+gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2)
+{
+  gfc_equiv_list *l;
+  gfc_equiv_info *s, *fl1, *fl2;
+
+  gcc_assert (e1->expr_type == EXPR_VARIABLE
+	      && e2->expr_type == EXPR_VARIABLE);
+
+  if (!e1->symtree->n.sym->attr.in_equivalence
+      || !e2->symtree->n.sym->attr.in_equivalence|| !e1->rank || !e2->rank)
+    return 0;
+
+  if (e1->symtree->n.sym->ns
+	&& e1->symtree->n.sym->ns != gfc_current_ns)
+    l = e1->symtree->n.sym->ns->equiv_lists;
+  else
+    l = gfc_current_ns->equiv_lists;
+
+  /* Go through the equiv_lists and return 1 if the variables
+     e1 and e2 are members of the same group and satisfy the
+     requirement on their relative offsets.  */
+  for (; l; l = l->next)
+    {
+      fl1 = NULL;
+      fl2 = NULL;
+      for (s = l->equiv; s; s = s->next)
+	{
+	  if (s->sym == e1->symtree->n.sym)
+	    {
+	      fl1 = s;
+	      if (fl2)
+		break;
+	    }
+	  if (s->sym == e2->symtree->n.sym)
+	    {
+	      fl2 = s;
+	      if (fl1)
+		break;
+	    }
+	}
+
+      if (s)
+	{
+	  /* Can these lengths be zero?  */
+	  if (fl1->length <= 0 || fl2->length <= 0)
+	    return 1;
+	  /* These can't overlap if [f11,fl1+length] is before 
+	     [fl2,fl2+length], or [fl2,fl2+length] is before
+	     [fl1,fl1+length], otherwise they do overlap.  */
+	  if (fl1->offset + fl1->length > fl2->offset
+	      && fl2->offset + fl2->length > fl1->offset)
+	    return 1;
+	}
+    }
+  return 0;
+}
+
+
+/* Return true if there is no possibility of aliasing because of a type
+   mismatch between all the possible pointer references and the
+   potential target.  Note that this function is asymmetric in the
+   arguments and so must be called twice with the arguments exchanged.  */
+
+static bool
+check_data_pointer_types (gfc_expr *expr1, gfc_expr *expr2)
+{
+  gfc_component *cm1;
+  gfc_symbol *sym1;
+  gfc_symbol *sym2;
+  gfc_ref *ref1;
+  bool seen_component_ref;
+
+  if (expr1->expr_type != EXPR_VARIABLE
+	|| expr2->expr_type != EXPR_VARIABLE)
+    return false;
+
+  sym1 = expr1->symtree->n.sym;
+  sym2 = expr2->symtree->n.sym;
+
+  /* Keep it simple for now.  */
+  if (sym1->ts.type == BT_DERIVED && sym2->ts.type == BT_DERIVED)
+    return false;
+
+  if (sym1->attr.pointer)
+    {
+      if (gfc_compare_types (&sym1->ts, &sym2->ts))
+	return false;
+    }
+
+  /* This is a conservative check on the components of the derived type
+     if no component references have been seen.  Since we will not dig
+     into the components of derived type components, we play it safe by
+     returning false.  First we check the reference chain and then, if
+     no component references have been seen, the components.  */
+  seen_component_ref = false;
+  if (sym1->ts.type == BT_DERIVED)
+    {
+      for (ref1 = expr1->ref; ref1; ref1 = ref1->next)
+	{
+	  if (ref1->type != REF_COMPONENT)
+	    continue;
+
+	  if (ref1->u.c.component->ts.type == BT_DERIVED)
+	    return false;
+
+	  if ((sym2->attr.pointer || ref1->u.c.component->attr.pointer)
+		&& gfc_compare_types (&ref1->u.c.component->ts, &sym2->ts))
+	    return false;
+
+	  seen_component_ref = true;
+	}
+    }
+
+  if (sym1->ts.type == BT_DERIVED && !seen_component_ref)
+    {
+      for (cm1 = sym1->ts.u.derived->components; cm1; cm1 = cm1->next)
+	{
+	  if (cm1->ts.type == BT_DERIVED)
+	    return false;
+
+	  if ((sym2->attr.pointer || cm1->attr.pointer)
+		&& gfc_compare_types (&cm1->ts, &sym2->ts))
+	    return false;
+	}
+    }
+
+  return true;
+}
+
+
+/* Return true if the statement body redefines the condition.  Returns
+   true if expr2 depends on expr1.  expr1 should be a single term
+   suitable for the lhs of an assignment.  The IDENTICAL flag indicates
+   whether array references to the same symbol with identical range
+   references count as a dependency or not.  Used for forall and where
+   statements.  Also used with functions returning arrays without a
+   temporary.  */
+
+int
+gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical)
+{
+  gfc_actual_arglist *actual;
+  gfc_constructor *c;
+  int n;
+
+  gcc_assert (expr1->expr_type == EXPR_VARIABLE);
+
+  switch (expr2->expr_type)
+    {
+    case EXPR_OP:
+      n = gfc_check_dependency (expr1, expr2->value.op.op1, identical);
+      if (n)
+	return n;
+      if (expr2->value.op.op2)
+	return gfc_check_dependency (expr1, expr2->value.op.op2, identical);
+      return 0;
+
+    case EXPR_VARIABLE:
+      /* The interesting cases are when the symbols don't match.  */
+      if (expr1->symtree->n.sym != expr2->symtree->n.sym)
+	{
+	  gfc_typespec *ts1 = &expr1->symtree->n.sym->ts;
+	  gfc_typespec *ts2 = &expr2->symtree->n.sym->ts;
+
+	  /* Return 1 if expr1 and expr2 are equivalenced arrays.  */
+	  if (gfc_are_equivalenced_arrays (expr1, expr2))
+	    return 1;
+
+	  /* Symbols can only alias if they have the same type.  */
+	  if (ts1->type != BT_UNKNOWN && ts2->type != BT_UNKNOWN
+	      && ts1->type != BT_DERIVED && ts2->type != BT_DERIVED)
+	    {
+	      if (ts1->type != ts2->type || ts1->kind != ts2->kind)
+		return 0;
+	    }
+
+	  /* If either variable is a pointer, assume the worst.  */
+	  /* TODO: -fassume-no-pointer-aliasing */
+	  if (gfc_is_data_pointer (expr1) || gfc_is_data_pointer (expr2))
+	    {
+	      if (check_data_pointer_types (expr1, expr2)
+		    && check_data_pointer_types (expr2, expr1))
+		return 0;
+
+	      return 1;
+	    }
+	  else
+	    {
+	      gfc_symbol *sym1 = expr1->symtree->n.sym;
+	      gfc_symbol *sym2 = expr2->symtree->n.sym;
+	      if (sym1->attr.target && sym2->attr.target
+		  && ((sym1->attr.dummy && !sym1->attr.contiguous
+		       && (!sym1->attr.dimension
+		           || sym2->as->type == AS_ASSUMED_SHAPE))
+		      || (sym2->attr.dummy && !sym2->attr.contiguous
+			  && (!sym2->attr.dimension
+			      || sym2->as->type == AS_ASSUMED_SHAPE))))
+		return 1;
+	    }
+
+	  /* Otherwise distinct symbols have no dependencies.  */
+	  return 0;
+	}
+
+      if (identical)
+	return 1;
+
+      /* Identical and disjoint ranges return 0,
+	 overlapping ranges return 1.  */
+      if (expr1->ref && expr2->ref)
+	return gfc_dep_resolver (expr1->ref, expr2->ref, NULL);
+
+      return 1;
+
+    case EXPR_FUNCTION:
+      if (gfc_get_noncopying_intrinsic_argument (expr2) != NULL)
+	identical = 1;
+
+      /* Remember possible differences between elemental and
+	 transformational functions.  All functions inside a FORALL
+	 will be pure.  */
+      for (actual = expr2->value.function.actual;
+	   actual; actual = actual->next)
+	{
+	  if (!actual->expr)
+	    continue;
+	  n = gfc_check_dependency (expr1, actual->expr, identical);
+	  if (n)
+	    return n;
+	}
+      return 0;
+
+    case EXPR_CONSTANT:
+    case EXPR_NULL:
+      return 0;
+
+    case EXPR_ARRAY:
+      /* Loop through the array constructor's elements.  */
+      for (c = gfc_constructor_first (expr2->value.constructor);
+	   c; c = gfc_constructor_next (c))
+	{
+	  /* If this is an iterator, assume the worst.  */
+	  if (c->iterator)
+	    return 1;
+	  /* Avoid recursion in the common case.  */
+	  if (c->expr->expr_type == EXPR_CONSTANT)
+	    continue;
+	  if (gfc_check_dependency (expr1, c->expr, 1))
+	    return 1;
+	}
+      return 0;
+
+    default:
+      return 1;
+    }
+}
+
+
+/* Determines overlapping for two array sections.  */
+
+static gfc_dependency
+check_section_vs_section (gfc_array_ref *l_ar, gfc_array_ref *r_ar, int n)
+{
+  gfc_expr *l_start;
+  gfc_expr *l_end;
+  gfc_expr *l_stride;
+  gfc_expr *l_lower;
+  gfc_expr *l_upper;
+  int l_dir;
+
+  gfc_expr *r_start;
+  gfc_expr *r_end;
+  gfc_expr *r_stride;
+  gfc_expr *r_lower;
+  gfc_expr *r_upper;
+  gfc_expr *one_expr;
+  int r_dir;
+  int stride_comparison;
+  int start_comparison;
+  mpz_t tmp;
+
+  /* If they are the same range, return without more ado.  */
+  if (is_same_range (l_ar, r_ar, n))
+    return GFC_DEP_EQUAL;
+
+  l_start = l_ar->start[n];
+  l_end = l_ar->end[n];
+  l_stride = l_ar->stride[n];
+
+  r_start = r_ar->start[n];
+  r_end = r_ar->end[n];
+  r_stride = r_ar->stride[n];
+
+  /* If l_start is NULL take it from array specifier.  */
+  if (NULL == l_start && IS_ARRAY_EXPLICIT (l_ar->as))
+    l_start = l_ar->as->lower[n];
+  /* If l_end is NULL take it from array specifier.  */
+  if (NULL == l_end && IS_ARRAY_EXPLICIT (l_ar->as))
+    l_end = l_ar->as->upper[n];
+
+  /* If r_start is NULL take it from array specifier.  */
+  if (NULL == r_start && IS_ARRAY_EXPLICIT (r_ar->as))
+    r_start = r_ar->as->lower[n];
+  /* If r_end is NULL take it from array specifier.  */
+  if (NULL == r_end && IS_ARRAY_EXPLICIT (r_ar->as))
+    r_end = r_ar->as->upper[n];
+
+  /* Determine whether the l_stride is positive or negative.  */
+  if (!l_stride)
+    l_dir = 1;
+  else if (l_stride->expr_type == EXPR_CONSTANT
+	   && l_stride->ts.type == BT_INTEGER)
+    l_dir = mpz_sgn (l_stride->value.integer);
+  else if (l_start && l_end)
+    l_dir = gfc_dep_compare_expr (l_end, l_start);
+  else
+    l_dir = -2;
+
+  /* Determine whether the r_stride is positive or negative.  */
+  if (!r_stride)
+    r_dir = 1;
+  else if (r_stride->expr_type == EXPR_CONSTANT
+	   && r_stride->ts.type == BT_INTEGER)
+    r_dir = mpz_sgn (r_stride->value.integer);
+  else if (r_start && r_end)
+    r_dir = gfc_dep_compare_expr (r_end, r_start);
+  else
+    r_dir = -2;
+
+  /* The strides should never be zero.  */
+  if (l_dir == 0 || r_dir == 0)
+    return GFC_DEP_OVERLAP;
+
+  /* Determine the relationship between the strides.  Set stride_comparison to
+     -2 if the dependency cannot be determined
+     -1 if l_stride < r_stride
+      0 if l_stride == r_stride
+      1 if l_stride > r_stride
+     as determined by gfc_dep_compare_expr.  */
+
+  one_expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+
+  stride_comparison = gfc_dep_compare_expr (l_stride ? l_stride : one_expr,
+					    r_stride ? r_stride : one_expr);
+
+  if (l_start && r_start)
+    start_comparison = gfc_dep_compare_expr (l_start, r_start);
+  else
+    start_comparison = -2;
+      
+  gfc_free_expr (one_expr);
+
+  /* Determine LHS upper and lower bounds.  */
+  if (l_dir == 1)
+    {
+      l_lower = l_start;
+      l_upper = l_end;
+    }
+  else if (l_dir == -1)
+    {
+      l_lower = l_end;
+      l_upper = l_start;
+    }
+  else
+    {
+      l_lower = NULL;
+      l_upper = NULL;
+    }
+
+  /* Determine RHS upper and lower bounds.  */
+  if (r_dir == 1)
+    {
+      r_lower = r_start;
+      r_upper = r_end;
+    }
+  else if (r_dir == -1)
+    {
+      r_lower = r_end;
+      r_upper = r_start;
+    }
+  else
+    {
+      r_lower = NULL;
+      r_upper = NULL;
+    }
+
+  /* Check whether the ranges are disjoint.  */
+  if (l_upper && r_lower && gfc_dep_compare_expr (l_upper, r_lower) == -1)
+    return GFC_DEP_NODEP;
+  if (r_upper && l_lower && gfc_dep_compare_expr (r_upper, l_lower) == -1)
+    return GFC_DEP_NODEP;
+
+  /* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL.  */
+  if (l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 0)
+    {
+      if (l_dir == 1 && r_dir == -1)
+	return GFC_DEP_EQUAL;
+      if (l_dir == -1 && r_dir == 1)
+	return GFC_DEP_EQUAL;
+    }
+
+  /* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL.  */
+  if (l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 0)
+    {
+      if (l_dir == 1 && r_dir == -1)
+	return GFC_DEP_EQUAL;
+      if (l_dir == -1 && r_dir == 1)
+	return GFC_DEP_EQUAL;
+    }
+
+  /* Handle cases like x:y:2 vs. x+1:z:4 as GFC_DEP_NODEP.
+     There is no dependency if the remainder of
+     (l_start - r_start) / gcd(l_stride, r_stride) is
+     nonzero.
+     TODO:
+       - Cases like a(1:4:2) = a(2:3) are still not handled.
+  */
+
+#define IS_CONSTANT_INTEGER(a) ((a) && ((a)->expr_type == EXPR_CONSTANT) \
+			      && (a)->ts.type == BT_INTEGER)
+
+  if (IS_CONSTANT_INTEGER (l_stride) && IS_CONSTANT_INTEGER (r_stride)
+      && gfc_dep_difference (l_start, r_start, &tmp))
+    {
+      mpz_t gcd;
+      int result;
+
+      mpz_init (gcd);
+      mpz_gcd (gcd, l_stride->value.integer, r_stride->value.integer);
+
+      mpz_fdiv_r (tmp, tmp, gcd);
+      result = mpz_cmp_si (tmp, 0L);
+
+      mpz_clear (gcd);
+      mpz_clear (tmp);
+
+      if (result != 0)
+	return GFC_DEP_NODEP;
+    }
+
+#undef IS_CONSTANT_INTEGER
+
+  /* Check for forward dependencies x:y vs. x+1:z and x:y:z vs. x:y:z+1. */
+
+  if (l_dir == 1 && r_dir == 1 &&
+      (start_comparison == 0 || start_comparison == -1)
+      && (stride_comparison == 0 || stride_comparison == -1))
+	  return GFC_DEP_FORWARD;
+
+  /* Check for forward dependencies x:y:-1 vs. x-1:z:-1 and
+     x:y:-1 vs. x:y:-2.  */
+  if (l_dir == -1 && r_dir == -1 && 
+      (start_comparison == 0 || start_comparison == 1)
+      && (stride_comparison == 0 || stride_comparison == 1))
+    return GFC_DEP_FORWARD;
+
+  if (stride_comparison == 0 || stride_comparison == -1)
+    {
+      if (l_start && IS_ARRAY_EXPLICIT (l_ar->as))
+	{
+
+	  /* Check for a(low:y:s) vs. a(z:x:s) or
+	     a(low:y:s) vs. a(z:x:s+1) where a has a lower bound
+	     of low, which is always at least a forward dependence.  */
+
+	  if (r_dir == 1
+	      && gfc_dep_compare_expr (l_start, l_ar->as->lower[n]) == 0)
+	    return GFC_DEP_FORWARD;
+	}
+    }
+
+  if (stride_comparison == 0 || stride_comparison == 1)
+    {
+      if (l_start && IS_ARRAY_EXPLICIT (l_ar->as))
+	{
+      
+	  /* Check for a(high:y:-s) vs. a(z:x:-s) or
+	     a(high:y:-s vs. a(z:x:-s-1) where a has a higher bound
+	     of high, which is always at least a forward dependence.  */
+
+	  if (r_dir == -1
+	      && gfc_dep_compare_expr (l_start, l_ar->as->upper[n]) == 0)
+	    return GFC_DEP_FORWARD;
+	}
+    }
+
+
+  if (stride_comparison == 0)
+    {
+      /* From here, check for backwards dependencies.  */
+      /* x+1:y vs. x:z.  */
+      if (l_dir == 1 && r_dir == 1  && start_comparison == 1)
+	return GFC_DEP_BACKWARD;
+
+      /* x-1:y:-1 vs. x:z:-1.  */
+      if (l_dir == -1 && r_dir == -1 && start_comparison == -1)
+	return GFC_DEP_BACKWARD;
+    }
+
+  return GFC_DEP_OVERLAP;
+}
+
+
+/* Determines overlapping for a single element and a section.  */
+
+static gfc_dependency
+gfc_check_element_vs_section( gfc_ref *lref, gfc_ref *rref, int n)
+{
+  gfc_array_ref *ref;
+  gfc_expr *elem;
+  gfc_expr *start;
+  gfc_expr *end;
+  gfc_expr *stride;
+  int s;
+
+  elem = lref->u.ar.start[n];
+  if (!elem)
+    return GFC_DEP_OVERLAP;
+
+  ref = &rref->u.ar;
+  start = ref->start[n] ;
+  end = ref->end[n] ;
+  stride = ref->stride[n];
+
+  if (!start && IS_ARRAY_EXPLICIT (ref->as))
+    start = ref->as->lower[n];
+  if (!end && IS_ARRAY_EXPLICIT (ref->as))
+    end = ref->as->upper[n];
+
+  /* Determine whether the stride is positive or negative.  */
+  if (!stride)
+    s = 1;
+  else if (stride->expr_type == EXPR_CONSTANT
+	   && stride->ts.type == BT_INTEGER)
+    s = mpz_sgn (stride->value.integer);
+  else
+    s = -2;
+
+  /* Stride should never be zero.  */
+  if (s == 0)
+    return GFC_DEP_OVERLAP;
+
+  /* Positive strides.  */
+  if (s == 1)
+    {
+      /* Check for elem < lower.  */
+      if (start && gfc_dep_compare_expr (elem, start) == -1)
+	return GFC_DEP_NODEP;
+      /* Check for elem > upper.  */
+      if (end && gfc_dep_compare_expr (elem, end) == 1)
+	return GFC_DEP_NODEP;
+
+      if (start && end)
+	{
+	  s = gfc_dep_compare_expr (start, end);
+	  /* Check for an empty range.  */
+	  if (s == 1)
+	    return GFC_DEP_NODEP;
+	  if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
+	    return GFC_DEP_EQUAL;
+	}
+    }
+  /* Negative strides.  */
+  else if (s == -1)
+    {
+      /* Check for elem > upper.  */
+      if (end && gfc_dep_compare_expr (elem, start) == 1)
+	return GFC_DEP_NODEP;
+      /* Check for elem < lower.  */
+      if (start && gfc_dep_compare_expr (elem, end) == -1)
+	return GFC_DEP_NODEP;
+
+      if (start && end)
+	{
+	  s = gfc_dep_compare_expr (start, end);
+	  /* Check for an empty range.  */
+	  if (s == -1)
+	    return GFC_DEP_NODEP;
+	  if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
+	    return GFC_DEP_EQUAL;
+	}
+    }
+  /* Unknown strides.  */
+  else
+    {
+      if (!start || !end)
+	return GFC_DEP_OVERLAP;
+      s = gfc_dep_compare_expr (start, end);
+      if (s <= -2)
+	return GFC_DEP_OVERLAP;
+      /* Assume positive stride.  */
+      if (s == -1)
+	{
+	  /* Check for elem < lower.  */
+	  if (gfc_dep_compare_expr (elem, start) == -1)
+	    return GFC_DEP_NODEP;
+	  /* Check for elem > upper.  */
+	  if (gfc_dep_compare_expr (elem, end) == 1)
+	    return GFC_DEP_NODEP;
+	}
+      /* Assume negative stride.  */
+      else if (s == 1)
+	{
+	  /* Check for elem > upper.  */
+	  if (gfc_dep_compare_expr (elem, start) == 1)
+	    return GFC_DEP_NODEP;
+	  /* Check for elem < lower.  */
+	  if (gfc_dep_compare_expr (elem, end) == -1)
+	    return GFC_DEP_NODEP;
+	}
+      /* Equal bounds.  */
+      else if (s == 0)
+	{
+	  s = gfc_dep_compare_expr (elem, start);
+	  if (s == 0)
+	    return GFC_DEP_EQUAL;
+	  if (s == 1 || s == -1)
+	    return GFC_DEP_NODEP;
+	}
+    }
+
+  return GFC_DEP_OVERLAP;
+}
+
+
+/* Traverse expr, checking all EXPR_VARIABLE symbols for their
+   forall_index attribute.  Return true if any variable may be
+   being used as a FORALL index.  Its safe to pessimistically
+   return true, and assume a dependency.  */
+
+static bool
+contains_forall_index_p (gfc_expr *expr)
+{
+  gfc_actual_arglist *arg;
+  gfc_constructor *c;
+  gfc_ref *ref;
+  int i;
+
+  if (!expr)
+    return false;
+
+  switch (expr->expr_type)
+    {
+    case EXPR_VARIABLE:
+      if (expr->symtree->n.sym->forall_index)
+	return true;
+      break;
+
+    case EXPR_OP:
+      if (contains_forall_index_p (expr->value.op.op1)
+	  || contains_forall_index_p (expr->value.op.op2))
+	return true;
+      break;
+
+    case EXPR_FUNCTION:
+      for (arg = expr->value.function.actual; arg; arg = arg->next)
+	if (contains_forall_index_p (arg->expr))
+	  return true;
+      break;
+
+    case EXPR_CONSTANT:
+    case EXPR_NULL:
+    case EXPR_SUBSTRING:
+      break;
+
+    case EXPR_STRUCTURE:
+    case EXPR_ARRAY:
+      for (c = gfc_constructor_first (expr->value.constructor);
+	   c; gfc_constructor_next (c))
+	if (contains_forall_index_p (c->expr))
+	  return true;
+      break;
+
+    default:
+      gcc_unreachable ();
+    }
+
+  for (ref = expr->ref; ref; ref = ref->next)
+    switch (ref->type)
+      {
+      case REF_ARRAY:
+	for (i = 0; i < ref->u.ar.dimen; i++)
+	  if (contains_forall_index_p (ref->u.ar.start[i])
+	      || contains_forall_index_p (ref->u.ar.end[i])
+	      || contains_forall_index_p (ref->u.ar.stride[i]))
+	    return true;
+	break;
+
+      case REF_COMPONENT:
+	break;
+
+      case REF_SUBSTRING:
+	if (contains_forall_index_p (ref->u.ss.start)
+	    || contains_forall_index_p (ref->u.ss.end))
+	  return true;
+	break;
+
+      default:
+	gcc_unreachable ();
+      }
+
+  return false;
+}
+
+/* Determines overlapping for two single element array references.  */
+
+static gfc_dependency
+gfc_check_element_vs_element (gfc_ref *lref, gfc_ref *rref, int n)
+{
+  gfc_array_ref l_ar;
+  gfc_array_ref r_ar;
+  gfc_expr *l_start;
+  gfc_expr *r_start;
+  int i;
+
+  l_ar = lref->u.ar;
+  r_ar = rref->u.ar;
+  l_start = l_ar.start[n] ;
+  r_start = r_ar.start[n] ;
+  i = gfc_dep_compare_expr (r_start, l_start);
+  if (i == 0)
+    return GFC_DEP_EQUAL;
+
+  /* Treat two scalar variables as potentially equal.  This allows
+     us to prove that a(i,:) and a(j,:) have no dependency.  See
+     Gerald Roth, "Evaluation of Array Syntax Dependence Analysis",
+     Proceedings of the International Conference on Parallel and
+     Distributed Processing Techniques and Applications (PDPTA2001),
+     Las Vegas, Nevada, June 2001.  */
+  /* However, we need to be careful when either scalar expression
+     contains a FORALL index, as these can potentially change value
+     during the scalarization/traversal of this array reference.  */
+  if (contains_forall_index_p (r_start) || contains_forall_index_p (l_start))
+    return GFC_DEP_OVERLAP;
+
+  if (i > -2)
+    return GFC_DEP_NODEP;
+  return GFC_DEP_EQUAL;
+}
+
+
+/* Determine if an array ref, usually an array section specifies the
+   entire array.  In addition, if the second, pointer argument is
+   provided, the function will return true if the reference is
+   contiguous; eg. (:, 1) gives true but (1,:) gives false.  */
+
+bool
+gfc_full_array_ref_p (gfc_ref *ref, bool *contiguous)
+{
+  int i;
+  int n;
+  bool lbound_OK = true;
+  bool ubound_OK = true;
+
+  if (contiguous)
+    *contiguous = false;
+
+  if (ref->type != REF_ARRAY)
+    return false;
+
+  if (ref->u.ar.type == AR_FULL)
+    {
+      if (contiguous)
+	*contiguous = true;
+      return true;
+    }
+
+  if (ref->u.ar.type != AR_SECTION)
+    return false;
+  if (ref->next)
+    return false;
+
+  for (i = 0; i < ref->u.ar.dimen; i++)
+    {
+      /* If we have a single element in the reference, for the reference
+	 to be full, we need to ascertain that the array has a single
+	 element in this dimension and that we actually reference the
+	 correct element.  */
+      if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
+	{
+	  /* This is unconditionally a contiguous reference if all the
+	     remaining dimensions are elements.  */
+	  if (contiguous)
+	    {
+	      *contiguous = true;
+	      for (n = i + 1; n < ref->u.ar.dimen; n++)
+		if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
+		  *contiguous = false;
+	    }
+
+	  if (!ref->u.ar.as
+	      || !ref->u.ar.as->lower[i]
+	      || !ref->u.ar.as->upper[i]
+	      || gfc_dep_compare_expr (ref->u.ar.as->lower[i],
+				       ref->u.ar.as->upper[i])
+	      || !ref->u.ar.start[i]
+	      || gfc_dep_compare_expr (ref->u.ar.start[i],
+				       ref->u.ar.as->lower[i]))
+	    return false;
+	  else
+	    continue;
+	}
+
+      /* Check the lower bound.  */
+      if (ref->u.ar.start[i]
+	  && (!ref->u.ar.as
+	      || !ref->u.ar.as->lower[i]
+	      || gfc_dep_compare_expr (ref->u.ar.start[i],
+				       ref->u.ar.as->lower[i])))
+	lbound_OK = false;
+      /* Check the upper bound.  */
+      if (ref->u.ar.end[i]
+	  && (!ref->u.ar.as
+	      || !ref->u.ar.as->upper[i]
+	      || gfc_dep_compare_expr (ref->u.ar.end[i],
+				       ref->u.ar.as->upper[i])))
+	ubound_OK = false;
+      /* Check the stride.  */
+      if (ref->u.ar.stride[i]
+	    && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
+	return false;
+
+      /* This is unconditionally a contiguous reference as long as all
+	 the subsequent dimensions are elements.  */
+      if (contiguous)
+	{
+	  *contiguous = true;
+	  for (n = i + 1; n < ref->u.ar.dimen; n++)
+	    if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
+	      *contiguous = false;
+	}
+
+      if (!lbound_OK || !ubound_OK)
+	return false;
+    }
+  return true;
+}
+
+
+/* Determine if a full array is the same as an array section with one
+   variable limit.  For this to be so, the strides must both be unity
+   and one of either start == lower or end == upper must be true.  */
+
+static bool
+ref_same_as_full_array (gfc_ref *full_ref, gfc_ref *ref)
+{
+  int i;
+  bool upper_or_lower;
+
+  if (full_ref->type != REF_ARRAY)
+    return false;
+  if (full_ref->u.ar.type != AR_FULL)
+    return false;
+  if (ref->type != REF_ARRAY)
+    return false;
+  if (ref->u.ar.type != AR_SECTION)
+    return false;
+
+  for (i = 0; i < ref->u.ar.dimen; i++)
+    {
+      /* If we have a single element in the reference, we need to check
+	 that the array has a single element and that we actually reference
+	 the correct element.  */
+      if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
+	{
+	  if (!full_ref->u.ar.as
+	      || !full_ref->u.ar.as->lower[i]
+	      || !full_ref->u.ar.as->upper[i]
+	      || gfc_dep_compare_expr (full_ref->u.ar.as->lower[i],
+				       full_ref->u.ar.as->upper[i])
+	      || !ref->u.ar.start[i]
+	      || gfc_dep_compare_expr (ref->u.ar.start[i],
+				       full_ref->u.ar.as->lower[i]))
+	    return false;
+	}
+
+      /* Check the strides.  */
+      if (full_ref->u.ar.stride[i] && !gfc_expr_is_one (full_ref->u.ar.stride[i], 0))
+	return false;
+      if (ref->u.ar.stride[i] && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
+	return false;
+
+      upper_or_lower = false;
+      /* Check the lower bound.  */
+      if (ref->u.ar.start[i]
+	  && (ref->u.ar.as
+	        && full_ref->u.ar.as->lower[i]
+	        && gfc_dep_compare_expr (ref->u.ar.start[i],
+				         full_ref->u.ar.as->lower[i]) == 0))
+	upper_or_lower =  true;
+      /* Check the upper bound.  */
+      if (ref->u.ar.end[i]
+	  && (ref->u.ar.as
+	        && full_ref->u.ar.as->upper[i]
+	        && gfc_dep_compare_expr (ref->u.ar.end[i],
+				         full_ref->u.ar.as->upper[i]) == 0))
+	upper_or_lower =  true;
+      if (!upper_or_lower)
+	return false;
+    }
+  return true;
+}
+
+
+/* Finds if two array references are overlapping or not.
+   Return value
+   	2 : array references are overlapping but reversal of one or
+	    more dimensions will clear the dependency.
+   	1 : array references are overlapping.
+   	0 : array references are identical or not overlapping.  */
+
+int
+gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref, gfc_reverse *reverse)
+{
+  int n;
+  gfc_dependency fin_dep;
+  gfc_dependency this_dep;
+
+  this_dep = GFC_DEP_ERROR;
+  fin_dep = GFC_DEP_ERROR;
+  /* Dependencies due to pointers should already have been identified.
+     We only need to check for overlapping array references.  */
+
+  while (lref && rref)
+    {
+      /* We're resolving from the same base symbol, so both refs should be
+	 the same type.  We traverse the reference chain until we find ranges
+	 that are not equal.  */
+      gcc_assert (lref->type == rref->type);
+      switch (lref->type)
+	{
+	case REF_COMPONENT:
+	  /* The two ranges can't overlap if they are from different
+	     components.  */
+	  if (lref->u.c.component != rref->u.c.component)
+	    return 0;
+	  break;
+	  
+	case REF_SUBSTRING:
+	  /* Substring overlaps are handled by the string assignment code
+	     if there is not an underlying dependency.  */
+	  return (fin_dep == GFC_DEP_OVERLAP) ? 1 : 0;
+	
+	case REF_ARRAY:
+
+	  if (ref_same_as_full_array (lref, rref))
+	    return 0;
+
+	  if (ref_same_as_full_array (rref, lref))
+	    return 0;
+
+	  if (lref->u.ar.dimen != rref->u.ar.dimen)
+	    {
+	      if (lref->u.ar.type == AR_FULL)
+		fin_dep = gfc_full_array_ref_p (rref, NULL) ? GFC_DEP_EQUAL
+							    : GFC_DEP_OVERLAP;
+	      else if (rref->u.ar.type == AR_FULL)
+		fin_dep = gfc_full_array_ref_p (lref, NULL) ? GFC_DEP_EQUAL
+							    : GFC_DEP_OVERLAP;
+	      else
+		return 1;
+	      break;
+	    }
+
+	  for (n=0; n < lref->u.ar.dimen; n++)
+	    {
+	      /* Handle dependency when either of array reference is vector
+		 subscript. There is no dependency if the vector indices
+		 are equal or if indices are known to be different in a
+		 different dimension.  */
+	      if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
+		  || rref->u.ar.dimen_type[n] == DIMEN_VECTOR)
+		{
+		  if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR 
+		      && rref->u.ar.dimen_type[n] == DIMEN_VECTOR
+		      && gfc_dep_compare_expr (lref->u.ar.start[n],
+					       rref->u.ar.start[n]) == 0)
+		    this_dep = GFC_DEP_EQUAL;
+		  else
+		    this_dep = GFC_DEP_OVERLAP;
+
+		  goto update_fin_dep;
+		}
+
+	      if (lref->u.ar.dimen_type[n] == DIMEN_RANGE
+		  && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
+		this_dep = check_section_vs_section (&lref->u.ar, &rref->u.ar, n);
+	      else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT
+		       && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
+		this_dep = gfc_check_element_vs_section (lref, rref, n);
+	      else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
+		       && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
+		this_dep = gfc_check_element_vs_section (rref, lref, n);
+	      else 
+		{
+		  gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
+			      && lref->u.ar.dimen_type[n] == DIMEN_ELEMENT);
+		  this_dep = gfc_check_element_vs_element (rref, lref, n);
+		}
+
+	      /* If any dimension doesn't overlap, we have no dependency.  */
+	      if (this_dep == GFC_DEP_NODEP)
+		return 0;
+
+	      /* Now deal with the loop reversal logic:  This only works on
+		 ranges and is activated by setting
+				reverse[n] == GFC_ENABLE_REVERSE
+		 The ability to reverse or not is set by previous conditions
+		 in this dimension.  If reversal is not activated, the
+		 value GFC_DEP_BACKWARD is reset to GFC_DEP_OVERLAP.  */
+	      if (rref->u.ar.dimen_type[n] == DIMEN_RANGE
+		    && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
+		{
+		  /* Set reverse if backward dependence and not inhibited.  */
+		  if (reverse && reverse[n] == GFC_ENABLE_REVERSE)
+		    reverse[n] = (this_dep == GFC_DEP_BACKWARD) ?
+			         GFC_REVERSE_SET : reverse[n];
+
+		  /* Set forward if forward dependence and not inhibited.  */
+		  if (reverse && reverse[n] == GFC_ENABLE_REVERSE)
+		    reverse[n] = (this_dep == GFC_DEP_FORWARD) ?
+			         GFC_FORWARD_SET : reverse[n];
+
+		  /* Flag up overlap if dependence not compatible with
+		     the overall state of the expression.  */
+		  if (reverse && reverse[n] == GFC_REVERSE_SET
+		        && this_dep == GFC_DEP_FORWARD)
+		    {
+	              reverse[n] = GFC_INHIBIT_REVERSE;
+		      this_dep = GFC_DEP_OVERLAP;
+		    }
+		  else if (reverse && reverse[n] == GFC_FORWARD_SET
+		        && this_dep == GFC_DEP_BACKWARD)
+		    {
+	              reverse[n] = GFC_INHIBIT_REVERSE;
+		      this_dep = GFC_DEP_OVERLAP;
+		    }
+
+		  /* If no intention of reversing or reversing is explicitly
+		     inhibited, convert backward dependence to overlap.  */
+		  if ((reverse == NULL && this_dep == GFC_DEP_BACKWARD)
+		      || (reverse != NULL && reverse[n] == GFC_INHIBIT_REVERSE))
+		    this_dep = GFC_DEP_OVERLAP;
+		}
+
+	      /* Overlap codes are in order of priority.  We only need to
+		 know the worst one.*/
+
+	    update_fin_dep:
+	      if (this_dep > fin_dep)
+		fin_dep = this_dep;
+	    }
+
+	  /* If this is an equal element, we have to keep going until we find
+	     the "real" array reference.  */
+	  if (lref->u.ar.type == AR_ELEMENT
+		&& rref->u.ar.type == AR_ELEMENT
+		&& fin_dep == GFC_DEP_EQUAL)
+	    break;
+
+	  /* Exactly matching and forward overlapping ranges don't cause a
+	     dependency.  */
+	  if (fin_dep < GFC_DEP_BACKWARD)
+	    return 0;
+
+	  /* Keep checking.  We only have a dependency if
+	     subsequent references also overlap.  */
+	  break;
+
+	default:
+	  gcc_unreachable ();
+	}
+      lref = lref->next;
+      rref = rref->next;
+    }
+
+  /* If we haven't seen any array refs then something went wrong.  */
+  gcc_assert (fin_dep != GFC_DEP_ERROR);
+
+  /* Assume the worst if we nest to different depths.  */
+  if (lref || rref)
+    return 1;
+
+  return fin_dep == GFC_DEP_OVERLAP;
+}
diff --git a/gcc-4.9/gcc/fortran/dependency.h b/gcc-4.9/gcc/fortran/dependency.h
new file mode 100644
index 000000000..e3bbbae5c
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/dependency.h
@@ -0,0 +1,42 @@
+/* Header for dependency analysis
+   Copyright (C) 2000-2014 Free Software Foundation, Inc.
+   Contributed by Paul Brook
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+/****************************** Enums *********************************/
+typedef enum
+{
+  NOT_ELEMENTAL,        /* Not elemental case: normal dependency check.  */
+  ELEM_CHECK_VARIABLE,  /* Test whether variables overlap.  */
+  ELEM_DONT_CHECK_VARIABLE  /* Test whether variables overlap only if used 
+			       in an expression.  */
+}
+gfc_dep_check;
+
+/*********************** Functions prototypes **************************/
+
+bool gfc_ref_needs_temporary_p (gfc_ref *);
+bool gfc_full_array_ref_p (gfc_ref *, bool *);
+gfc_expr *gfc_get_noncopying_intrinsic_argument (gfc_expr *);
+int gfc_check_fncall_dependency (gfc_expr *, sym_intent, gfc_symbol *,
+				 gfc_actual_arglist *, gfc_dep_check);
+int gfc_check_dependency (gfc_expr *, gfc_expr *, bool);
+int gfc_expr_is_one (gfc_expr *, int);
+
+int gfc_dep_resolver(gfc_ref *, gfc_ref *, gfc_reverse *);
+int gfc_are_equivalenced_arrays (gfc_expr *, gfc_expr *);
diff --git a/gcc-4.9/gcc/fortran/dump-parse-tree.c b/gcc-4.9/gcc/fortran/dump-parse-tree.c
new file mode 100644
index 000000000..b1343bc2a
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/dump-parse-tree.c
@@ -0,0 +1,2339 @@
+/* Parse tree dumper
+   Copyright (C) 2003-2014 Free Software Foundation, Inc.
+   Contributed by Steven Bosscher
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+
+/* Actually this is just a collection of routines that used to be
+   scattered around the sources.  Now that they are all in a single
+   file, almost all of them can be static, and the other files don't
+   have this mess in them.
+
+   As a nice side-effect, this file can act as documentation of the
+   gfc_code and gfc_expr structures and all their friends and
+   relatives.
+
+   TODO: Dump DATA.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "gfortran.h"
+#include "constructor.h"
+
+/* Keep track of indentation for symbol tree dumps.  */
+static int show_level = 0;
+
+/* The file handle we're dumping to is kept in a static variable.  This
+   is not too cool, but it avoids a lot of passing it around.  */
+static FILE *dumpfile;
+
+/* Forward declaration of some of the functions.  */
+static void show_expr (gfc_expr *p);
+static void show_code_node (int, gfc_code *);
+static void show_namespace (gfc_namespace *ns);
+
+
+/* Allow dumping of an expression in the debugger.  */
+void gfc_debug_expr (gfc_expr *);
+
+void
+gfc_debug_expr (gfc_expr *e)
+{
+  FILE *tmp = dumpfile;
+  dumpfile = stderr;
+  show_expr (e);
+  fputc ('\n', dumpfile);
+  dumpfile = tmp;
+}
+
+
+/* Do indentation for a specific level.  */
+
+static inline void
+code_indent (int level, gfc_st_label *label)
+{
+  int i;
+
+  if (label != NULL)
+    fprintf (dumpfile, "%-5d ", label->value);
+
+  for (i = 0; i < (2 * level - (label ? 6 : 0)); i++)
+    fputc (' ', dumpfile);
+}
+
+
+/* Simple indentation at the current level.  This one
+   is used to show symbols.  */
+
+static inline void
+show_indent (void)
+{
+  fputc ('\n', dumpfile);
+  code_indent (show_level, NULL);
+}
+
+
+/* Show type-specific information.  */
+
+static void
+show_typespec (gfc_typespec *ts)
+{
+  if (ts->type == BT_ASSUMED)
+    {
+      fputs ("(TYPE(*))", dumpfile);
+      return;
+    }
+
+  fprintf (dumpfile, "(%s ", gfc_basic_typename (ts->type));
+
+  switch (ts->type)
+    {
+    case BT_DERIVED:
+    case BT_CLASS:
+      fprintf (dumpfile, "%s", ts->u.derived->name);
+      break;
+
+    case BT_CHARACTER:
+      if (ts->u.cl)
+	show_expr (ts->u.cl->length);
+      fprintf(dumpfile, " %d", ts->kind);
+      break;
+
+    default:
+      fprintf (dumpfile, "%d", ts->kind);
+      break;
+    }
+
+  fputc (')', dumpfile);
+}
+
+
+/* Show an actual argument list.  */
+
+static void
+show_actual_arglist (gfc_actual_arglist *a)
+{
+  fputc ('(', dumpfile);
+
+  for (; a; a = a->next)
+    {
+      fputc ('(', dumpfile);
+      if (a->name != NULL)
+	fprintf (dumpfile, "%s = ", a->name);
+      if (a->expr != NULL)
+	show_expr (a->expr);
+      else
+	fputs ("(arg not-present)", dumpfile);
+
+      fputc (')', dumpfile);
+      if (a->next != NULL)
+	fputc (' ', dumpfile);
+    }
+
+  fputc (')', dumpfile);
+}
+
+
+/* Show a gfc_array_spec array specification structure.  */
+
+static void
+show_array_spec (gfc_array_spec *as)
+{
+  const char *c;
+  int i;
+
+  if (as == NULL)
+    {
+      fputs ("()", dumpfile);
+      return;
+    }
+
+  fprintf (dumpfile, "(%d [%d]", as->rank, as->corank);
+
+  if (as->rank + as->corank > 0 || as->rank == -1)
+    {
+      switch (as->type)
+      {
+	case AS_EXPLICIT:      c = "AS_EXPLICIT";      break;
+	case AS_DEFERRED:      c = "AS_DEFERRED";      break;
+	case AS_ASSUMED_SIZE:  c = "AS_ASSUMED_SIZE";  break;
+	case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break;
+	case AS_ASSUMED_RANK:  c = "AS_ASSUMED_RANK";  break;
+	default:
+	  gfc_internal_error ("show_array_spec(): Unhandled array shape "
+			      "type.");
+      }
+      fprintf (dumpfile, " %s ", c);
+
+      for (i = 0; i < as->rank + as->corank; i++)
+	{
+	  show_expr (as->lower[i]);
+	  fputc (' ', dumpfile);
+	  show_expr (as->upper[i]);
+	  fputc (' ', dumpfile);
+	}
+    }
+
+  fputc (')', dumpfile);
+}
+
+
+/* Show a gfc_array_ref array reference structure.  */
+
+static void
+show_array_ref (gfc_array_ref * ar)
+{
+  int i;
+
+  fputc ('(', dumpfile);
+
+  switch (ar->type)
+    {
+    case AR_FULL:
+      fputs ("FULL", dumpfile);
+      break;
+
+    case AR_SECTION:
+      for (i = 0; i < ar->dimen; i++)
+	{
+	  /* There are two types of array sections: either the
+	     elements are identified by an integer array ('vector'),
+	     or by an index range. In the former case we only have to
+	     print the start expression which contains the vector, in
+	     the latter case we have to print any of lower and upper
+	     bound and the stride, if they're present.  */
+  
+	  if (ar->start[i] != NULL)
+	    show_expr (ar->start[i]);
+
+	  if (ar->dimen_type[i] == DIMEN_RANGE)
+	    {
+	      fputc (':', dumpfile);
+
+	      if (ar->end[i] != NULL)
+		show_expr (ar->end[i]);
+
+	      if (ar->stride[i] != NULL)
+		{
+		  fputc (':', dumpfile);
+		  show_expr (ar->stride[i]);
+		}
+	    }
+
+	  if (i != ar->dimen - 1)
+	    fputs (" , ", dumpfile);
+	}
+      break;
+
+    case AR_ELEMENT:
+      for (i = 0; i < ar->dimen; i++)
+	{
+	  show_expr (ar->start[i]);
+	  if (i != ar->dimen - 1)
+	    fputs (" , ", dumpfile);
+	}
+      break;
+
+    case AR_UNKNOWN:
+      fputs ("UNKNOWN", dumpfile);
+      break;
+
+    default:
+      gfc_internal_error ("show_array_ref(): Unknown array reference");
+    }
+
+  fputc (')', dumpfile);
+}
+
+
+/* Show a list of gfc_ref structures.  */
+
+static void
+show_ref (gfc_ref *p)
+{
+  for (; p; p = p->next)
+    switch (p->type)
+      {
+      case REF_ARRAY:
+	show_array_ref (&p->u.ar);
+	break;
+
+      case REF_COMPONENT:
+	fprintf (dumpfile, " %% %s", p->u.c.component->name);
+	break;
+
+      case REF_SUBSTRING:
+	fputc ('(', dumpfile);
+	show_expr (p->u.ss.start);
+	fputc (':', dumpfile);
+	show_expr (p->u.ss.end);
+	fputc (')', dumpfile);
+	break;
+
+      default:
+	gfc_internal_error ("show_ref(): Bad component code");
+      }
+}
+
+
+/* Display a constructor.  Works recursively for array constructors.  */
+
+static void
+show_constructor (gfc_constructor_base base)
+{
+  gfc_constructor *c;
+  for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
+    {
+      if (c->iterator == NULL)
+	show_expr (c->expr);
+      else
+	{
+	  fputc ('(', dumpfile);
+	  show_expr (c->expr);
+
+	  fputc (' ', dumpfile);
+	  show_expr (c->iterator->var);
+	  fputc ('=', dumpfile);
+	  show_expr (c->iterator->start);
+	  fputc (',', dumpfile);
+	  show_expr (c->iterator->end);
+	  fputc (',', dumpfile);
+	  show_expr (c->iterator->step);
+
+	  fputc (')', dumpfile);
+	}
+
+      if (gfc_constructor_next (c) != NULL)
+	fputs (" , ", dumpfile);
+    }
+}
+
+
+static void
+show_char_const (const gfc_char_t *c, int length)
+{
+  int i;
+
+  fputc ('\'', dumpfile);
+  for (i = 0; i < length; i++)
+    {
+      if (c[i] == '\'')
+	fputs ("''", dumpfile);
+      else
+	fputs (gfc_print_wide_char (c[i]), dumpfile);
+    }
+  fputc ('\'', dumpfile);
+}
+
+
+/* Show a component-call expression.  */
+
+static void
+show_compcall (gfc_expr* p)
+{
+  gcc_assert (p->expr_type == EXPR_COMPCALL);
+
+  fprintf (dumpfile, "%s", p->symtree->n.sym->name);
+  show_ref (p->ref);
+  fprintf (dumpfile, "%s", p->value.compcall.name);
+
+  show_actual_arglist (p->value.compcall.actual);
+}
+
+
+/* Show an expression.  */
+
+static void
+show_expr (gfc_expr *p)
+{
+  const char *c;
+  int i;
+
+  if (p == NULL)
+    {
+      fputs ("()", dumpfile);
+      return;
+    }
+
+  switch (p->expr_type)
+    {
+    case EXPR_SUBSTRING:
+      show_char_const (p->value.character.string, p->value.character.length);
+      show_ref (p->ref);
+      break;
+
+    case EXPR_STRUCTURE:
+      fprintf (dumpfile, "%s(", p->ts.u.derived->name);
+      show_constructor (p->value.constructor);
+      fputc (')', dumpfile);
+      break;
+
+    case EXPR_ARRAY:
+      fputs ("(/ ", dumpfile);
+      show_constructor (p->value.constructor);
+      fputs (" /)", dumpfile);
+
+      show_ref (p->ref);
+      break;
+
+    case EXPR_NULL:
+      fputs ("NULL()", dumpfile);
+      break;
+
+    case EXPR_CONSTANT:
+      switch (p->ts.type)
+	{
+	case BT_INTEGER:
+	  mpz_out_str (stdout, 10, p->value.integer);
+
+	  if (p->ts.kind != gfc_default_integer_kind)
+	    fprintf (dumpfile, "_%d", p->ts.kind);
+	  break;
+
+	case BT_LOGICAL:
+	  if (p->value.logical)
+	    fputs (".true.", dumpfile);
+	  else
+	    fputs (".false.", dumpfile);
+	  break;
+
+	case BT_REAL:
+	  mpfr_out_str (stdout, 10, 0, p->value.real, GFC_RND_MODE);
+	  if (p->ts.kind != gfc_default_real_kind)
+	    fprintf (dumpfile, "_%d", p->ts.kind);
+	  break;
+
+	case BT_CHARACTER:
+	  show_char_const (p->value.character.string, 
+			   p->value.character.length);
+	  break;
+
+	case BT_COMPLEX:
+	  fputs ("(complex ", dumpfile);
+
+	  mpfr_out_str (stdout, 10, 0, mpc_realref (p->value.complex),
+			GFC_RND_MODE);
+	  if (p->ts.kind != gfc_default_complex_kind)
+	    fprintf (dumpfile, "_%d", p->ts.kind);
+
+	  fputc (' ', dumpfile);
+
+	  mpfr_out_str (stdout, 10, 0, mpc_imagref (p->value.complex),
+			GFC_RND_MODE);
+	  if (p->ts.kind != gfc_default_complex_kind)
+	    fprintf (dumpfile, "_%d", p->ts.kind);
+
+	  fputc (')', dumpfile);
+	  break;
+
+	case BT_HOLLERITH:
+	  fprintf (dumpfile, "%dH", p->representation.length);
+	  c = p->representation.string;
+	  for (i = 0; i < p->representation.length; i++, c++)
+	    {
+	      fputc (*c, dumpfile);
+	    }
+	  break;
+
+	default:
+	  fputs ("???", dumpfile);
+	  break;
+	}
+
+      if (p->representation.string)
+	{
+	  fputs (" {", dumpfile);
+	  c = p->representation.string;
+	  for (i = 0; i < p->representation.length; i++, c++)
+	    {
+	      fprintf (dumpfile, "%.2x", (unsigned int) *c);
+	      if (i < p->representation.length - 1)
+		fputc (',', dumpfile);
+	    }
+	  fputc ('}', dumpfile);
+	}
+
+      break;
+
+    case EXPR_VARIABLE:
+      if (p->symtree->n.sym->ns && p->symtree->n.sym->ns->proc_name)
+	fprintf (dumpfile, "%s:", p->symtree->n.sym->ns->proc_name->name);
+      fprintf (dumpfile, "%s", p->symtree->n.sym->name);
+      show_ref (p->ref);
+      break;
+
+    case EXPR_OP:
+      fputc ('(', dumpfile);
+      switch (p->value.op.op)
+	{
+	case INTRINSIC_UPLUS:
+	  fputs ("U+ ", dumpfile);
+	  break;
+	case INTRINSIC_UMINUS:
+	  fputs ("U- ", dumpfile);
+	  break;
+	case INTRINSIC_PLUS:
+	  fputs ("+ ", dumpfile);
+	  break;
+	case INTRINSIC_MINUS:
+	  fputs ("- ", dumpfile);
+	  break;
+	case INTRINSIC_TIMES:
+	  fputs ("* ", dumpfile);
+	  break;
+	case INTRINSIC_DIVIDE:
+	  fputs ("/ ", dumpfile);
+	  break;
+	case INTRINSIC_POWER:
+	  fputs ("** ", dumpfile);
+	  break;
+	case INTRINSIC_CONCAT:
+	  fputs ("// ", dumpfile);
+	  break;
+	case INTRINSIC_AND:
+	  fputs ("AND ", dumpfile);
+	  break;
+	case INTRINSIC_OR:
+	  fputs ("OR ", dumpfile);
+	  break;
+	case INTRINSIC_EQV:
+	  fputs ("EQV ", dumpfile);
+	  break;
+	case INTRINSIC_NEQV:
+	  fputs ("NEQV ", dumpfile);
+	  break;
+	case INTRINSIC_EQ:
+	case INTRINSIC_EQ_OS:
+	  fputs ("= ", dumpfile);
+	  break;
+	case INTRINSIC_NE:
+	case INTRINSIC_NE_OS:
+	  fputs ("/= ", dumpfile);
+	  break;
+	case INTRINSIC_GT:
+	case INTRINSIC_GT_OS:
+	  fputs ("> ", dumpfile);
+	  break;
+	case INTRINSIC_GE:
+	case INTRINSIC_GE_OS:
+	  fputs (">= ", dumpfile);
+	  break;
+	case INTRINSIC_LT:
+	case INTRINSIC_LT_OS:
+	  fputs ("< ", dumpfile);
+	  break;
+	case INTRINSIC_LE:
+	case INTRINSIC_LE_OS:
+	  fputs ("<= ", dumpfile);
+	  break;
+	case INTRINSIC_NOT:
+	  fputs ("NOT ", dumpfile);
+	  break;
+	case INTRINSIC_PARENTHESES:
+	  fputs ("parens ", dumpfile);
+	  break;
+
+	default:
+	  gfc_internal_error
+	    ("show_expr(): Bad intrinsic in expression!");
+	}
+
+      show_expr (p->value.op.op1);
+
+      if (p->value.op.op2)
+	{
+	  fputc (' ', dumpfile);
+	  show_expr (p->value.op.op2);
+	}
+
+      fputc (')', dumpfile);
+      break;
+
+    case EXPR_FUNCTION:
+      if (p->value.function.name == NULL)
+	{
+	  fprintf (dumpfile, "%s", p->symtree->n.sym->name);
+	  if (gfc_is_proc_ptr_comp (p))
+	    show_ref (p->ref);
+	  fputc ('[', dumpfile);
+	  show_actual_arglist (p->value.function.actual);
+	  fputc (']', dumpfile);
+	}
+      else
+	{
+	  fprintf (dumpfile, "%s", p->value.function.name);
+	  if (gfc_is_proc_ptr_comp (p))
+	    show_ref (p->ref);
+	  fputc ('[', dumpfile);
+	  fputc ('[', dumpfile);
+	  show_actual_arglist (p->value.function.actual);
+	  fputc (']', dumpfile);
+	  fputc (']', dumpfile);
+	}
+
+      break;
+
+    case EXPR_COMPCALL:
+      show_compcall (p);
+      break;
+
+    default:
+      gfc_internal_error ("show_expr(): Don't know how to show expr");
+    }
+}
+
+/* Show symbol attributes.  The flavor and intent are followed by
+   whatever single bit attributes are present.  */
+
+static void
+show_attr (symbol_attribute *attr, const char * module)
+{
+  if (attr->flavor != FL_UNKNOWN)
+    fprintf (dumpfile, "(%s ", gfc_code2string (flavors, attr->flavor));
+  if (attr->access != ACCESS_UNKNOWN)
+    fprintf (dumpfile, "%s ", gfc_code2string (access_types, attr->access));
+  if (attr->proc != PROC_UNKNOWN)
+    fprintf (dumpfile, "%s ", gfc_code2string (procedures, attr->proc));
+  if (attr->save != SAVE_NONE)
+    fprintf (dumpfile, "%s", gfc_code2string (save_status, attr->save));
+
+  if (attr->artificial)
+    fputs (" ARTIFICIAL", dumpfile);
+  if (attr->allocatable)
+    fputs (" ALLOCATABLE", dumpfile);
+  if (attr->asynchronous)
+    fputs (" ASYNCHRONOUS", dumpfile);
+  if (attr->codimension)
+    fputs (" CODIMENSION", dumpfile);
+  if (attr->dimension)
+    fputs (" DIMENSION", dumpfile);
+  if (attr->contiguous)
+    fputs (" CONTIGUOUS", dumpfile);
+  if (attr->external)
+    fputs (" EXTERNAL", dumpfile);
+  if (attr->intrinsic)
+    fputs (" INTRINSIC", dumpfile);
+  if (attr->optional)
+    fputs (" OPTIONAL", dumpfile);
+  if (attr->pointer)
+    fputs (" POINTER", dumpfile);
+  if (attr->is_protected)
+    fputs (" PROTECTED", dumpfile);
+  if (attr->value)
+    fputs (" VALUE", dumpfile);
+  if (attr->volatile_)
+    fputs (" VOLATILE", dumpfile);
+  if (attr->threadprivate)
+    fputs (" THREADPRIVATE", dumpfile);
+  if (attr->target)
+    fputs (" TARGET", dumpfile);
+  if (attr->dummy)
+    {
+      fputs (" DUMMY", dumpfile);
+      if (attr->intent != INTENT_UNKNOWN)
+	fprintf (dumpfile, "(%s)", gfc_intent_string (attr->intent));
+    }
+
+  if (attr->result)
+    fputs (" RESULT", dumpfile);
+  if (attr->entry)
+    fputs (" ENTRY", dumpfile);
+  if (attr->is_bind_c)
+    fputs (" BIND(C)", dumpfile);
+
+  if (attr->data)
+    fputs (" DATA", dumpfile);
+  if (attr->use_assoc)
+    {
+      fputs (" USE-ASSOC", dumpfile);
+      if (module != NULL)
+	fprintf (dumpfile, "(%s)", module);
+    }
+
+  if (attr->in_namelist)
+    fputs (" IN-NAMELIST", dumpfile);
+  if (attr->in_common)
+    fputs (" IN-COMMON", dumpfile);
+
+  if (attr->abstract)
+    fputs (" ABSTRACT", dumpfile);
+  if (attr->function)
+    fputs (" FUNCTION", dumpfile);
+  if (attr->subroutine)
+    fputs (" SUBROUTINE", dumpfile);
+  if (attr->implicit_type)
+    fputs (" IMPLICIT-TYPE", dumpfile);
+
+  if (attr->sequence)
+    fputs (" SEQUENCE", dumpfile);
+  if (attr->elemental)
+    fputs (" ELEMENTAL", dumpfile);
+  if (attr->pure)
+    fputs (" PURE", dumpfile);
+  if (attr->recursive)
+    fputs (" RECURSIVE", dumpfile);
+
+  fputc (')', dumpfile);
+}
+
+
+/* Show components of a derived type.  */
+
+static void
+show_components (gfc_symbol *sym)
+{
+  gfc_component *c;
+
+  for (c = sym->components; c; c = c->next)
+    {
+      fprintf (dumpfile, "(%s ", c->name);
+      show_typespec (&c->ts);
+      if (c->attr.allocatable)
+	fputs (" ALLOCATABLE", dumpfile);
+      if (c->attr.pointer)
+	fputs (" POINTER", dumpfile);
+      if (c->attr.proc_pointer)
+	fputs (" PPC", dumpfile);
+      if (c->attr.dimension)
+	fputs (" DIMENSION", dumpfile);
+      fputc (' ', dumpfile);
+      show_array_spec (c->as);
+      if (c->attr.access)
+	fprintf (dumpfile, " %s", gfc_code2string (access_types, c->attr.access));
+      fputc (')', dumpfile);
+      if (c->next != NULL)
+	fputc (' ', dumpfile);
+    }
+}
+
+
+/* Show the f2k_derived namespace with procedure bindings.  */
+
+static void
+show_typebound_proc (gfc_typebound_proc* tb, const char* name)
+{
+  show_indent ();
+
+  if (tb->is_generic)
+    fputs ("GENERIC", dumpfile);
+  else
+    {
+      fputs ("PROCEDURE, ", dumpfile);
+      if (tb->nopass)
+	fputs ("NOPASS", dumpfile);
+      else
+	{
+	  if (tb->pass_arg)
+	    fprintf (dumpfile, "PASS(%s)", tb->pass_arg);
+	  else
+	    fputs ("PASS", dumpfile);
+	}
+      if (tb->non_overridable)
+	fputs (", NON_OVERRIDABLE", dumpfile);
+    }
+
+  if (tb->access == ACCESS_PUBLIC)
+    fputs (", PUBLIC", dumpfile);
+  else
+    fputs (", PRIVATE", dumpfile);
+
+  fprintf (dumpfile, " :: %s => ", name);
+
+  if (tb->is_generic)
+    {
+      gfc_tbp_generic* g;
+      for (g = tb->u.generic; g; g = g->next)
+	{
+	  fputs (g->specific_st->name, dumpfile);
+	  if (g->next)
+	    fputs (", ", dumpfile);
+	}
+    }
+  else
+    fputs (tb->u.specific->n.sym->name, dumpfile);
+}
+
+static void
+show_typebound_symtree (gfc_symtree* st)
+{
+  gcc_assert (st->n.tb);
+  show_typebound_proc (st->n.tb, st->name);
+}
+
+static void
+show_f2k_derived (gfc_namespace* f2k)
+{
+  gfc_finalizer* f;
+  int op;
+
+  show_indent ();
+  fputs ("Procedure bindings:", dumpfile);
+  ++show_level;
+
+  /* Finalizer bindings.  */
+  for (f = f2k->finalizers; f; f = f->next)
+    {
+      show_indent ();
+      fprintf (dumpfile, "FINAL %s", f->proc_tree->n.sym->name);
+    }
+
+  /* Type-bound procedures.  */
+  gfc_traverse_symtree (f2k->tb_sym_root, &show_typebound_symtree);
+
+  --show_level;
+
+  show_indent ();
+  fputs ("Operator bindings:", dumpfile);
+  ++show_level;
+
+  /* User-defined operators.  */
+  gfc_traverse_symtree (f2k->tb_uop_root, &show_typebound_symtree);
+
+  /* Intrinsic operators.  */
+  for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op)
+    if (f2k->tb_op[op])
+      show_typebound_proc (f2k->tb_op[op],
+			   gfc_op2string ((gfc_intrinsic_op) op));
+
+  --show_level;
+}
+
+
+/* Show a symbol.  If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
+   show the interface.  Information needed to reconstruct the list of
+   specific interfaces associated with a generic symbol is done within
+   that symbol.  */
+
+static void
+show_symbol (gfc_symbol *sym)
+{
+  gfc_formal_arglist *formal;
+  gfc_interface *intr;
+  int i,len;
+
+  if (sym == NULL)
+    return;
+
+  fprintf (dumpfile, "|| symbol: '%s' ", sym->name);
+  len = strlen (sym->name);
+  for (i=len; i<12; i++)
+    fputc(' ', dumpfile);
+
+  ++show_level;
+
+  show_indent ();
+  fputs ("type spec : ", dumpfile);
+  show_typespec (&sym->ts);
+
+  show_indent ();
+  fputs ("attributes: ", dumpfile);
+  show_attr (&sym->attr, sym->module);
+
+  if (sym->value)
+    {
+      show_indent ();
+      fputs ("value: ", dumpfile);
+      show_expr (sym->value);
+    }
+
+  if (sym->as)
+    {
+      show_indent ();
+      fputs ("Array spec:", dumpfile);
+      show_array_spec (sym->as);
+    }
+
+  if (sym->generic)
+    {
+      show_indent ();
+      fputs ("Generic interfaces:", dumpfile);
+      for (intr = sym->generic; intr; intr = intr->next)
+	fprintf (dumpfile, " %s", intr->sym->name);
+    }
+
+  if (sym->result)
+    {
+      show_indent ();
+      fprintf (dumpfile, "result: %s", sym->result->name);
+    }
+
+  if (sym->components)
+    {
+      show_indent ();
+      fputs ("components: ", dumpfile);
+      show_components (sym);
+    }
+
+  if (sym->f2k_derived)
+    {
+      show_indent ();
+      if (sym->hash_value)
+	fprintf (dumpfile, "hash: %d", sym->hash_value);
+      show_f2k_derived (sym->f2k_derived);
+    }
+
+  if (sym->formal)
+    {
+      show_indent ();
+      fputs ("Formal arglist:", dumpfile);
+
+      for (formal = sym->formal; formal; formal = formal->next)
+	{
+	  if (formal->sym != NULL)
+	    fprintf (dumpfile, " %s", formal->sym->name);
+	  else
+	    fputs (" [Alt Return]", dumpfile);
+	}
+    }
+
+  if (sym->formal_ns && (sym->formal_ns->proc_name != sym)
+      && sym->attr.proc != PROC_ST_FUNCTION
+      && !sym->attr.entry)
+    {
+      show_indent ();
+      fputs ("Formal namespace", dumpfile);
+      show_namespace (sym->formal_ns);
+    }
+  --show_level;
+}
+
+
+/* Show a user-defined operator.  Just prints an operator
+   and the name of the associated subroutine, really.  */
+
+static void
+show_uop (gfc_user_op *uop)
+{
+  gfc_interface *intr;
+
+  show_indent ();
+  fprintf (dumpfile, "%s:", uop->name);
+
+  for (intr = uop->op; intr; intr = intr->next)
+    fprintf (dumpfile, " %s", intr->sym->name);
+}
+
+
+/* Workhorse function for traversing the user operator symtree.  */
+
+static void
+traverse_uop (gfc_symtree *st, void (*func) (gfc_user_op *))
+{
+  if (st == NULL)
+    return;
+
+  (*func) (st->n.uop);
+
+  traverse_uop (st->left, func);
+  traverse_uop (st->right, func);
+}
+
+
+/* Traverse the tree of user operator nodes.  */
+
+void
+gfc_traverse_user_op (gfc_namespace *ns, void (*func) (gfc_user_op *))
+{
+  traverse_uop (ns->uop_root, func);
+}
+
+
+/* Function to display a common block.  */
+
+static void
+show_common (gfc_symtree *st)
+{
+  gfc_symbol *s;
+
+  show_indent ();
+  fprintf (dumpfile, "common: /%s/ ", st->name);
+
+  s = st->n.common->head;
+  while (s)
+    {
+      fprintf (dumpfile, "%s", s->name);
+      s = s->common_next;
+      if (s)
+	fputs (", ", dumpfile);
+    }
+  fputc ('\n', dumpfile);
+}    
+
+
+/* Worker function to display the symbol tree.  */
+
+static void
+show_symtree (gfc_symtree *st)
+{
+  int len, i;
+
+  show_indent ();
+
+  len = strlen(st->name);
+  fprintf (dumpfile, "symtree: '%s'", st->name);
+
+  for (i=len; i<12; i++)
+    fputc(' ', dumpfile);
+
+  if (st->ambiguous)
+    fputs( " Ambiguous", dumpfile);
+
+  if (st->n.sym->ns != gfc_current_ns)
+    fprintf (dumpfile, "|| symbol: '%s' from namespace '%s'", st->n.sym->name,
+	     st->n.sym->ns->proc_name->name);
+  else
+    show_symbol (st->n.sym);
+}
+
+
+/******************* Show gfc_code structures **************/
+
+
+/* Show a list of code structures.  Mutually recursive with
+   show_code_node().  */
+
+static void
+show_code (int level, gfc_code *c)
+{
+  for (; c; c = c->next)
+    show_code_node (level, c);
+}
+
+static void
+show_namelist (gfc_namelist *n)
+{
+  for (; n->next; n = n->next)
+    fprintf (dumpfile, "%s,", n->sym->name);
+  fprintf (dumpfile, "%s", n->sym->name);
+}
+
+/* Show a single OpenMP directive node and everything underneath it
+   if necessary.  */
+
+static void
+show_omp_node (int level, gfc_code *c)
+{
+  gfc_omp_clauses *omp_clauses = NULL;
+  const char *name = NULL;
+
+  switch (c->op)
+    {
+    case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
+    case EXEC_OMP_BARRIER: name = "BARRIER"; break;
+    case EXEC_OMP_CRITICAL: name = "CRITICAL"; break;
+    case EXEC_OMP_FLUSH: name = "FLUSH"; break;
+    case EXEC_OMP_DO: name = "DO"; break;
+    case EXEC_OMP_MASTER: name = "MASTER"; break;
+    case EXEC_OMP_ORDERED: name = "ORDERED"; break;
+    case EXEC_OMP_PARALLEL: name = "PARALLEL"; break;
+    case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break;
+    case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break;
+    case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break;
+    case EXEC_OMP_SECTIONS: name = "SECTIONS"; break;
+    case EXEC_OMP_SINGLE: name = "SINGLE"; break;
+    case EXEC_OMP_TASK: name = "TASK"; break;
+    case EXEC_OMP_TASKWAIT: name = "TASKWAIT"; break;
+    case EXEC_OMP_TASKYIELD: name = "TASKYIELD"; break;
+    case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break;
+    default:
+      gcc_unreachable ();
+    }
+  fprintf (dumpfile, "!$OMP %s", name);
+  switch (c->op)
+    {
+    case EXEC_OMP_DO:
+    case EXEC_OMP_PARALLEL:
+    case EXEC_OMP_PARALLEL_DO:
+    case EXEC_OMP_PARALLEL_SECTIONS:
+    case EXEC_OMP_SECTIONS:
+    case EXEC_OMP_SINGLE:
+    case EXEC_OMP_WORKSHARE:
+    case EXEC_OMP_PARALLEL_WORKSHARE:
+    case EXEC_OMP_TASK:
+      omp_clauses = c->ext.omp_clauses;
+      break;
+    case EXEC_OMP_CRITICAL:
+      if (c->ext.omp_name)
+	fprintf (dumpfile, " (%s)", c->ext.omp_name);
+      break;
+    case EXEC_OMP_FLUSH:
+      if (c->ext.omp_namelist)
+	{
+	  fputs (" (", dumpfile);
+	  show_namelist (c->ext.omp_namelist);
+	  fputc (')', dumpfile);
+	}
+      return;
+    case EXEC_OMP_BARRIER:
+    case EXEC_OMP_TASKWAIT:
+    case EXEC_OMP_TASKYIELD:
+      return;
+    default:
+      break;
+    }
+  if (omp_clauses)
+    {
+      int list_type;
+
+      if (omp_clauses->if_expr)
+	{
+	  fputs (" IF(", dumpfile);
+	  show_expr (omp_clauses->if_expr);
+	  fputc (')', dumpfile);
+	}
+      if (omp_clauses->final_expr)
+	{
+	  fputs (" FINAL(", dumpfile);
+	  show_expr (omp_clauses->final_expr);
+	  fputc (')', dumpfile);
+	}
+      if (omp_clauses->num_threads)
+	{
+	  fputs (" NUM_THREADS(", dumpfile);
+	  show_expr (omp_clauses->num_threads);
+	  fputc (')', dumpfile);
+	}
+      if (omp_clauses->sched_kind != OMP_SCHED_NONE)
+	{
+	  const char *type;
+	  switch (omp_clauses->sched_kind)
+	    {
+	    case OMP_SCHED_STATIC: type = "STATIC"; break;
+	    case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break;
+	    case OMP_SCHED_GUIDED: type = "GUIDED"; break;
+	    case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
+	    case OMP_SCHED_AUTO: type = "AUTO"; break;
+	    default:
+	      gcc_unreachable ();
+	    }
+	  fprintf (dumpfile, " SCHEDULE (%s", type);
+	  if (omp_clauses->chunk_size)
+	    {
+	      fputc (',', dumpfile);
+	      show_expr (omp_clauses->chunk_size);
+	    }
+	  fputc (')', dumpfile);
+	}
+      if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
+	{
+	  const char *type;
+	  switch (omp_clauses->default_sharing)
+	    {
+	    case OMP_DEFAULT_NONE: type = "NONE"; break;
+	    case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break;
+	    case OMP_DEFAULT_SHARED: type = "SHARED"; break;
+	    case OMP_DEFAULT_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
+	    default:
+	      gcc_unreachable ();
+	    }
+	  fprintf (dumpfile, " DEFAULT(%s)", type);
+	}
+      if (omp_clauses->ordered)
+	fputs (" ORDERED", dumpfile);
+      if (omp_clauses->untied)
+	fputs (" UNTIED", dumpfile);
+      if (omp_clauses->mergeable)
+	fputs (" MERGEABLE", dumpfile);
+      if (omp_clauses->collapse)
+	fprintf (dumpfile, " COLLAPSE(%d)", omp_clauses->collapse);
+      for (list_type = 0; list_type < OMP_LIST_NUM; list_type++)
+	if (omp_clauses->lists[list_type] != NULL
+	    && list_type != OMP_LIST_COPYPRIVATE)
+	  {
+	    const char *type;
+	    if (list_type >= OMP_LIST_REDUCTION_FIRST)
+	      {
+		switch (list_type)
+		  {
+		  case OMP_LIST_PLUS: type = "+"; break;
+		  case OMP_LIST_MULT: type = "*"; break;
+		  case OMP_LIST_SUB: type = "-"; break;
+		  case OMP_LIST_AND: type = ".AND."; break;
+		  case OMP_LIST_OR: type = ".OR."; break;
+		  case OMP_LIST_EQV: type = ".EQV."; break;
+		  case OMP_LIST_NEQV: type = ".NEQV."; break;
+		  case OMP_LIST_MAX: type = "MAX"; break;
+		  case OMP_LIST_MIN: type = "MIN"; break;
+		  case OMP_LIST_IAND: type = "IAND"; break;
+		  case OMP_LIST_IOR: type = "IOR"; break;
+		  case OMP_LIST_IEOR: type = "IEOR"; break;
+		  default:
+		    gcc_unreachable ();
+		  }
+		fprintf (dumpfile, " REDUCTION(%s:", type);
+	      }
+	    else
+	      {
+		switch (list_type)
+		  {
+		  case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
+		  case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
+		  case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
+		  case OMP_LIST_SHARED: type = "SHARED"; break;
+		  case OMP_LIST_COPYIN: type = "COPYIN"; break;
+		  default:
+		    gcc_unreachable ();
+		  }
+		fprintf (dumpfile, " %s(", type);
+	      }
+	    show_namelist (omp_clauses->lists[list_type]);
+	    fputc (')', dumpfile);
+	  }
+    }
+  fputc ('\n', dumpfile);
+  if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
+    {
+      gfc_code *d = c->block;
+      while (d != NULL)
+	{
+	  show_code (level + 1, d->next);
+	  if (d->block == NULL)
+	    break;
+	  code_indent (level, 0);
+	  fputs ("!$OMP SECTION\n", dumpfile);
+	  d = d->block;
+	}
+    }
+  else
+    show_code (level + 1, c->block->next);
+  if (c->op == EXEC_OMP_ATOMIC)
+    return;
+  code_indent (level, 0);
+  fprintf (dumpfile, "!$OMP END %s", name);
+  if (omp_clauses != NULL)
+    {
+      if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
+	{
+	  fputs (" COPYPRIVATE(", dumpfile);
+	  show_namelist (omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
+	  fputc (')', dumpfile);
+	}
+      else if (omp_clauses->nowait)
+	fputs (" NOWAIT", dumpfile);
+    }
+  else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_name)
+    fprintf (dumpfile, " (%s)", c->ext.omp_name);
+}
+
+
+/* Show a single code node and everything underneath it if necessary.  */
+
+static void
+show_code_node (int level, gfc_code *c)
+{
+  gfc_forall_iterator *fa;
+  gfc_open *open;
+  gfc_case *cp;
+  gfc_alloc *a;
+  gfc_code *d;
+  gfc_close *close;
+  gfc_filepos *fp;
+  gfc_inquire *i;
+  gfc_dt *dt;
+  gfc_namespace *ns;
+
+  if (c->here)
+    {
+      fputc ('\n', dumpfile);
+      code_indent (level, c->here);
+    }
+  else
+    show_indent ();
+
+  switch (c->op)
+    {
+    case EXEC_END_PROCEDURE:
+      break;
+
+    case EXEC_NOP:
+      fputs ("NOP", dumpfile);
+      break;
+
+    case EXEC_CONTINUE:
+      fputs ("CONTINUE", dumpfile);
+      break;
+
+    case EXEC_ENTRY:
+      fprintf (dumpfile, "ENTRY %s", c->ext.entry->sym->name);
+      break;
+
+    case EXEC_INIT_ASSIGN:
+    case EXEC_ASSIGN:
+      fputs ("ASSIGN ", dumpfile);
+      show_expr (c->expr1);
+      fputc (' ', dumpfile);
+      show_expr (c->expr2);
+      break;
+
+    case EXEC_LABEL_ASSIGN:
+      fputs ("LABEL ASSIGN ", dumpfile);
+      show_expr (c->expr1);
+      fprintf (dumpfile, " %d", c->label1->value);
+      break;
+
+    case EXEC_POINTER_ASSIGN:
+      fputs ("POINTER ASSIGN ", dumpfile);
+      show_expr (c->expr1);
+      fputc (' ', dumpfile);
+      show_expr (c->expr2);
+      break;
+
+    case EXEC_GOTO:
+      fputs ("GOTO ", dumpfile);
+      if (c->label1)
+	fprintf (dumpfile, "%d", c->label1->value);
+      else
+	{
+	  show_expr (c->expr1);
+	  d = c->block;
+	  if (d != NULL)
+	    {
+	      fputs (", (", dumpfile);
+	      for (; d; d = d ->block)
+		{
+		  code_indent (level, d->label1);
+		  if (d->block != NULL)
+		    fputc (',', dumpfile);
+		  else
+		    fputc (')', dumpfile);
+		}
+	    }
+	}
+      break;
+
+    case EXEC_CALL:
+    case EXEC_ASSIGN_CALL:
+      if (c->resolved_sym)
+	fprintf (dumpfile, "CALL %s ", c->resolved_sym->name);
+      else if (c->symtree)
+	fprintf (dumpfile, "CALL %s ", c->symtree->name);
+      else
+	fputs ("CALL ?? ", dumpfile);
+
+      show_actual_arglist (c->ext.actual);
+      break;
+
+    case EXEC_COMPCALL:
+      fputs ("CALL ", dumpfile);
+      show_compcall (c->expr1);
+      break;
+
+    case EXEC_CALL_PPC:
+      fputs ("CALL ", dumpfile);
+      show_expr (c->expr1);
+      show_actual_arglist (c->ext.actual);
+      break;
+
+    case EXEC_RETURN:
+      fputs ("RETURN ", dumpfile);
+      if (c->expr1)
+	show_expr (c->expr1);
+      break;
+
+    case EXEC_PAUSE:
+      fputs ("PAUSE ", dumpfile);
+
+      if (c->expr1 != NULL)
+	show_expr (c->expr1);
+      else
+	fprintf (dumpfile, "%d", c->ext.stop_code);
+
+      break;
+
+    case EXEC_ERROR_STOP:
+      fputs ("ERROR ", dumpfile);
+      /* Fall through.  */
+
+    case EXEC_STOP:
+      fputs ("STOP ", dumpfile);
+
+      if (c->expr1 != NULL)
+	show_expr (c->expr1);
+      else
+	fprintf (dumpfile, "%d", c->ext.stop_code);
+
+      break;
+
+    case EXEC_SYNC_ALL:
+      fputs ("SYNC ALL ", dumpfile);
+      if (c->expr2 != NULL)
+	{
+	  fputs (" stat=", dumpfile);
+	  show_expr (c->expr2);
+	}
+      if (c->expr3 != NULL)
+	{
+	  fputs (" errmsg=", dumpfile);
+	  show_expr (c->expr3);
+	}
+      break;
+
+    case EXEC_SYNC_MEMORY:
+      fputs ("SYNC MEMORY ", dumpfile);
+      if (c->expr2 != NULL)
+ 	{
+	  fputs (" stat=", dumpfile);
+	  show_expr (c->expr2);
+	}
+      if (c->expr3 != NULL)
+	{
+	  fputs (" errmsg=", dumpfile);
+	  show_expr (c->expr3);
+	}
+      break;
+
+    case EXEC_SYNC_IMAGES:
+      fputs ("SYNC IMAGES  image-set=", dumpfile);
+      if (c->expr1 != NULL)
+	show_expr (c->expr1);
+      else
+	fputs ("* ", dumpfile);
+      if (c->expr2 != NULL)
+	{
+	  fputs (" stat=", dumpfile);
+	  show_expr (c->expr2);
+	}
+      if (c->expr3 != NULL)
+	{
+	  fputs (" errmsg=", dumpfile);
+	  show_expr (c->expr3);
+	}
+      break;
+
+    case EXEC_LOCK:
+    case EXEC_UNLOCK:
+      if (c->op == EXEC_LOCK)
+	fputs ("LOCK ", dumpfile);
+      else
+	fputs ("UNLOCK ", dumpfile);
+
+      fputs ("lock-variable=", dumpfile);
+      if (c->expr1 != NULL)
+	show_expr (c->expr1);
+      if (c->expr4 != NULL)
+	{
+	  fputs (" acquired_lock=", dumpfile);
+	  show_expr (c->expr4);
+	}
+      if (c->expr2 != NULL)
+	{
+	  fputs (" stat=", dumpfile);
+	  show_expr (c->expr2);
+	}
+      if (c->expr3 != NULL)
+	{
+	  fputs (" errmsg=", dumpfile);
+	  show_expr (c->expr3);
+	}
+      break;
+
+    case EXEC_ARITHMETIC_IF:
+      fputs ("IF ", dumpfile);
+      show_expr (c->expr1);
+      fprintf (dumpfile, " %d, %d, %d",
+		  c->label1->value, c->label2->value, c->label3->value);
+      break;
+
+    case EXEC_IF:
+      d = c->block;
+      fputs ("IF ", dumpfile);
+      show_expr (d->expr1);
+
+      ++show_level;
+      show_code (level + 1, d->next);
+      --show_level;
+
+      d = d->block;
+      for (; d; d = d->block)
+	{
+	  code_indent (level, 0);
+
+	  if (d->expr1 == NULL)
+	    fputs ("ELSE", dumpfile);
+	  else
+	    {
+	      fputs ("ELSE IF ", dumpfile);
+	      show_expr (d->expr1);
+	    }
+
+	  ++show_level;
+	  show_code (level + 1, d->next);
+	  --show_level;
+	}
+
+      if (c->label1)
+	code_indent (level, c->label1);
+      else
+	show_indent ();
+
+      fputs ("ENDIF", dumpfile);
+      break;
+
+    case EXEC_BLOCK:
+      {
+	const char* blocktype;
+	gfc_namespace *saved_ns;
+
+	if (c->ext.block.assoc)
+	  blocktype = "ASSOCIATE";
+	else
+	  blocktype = "BLOCK";
+	show_indent ();
+	fprintf (dumpfile, "%s ", blocktype);
+	++show_level;
+	ns = c->ext.block.ns;
+	saved_ns = gfc_current_ns;
+	gfc_current_ns = ns;
+	gfc_traverse_symtree (ns->sym_root, show_symtree);
+	gfc_current_ns = saved_ns;
+	show_code (show_level, ns->code);
+	--show_level;
+	show_indent ();
+	fprintf (dumpfile, "END %s ", blocktype);
+	break;
+      }
+
+    case EXEC_SELECT:
+      d = c->block;
+      fputs ("SELECT CASE ", dumpfile);
+      show_expr (c->expr1);
+      fputc ('\n', dumpfile);
+
+      for (; d; d = d->block)
+	{
+	  code_indent (level, 0);
+
+	  fputs ("CASE ", dumpfile);
+	  for (cp = d->ext.block.case_list; cp; cp = cp->next)
+	    {
+	      fputc ('(', dumpfile);
+	      show_expr (cp->low);
+	      fputc (' ', dumpfile);
+	      show_expr (cp->high);
+	      fputc (')', dumpfile);
+	      fputc (' ', dumpfile);
+	    }
+	  fputc ('\n', dumpfile);
+
+	  show_code (level + 1, d->next);
+	}
+
+      code_indent (level, c->label1);
+      fputs ("END SELECT", dumpfile);
+      break;
+
+    case EXEC_WHERE:
+      fputs ("WHERE ", dumpfile);
+
+      d = c->block;
+      show_expr (d->expr1);
+      fputc ('\n', dumpfile);
+
+      show_code (level + 1, d->next);
+
+      for (d = d->block; d; d = d->block)
+	{
+	  code_indent (level, 0);
+	  fputs ("ELSE WHERE ", dumpfile);
+	  show_expr (d->expr1);
+	  fputc ('\n', dumpfile);
+	  show_code (level + 1, d->next);
+	}
+
+      code_indent (level, 0);
+      fputs ("END WHERE", dumpfile);
+      break;
+
+
+    case EXEC_FORALL:
+      fputs ("FORALL ", dumpfile);
+      for (fa = c->ext.forall_iterator; fa; fa = fa->next)
+	{
+	  show_expr (fa->var);
+	  fputc (' ', dumpfile);
+	  show_expr (fa->start);
+	  fputc (':', dumpfile);
+	  show_expr (fa->end);
+	  fputc (':', dumpfile);
+	  show_expr (fa->stride);
+
+	  if (fa->next != NULL)
+	    fputc (',', dumpfile);
+	}
+
+      if (c->expr1 != NULL)
+	{
+	  fputc (',', dumpfile);
+	  show_expr (c->expr1);
+	}
+      fputc ('\n', dumpfile);
+
+      show_code (level + 1, c->block->next);
+
+      code_indent (level, 0);
+      fputs ("END FORALL", dumpfile);
+      break;
+
+    case EXEC_CRITICAL:
+      fputs ("CRITICAL\n", dumpfile);
+      show_code (level + 1, c->block->next);
+      code_indent (level, 0);
+      fputs ("END CRITICAL", dumpfile);
+      break;
+
+    case EXEC_DO:
+      fputs ("DO ", dumpfile);
+      if (c->label1)
+	fprintf (dumpfile, " %-5d ", c->label1->value);
+
+      show_expr (c->ext.iterator->var);
+      fputc ('=', dumpfile);
+      show_expr (c->ext.iterator->start);
+      fputc (' ', dumpfile);
+      show_expr (c->ext.iterator->end);
+      fputc (' ', dumpfile);
+      show_expr (c->ext.iterator->step);
+
+      ++show_level;
+      show_code (level + 1, c->block->next);
+      --show_level;
+
+      if (c->label1)
+	break;
+
+      show_indent ();
+      fputs ("END DO", dumpfile);
+      break;
+
+    case EXEC_DO_CONCURRENT:
+      fputs ("DO CONCURRENT ", dumpfile);
+      for (fa = c->ext.forall_iterator; fa; fa = fa->next)
+        {
+          show_expr (fa->var);
+          fputc (' ', dumpfile);
+          show_expr (fa->start);
+          fputc (':', dumpfile);
+          show_expr (fa->end);
+          fputc (':', dumpfile);
+          show_expr (fa->stride);
+
+          if (fa->next != NULL)
+            fputc (',', dumpfile);
+        }
+      show_expr (c->expr1);
+
+      show_code (level + 1, c->block->next);
+      code_indent (level, c->label1);
+      fputs ("END DO", dumpfile);
+      break;
+
+    case EXEC_DO_WHILE:
+      fputs ("DO WHILE ", dumpfile);
+      show_expr (c->expr1);
+      fputc ('\n', dumpfile);
+
+      show_code (level + 1, c->block->next);
+
+      code_indent (level, c->label1);
+      fputs ("END DO", dumpfile);
+      break;
+
+    case EXEC_CYCLE:
+      fputs ("CYCLE", dumpfile);
+      if (c->symtree)
+	fprintf (dumpfile, " %s", c->symtree->n.sym->name);
+      break;
+
+    case EXEC_EXIT:
+      fputs ("EXIT", dumpfile);
+      if (c->symtree)
+	fprintf (dumpfile, " %s", c->symtree->n.sym->name);
+      break;
+
+    case EXEC_ALLOCATE:
+      fputs ("ALLOCATE ", dumpfile);
+      if (c->expr1)
+	{
+	  fputs (" STAT=", dumpfile);
+	  show_expr (c->expr1);
+	}
+
+      if (c->expr2)
+	{
+	  fputs (" ERRMSG=", dumpfile);
+	  show_expr (c->expr2);
+	}
+
+      if (c->expr3)
+	{
+	  if (c->expr3->mold)
+	    fputs (" MOLD=", dumpfile);
+	  else
+	    fputs (" SOURCE=", dumpfile);
+	  show_expr (c->expr3);
+	}
+
+      for (a = c->ext.alloc.list; a; a = a->next)
+	{
+	  fputc (' ', dumpfile);
+	  show_expr (a->expr);
+	}
+
+      break;
+
+    case EXEC_DEALLOCATE:
+      fputs ("DEALLOCATE ", dumpfile);
+      if (c->expr1)
+	{
+	  fputs (" STAT=", dumpfile);
+	  show_expr (c->expr1);
+	}
+
+      if (c->expr2)
+	{
+	  fputs (" ERRMSG=", dumpfile);
+	  show_expr (c->expr2);
+	}
+
+      for (a = c->ext.alloc.list; a; a = a->next)
+	{
+	  fputc (' ', dumpfile);
+	  show_expr (a->expr);
+	}
+
+      break;
+
+    case EXEC_OPEN:
+      fputs ("OPEN", dumpfile);
+      open = c->ext.open;
+
+      if (open->unit)
+	{
+	  fputs (" UNIT=", dumpfile);
+	  show_expr (open->unit);
+	}
+      if (open->iomsg)
+	{
+	  fputs (" IOMSG=", dumpfile);
+	  show_expr (open->iomsg);
+	}
+      if (open->iostat)
+	{
+	  fputs (" IOSTAT=", dumpfile);
+	  show_expr (open->iostat);
+	}
+      if (open->file)
+	{
+	  fputs (" FILE=", dumpfile);
+	  show_expr (open->file);
+	}
+      if (open->status)
+	{
+	  fputs (" STATUS=", dumpfile);
+	  show_expr (open->status);
+	}
+      if (open->access)
+	{
+	  fputs (" ACCESS=", dumpfile);
+	  show_expr (open->access);
+	}
+      if (open->form)
+	{
+	  fputs (" FORM=", dumpfile);
+	  show_expr (open->form);
+	}
+      if (open->recl)
+	{
+	  fputs (" RECL=", dumpfile);
+	  show_expr (open->recl);
+	}
+      if (open->blank)
+	{
+	  fputs (" BLANK=", dumpfile);
+	  show_expr (open->blank);
+	}
+      if (open->position)
+	{
+	  fputs (" POSITION=", dumpfile);
+	  show_expr (open->position);
+	}
+      if (open->action)
+	{
+	  fputs (" ACTION=", dumpfile);
+	  show_expr (open->action);
+	}
+      if (open->delim)
+	{
+	  fputs (" DELIM=", dumpfile);
+	  show_expr (open->delim);
+	}
+      if (open->pad)
+	{
+	  fputs (" PAD=", dumpfile);
+	  show_expr (open->pad);
+	}
+      if (open->decimal)
+	{
+	  fputs (" DECIMAL=", dumpfile);
+	  show_expr (open->decimal);
+	}
+      if (open->encoding)
+	{
+	  fputs (" ENCODING=", dumpfile);
+	  show_expr (open->encoding);
+	}
+      if (open->round)
+	{
+	  fputs (" ROUND=", dumpfile);
+	  show_expr (open->round);
+	}
+      if (open->sign)
+	{
+	  fputs (" SIGN=", dumpfile);
+	  show_expr (open->sign);
+	}
+      if (open->convert)
+	{
+	  fputs (" CONVERT=", dumpfile);
+	  show_expr (open->convert);
+	}
+      if (open->asynchronous)
+	{
+	  fputs (" ASYNCHRONOUS=", dumpfile);
+	  show_expr (open->asynchronous);
+	}
+      if (open->err != NULL)
+	fprintf (dumpfile, " ERR=%d", open->err->value);
+
+      break;
+
+    case EXEC_CLOSE:
+      fputs ("CLOSE", dumpfile);
+      close = c->ext.close;
+
+      if (close->unit)
+	{
+	  fputs (" UNIT=", dumpfile);
+	  show_expr (close->unit);
+	}
+      if (close->iomsg)
+	{
+	  fputs (" IOMSG=", dumpfile);
+	  show_expr (close->iomsg);
+	}
+      if (close->iostat)
+	{
+	  fputs (" IOSTAT=", dumpfile);
+	  show_expr (close->iostat);
+	}
+      if (close->status)
+	{
+	  fputs (" STATUS=", dumpfile);
+	  show_expr (close->status);
+	}
+      if (close->err != NULL)
+	fprintf (dumpfile, " ERR=%d", close->err->value);
+      break;
+
+    case EXEC_BACKSPACE:
+      fputs ("BACKSPACE", dumpfile);
+      goto show_filepos;
+
+    case EXEC_ENDFILE:
+      fputs ("ENDFILE", dumpfile);
+      goto show_filepos;
+
+    case EXEC_REWIND:
+      fputs ("REWIND", dumpfile);
+      goto show_filepos;
+
+    case EXEC_FLUSH:
+      fputs ("FLUSH", dumpfile);
+
+    show_filepos:
+      fp = c->ext.filepos;
+
+      if (fp->unit)
+	{
+	  fputs (" UNIT=", dumpfile);
+	  show_expr (fp->unit);
+	}
+      if (fp->iomsg)
+	{
+	  fputs (" IOMSG=", dumpfile);
+	  show_expr (fp->iomsg);
+	}
+      if (fp->iostat)
+	{
+	  fputs (" IOSTAT=", dumpfile);
+	  show_expr (fp->iostat);
+	}
+      if (fp->err != NULL)
+	fprintf (dumpfile, " ERR=%d", fp->err->value);
+      break;
+
+    case EXEC_INQUIRE:
+      fputs ("INQUIRE", dumpfile);
+      i = c->ext.inquire;
+
+      if (i->unit)
+	{
+	  fputs (" UNIT=", dumpfile);
+	  show_expr (i->unit);
+	}
+      if (i->file)
+	{
+	  fputs (" FILE=", dumpfile);
+	  show_expr (i->file);
+	}
+
+      if (i->iomsg)
+	{
+	  fputs (" IOMSG=", dumpfile);
+	  show_expr (i->iomsg);
+	}
+      if (i->iostat)
+	{
+	  fputs (" IOSTAT=", dumpfile);
+	  show_expr (i->iostat);
+	}
+      if (i->exist)
+	{
+	  fputs (" EXIST=", dumpfile);
+	  show_expr (i->exist);
+	}
+      if (i->opened)
+	{
+	  fputs (" OPENED=", dumpfile);
+	  show_expr (i->opened);
+	}
+      if (i->number)
+	{
+	  fputs (" NUMBER=", dumpfile);
+	  show_expr (i->number);
+	}
+      if (i->named)
+	{
+	  fputs (" NAMED=", dumpfile);
+	  show_expr (i->named);
+	}
+      if (i->name)
+	{
+	  fputs (" NAME=", dumpfile);
+	  show_expr (i->name);
+	}
+      if (i->access)
+	{
+	  fputs (" ACCESS=", dumpfile);
+	  show_expr (i->access);
+	}
+      if (i->sequential)
+	{
+	  fputs (" SEQUENTIAL=", dumpfile);
+	  show_expr (i->sequential);
+	}
+
+      if (i->direct)
+	{
+	  fputs (" DIRECT=", dumpfile);
+	  show_expr (i->direct);
+	}
+      if (i->form)
+	{
+	  fputs (" FORM=", dumpfile);
+	  show_expr (i->form);
+	}
+      if (i->formatted)
+	{
+	  fputs (" FORMATTED", dumpfile);
+	  show_expr (i->formatted);
+	}
+      if (i->unformatted)
+	{
+	  fputs (" UNFORMATTED=", dumpfile);
+	  show_expr (i->unformatted);
+	}
+      if (i->recl)
+	{
+	  fputs (" RECL=", dumpfile);
+	  show_expr (i->recl);
+	}
+      if (i->nextrec)
+	{
+	  fputs (" NEXTREC=", dumpfile);
+	  show_expr (i->nextrec);
+	}
+      if (i->blank)
+	{
+	  fputs (" BLANK=", dumpfile);
+	  show_expr (i->blank);
+	}
+      if (i->position)
+	{
+	  fputs (" POSITION=", dumpfile);
+	  show_expr (i->position);
+	}
+      if (i->action)
+	{
+	  fputs (" ACTION=", dumpfile);
+	  show_expr (i->action);
+	}
+      if (i->read)
+	{
+	  fputs (" READ=", dumpfile);
+	  show_expr (i->read);
+	}
+      if (i->write)
+	{
+	  fputs (" WRITE=", dumpfile);
+	  show_expr (i->write);
+	}
+      if (i->readwrite)
+	{
+	  fputs (" READWRITE=", dumpfile);
+	  show_expr (i->readwrite);
+	}
+      if (i->delim)
+	{
+	  fputs (" DELIM=", dumpfile);
+	  show_expr (i->delim);
+	}
+      if (i->pad)
+	{
+	  fputs (" PAD=", dumpfile);
+	  show_expr (i->pad);
+	}
+      if (i->convert)
+	{
+	  fputs (" CONVERT=", dumpfile);
+	  show_expr (i->convert);
+	}
+      if (i->asynchronous)
+	{
+	  fputs (" ASYNCHRONOUS=", dumpfile);
+	  show_expr (i->asynchronous);
+	}
+      if (i->decimal)
+	{
+	  fputs (" DECIMAL=", dumpfile);
+	  show_expr (i->decimal);
+	}
+      if (i->encoding)
+	{
+	  fputs (" ENCODING=", dumpfile);
+	  show_expr (i->encoding);
+	}
+      if (i->pending)
+	{
+	  fputs (" PENDING=", dumpfile);
+	  show_expr (i->pending);
+	}
+      if (i->round)
+	{
+	  fputs (" ROUND=", dumpfile);
+	  show_expr (i->round);
+	}
+      if (i->sign)
+	{
+	  fputs (" SIGN=", dumpfile);
+	  show_expr (i->sign);
+	}
+      if (i->size)
+	{
+	  fputs (" SIZE=", dumpfile);
+	  show_expr (i->size);
+	}
+      if (i->id)
+	{
+	  fputs (" ID=", dumpfile);
+	  show_expr (i->id);
+	}
+
+      if (i->err != NULL)
+	fprintf (dumpfile, " ERR=%d", i->err->value);
+      break;
+
+    case EXEC_IOLENGTH:
+      fputs ("IOLENGTH ", dumpfile);
+      show_expr (c->expr1);
+      goto show_dt_code;
+      break;
+
+    case EXEC_READ:
+      fputs ("READ", dumpfile);
+      goto show_dt;
+
+    case EXEC_WRITE:
+      fputs ("WRITE", dumpfile);
+
+    show_dt:
+      dt = c->ext.dt;
+      if (dt->io_unit)
+	{
+	  fputs (" UNIT=", dumpfile);
+	  show_expr (dt->io_unit);
+	}
+
+      if (dt->format_expr)
+	{
+	  fputs (" FMT=", dumpfile);
+	  show_expr (dt->format_expr);
+	}
+
+      if (dt->format_label != NULL)
+	fprintf (dumpfile, " FMT=%d", dt->format_label->value);
+      if (dt->namelist)
+	fprintf (dumpfile, " NML=%s", dt->namelist->name);
+
+      if (dt->iomsg)
+	{
+	  fputs (" IOMSG=", dumpfile);
+	  show_expr (dt->iomsg);
+	}
+      if (dt->iostat)
+	{
+	  fputs (" IOSTAT=", dumpfile);
+	  show_expr (dt->iostat);
+	}
+      if (dt->size)
+	{
+	  fputs (" SIZE=", dumpfile);
+	  show_expr (dt->size);
+	}
+      if (dt->rec)
+	{
+	  fputs (" REC=", dumpfile);
+	  show_expr (dt->rec);
+	}
+      if (dt->advance)
+	{
+	  fputs (" ADVANCE=", dumpfile);
+	  show_expr (dt->advance);
+	}
+      if (dt->id)
+	{
+	  fputs (" ID=", dumpfile);
+	  show_expr (dt->id);
+	}
+      if (dt->pos)
+	{
+	  fputs (" POS=", dumpfile);
+	  show_expr (dt->pos);
+	}
+      if (dt->asynchronous)
+	{
+	  fputs (" ASYNCHRONOUS=", dumpfile);
+	  show_expr (dt->asynchronous);
+	}
+      if (dt->blank)
+	{
+	  fputs (" BLANK=", dumpfile);
+	  show_expr (dt->blank);
+	}
+      if (dt->decimal)
+	{
+	  fputs (" DECIMAL=", dumpfile);
+	  show_expr (dt->decimal);
+	}
+      if (dt->delim)
+	{
+	  fputs (" DELIM=", dumpfile);
+	  show_expr (dt->delim);
+	}
+      if (dt->pad)
+	{
+	  fputs (" PAD=", dumpfile);
+	  show_expr (dt->pad);
+	}
+      if (dt->round)
+	{
+	  fputs (" ROUND=", dumpfile);
+	  show_expr (dt->round);
+	}
+      if (dt->sign)
+	{
+	  fputs (" SIGN=", dumpfile);
+	  show_expr (dt->sign);
+	}
+
+    show_dt_code:
+      for (c = c->block->next; c; c = c->next)
+	show_code_node (level + (c->next != NULL), c);
+      return;
+
+    case EXEC_TRANSFER:
+      fputs ("TRANSFER ", dumpfile);
+      show_expr (c->expr1);
+      break;
+
+    case EXEC_DT_END:
+      fputs ("DT_END", dumpfile);
+      dt = c->ext.dt;
+
+      if (dt->err != NULL)
+	fprintf (dumpfile, " ERR=%d", dt->err->value);
+      if (dt->end != NULL)
+	fprintf (dumpfile, " END=%d", dt->end->value);
+      if (dt->eor != NULL)
+	fprintf (dumpfile, " EOR=%d", dt->eor->value);
+      break;
+
+    case EXEC_OMP_ATOMIC:
+    case EXEC_OMP_BARRIER:
+    case EXEC_OMP_CRITICAL:
+    case EXEC_OMP_FLUSH:
+    case EXEC_OMP_DO:
+    case EXEC_OMP_MASTER:
+    case EXEC_OMP_ORDERED:
+    case EXEC_OMP_PARALLEL:
+    case EXEC_OMP_PARALLEL_DO:
+    case EXEC_OMP_PARALLEL_SECTIONS:
+    case EXEC_OMP_PARALLEL_WORKSHARE:
+    case EXEC_OMP_SECTIONS:
+    case EXEC_OMP_SINGLE:
+    case EXEC_OMP_TASK:
+    case EXEC_OMP_TASKWAIT:
+    case EXEC_OMP_TASKYIELD:
+    case EXEC_OMP_WORKSHARE:
+      show_omp_node (level, c);
+      break;
+
+    default:
+      gfc_internal_error ("show_code_node(): Bad statement code");
+    }
+}
+
+
+/* Show an equivalence chain.  */
+
+static void
+show_equiv (gfc_equiv *eq)
+{
+  show_indent ();
+  fputs ("Equivalence: ", dumpfile);
+  while (eq)
+    {
+      show_expr (eq->expr);
+      eq = eq->eq;
+      if (eq)
+	fputs (", ", dumpfile);
+    }
+}
+
+
+/* Show a freakin' whole namespace.  */
+
+static void
+show_namespace (gfc_namespace *ns)
+{
+  gfc_interface *intr;
+  gfc_namespace *save;
+  int op;
+  gfc_equiv *eq;
+  int i;
+
+  gcc_assert (ns);
+  save = gfc_current_ns;
+
+  show_indent ();
+  fputs ("Namespace:", dumpfile);
+
+  i = 0;
+  do
+    {
+      int l = i;
+      while (i < GFC_LETTERS - 1
+	     && gfc_compare_types (&ns->default_type[i+1],
+				   &ns->default_type[l]))
+	i++;
+
+      if (i > l)
+	fprintf (dumpfile, " %c-%c: ", l+'A', i+'A');
+      else
+	fprintf (dumpfile, " %c: ", l+'A');
+
+      show_typespec(&ns->default_type[l]);
+      i++;
+    } while (i < GFC_LETTERS);
+
+  if (ns->proc_name != NULL)
+    {
+      show_indent ();
+      fprintf (dumpfile, "procedure name = %s", ns->proc_name->name);
+    }
+
+  ++show_level;
+  gfc_current_ns = ns;
+  gfc_traverse_symtree (ns->common_root, show_common);
+
+  gfc_traverse_symtree (ns->sym_root, show_symtree);
+
+  for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
+    {
+      /* User operator interfaces */
+      intr = ns->op[op];
+      if (intr == NULL)
+	continue;
+
+      show_indent ();
+      fprintf (dumpfile, "Operator interfaces for %s:",
+	       gfc_op2string ((gfc_intrinsic_op) op));
+
+      for (; intr; intr = intr->next)
+	fprintf (dumpfile, " %s", intr->sym->name);
+    }
+
+  if (ns->uop_root != NULL)
+    {
+      show_indent ();
+      fputs ("User operators:\n", dumpfile);
+      gfc_traverse_user_op (ns, show_uop);
+    }
+  
+  for (eq = ns->equiv; eq; eq = eq->next)
+    show_equiv (eq);
+
+  fputc ('\n', dumpfile);
+  show_indent ();
+  fputs ("code:", dumpfile);
+  show_code (show_level, ns->code);
+  --show_level;
+
+  for (ns = ns->contained; ns; ns = ns->sibling)
+    {
+      fputs ("\nCONTAINS\n", dumpfile);
+      ++show_level;
+      show_namespace (ns);
+      --show_level;
+    }
+
+  fputc ('\n', dumpfile);
+  gfc_current_ns = save;
+}
+
+
+/* Main function for dumping a parse tree.  */
+
+void
+gfc_dump_parse_tree (gfc_namespace *ns, FILE *file)
+{
+  dumpfile = file;
+  show_namespace (ns);
+}
+
diff --git a/gcc-4.9/gcc/fortran/error.c b/gcc-4.9/gcc/fortran/error.c
new file mode 100644
index 000000000..e843fa5a9
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/error.c
@@ -0,0 +1,1207 @@
+/* Handle errors.
+   Copyright (C) 2000-2014 Free Software Foundation, Inc.
+   Contributed by Andy Vaught & Niels Kristian Bech Jensen
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+/* Handle the inevitable errors.  A major catch here is that things
+   flagged as errors in one match subroutine can conceivably be legal
+   elsewhere.  This means that error messages are recorded and saved
+   for possible use later.  If a line does not match a legal
+   construction, then the saved error message is reported.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "flags.h"
+#include "gfortran.h"
+
+#ifdef HAVE_TERMIOS_H
+# include <termios.h>
+#endif
+
+#ifdef GWINSZ_IN_SYS_IOCTL
+# include <sys/ioctl.h>
+#endif
+
+
+static int suppress_errors = 0;
+
+static int warnings_not_errors = 0; 
+
+static int terminal_width, buffer_flag, errors, warnings;
+
+static gfc_error_buf error_buffer, warning_buffer, *cur_error_buffer;
+
+
+/* Go one level deeper suppressing errors.  */
+
+void
+gfc_push_suppress_errors (void)
+{
+  gcc_assert (suppress_errors >= 0);
+  ++suppress_errors;
+}
+
+
+/* Leave one level of error suppressing.  */
+
+void
+gfc_pop_suppress_errors (void)
+{
+  gcc_assert (suppress_errors > 0);
+  --suppress_errors;
+}
+
+
+/* Determine terminal width (for trimming source lines in output).  */
+
+static int
+get_terminal_width (void)
+{
+  /* Only limit the width if we're outputting to a terminal.  */
+#ifdef HAVE_UNISTD_H
+  if (!isatty (STDERR_FILENO))
+    return INT_MAX;
+#endif
+  
+  /* Method #1: Use ioctl (not available on all systems).  */
+#ifdef TIOCGWINSZ
+  struct winsize w;
+  w.ws_col = 0;
+  if (ioctl (0, TIOCGWINSZ, &w) == 0 && w.ws_col > 0)
+    return w.ws_col;
+#endif
+
+  /* Method #2: Query environment variable $COLUMNS.  */
+  const char *p = getenv ("COLUMNS");
+  if (p)
+    {
+      int value = atoi (p);
+      if (value > 0)
+	return value;
+    }
+
+  /* If both fail, use reasonable default.  */
+  return 80;
+}
+
+
+/* Per-file error initialization.  */
+
+void
+gfc_error_init_1 (void)
+{
+  terminal_width = get_terminal_width ();
+  errors = 0;
+  warnings = 0;
+  buffer_flag = 0;
+}
+
+
+/* Set the flag for buffering errors or not.  */
+
+void
+gfc_buffer_error (int flag)
+{
+  buffer_flag = flag;
+}
+
+
+/* Add a single character to the error buffer or output depending on
+   buffer_flag.  */
+
+static void
+error_char (char c)
+{
+  if (buffer_flag)
+    {
+      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;
+	    }
+	}
+    }
+}
+
+
+/* Copy a string to wherever it needs to go.  */
+
+static void
+error_string (const char *p)
+{
+  while (*p)
+    error_char (*p++);
+}
+
+
+/* Print a formatted integer to the error buffer or output.  */
+
+#define IBUF_LEN 60
+
+static void
+error_uinteger (unsigned long int i)
+{
+  char *p, int_buf[IBUF_LEN];
+
+  p = int_buf + IBUF_LEN - 1;
+  *p-- = '\0';
+
+  if (i == 0)
+    *p-- = '0';
+
+  while (i > 0)
+    {
+      *p-- = i % 10 + '0';
+      i = i / 10;
+    }
+
+  error_string (p + 1);
+}
+
+static void
+error_integer (long int i)
+{
+  unsigned long int u;
+
+  if (i < 0)
+    {
+      u = (unsigned long int) -i;
+      error_char ('-');
+    }
+  else
+    u = i;
+
+  error_uinteger (u);
+}
+
+
+static size_t
+gfc_widechar_display_length (gfc_char_t c)
+{
+  if (gfc_wide_is_printable (c) || c == '\t')
+    /* Printable ASCII character, or tabulation (output as a space).  */
+    return 1;
+  else if (c < ((gfc_char_t) 1 << 8))
+    /* Displayed as \x??  */
+    return 4;
+  else if (c < ((gfc_char_t) 1 << 16))
+    /* Displayed as \u????  */
+    return 6;
+  else
+    /* Displayed as \U????????  */
+    return 10;
+}
+
+
+/* Length of the ASCII representation of the wide string, escaping wide
+   characters as print_wide_char_into_buffer() does.  */
+
+static size_t
+gfc_wide_display_length (const gfc_char_t *str)
+{
+  size_t i, len;
+
+  for (i = 0, len = 0; str[i]; i++)
+    len += gfc_widechar_display_length (str[i]);
+
+  return len;
+}
+
+static int
+print_wide_char_into_buffer (gfc_char_t c, char *buf)
+{
+  static const char xdigit[16] = { '0', '1', '2', '3', '4', '5', '6',
+    '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' };
+
+  if (gfc_wide_is_printable (c) || c == '\t')
+    {
+      buf[1] = '\0';
+      /* Tabulation is output as a space.  */
+      buf[0] = (unsigned char) (c == '\t' ? ' ' : c);
+      return 1;
+    }
+  else if (c < ((gfc_char_t) 1 << 8))
+    {
+      buf[4] = '\0';
+      buf[3] = xdigit[c & 0x0F];
+      c = c >> 4;
+      buf[2] = xdigit[c & 0x0F];
+
+      buf[1] = 'x';
+      buf[0] = '\\';
+      return 4;
+    }
+  else if (c < ((gfc_char_t) 1 << 16))
+    {
+      buf[6] = '\0';
+      buf[5] = xdigit[c & 0x0F];
+      c = c >> 4;
+      buf[4] = xdigit[c & 0x0F];
+      c = c >> 4;
+      buf[3] = xdigit[c & 0x0F];
+      c = c >> 4;
+      buf[2] = xdigit[c & 0x0F];
+
+      buf[1] = 'u';
+      buf[0] = '\\';
+      return 6;
+    }
+  else
+    {
+      buf[10] = '\0';
+      buf[9] = xdigit[c & 0x0F];
+      c = c >> 4;
+      buf[8] = xdigit[c & 0x0F];
+      c = c >> 4;
+      buf[7] = xdigit[c & 0x0F];
+      c = c >> 4;
+      buf[6] = xdigit[c & 0x0F];
+      c = c >> 4;
+      buf[5] = xdigit[c & 0x0F];
+      c = c >> 4;
+      buf[4] = xdigit[c & 0x0F];
+      c = c >> 4;
+      buf[3] = xdigit[c & 0x0F];
+      c = c >> 4;
+      buf[2] = xdigit[c & 0x0F];
+
+      buf[1] = 'U';
+      buf[0] = '\\';
+      return 10;
+    }
+}
+
+static char wide_char_print_buffer[11];
+
+const char *
+gfc_print_wide_char (gfc_char_t c)
+{
+  print_wide_char_into_buffer (c, wide_char_print_buffer);
+  return wide_char_print_buffer;
+}
+
+
+/* Show the file, where it was included, and the source line, give a
+   locus.  Calls error_printf() recursively, but the recursion is at
+   most one level deep.  */
+
+static void error_printf (const char *, ...) ATTRIBUTE_GCC_GFC(1,2);
+
+static void
+show_locus (locus *loc, int c1, int c2)
+{
+  gfc_linebuf *lb;
+  gfc_file *f;
+  gfc_char_t *p;
+  int i, offset, cmax;
+
+  /* TODO: Either limit the total length and number of included files
+     displayed or add buffering of arbitrary number of characters in
+     error messages.  */
+
+  /* Write out the error header line, giving the source file and error
+     location (in GNU standard "[file]:[line].[column]:" format),
+     followed by an "included by" stack and a blank line.  This header
+     format is matched by a testsuite parser defined in
+     lib/gfortran-dg.exp.  */
+
+  lb = loc->lb;
+  f = lb->file;
+
+  error_string (f->filename);
+  error_char (':');
+    
+  error_integer (LOCATION_LINE (lb->location));
+
+  if ((c1 > 0) || (c2 > 0))
+    error_char ('.');
+
+  if (c1 > 0)
+    error_integer (c1);
+
+  if ((c1 > 0) && (c2 > 0))
+    error_char ('-');
+
+  if (c2 > 0)
+    error_integer (c2);
+
+  error_char (':');
+  error_char ('\n');
+
+  for (;;)
+    {
+      i = f->inclusion_line;
+
+      f = f->up;
+      if (f == NULL) break;
+
+      error_printf ("    Included at %s:%d:", f->filename, i);
+    }
+
+  error_char ('\n');
+
+  /* Calculate an appropriate horizontal offset of the source line in
+     order to get the error locus within the visible portion of the
+     line.  Note that if the margin of 5 here is changed, the
+     corresponding margin of 10 in show_loci should be changed.  */
+
+  offset = 0;
+
+  /* If the two loci would appear in the same column, we shift
+     '2' one column to the right, so as to print '12' rather than
+     just '1'.  We do this here so it will be accounted for in the
+     margin calculations.  */
+
+  if (c1 == c2)
+    c2 += 1;
+
+  cmax = (c1 < c2) ? c2 : c1;
+  if (cmax > terminal_width - 5)
+    offset = cmax - terminal_width + 5;
+
+  /* Show the line itself, taking care not to print more than what can
+     show up on the terminal.  Tabs are converted to spaces, and 
+     nonprintable characters are converted to a "\xNN" sequence.  */
+
+  p = &(lb->line[offset]);
+  i = gfc_wide_display_length (p);
+  if (i > terminal_width)
+    i = terminal_width - 1;
+
+  while (i > 0)
+    {
+      static char buffer[11];
+      i -= print_wide_char_into_buffer (*p++, buffer);
+      error_string (buffer);
+    }
+
+  error_char ('\n');
+
+  /* Show the '1' and/or '2' corresponding to the column of the error
+     locus.  Note that a value of -1 for c1 or c2 will simply cause 
+     the relevant number not to be printed.  */
+
+  c1 -= offset;
+  c2 -= offset;
+  cmax -= offset;
+
+  p = &(lb->line[offset]);
+  for (i = 0; i < cmax; i++)
+    {
+      int spaces, j;
+      spaces = gfc_widechar_display_length (*p++);
+
+      if (i == c1)
+	error_char ('1'), spaces--;
+      else if (i == c2)
+	error_char ('2'), spaces--;
+
+      for (j = 0; j < spaces; j++)
+	error_char (' ');
+    }
+
+  if (i == c1)
+    error_char ('1');
+  else if (i == c2)
+    error_char ('2');
+
+  error_char ('\n');
+
+}
+
+
+/* As part of printing an error, we show the source lines that caused
+   the problem.  We show at least one, and possibly two loci; the two
+   loci may or may not be on the same source line.  */
+
+static void
+show_loci (locus *l1, locus *l2)
+{
+  int m, c1, c2;
+
+  if (l1 == NULL || l1->lb == NULL)
+    {
+      error_printf ("<During initialization>\n");
+      return;
+    }
+
+  /* While calculating parameters for printing the loci, we consider possible
+     reasons for printing one per line.  If appropriate, print the loci
+     individually; otherwise we print them both on the same line.  */
+
+  c1 = l1->nextc - l1->lb->line;
+  if (l2 == NULL)
+    {
+      show_locus (l1, c1, -1);
+      return;
+    }
+
+  c2 = l2->nextc - l2->lb->line;
+
+  if (c1 < c2)
+    m = c2 - c1;
+  else
+    m = c1 - c2;
+
+  /* Note that the margin value of 10 here needs to be less than the 
+     margin of 5 used in the calculation of offset in show_locus.  */
+
+  if (l1->lb != l2->lb || m > terminal_width - 10)
+    {
+      show_locus (l1, c1, -1);
+      show_locus (l2, -1, c2);
+      return;
+    }
+
+  show_locus (l1, c1, c2);
+
+  return;
+}
+
+
+/* Workhorse for the error printing subroutines.  This subroutine is
+   inspired by g77's error handling and is similar to printf() with
+   the following %-codes:
+
+   %c Character, %d or %i Integer, %s String, %% Percent
+   %L  Takes locus argument
+   %C  Current locus (no argument)
+
+   If a locus pointer is given, the actual source line is printed out
+   and the column is indicated.  Since we want the error message at
+   the bottom of any source file information, we must scan the
+   argument list twice -- once to determine whether the loci are 
+   present and record this for printing, and once to print the error
+   message after and loci have been printed.  A maximum of two locus
+   arguments are permitted.
+   
+   This function is also called (recursively) by show_locus in the
+   case of included files; however, as show_locus does not resupply
+   any loci, the recursion is at most one level deep.  */
+
+#define MAX_ARGS 10
+
+static void ATTRIBUTE_GCC_GFC(2,0)
+error_print (const char *type, const char *format0, va_list argp)
+{
+  enum { TYPE_CURRENTLOC, TYPE_LOCUS, TYPE_INTEGER, TYPE_UINTEGER,
+         TYPE_LONGINT, TYPE_ULONGINT, TYPE_CHAR, TYPE_STRING,
+	 NOTYPE };
+  struct
+  {
+    int type;
+    int pos;
+    union
+    {
+      int intval;
+      unsigned int uintval;
+      long int longintval;
+      unsigned long int ulongintval;
+      char charval;
+      const char * stringval;
+    } u;
+  } arg[MAX_ARGS], spec[MAX_ARGS];
+  /* spec is the array of specifiers, in the same order as they
+     appear in the format string.  arg is the array of arguments,
+     in the same order as they appear in the va_list.  */
+
+  char c;
+  int i, n, have_l1, pos, maxpos;
+  locus *l1, *l2, *loc;
+  const char *format;
+
+  loc = l1 = l2 = NULL;
+
+  have_l1 = 0;
+  pos = -1;
+  maxpos = -1;
+
+  n = 0;
+  format = format0;
+
+  for (i = 0; i < MAX_ARGS; i++)
+    {
+      arg[i].type = NOTYPE;
+      spec[i].pos = -1;
+    }
+
+  /* First parse the format string for position specifiers.  */
+  while (*format)
+    {
+      c = *format++;
+      if (c != '%')
+	continue;
+
+      if (*format == '%')
+	{
+	  format++;
+	  continue;
+	}
+
+      if (ISDIGIT (*format))
+	{
+	  /* This is a position specifier.  For example, the number
+	     12 in the format string "%12$d", which specifies the third
+	     argument of the va_list, formatted in %d format.
+	     For details, see "man 3 printf".  */
+	  pos = atoi(format) - 1;
+	  gcc_assert (pos >= 0);
+	  while (ISDIGIT(*format))
+	    format++;
+	  gcc_assert (*format == '$');
+	  format++;
+	}
+      else
+	pos++;
+
+      c = *format++;
+
+      if (pos > maxpos)
+	maxpos = pos;
+
+      switch (c)
+	{
+	  case 'C':
+	    arg[pos].type = TYPE_CURRENTLOC;
+	    break;
+
+	  case 'L':
+	    arg[pos].type = TYPE_LOCUS;
+	    break;
+
+	  case 'd':
+	  case 'i':
+	    arg[pos].type = TYPE_INTEGER;
+	    break;
+
+	  case 'u':
+	    arg[pos].type = TYPE_UINTEGER;
+	    break;
+
+	  case 'l':
+	    c = *format++;
+	    if (c == 'u')
+	      arg[pos].type = TYPE_ULONGINT;
+	    else if (c == 'i' || c == 'd')
+	      arg[pos].type = TYPE_LONGINT;
+	    else
+	      gcc_unreachable ();
+	    break;
+
+	  case 'c':
+	    arg[pos].type = TYPE_CHAR;
+	    break;
+
+	  case 's':
+	    arg[pos].type = TYPE_STRING;
+	    break;
+
+	  default:
+	    gcc_unreachable ();
+	}
+
+      spec[n++].pos = pos;
+    }
+
+  /* Then convert the values for each %-style argument.  */
+  for (pos = 0; pos <= maxpos; pos++)
+    {
+      gcc_assert (arg[pos].type != NOTYPE);
+      switch (arg[pos].type)
+	{
+	  case TYPE_CURRENTLOC:
+	    loc = &gfc_current_locus;
+	    /* Fall through.  */
+
+	  case TYPE_LOCUS:
+	    if (arg[pos].type == TYPE_LOCUS)
+	      loc = va_arg (argp, locus *);
+
+	    if (have_l1)
+	      {
+		l2 = loc;
+		arg[pos].u.stringval = "(2)";
+	      }
+	    else
+	      {
+		l1 = loc;
+		have_l1 = 1;
+		arg[pos].u.stringval = "(1)";
+	      }
+	    break;
+
+	  case TYPE_INTEGER:
+	    arg[pos].u.intval = va_arg (argp, int);
+	    break;
+
+	  case TYPE_UINTEGER:
+	    arg[pos].u.uintval = va_arg (argp, unsigned int);
+	    break;
+
+	  case TYPE_LONGINT:
+	    arg[pos].u.longintval = va_arg (argp, long int);
+	    break;
+
+	  case TYPE_ULONGINT:
+	    arg[pos].u.ulongintval = va_arg (argp, unsigned long int);
+	    break;
+
+	  case TYPE_CHAR:
+	    arg[pos].u.charval = (char) va_arg (argp, int);
+	    break;
+
+	  case TYPE_STRING:
+	    arg[pos].u.stringval = (const char *) va_arg (argp, char *);
+	    break;
+
+	  default:
+	    gcc_unreachable ();
+	}
+    }
+
+  for (n = 0; spec[n].pos >= 0; n++)
+    spec[n].u = arg[spec[n].pos].u;
+
+  /* Show the current loci if we have to.  */
+  if (have_l1)
+    show_loci (l1, l2);
+
+  if (*type)
+    {
+      error_string (type);
+      error_char (' ');
+    }
+
+  have_l1 = 0;
+  format = format0;
+  n = 0;
+
+  for (; *format; format++)
+    {
+      if (*format != '%')
+	{
+	  error_char (*format);
+	  continue;
+	}
+
+      format++;
+      if (ISDIGIT (*format))
+	{
+	  /* This is a position specifier.  See comment above.  */
+	  while (ISDIGIT (*format))
+	    format++;
+	    
+	  /* Skip over the dollar sign.  */
+	  format++;
+	}
+	
+      switch (*format)
+	{
+	case '%':
+	  error_char ('%');
+	  break;
+
+	case 'c':
+	  error_char (spec[n++].u.charval);
+	  break;
+
+	case 's':
+	case 'C':		/* Current locus */
+	case 'L':		/* Specified locus */
+	  error_string (spec[n++].u.stringval);
+	  break;
+
+	case 'd':
+	case 'i':
+	  error_integer (spec[n++].u.intval);
+	  break;
+
+	case 'u':
+	  error_uinteger (spec[n++].u.uintval);
+	  break;
+
+	case 'l':
+	  format++;
+	  if (*format == 'u')
+	    error_uinteger (spec[n++].u.ulongintval);
+	  else
+	    error_integer (spec[n++].u.longintval);
+	  break;
+
+	}
+    }
+
+  error_char ('\n');
+}
+
+
+/* Wrapper for error_print().  */
+
+static void
+error_printf (const char *gmsgid, ...)
+{
+  va_list argp;
+
+  va_start (argp, gmsgid);
+  error_print ("", _(gmsgid), argp);
+  va_end (argp);
+}
+
+
+/* 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);
+}
+
+
+/* Issue a warning.  */
+
+void
+gfc_warning (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 (buffer_flag == 0)
+  {
+    warnings++;
+    if (warnings_are_errors)
+      gfc_increment_error_count();
+  }
+}
+
+
+/* Whether, for a feature included in a given standard set (GFC_STD_*),
+   we should issue an error or a warning, or be quiet.  */
+
+notification
+gfc_notification_std (int std)
+{
+  bool warning;
+
+  warning = ((gfc_option.warn_std & std) != 0) && !inhibit_warnings;
+  if ((gfc_option.allow_std & std) != 0 && !warning)
+    return SILENT;
+
+  return warning ? WARNING : ERROR;
+}
+
+
+/* Possibly issue a warning/error about use of a nonstandard (or deleted)
+   feature.  An error/warning will be issued if the currently selected
+   standard does not contain the requested bits.  Return false if
+   an error is generated.  */
+
+bool
+gfc_notify_std (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:";
+      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 (buffer_flag == 0)
+    {
+      if (warning && !warnings_are_errors)
+	warnings++;
+      else
+	gfc_increment_error_count();
+      cur_error_buffer->flag = 0;
+    }
+
+  return (warning && !warnings_are_errors) ? true : false;
+}
+
+
+/* Immediate warning (i.e. do not buffer the warning).  */
+
+void
+gfc_warning_now (const char *gmsgid, ...)
+{
+  va_list argp;
+  int i;
+
+  if (inhibit_warnings)
+    return;
+
+  i = buffer_flag;
+  buffer_flag = 0;
+  warnings++;
+
+  va_start (argp, gmsgid);
+  error_print (_("Warning:"), _(gmsgid), argp);
+  va_end (argp);
+
+  error_char ('\0');
+
+  if (warnings_are_errors)
+    gfc_increment_error_count();
+
+  buffer_flag = i;
+}
+
+
+/* Clear the warning flag.  */
+
+void
+gfc_clear_warning (void)
+{
+  warning_buffer.flag = 0;
+}
+
+
+/* Check to see if any warnings have been saved.
+   If so, print the warning.  */
+
+void
+gfc_warning_check (void)
+{
+  if (warning_buffer.flag)
+    {
+      warnings++;
+      if (warning_buffer.message != NULL)
+	fputs (warning_buffer.message, stderr);
+      warning_buffer.flag = 0;
+    }
+}
+
+
+/* Issue an error.  */
+
+void
+gfc_error (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 (buffer_flag == 0)
+    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 (buffer_flag == 0)
+  {
+    warnings++;
+    if (warnings_are_errors)
+      gfc_increment_error_count();
+  }
+}
+
+
+/* Immediate error.  */
+
+void
+gfc_error_now (const char *gmsgid, ...)
+{
+  va_list argp;
+  int i;
+
+  error_buffer.flag = 1;
+  error_buffer.index = 0;
+  cur_error_buffer = &error_buffer;
+
+  i = buffer_flag;
+  buffer_flag = 0;
+
+  va_start (argp, gmsgid);
+  error_print (_("Error:"), _(gmsgid), argp);
+  va_end (argp);
+
+  error_char ('\0');
+
+  gfc_increment_error_count();
+
+  buffer_flag = i;
+
+  if (flag_fatal_errors)
+    exit (FATAL_EXIT_CODE);
+}
+
+
+/* Fatal error, never returns.  */
+
+void
+gfc_fatal_error (const char *gmsgid, ...)
+{
+  va_list argp;
+
+  buffer_flag = 0;
+
+  va_start (argp, gmsgid);
+  error_print (_("Fatal Error:"), _(gmsgid), argp);
+  va_end (argp);
+
+  exit (FATAL_EXIT_CODE);
+}
+
+
+/* This shouldn't happen... but sometimes does.  */
+
+void
+gfc_internal_error (const char *format, ...)
+{
+  va_list argp;
+
+  buffer_flag = 0;
+
+  va_start (argp, format);
+
+  show_loci (&gfc_current_locus, NULL);
+  error_printf ("Internal Error at (1):");
+
+  error_print ("", format, argp);
+  va_end (argp);
+
+  exit (ICE_EXIT_CODE);
+}
+
+
+/* Clear the error flag when we start to compile a source line.  */
+
+void
+gfc_clear_error (void)
+{
+  error_buffer.flag = 0;
+  warnings_not_errors = 0;
+}
+
+
+/* Tests the state of error_flag.  */
+
+int
+gfc_error_flag_test (void)
+{
+  return error_buffer.flag;
+}
+
+
+/* Check to see if any errors have been saved.
+   If so, print the error.  Returns the state of error_flag.  */
+
+int
+gfc_error_check (void)
+{
+  int rc;
+
+  rc = error_buffer.flag;
+
+  if (error_buffer.flag)
+    {
+      if (error_buffer.message != NULL)
+	fputs (error_buffer.message, stderr);
+      error_buffer.flag = 0;
+
+      gfc_increment_error_count();
+
+      if (flag_fatal_errors)
+	exit (FATAL_EXIT_CODE);
+    }
+
+  return rc;
+}
+
+
+/* Save the existing error state.  */
+
+void
+gfc_push_error (gfc_error_buf *err)
+{
+  err->flag = error_buffer.flag;
+  if (error_buffer.flag)
+    err->message = xstrdup (error_buffer.message);
+
+  error_buffer.flag = 0;
+}
+
+
+/* Restore a previous pushed error state.  */
+
+void
+gfc_pop_error (gfc_error_buf *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);
+    }
+}
+
+
+/* Free a pushed error state, but keep the current error state.  */
+
+void
+gfc_free_error (gfc_error_buf *err)
+{
+  if (err->flag)
+    free (err->message);
+}
+
+
+/* Report the number of warnings and errors that occurred to the caller.  */
+
+void
+gfc_get_errors (int *w, int *e)
+{
+  if (w != NULL)
+    *w = warnings;
+  if (e != NULL)
+    *e = errors;
+}
+
+
+/* Switch errors into warnings.  */
+
+void
+gfc_errors_to_warnings (int f)
+{
+  warnings_not_errors = (f == 1) ? 1 : 0;
+}
diff --git a/gcc-4.9/gcc/fortran/expr.c b/gcc-4.9/gcc/fortran/expr.c
new file mode 100644
index 000000000..f6772047e
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/expr.c
@@ -0,0 +1,4972 @@
+/* Routines for manipulation of expression nodes.
+   Copyright (C) 2000-2014 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "gfortran.h"
+#include "arith.h"
+#include "match.h"
+#include "target-memory.h" /* for gfc_convert_boz */
+#include "constructor.h"
+
+
+/* The following set of functions provide access to gfc_expr* of
+   various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE.
+
+   There are two functions available elsewhere that provide
+   slightly different flavours of variables.  Namely:
+     expr.c (gfc_get_variable_expr)
+     symbol.c (gfc_lval_expr_from_sym)
+   TODO: Merge these functions, if possible.  */
+
+/* Get a new expression node.  */
+
+gfc_expr *
+gfc_get_expr (void)
+{
+  gfc_expr *e;
+
+  e = XCNEW (gfc_expr);
+  gfc_clear_ts (&e->ts);
+  e->shape = NULL;
+  e->ref = NULL;
+  e->symtree = NULL;
+  return e;
+}
+
+
+/* Get a new expression node that is an array constructor
+   of given type and kind.  */
+
+gfc_expr *
+gfc_get_array_expr (bt type, int kind, locus *where)
+{
+  gfc_expr *e;
+
+  e = gfc_get_expr ();
+  e->expr_type = EXPR_ARRAY;
+  e->value.constructor = NULL;
+  e->rank = 1;
+  e->shape = NULL;
+
+  e->ts.type = type;
+  e->ts.kind = kind;
+  if (where)
+    e->where = *where;
+
+  return e;
+}
+
+
+/* Get a new expression node that is the NULL expression.  */
+
+gfc_expr *
+gfc_get_null_expr (locus *where)
+{
+  gfc_expr *e;
+
+  e = gfc_get_expr ();
+  e->expr_type = EXPR_NULL;
+  e->ts.type = BT_UNKNOWN;
+
+  if (where)
+    e->where = *where;
+
+  return e;
+}
+
+
+/* Get a new expression node that is an operator expression node.  */
+
+gfc_expr *
+gfc_get_operator_expr (locus *where, gfc_intrinsic_op op,
+                      gfc_expr *op1, gfc_expr *op2)
+{
+  gfc_expr *e;
+
+  e = gfc_get_expr ();
+  e->expr_type = EXPR_OP;
+  e->value.op.op = op;
+  e->value.op.op1 = op1;
+  e->value.op.op2 = op2;
+
+  if (where)
+    e->where = *where;
+
+  return e;
+}
+
+
+/* Get a new expression node that is an structure constructor
+   of given type and kind.  */
+
+gfc_expr *
+gfc_get_structure_constructor_expr (bt type, int kind, locus *where)
+{
+  gfc_expr *e;
+
+  e = gfc_get_expr ();
+  e->expr_type = EXPR_STRUCTURE;
+  e->value.constructor = NULL;
+
+  e->ts.type = type;
+  e->ts.kind = kind;
+  if (where)
+    e->where = *where;
+
+  return e;
+}
+
+
+/* Get a new expression node that is an constant of given type and kind.  */
+
+gfc_expr *
+gfc_get_constant_expr (bt type, int kind, locus *where)
+{
+  gfc_expr *e;
+
+  if (!where)
+    gfc_internal_error ("gfc_get_constant_expr(): locus 'where' cannot be NULL");
+
+  e = gfc_get_expr ();
+
+  e->expr_type = EXPR_CONSTANT;
+  e->ts.type = type;
+  e->ts.kind = kind;
+  e->where = *where;
+
+  switch (type)
+    {
+    case BT_INTEGER:
+      mpz_init (e->value.integer);
+      break;
+
+    case BT_REAL:
+      gfc_set_model_kind (kind);
+      mpfr_init (e->value.real);
+      break;
+
+    case BT_COMPLEX:
+      gfc_set_model_kind (kind);
+      mpc_init2 (e->value.complex, mpfr_get_default_prec());
+      break;
+
+    default:
+      break;
+    }
+
+  return e;
+}
+
+
+/* Get a new expression node that is an string constant.
+   If no string is passed, a string of len is allocated,
+   blanked and null-terminated.  */
+
+gfc_expr *
+gfc_get_character_expr (int kind, locus *where, const char *src, int len)
+{
+  gfc_expr *e;
+  gfc_char_t *dest;
+
+  if (!src)
+    {
+      dest = gfc_get_wide_string (len + 1);
+      gfc_wide_memset (dest, ' ', len);
+      dest[len] = '\0';
+    }
+  else
+    dest = gfc_char_to_widechar (src);
+
+  e = gfc_get_constant_expr (BT_CHARACTER, kind,
+                            where ? where : &gfc_current_locus);
+  e->value.character.string = dest;
+  e->value.character.length = len;
+
+  return e;
+}
+
+
+/* Get a new expression node that is an integer constant.  */
+
+gfc_expr *
+gfc_get_int_expr (int kind, locus *where, int value)
+{
+  gfc_expr *p;
+  p = gfc_get_constant_expr (BT_INTEGER, kind,
+			     where ? where : &gfc_current_locus);
+
+  mpz_set_si (p->value.integer, value);
+
+  return p;
+}
+
+
+/* Get a new expression node that is a logical constant.  */
+
+gfc_expr *
+gfc_get_logical_expr (int kind, locus *where, bool value)
+{
+  gfc_expr *p;
+  p = gfc_get_constant_expr (BT_LOGICAL, kind,
+			     where ? where : &gfc_current_locus);
+
+  p->value.logical = value;
+
+  return p;
+}
+
+
+gfc_expr *
+gfc_get_iokind_expr (locus *where, io_kind k)
+{
+  gfc_expr *e;
+
+  /* Set the types to something compatible with iokind. This is needed to
+     get through gfc_free_expr later since iokind really has no Basic Type,
+     BT, of its own.  */
+
+  e = gfc_get_expr ();
+  e->expr_type = EXPR_CONSTANT;
+  e->ts.type = BT_LOGICAL;
+  e->value.iokind = k;
+  e->where = *where;
+
+  return e;
+}
+
+
+/* Given an expression pointer, return a copy of the expression.  This
+   subroutine is recursive.  */
+
+gfc_expr *
+gfc_copy_expr (gfc_expr *p)
+{
+  gfc_expr *q;
+  gfc_char_t *s;
+  char *c;
+
+  if (p == NULL)
+    return NULL;
+
+  q = gfc_get_expr ();
+  *q = *p;
+
+  switch (q->expr_type)
+    {
+    case EXPR_SUBSTRING:
+      s = gfc_get_wide_string (p->value.character.length + 1);
+      q->value.character.string = s;
+      memcpy (s, p->value.character.string,
+	      (p->value.character.length + 1) * sizeof (gfc_char_t));
+      break;
+
+    case EXPR_CONSTANT:
+      /* Copy target representation, if it exists.  */
+      if (p->representation.string)
+	{
+	  c = XCNEWVEC (char, p->representation.length + 1);
+	  q->representation.string = c;
+	  memcpy (c, p->representation.string, (p->representation.length + 1));
+	}
+
+      /* Copy the values of any pointer components of p->value.  */
+      switch (q->ts.type)
+	{
+	case BT_INTEGER:
+	  mpz_init_set (q->value.integer, p->value.integer);
+	  break;
+
+	case BT_REAL:
+	  gfc_set_model_kind (q->ts.kind);
+	  mpfr_init (q->value.real);
+	  mpfr_set (q->value.real, p->value.real, GFC_RND_MODE);
+	  break;
+
+	case BT_COMPLEX:
+	  gfc_set_model_kind (q->ts.kind);
+	  mpc_init2 (q->value.complex, mpfr_get_default_prec());
+	  mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE);
+	  break;
+
+	case BT_CHARACTER:
+	  if (p->representation.string)
+	    q->value.character.string
+	      = gfc_char_to_widechar (q->representation.string);
+	  else
+	    {
+	      s = gfc_get_wide_string (p->value.character.length + 1);
+	      q->value.character.string = s;
+
+	      /* This is the case for the C_NULL_CHAR named constant.  */
+	      if (p->value.character.length == 0
+		  && (p->ts.is_c_interop || p->ts.is_iso_c))
+		{
+		  *s = '\0';
+		  /* Need to set the length to 1 to make sure the NUL
+		     terminator is copied.  */
+		  q->value.character.length = 1;
+		}
+	      else
+		memcpy (s, p->value.character.string,
+			(p->value.character.length + 1) * sizeof (gfc_char_t));
+	    }
+	  break;
+
+	case BT_HOLLERITH:
+	case BT_LOGICAL:
+	case BT_DERIVED:
+	case BT_CLASS:
+	case BT_ASSUMED:
+	  break;		/* Already done.  */
+
+	case BT_PROCEDURE:
+        case BT_VOID:
+           /* Should never be reached.  */
+	case BT_UNKNOWN:
+	  gfc_internal_error ("gfc_copy_expr(): Bad expr node");
+	  /* Not reached.  */
+	}
+
+      break;
+
+    case EXPR_OP:
+      switch (q->value.op.op)
+	{
+	case INTRINSIC_NOT:
+	case INTRINSIC_PARENTHESES:
+	case INTRINSIC_UPLUS:
+	case INTRINSIC_UMINUS:
+	  q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
+	  break;
+
+	default:		/* Binary operators.  */
+	  q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
+	  q->value.op.op2 = gfc_copy_expr (p->value.op.op2);
+	  break;
+	}
+
+      break;
+
+    case EXPR_FUNCTION:
+      q->value.function.actual =
+	gfc_copy_actual_arglist (p->value.function.actual);
+      break;
+
+    case EXPR_COMPCALL:
+    case EXPR_PPC:
+      q->value.compcall.actual =
+	gfc_copy_actual_arglist (p->value.compcall.actual);
+      q->value.compcall.tbp = p->value.compcall.tbp;
+      break;
+
+    case EXPR_STRUCTURE:
+    case EXPR_ARRAY:
+      q->value.constructor = gfc_constructor_copy (p->value.constructor);
+      break;
+
+    case EXPR_VARIABLE:
+    case EXPR_NULL:
+      break;
+    }
+
+  q->shape = gfc_copy_shape (p->shape, p->rank);
+
+  q->ref = gfc_copy_ref (p->ref);
+
+  return q;
+}
+
+
+void
+gfc_clear_shape (mpz_t *shape, int rank)
+{
+  int i;
+
+  for (i = 0; i < rank; i++)
+    mpz_clear (shape[i]);
+}
+
+
+void
+gfc_free_shape (mpz_t **shape, int rank)
+{
+  if (*shape == NULL)
+    return;
+
+  gfc_clear_shape (*shape, rank);
+  free (*shape);
+  *shape = NULL;
+}
+
+
+/* Workhorse function for gfc_free_expr() that frees everything
+   beneath an expression node, but not the node itself.  This is
+   useful when we want to simplify a node and replace it with
+   something else or the expression node belongs to another structure.  */
+
+static void
+free_expr0 (gfc_expr *e)
+{
+  switch (e->expr_type)
+    {
+    case EXPR_CONSTANT:
+      /* Free any parts of the value that need freeing.  */
+      switch (e->ts.type)
+	{
+	case BT_INTEGER:
+	  mpz_clear (e->value.integer);
+	  break;
+
+	case BT_REAL:
+	  mpfr_clear (e->value.real);
+	  break;
+
+	case BT_CHARACTER:
+	  free (e->value.character.string);
+	  break;
+
+	case BT_COMPLEX:
+	  mpc_clear (e->value.complex);
+	  break;
+
+	default:
+	  break;
+	}
+
+      /* Free the representation.  */
+      free (e->representation.string);
+
+      break;
+
+    case EXPR_OP:
+      if (e->value.op.op1 != NULL)
+	gfc_free_expr (e->value.op.op1);
+      if (e->value.op.op2 != NULL)
+	gfc_free_expr (e->value.op.op2);
+      break;
+
+    case EXPR_FUNCTION:
+      gfc_free_actual_arglist (e->value.function.actual);
+      break;
+
+    case EXPR_COMPCALL:
+    case EXPR_PPC:
+      gfc_free_actual_arglist (e->value.compcall.actual);
+      break;
+
+    case EXPR_VARIABLE:
+      break;
+
+    case EXPR_ARRAY:
+    case EXPR_STRUCTURE:
+      gfc_constructor_free (e->value.constructor);
+      break;
+
+    case EXPR_SUBSTRING:
+      free (e->value.character.string);
+      break;
+
+    case EXPR_NULL:
+      break;
+
+    default:
+      gfc_internal_error ("free_expr0(): Bad expr type");
+    }
+
+  /* Free a shape array.  */
+  gfc_free_shape (&e->shape, e->rank);
+
+  gfc_free_ref_list (e->ref);
+
+  memset (e, '\0', sizeof (gfc_expr));
+}
+
+
+/* Free an expression node and everything beneath it.  */
+
+void
+gfc_free_expr (gfc_expr *e)
+{
+  if (e == NULL)
+    return;
+  free_expr0 (e);
+  free (e);
+}
+
+
+/* Free an argument list and everything below it.  */
+
+void
+gfc_free_actual_arglist (gfc_actual_arglist *a1)
+{
+  gfc_actual_arglist *a2;
+
+  while (a1)
+    {
+      a2 = a1->next;
+      gfc_free_expr (a1->expr);
+      free (a1);
+      a1 = a2;
+    }
+}
+
+
+/* Copy an arglist structure and all of the arguments.  */
+
+gfc_actual_arglist *
+gfc_copy_actual_arglist (gfc_actual_arglist *p)
+{
+  gfc_actual_arglist *head, *tail, *new_arg;
+
+  head = tail = NULL;
+
+  for (; p; p = p->next)
+    {
+      new_arg = gfc_get_actual_arglist ();
+      *new_arg = *p;
+
+      new_arg->expr = gfc_copy_expr (p->expr);
+      new_arg->next = NULL;
+
+      if (head == NULL)
+	head = new_arg;
+      else
+	tail->next = new_arg;
+
+      tail = new_arg;
+    }
+
+  return head;
+}
+
+
+/* Free a list of reference structures.  */
+
+void
+gfc_free_ref_list (gfc_ref *p)
+{
+  gfc_ref *q;
+  int i;
+
+  for (; p; p = q)
+    {
+      q = p->next;
+
+      switch (p->type)
+	{
+	case REF_ARRAY:
+	  for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
+	    {
+	      gfc_free_expr (p->u.ar.start[i]);
+	      gfc_free_expr (p->u.ar.end[i]);
+	      gfc_free_expr (p->u.ar.stride[i]);
+	    }
+
+	  break;
+
+	case REF_SUBSTRING:
+	  gfc_free_expr (p->u.ss.start);
+	  gfc_free_expr (p->u.ss.end);
+	  break;
+
+	case REF_COMPONENT:
+	  break;
+	}
+
+      free (p);
+    }
+}
+
+
+/* Graft the *src expression onto the *dest subexpression.  */
+
+void
+gfc_replace_expr (gfc_expr *dest, gfc_expr *src)
+{
+  free_expr0 (dest);
+  *dest = *src;
+  free (src);
+}
+
+
+/* Try to extract an integer constant from the passed expression node.
+   Returns an error message or NULL if the result is set.  It is
+   tempting to generate an error and return true or false, but
+   failure is OK for some callers.  */
+
+const char *
+gfc_extract_int (gfc_expr *expr, int *result)
+{
+  if (expr->expr_type != EXPR_CONSTANT)
+    return _("Constant expression required at %C");
+
+  if (expr->ts.type != BT_INTEGER)
+    return _("Integer expression required at %C");
+
+  if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0)
+      || (mpz_cmp_si (expr->value.integer, INT_MIN) < 0))
+    {
+      return _("Integer value too large in expression at %C");
+    }
+
+  *result = (int) mpz_get_si (expr->value.integer);
+
+  return NULL;
+}
+
+
+/* Recursively copy a list of reference structures.  */
+
+gfc_ref *
+gfc_copy_ref (gfc_ref *src)
+{
+  gfc_array_ref *ar;
+  gfc_ref *dest;
+
+  if (src == NULL)
+    return NULL;
+
+  dest = gfc_get_ref ();
+  dest->type = src->type;
+
+  switch (src->type)
+    {
+    case REF_ARRAY:
+      ar = gfc_copy_array_ref (&src->u.ar);
+      dest->u.ar = *ar;
+      free (ar);
+      break;
+
+    case REF_COMPONENT:
+      dest->u.c = src->u.c;
+      break;
+
+    case REF_SUBSTRING:
+      dest->u.ss = src->u.ss;
+      dest->u.ss.start = gfc_copy_expr (src->u.ss.start);
+      dest->u.ss.end = gfc_copy_expr (src->u.ss.end);
+      break;
+    }
+
+  dest->next = gfc_copy_ref (src->next);
+
+  return dest;
+}
+
+
+/* Detect whether an expression has any vector index array references.  */
+
+int
+gfc_has_vector_index (gfc_expr *e)
+{
+  gfc_ref *ref;
+  int i;
+  for (ref = e->ref; ref; ref = ref->next)
+    if (ref->type == REF_ARRAY)
+      for (i = 0; i < ref->u.ar.dimen; i++)
+	if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
+	  return 1;
+  return 0;
+}
+
+
+/* Copy a shape array.  */
+
+mpz_t *
+gfc_copy_shape (mpz_t *shape, int rank)
+{
+  mpz_t *new_shape;
+  int n;
+
+  if (shape == NULL)
+    return NULL;
+
+  new_shape = gfc_get_shape (rank);
+
+  for (n = 0; n < rank; n++)
+    mpz_init_set (new_shape[n], shape[n]);
+
+  return new_shape;
+}
+
+
+/* Copy a shape array excluding dimension N, where N is an integer
+   constant expression.  Dimensions are numbered in Fortran style --
+   starting with ONE.
+
+   So, if the original shape array contains R elements
+      { s1 ... sN-1  sN  sN+1 ... sR-1 sR}
+   the result contains R-1 elements:
+      { s1 ... sN-1  sN+1    ...  sR-1}
+
+   If anything goes wrong -- N is not a constant, its value is out
+   of range -- or anything else, just returns NULL.  */
+
+mpz_t *
+gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim)
+{
+  mpz_t *new_shape, *s;
+  int i, n;
+
+  if (shape == NULL
+      || rank <= 1
+      || dim == NULL
+      || dim->expr_type != EXPR_CONSTANT
+      || dim->ts.type != BT_INTEGER)
+    return NULL;
+
+  n = mpz_get_si (dim->value.integer);
+  n--; /* Convert to zero based index.  */
+  if (n < 0 || n >= rank)
+    return NULL;
+
+  s = new_shape = gfc_get_shape (rank - 1);
+
+  for (i = 0; i < rank; i++)
+    {
+      if (i == n)
+	continue;
+      mpz_init_set (*s, shape[i]);
+      s++;
+    }
+
+  return new_shape;
+}
+
+
+/* Return the maximum kind of two expressions.  In general, higher
+   kind numbers mean more precision for numeric types.  */
+
+int
+gfc_kind_max (gfc_expr *e1, gfc_expr *e2)
+{
+  return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind;
+}
+
+
+/* Returns nonzero if the type is numeric, zero otherwise.  */
+
+static int
+numeric_type (bt type)
+{
+  return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER;
+}
+
+
+/* Returns nonzero if the typespec is a numeric type, zero otherwise.  */
+
+int
+gfc_numeric_ts (gfc_typespec *ts)
+{
+  return numeric_type (ts->type);
+}
+
+
+/* Return an expression node with an optional argument list attached.
+   A variable number of gfc_expr pointers are strung together in an
+   argument list with a NULL pointer terminating the list.  */
+
+gfc_expr *
+gfc_build_conversion (gfc_expr *e)
+{
+  gfc_expr *p;
+
+  p = gfc_get_expr ();
+  p->expr_type = EXPR_FUNCTION;
+  p->symtree = NULL;
+  p->value.function.actual = NULL;
+
+  p->value.function.actual = gfc_get_actual_arglist ();
+  p->value.function.actual->expr = e;
+
+  return p;
+}
+
+
+/* Given an expression node with some sort of numeric binary
+   expression, insert type conversions required to make the operands
+   have the same type. Conversion warnings are disabled if wconversion
+   is set to 0.
+
+   The exception is that the operands of an exponential don't have to
+   have the same type.  If possible, the base is promoted to the type
+   of the exponent.  For example, 1**2.3 becomes 1.0**2.3, but
+   1.0**2 stays as it is.  */
+
+void
+gfc_type_convert_binary (gfc_expr *e, int wconversion)
+{
+  gfc_expr *op1, *op2;
+
+  op1 = e->value.op.op1;
+  op2 = e->value.op.op2;
+
+  if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN)
+    {
+      gfc_clear_ts (&e->ts);
+      return;
+    }
+
+  /* Kind conversions of same type.  */
+  if (op1->ts.type == op2->ts.type)
+    {
+      if (op1->ts.kind == op2->ts.kind)
+	{
+	  /* No type conversions.  */
+	  e->ts = op1->ts;
+	  goto done;
+	}
+
+      if (op1->ts.kind > op2->ts.kind)
+	gfc_convert_type_warn (op2, &op1->ts, 2, wconversion);
+      else
+	gfc_convert_type_warn (op1, &op2->ts, 2, wconversion);
+
+      e->ts = op1->ts;
+      goto done;
+    }
+
+  /* Integer combined with real or complex.  */
+  if (op2->ts.type == BT_INTEGER)
+    {
+      e->ts = op1->ts;
+
+      /* Special case for ** operator.  */
+      if (e->value.op.op == INTRINSIC_POWER)
+	goto done;
+
+      gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion);
+      goto done;
+    }
+
+  if (op1->ts.type == BT_INTEGER)
+    {
+      e->ts = op2->ts;
+      gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion);
+      goto done;
+    }
+
+  /* Real combined with complex.  */
+  e->ts.type = BT_COMPLEX;
+  if (op1->ts.kind > op2->ts.kind)
+    e->ts.kind = op1->ts.kind;
+  else
+    e->ts.kind = op2->ts.kind;
+  if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind)
+    gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion);
+  if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind)
+    gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion);
+
+done:
+  return;
+}
+
+
+/* Function to determine if an expression is constant or not.  This
+   function expects that the expression has already been simplified.  */
+
+int
+gfc_is_constant_expr (gfc_expr *e)
+{
+  gfc_constructor *c;
+  gfc_actual_arglist *arg;
+  gfc_symbol *sym;
+
+  if (e == NULL)
+    return 1;
+
+  switch (e->expr_type)
+    {
+    case EXPR_OP:
+      return (gfc_is_constant_expr (e->value.op.op1)
+	      && (e->value.op.op2 == NULL
+		  || gfc_is_constant_expr (e->value.op.op2)));
+
+    case EXPR_VARIABLE:
+      return 0;
+
+    case EXPR_FUNCTION:
+    case EXPR_PPC:
+    case EXPR_COMPCALL:
+      gcc_assert (e->symtree || e->value.function.esym
+		  || e->value.function.isym);
+
+      /* Call to intrinsic with at least one argument.  */
+      if (e->value.function.isym && e->value.function.actual)
+	{
+	  for (arg = e->value.function.actual; arg; arg = arg->next)
+	    if (!gfc_is_constant_expr (arg->expr))
+	      return 0;
+	}
+
+      /* Specification functions are constant.  */
+      /* F95, 7.1.6.2; F2003, 7.1.7  */
+      sym = NULL;
+      if (e->symtree)
+	sym = e->symtree->n.sym;
+      if (e->value.function.esym)
+	sym = e->value.function.esym;
+
+      if (sym
+	  && sym->attr.function
+	  && sym->attr.pure
+	  && !sym->attr.intrinsic
+	  && !sym->attr.recursive
+	  && sym->attr.proc != PROC_INTERNAL
+	  && sym->attr.proc != PROC_ST_FUNCTION
+	  && sym->attr.proc != PROC_UNKNOWN
+	  && gfc_sym_get_dummy_args (sym) == NULL)
+	return 1;
+
+      if (e->value.function.isym
+	  && (e->value.function.isym->elemental
+	      || e->value.function.isym->pure
+	      || e->value.function.isym->inquiry
+	      || e->value.function.isym->transformational))
+	return 1;
+
+      return 0;
+
+    case EXPR_CONSTANT:
+    case EXPR_NULL:
+      return 1;
+
+    case EXPR_SUBSTRING:
+      return e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start)
+				&& gfc_is_constant_expr (e->ref->u.ss.end));
+
+    case EXPR_ARRAY:
+    case EXPR_STRUCTURE:
+      c = gfc_constructor_first (e->value.constructor);
+      if ((e->expr_type == EXPR_ARRAY) && c && c->iterator)
+        return gfc_constant_ac (e);
+
+      for (; c; c = gfc_constructor_next (c))
+	if (!gfc_is_constant_expr (c->expr))
+	  return 0;
+
+      return 1;
+
+
+    default:
+      gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
+      return 0;
+    }
+}
+
+
+/* Is true if an array reference is followed by a component or substring
+   reference.  */
+bool
+is_subref_array (gfc_expr * e)
+{
+  gfc_ref * ref;
+  bool seen_array;
+
+  if (e->expr_type != EXPR_VARIABLE)
+    return false;
+
+  if (e->symtree->n.sym->attr.subref_array_pointer)
+    return true;
+
+  seen_array = false;
+  for (ref = e->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_ARRAY
+	    && ref->u.ar.type != AR_ELEMENT)
+	seen_array = true;
+
+      if (seen_array
+	    && ref->type != REF_ARRAY)
+	return seen_array;
+    }
+  return false;
+}
+
+
+/* Try to collapse intrinsic expressions.  */
+
+static bool
+simplify_intrinsic_op (gfc_expr *p, int type)
+{
+  gfc_intrinsic_op op;
+  gfc_expr *op1, *op2, *result;
+
+  if (p->value.op.op == INTRINSIC_USER)
+    return true;
+
+  op1 = p->value.op.op1;
+  op2 = p->value.op.op2;
+  op  = p->value.op.op;
+
+  if (!gfc_simplify_expr (op1, type))
+    return false;
+  if (!gfc_simplify_expr (op2, type))
+    return false;
+
+  if (!gfc_is_constant_expr (op1)
+      || (op2 != NULL && !gfc_is_constant_expr (op2)))
+    return true;
+
+  /* Rip p apart.  */
+  p->value.op.op1 = NULL;
+  p->value.op.op2 = NULL;
+
+  switch (op)
+    {
+    case INTRINSIC_PARENTHESES:
+      result = gfc_parentheses (op1);
+      break;
+
+    case INTRINSIC_UPLUS:
+      result = gfc_uplus (op1);
+      break;
+
+    case INTRINSIC_UMINUS:
+      result = gfc_uminus (op1);
+      break;
+
+    case INTRINSIC_PLUS:
+      result = gfc_add (op1, op2);
+      break;
+
+    case INTRINSIC_MINUS:
+      result = gfc_subtract (op1, op2);
+      break;
+
+    case INTRINSIC_TIMES:
+      result = gfc_multiply (op1, op2);
+      break;
+
+    case INTRINSIC_DIVIDE:
+      result = gfc_divide (op1, op2);
+      break;
+
+    case INTRINSIC_POWER:
+      result = gfc_power (op1, op2);
+      break;
+
+    case INTRINSIC_CONCAT:
+      result = gfc_concat (op1, op2);
+      break;
+
+    case INTRINSIC_EQ:
+    case INTRINSIC_EQ_OS:
+      result = gfc_eq (op1, op2, op);
+      break;
+
+    case INTRINSIC_NE:
+    case INTRINSIC_NE_OS:
+      result = gfc_ne (op1, op2, op);
+      break;
+
+    case INTRINSIC_GT:
+    case INTRINSIC_GT_OS:
+      result = gfc_gt (op1, op2, op);
+      break;
+
+    case INTRINSIC_GE:
+    case INTRINSIC_GE_OS:
+      result = gfc_ge (op1, op2, op);
+      break;
+
+    case INTRINSIC_LT:
+    case INTRINSIC_LT_OS:
+      result = gfc_lt (op1, op2, op);
+      break;
+
+    case INTRINSIC_LE:
+    case INTRINSIC_LE_OS:
+      result = gfc_le (op1, op2, op);
+      break;
+
+    case INTRINSIC_NOT:
+      result = gfc_not (op1);
+      break;
+
+    case INTRINSIC_AND:
+      result = gfc_and (op1, op2);
+      break;
+
+    case INTRINSIC_OR:
+      result = gfc_or (op1, op2);
+      break;
+
+    case INTRINSIC_EQV:
+      result = gfc_eqv (op1, op2);
+      break;
+
+    case INTRINSIC_NEQV:
+      result = gfc_neqv (op1, op2);
+      break;
+
+    default:
+      gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
+    }
+
+  if (result == NULL)
+    {
+      gfc_free_expr (op1);
+      gfc_free_expr (op2);
+      return false;
+    }
+
+  result->rank = p->rank;
+  result->where = p->where;
+  gfc_replace_expr (p, result);
+
+  return true;
+}
+
+
+/* Subroutine to simplify constructor expressions.  Mutually recursive
+   with gfc_simplify_expr().  */
+
+static bool
+simplify_constructor (gfc_constructor_base base, int type)
+{
+  gfc_constructor *c;
+  gfc_expr *p;
+
+  for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
+    {
+      if (c->iterator
+	  && (!gfc_simplify_expr(c->iterator->start, type)
+	      || !gfc_simplify_expr (c->iterator->end, type)
+	      || !gfc_simplify_expr (c->iterator->step, type)))
+	return false;
+
+      if (c->expr)
+	{
+	  /* Try and simplify a copy.  Replace the original if successful
+	     but keep going through the constructor at all costs.  Not
+	     doing so can make a dog's dinner of complicated things.  */
+	  p = gfc_copy_expr (c->expr);
+
+	  if (!gfc_simplify_expr (p, type))
+	    {
+	      gfc_free_expr (p);
+	      continue;
+	    }
+
+	  gfc_replace_expr (c->expr, p);
+	}
+    }
+
+  return true;
+}
+
+
+/* Pull a single array element out of an array constructor.  */
+
+static bool
+find_array_element (gfc_constructor_base base, gfc_array_ref *ar,
+		    gfc_constructor **rval)
+{
+  unsigned long nelemen;
+  int i;
+  mpz_t delta;
+  mpz_t offset;
+  mpz_t span;
+  mpz_t tmp;
+  gfc_constructor *cons;
+  gfc_expr *e;
+  bool t;
+
+  t = true;
+  e = NULL;
+
+  mpz_init_set_ui (offset, 0);
+  mpz_init (delta);
+  mpz_init (tmp);
+  mpz_init_set_ui (span, 1);
+  for (i = 0; i < ar->dimen; i++)
+    {
+      if (!gfc_reduce_init_expr (ar->as->lower[i])
+	  || !gfc_reduce_init_expr (ar->as->upper[i]))
+	{
+	  t = false;
+	  cons = NULL;
+	  goto depart;
+	}
+
+      e = ar->start[i];
+      if (e->expr_type != EXPR_CONSTANT)
+	{
+	  cons = NULL;
+	  goto depart;
+	}
+
+      gcc_assert (ar->as->upper[i]->expr_type == EXPR_CONSTANT
+		  && ar->as->lower[i]->expr_type == EXPR_CONSTANT);
+
+      /* Check the bounds.  */
+      if ((ar->as->upper[i]
+	   && mpz_cmp (e->value.integer,
+		       ar->as->upper[i]->value.integer) > 0)
+	  || (mpz_cmp (e->value.integer,
+		       ar->as->lower[i]->value.integer) < 0))
+	{
+	  gfc_error ("Index in dimension %d is out of bounds "
+		     "at %L", i + 1, &ar->c_where[i]);
+	  cons = NULL;
+	  t = false;
+	  goto depart;
+	}
+
+      mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer);
+      mpz_mul (delta, delta, span);
+      mpz_add (offset, offset, delta);
+
+      mpz_set_ui (tmp, 1);
+      mpz_add (tmp, tmp, ar->as->upper[i]->value.integer);
+      mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
+      mpz_mul (span, span, tmp);
+    }
+
+  for (cons = gfc_constructor_first (base), nelemen = mpz_get_ui (offset);
+       cons && nelemen > 0; cons = gfc_constructor_next (cons), nelemen--)
+    {
+      if (cons->iterator)
+	{
+	  cons = NULL;
+	  goto depart;
+	}
+    }
+
+depart:
+  mpz_clear (delta);
+  mpz_clear (offset);
+  mpz_clear (span);
+  mpz_clear (tmp);
+  *rval = cons;
+  return t;
+}
+
+
+/* Find a component of a structure constructor.  */
+
+static gfc_constructor *
+find_component_ref (gfc_constructor_base base, gfc_ref *ref)
+{
+  gfc_component *comp;
+  gfc_component *pick;
+  gfc_constructor *c = gfc_constructor_first (base);
+
+  comp = ref->u.c.sym->components;
+  pick = ref->u.c.component;
+  while (comp != pick)
+    {
+      comp = comp->next;
+      c = gfc_constructor_next (c);
+    }
+
+  return c;
+}
+
+
+/* Replace an expression with the contents of a constructor, removing
+   the subobject reference in the process.  */
+
+static void
+remove_subobject_ref (gfc_expr *p, gfc_constructor *cons)
+{
+  gfc_expr *e;
+
+  if (cons)
+    {
+      e = cons->expr;
+      cons->expr = NULL;
+    }
+  else
+    e = gfc_copy_expr (p);
+  e->ref = p->ref->next;
+  p->ref->next =  NULL;
+  gfc_replace_expr (p, e);
+}
+
+
+/* Pull an array section out of an array constructor.  */
+
+static bool
+find_array_section (gfc_expr *expr, gfc_ref *ref)
+{
+  int idx;
+  int rank;
+  int d;
+  int shape_i;
+  int limit;
+  long unsigned one = 1;
+  bool incr_ctr;
+  mpz_t start[GFC_MAX_DIMENSIONS];
+  mpz_t end[GFC_MAX_DIMENSIONS];
+  mpz_t stride[GFC_MAX_DIMENSIONS];
+  mpz_t delta[GFC_MAX_DIMENSIONS];
+  mpz_t ctr[GFC_MAX_DIMENSIONS];
+  mpz_t delta_mpz;
+  mpz_t tmp_mpz;
+  mpz_t nelts;
+  mpz_t ptr;
+  gfc_constructor_base base;
+  gfc_constructor *cons, *vecsub[GFC_MAX_DIMENSIONS];
+  gfc_expr *begin;
+  gfc_expr *finish;
+  gfc_expr *step;
+  gfc_expr *upper;
+  gfc_expr *lower;
+  bool t;
+
+  t = true;
+
+  base = expr->value.constructor;
+  expr->value.constructor = NULL;
+
+  rank = ref->u.ar.as->rank;
+
+  if (expr->shape == NULL)
+    expr->shape = gfc_get_shape (rank);
+
+  mpz_init_set_ui (delta_mpz, one);
+  mpz_init_set_ui (nelts, one);
+  mpz_init (tmp_mpz);
+
+  /* Do the initialization now, so that we can cleanup without
+     keeping track of where we were.  */
+  for (d = 0; d < rank; d++)
+    {
+      mpz_init (delta[d]);
+      mpz_init (start[d]);
+      mpz_init (end[d]);
+      mpz_init (ctr[d]);
+      mpz_init (stride[d]);
+      vecsub[d] = NULL;
+    }
+
+  /* Build the counters to clock through the array reference.  */
+  shape_i = 0;
+  for (d = 0; d < rank; d++)
+    {
+      /* Make this stretch of code easier on the eye!  */
+      begin = ref->u.ar.start[d];
+      finish = ref->u.ar.end[d];
+      step = ref->u.ar.stride[d];
+      lower = ref->u.ar.as->lower[d];
+      upper = ref->u.ar.as->upper[d];
+
+      if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR)  /* Vector subscript.  */
+	{
+	  gfc_constructor *ci;
+	  gcc_assert (begin);
+
+	  if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin))
+	    {
+	      t = false;
+	      goto cleanup;
+	    }
+
+	  gcc_assert (begin->rank == 1);
+	  /* Zero-sized arrays have no shape and no elements, stop early.  */
+	  if (!begin->shape)
+	    {
+	      mpz_init_set_ui (nelts, 0);
+	      break;
+	    }
+
+	  vecsub[d] = gfc_constructor_first (begin->value.constructor);
+	  mpz_set (ctr[d], vecsub[d]->expr->value.integer);
+	  mpz_mul (nelts, nelts, begin->shape[0]);
+	  mpz_set (expr->shape[shape_i++], begin->shape[0]);
+
+	  /* Check bounds.  */
+	  for (ci = vecsub[d]; ci; ci = gfc_constructor_next (ci))
+	    {
+	      if (mpz_cmp (ci->expr->value.integer, upper->value.integer) > 0
+		  || mpz_cmp (ci->expr->value.integer,
+			      lower->value.integer) < 0)
+		{
+		  gfc_error ("index in dimension %d is out of bounds "
+			     "at %L", d + 1, &ref->u.ar.c_where[d]);
+		  t = false;
+		  goto cleanup;
+		}
+	    }
+	}
+      else
+	{
+	  if ((begin && begin->expr_type != EXPR_CONSTANT)
+	      || (finish && finish->expr_type != EXPR_CONSTANT)
+	      || (step && step->expr_type != EXPR_CONSTANT))
+	    {
+	      t = false;
+	      goto cleanup;
+	    }
+
+	  /* Obtain the stride.  */
+	  if (step)
+	    mpz_set (stride[d], step->value.integer);
+	  else
+	    mpz_set_ui (stride[d], one);
+
+	  if (mpz_cmp_ui (stride[d], 0) == 0)
+	    mpz_set_ui (stride[d], one);
+
+	  /* Obtain the start value for the index.  */
+	  if (begin)
+	    mpz_set (start[d], begin->value.integer);
+	  else
+	    mpz_set (start[d], lower->value.integer);
+
+	  mpz_set (ctr[d], start[d]);
+
+	  /* Obtain the end value for the index.  */
+	  if (finish)
+	    mpz_set (end[d], finish->value.integer);
+	  else
+	    mpz_set (end[d], upper->value.integer);
+
+	  /* Separate 'if' because elements sometimes arrive with
+	     non-null end.  */
+	  if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT)
+	    mpz_set (end [d], begin->value.integer);
+
+	  /* Check the bounds.  */
+	  if (mpz_cmp (ctr[d], upper->value.integer) > 0
+	      || mpz_cmp (end[d], upper->value.integer) > 0
+	      || mpz_cmp (ctr[d], lower->value.integer) < 0
+	      || mpz_cmp (end[d], lower->value.integer) < 0)
+	    {
+	      gfc_error ("index in dimension %d is out of bounds "
+			 "at %L", d + 1, &ref->u.ar.c_where[d]);
+	      t = false;
+	      goto cleanup;
+	    }
+
+	  /* Calculate the number of elements and the shape.  */
+	  mpz_set (tmp_mpz, stride[d]);
+	  mpz_add (tmp_mpz, end[d], tmp_mpz);
+	  mpz_sub (tmp_mpz, tmp_mpz, ctr[d]);
+	  mpz_div (tmp_mpz, tmp_mpz, stride[d]);
+	  mpz_mul (nelts, nelts, tmp_mpz);
+
+	  /* An element reference reduces the rank of the expression; don't
+	     add anything to the shape array.  */
+	  if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
+	    mpz_set (expr->shape[shape_i++], tmp_mpz);
+	}
+
+      /* Calculate the 'stride' (=delta) for conversion of the
+	 counter values into the index along the constructor.  */
+      mpz_set (delta[d], delta_mpz);
+      mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer);
+      mpz_add_ui (tmp_mpz, tmp_mpz, one);
+      mpz_mul (delta_mpz, delta_mpz, tmp_mpz);
+    }
+
+  mpz_init (ptr);
+  cons = gfc_constructor_first (base);
+
+  /* Now clock through the array reference, calculating the index in
+     the source constructor and transferring the elements to the new
+     constructor.  */
+  for (idx = 0; idx < (int) mpz_get_si (nelts); idx++)
+    {
+      mpz_init_set_ui (ptr, 0);
+
+      incr_ctr = true;
+      for (d = 0; d < rank; d++)
+	{
+	  mpz_set (tmp_mpz, ctr[d]);
+	  mpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer);
+	  mpz_mul (tmp_mpz, tmp_mpz, delta[d]);
+	  mpz_add (ptr, ptr, tmp_mpz);
+
+	  if (!incr_ctr) continue;
+
+	  if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript.  */
+	    {
+	      gcc_assert(vecsub[d]);
+
+	      if (!gfc_constructor_next (vecsub[d]))
+		vecsub[d] = gfc_constructor_first (ref->u.ar.start[d]->value.constructor);
+	      else
+		{
+		  vecsub[d] = gfc_constructor_next (vecsub[d]);
+		  incr_ctr = false;
+		}
+	      mpz_set (ctr[d], vecsub[d]->expr->value.integer);
+	    }
+	  else
+	    {
+	      mpz_add (ctr[d], ctr[d], stride[d]);
+
+	      if (mpz_cmp_ui (stride[d], 0) > 0
+		  ? mpz_cmp (ctr[d], end[d]) > 0
+		  : mpz_cmp (ctr[d], end[d]) < 0)
+		mpz_set (ctr[d], start[d]);
+	      else
+		incr_ctr = false;
+	    }
+	}
+
+      limit = mpz_get_ui (ptr);
+      if (limit >= gfc_option.flag_max_array_constructor)
+        {
+	  gfc_error ("The number of elements in the array constructor "
+		     "at %L requires an increase of the allowed %d "
+		     "upper limit.   See -fmax-array-constructor "
+		     "option", &expr->where,
+		     gfc_option.flag_max_array_constructor);
+	  return false;
+	}
+
+      cons = gfc_constructor_lookup (base, limit);
+      gcc_assert (cons);
+      gfc_constructor_append_expr (&expr->value.constructor,
+				   gfc_copy_expr (cons->expr), NULL);
+    }
+
+  mpz_clear (ptr);
+
+cleanup:
+
+  mpz_clear (delta_mpz);
+  mpz_clear (tmp_mpz);
+  mpz_clear (nelts);
+  for (d = 0; d < rank; d++)
+    {
+      mpz_clear (delta[d]);
+      mpz_clear (start[d]);
+      mpz_clear (end[d]);
+      mpz_clear (ctr[d]);
+      mpz_clear (stride[d]);
+    }
+  gfc_constructor_free (base);
+  return t;
+}
+
+/* Pull a substring out of an expression.  */
+
+static bool
+find_substring_ref (gfc_expr *p, gfc_expr **newp)
+{
+  int end;
+  int start;
+  int length;
+  gfc_char_t *chr;
+
+  if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
+      || p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
+    return false;
+
+  *newp = gfc_copy_expr (p);
+  free ((*newp)->value.character.string);
+
+  end = (int) mpz_get_ui (p->ref->u.ss.end->value.integer);
+  start = (int) mpz_get_ui (p->ref->u.ss.start->value.integer);
+  length = end - start + 1;
+
+  chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1);
+  (*newp)->value.character.length = length;
+  memcpy (chr, &p->value.character.string[start - 1],
+	  length * sizeof (gfc_char_t));
+  chr[length] = '\0';
+  return true;
+}
+
+
+
+/* Simplify a subobject reference of a constructor.  This occurs when
+   parameter variable values are substituted.  */
+
+static bool
+simplify_const_ref (gfc_expr *p)
+{
+  gfc_constructor *cons, *c;
+  gfc_expr *newp;
+  gfc_ref *last_ref;
+
+  while (p->ref)
+    {
+      switch (p->ref->type)
+	{
+	case REF_ARRAY:
+	  switch (p->ref->u.ar.type)
+	    {
+	    case AR_ELEMENT:
+	      /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
+		 will generate this.  */
+	      if (p->expr_type != EXPR_ARRAY)
+		{
+		  remove_subobject_ref (p, NULL);
+		  break;
+		}
+	      if (!find_array_element (p->value.constructor, &p->ref->u.ar, &cons))
+		return false;
+
+	      if (!cons)
+		return true;
+
+	      remove_subobject_ref (p, cons);
+	      break;
+
+	    case AR_SECTION:
+	      if (!find_array_section (p, p->ref))
+		return false;
+	      p->ref->u.ar.type = AR_FULL;
+
+	    /* Fall through.  */
+
+	    case AR_FULL:
+	      if (p->ref->next != NULL
+		  && (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED))
+		{
+		  for (c = gfc_constructor_first (p->value.constructor);
+		       c; c = gfc_constructor_next (c))
+		    {
+		      c->expr->ref = gfc_copy_ref (p->ref->next);
+		      if (!simplify_const_ref (c->expr))
+			return false;
+		    }
+
+		  if (p->ts.type == BT_DERIVED
+			&& p->ref->next
+			&& (c = gfc_constructor_first (p->value.constructor)))
+		    {
+		      /* There may have been component references.  */
+		      p->ts = c->expr->ts;
+		    }
+
+		  last_ref = p->ref;
+		  for (; last_ref->next; last_ref = last_ref->next) {};
+
+		  if (p->ts.type == BT_CHARACTER
+			&& last_ref->type == REF_SUBSTRING)
+		    {
+		      /* If this is a CHARACTER array and we possibly took
+			 a substring out of it, update the type-spec's
+			 character length according to the first element
+			 (as all should have the same length).  */
+		      int string_len;
+		      if ((c = gfc_constructor_first (p->value.constructor)))
+			{
+			  const gfc_expr* first = c->expr;
+			  gcc_assert (first->expr_type == EXPR_CONSTANT);
+			  gcc_assert (first->ts.type == BT_CHARACTER);
+			  string_len = first->value.character.length;
+			}
+		      else
+			string_len = 0;
+
+		      if (!p->ts.u.cl)
+			p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns,
+						      NULL);
+		      else
+			gfc_free_expr (p->ts.u.cl->length);
+
+		      p->ts.u.cl->length
+			= gfc_get_int_expr (gfc_default_integer_kind,
+					    NULL, string_len);
+		    }
+		}
+	      gfc_free_ref_list (p->ref);
+	      p->ref = NULL;
+	      break;
+
+	    default:
+	      return true;
+	    }
+
+	  break;
+
+	case REF_COMPONENT:
+	  cons = find_component_ref (p->value.constructor, p->ref);
+	  remove_subobject_ref (p, cons);
+	  break;
+
+	case REF_SUBSTRING:
+  	  if (!find_substring_ref (p, &newp))
+	    return false;
+
+	  gfc_replace_expr (p, newp);
+	  gfc_free_ref_list (p->ref);
+	  p->ref = NULL;
+	  break;
+	}
+    }
+
+  return true;
+}
+
+
+/* Simplify a chain of references.  */
+
+static bool
+simplify_ref_chain (gfc_ref *ref, int type)
+{
+  int n;
+
+  for (; ref; ref = ref->next)
+    {
+      switch (ref->type)
+	{
+	case REF_ARRAY:
+	  for (n = 0; n < ref->u.ar.dimen; n++)
+	    {
+	      if (!gfc_simplify_expr (ref->u.ar.start[n], type))
+		return false;
+	      if (!gfc_simplify_expr (ref->u.ar.end[n], type))
+		return false;
+	      if (!gfc_simplify_expr (ref->u.ar.stride[n], type))
+		return false;
+	    }
+	  break;
+
+	case REF_SUBSTRING:
+	  if (!gfc_simplify_expr (ref->u.ss.start, type))
+	    return false;
+	  if (!gfc_simplify_expr (ref->u.ss.end, type))
+	    return false;
+	  break;
+
+	default:
+	  break;
+	}
+    }
+  return true;
+}
+
+
+/* Try to substitute the value of a parameter variable.  */
+
+static bool
+simplify_parameter_variable (gfc_expr *p, int type)
+{
+  gfc_expr *e;
+  bool t;
+
+  e = gfc_copy_expr (p->symtree->n.sym->value);
+  if (e == NULL)
+    return false;
+
+  e->rank = p->rank;
+
+  /* Do not copy subobject refs for constant.  */
+  if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
+    e->ref = gfc_copy_ref (p->ref);
+  t = gfc_simplify_expr (e, type);
+
+  /* Only use the simplification if it eliminated all subobject references.  */
+  if (t && !e->ref)
+    gfc_replace_expr (p, e);
+  else
+    gfc_free_expr (e);
+
+  return t;
+}
+
+/* Given an expression, simplify it by collapsing constant
+   expressions.  Most simplification takes place when the expression
+   tree is being constructed.  If an intrinsic function is simplified
+   at some point, we get called again to collapse the result against
+   other constants.
+
+   We work by recursively simplifying expression nodes, simplifying
+   intrinsic functions where possible, which can lead to further
+   constant collapsing.  If an operator has constant operand(s), we
+   rip the expression apart, and rebuild it, hoping that it becomes
+   something simpler.
+
+   The expression type is defined for:
+     0   Basic expression parsing
+     1   Simplifying array constructors -- will substitute
+	 iterator values.
+   Returns false on error, true otherwise.
+   NOTE: Will return true even if the expression can not be simplified.  */
+
+bool
+gfc_simplify_expr (gfc_expr *p, int type)
+{
+  gfc_actual_arglist *ap;
+
+  if (p == NULL)
+    return true;
+
+  switch (p->expr_type)
+    {
+    case EXPR_CONSTANT:
+    case EXPR_NULL:
+      break;
+
+    case EXPR_FUNCTION:
+      for (ap = p->value.function.actual; ap; ap = ap->next)
+	if (!gfc_simplify_expr (ap->expr, type))
+	  return false;
+
+      if (p->value.function.isym != NULL
+	  && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
+	return false;
+
+      break;
+
+    case EXPR_SUBSTRING:
+      if (!simplify_ref_chain (p->ref, type))
+	return false;
+
+      if (gfc_is_constant_expr (p))
+	{
+	  gfc_char_t *s;
+	  int start, end;
+
+	  start = 0;
+	  if (p->ref && p->ref->u.ss.start)
+	    {
+	      gfc_extract_int (p->ref->u.ss.start, &start);
+	      start--;  /* Convert from one-based to zero-based.  */
+	    }
+
+	  end = p->value.character.length;
+	  if (p->ref && p->ref->u.ss.end)
+	    gfc_extract_int (p->ref->u.ss.end, &end);
+
+	  if (end < start)
+	    end = start;
+
+	  s = gfc_get_wide_string (end - start + 2);
+	  memcpy (s, p->value.character.string + start,
+		  (end - start) * sizeof (gfc_char_t));
+	  s[end - start + 1] = '\0';  /* TODO: C-style string.  */
+	  free (p->value.character.string);
+	  p->value.character.string = s;
+	  p->value.character.length = end - start;
+	  p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+	  p->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
+						 NULL,
+						 p->value.character.length);
+	  gfc_free_ref_list (p->ref);
+	  p->ref = NULL;
+	  p->expr_type = EXPR_CONSTANT;
+	}
+      break;
+
+    case EXPR_OP:
+      if (!simplify_intrinsic_op (p, type))
+	return false;
+      break;
+
+    case EXPR_VARIABLE:
+      /* Only substitute array parameter variables if we are in an
+	 initialization expression, or we want a subsection.  */
+      if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
+	  && (gfc_init_expr_flag || p->ref
+	      || p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
+	{
+	  if (!simplify_parameter_variable (p, type))
+	    return false;
+	  break;
+	}
+
+      if (type == 1)
+	{
+	  gfc_simplify_iterator_var (p);
+	}
+
+      /* Simplify subcomponent references.  */
+      if (!simplify_ref_chain (p->ref, type))
+	return false;
+
+      break;
+
+    case EXPR_STRUCTURE:
+    case EXPR_ARRAY:
+      if (!simplify_ref_chain (p->ref, type))
+	return false;
+
+      if (!simplify_constructor (p->value.constructor, type))
+	return false;
+
+      if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY
+	  && p->ref->u.ar.type == AR_FULL)
+	  gfc_expand_constructor (p, false);
+
+      if (!simplify_const_ref (p))
+	return false;
+
+      break;
+
+    case EXPR_COMPCALL:
+    case EXPR_PPC:
+      break;
+    }
+
+  return true;
+}
+
+
+/* Returns the type of an expression with the exception that iterator
+   variables are automatically integers no matter what else they may
+   be declared as.  */
+
+static bt
+et0 (gfc_expr *e)
+{
+  if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e))
+    return BT_INTEGER;
+
+  return e->ts.type;
+}
+
+
+/* Scalarize an expression for an elemental intrinsic call.  */
+
+static bool
+scalarize_intrinsic_call (gfc_expr *e)
+{
+  gfc_actual_arglist *a, *b;
+  gfc_constructor_base ctor;
+  gfc_constructor *args[5];
+  gfc_constructor *ci, *new_ctor;
+  gfc_expr *expr, *old;
+  int n, i, rank[5], array_arg;
+
+  /* Find which, if any, arguments are arrays.  Assume that the old
+     expression carries the type information and that the first arg
+     that is an array expression carries all the shape information.*/
+  n = array_arg = 0;
+  a = e->value.function.actual;
+  for (; a; a = a->next)
+    {
+      n++;
+      if (a->expr->expr_type != EXPR_ARRAY)
+	continue;
+      array_arg = n;
+      expr = gfc_copy_expr (a->expr);
+      break;
+    }
+
+  if (!array_arg)
+    return false;
+
+  old = gfc_copy_expr (e);
+
+  gfc_constructor_free (expr->value.constructor);
+  expr->value.constructor = NULL;
+  expr->ts = old->ts;
+  expr->where = old->where;
+  expr->expr_type = EXPR_ARRAY;
+
+  /* Copy the array argument constructors into an array, with nulls
+     for the scalars.  */
+  n = 0;
+  a = old->value.function.actual;
+  for (; a; a = a->next)
+    {
+      /* Check that this is OK for an initialization expression.  */
+      if (a->expr && !gfc_check_init_expr (a->expr))
+	goto cleanup;
+
+      rank[n] = 0;
+      if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE)
+	{
+	  rank[n] = a->expr->rank;
+	  ctor = a->expr->symtree->n.sym->value->value.constructor;
+	  args[n] = gfc_constructor_first (ctor);
+	}
+      else if (a->expr && a->expr->expr_type == EXPR_ARRAY)
+	{
+	  if (a->expr->rank)
+	    rank[n] = a->expr->rank;
+	  else
+	    rank[n] = 1;
+	  ctor = gfc_constructor_copy (a->expr->value.constructor);
+	  args[n] = gfc_constructor_first (ctor);
+	}
+      else
+	args[n] = NULL;
+
+      n++;
+    }
+
+
+  /* Using the array argument as the master, step through the array
+     calling the function for each element and advancing the array
+     constructors together.  */
+  for (ci = args[array_arg - 1]; ci; ci = gfc_constructor_next (ci))
+    {
+      new_ctor = gfc_constructor_append_expr (&expr->value.constructor,
+					      gfc_copy_expr (old), NULL);
+
+      gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
+      a = NULL;
+      b = old->value.function.actual;
+      for (i = 0; i < n; i++)
+	{
+	  if (a == NULL)
+	    new_ctor->expr->value.function.actual
+			= a = gfc_get_actual_arglist ();
+	  else
+	    {
+	      a->next = gfc_get_actual_arglist ();
+	      a = a->next;
+	    }
+
+	  if (args[i])
+	    a->expr = gfc_copy_expr (args[i]->expr);
+	  else
+	    a->expr = gfc_copy_expr (b->expr);
+
+	  b = b->next;
+	}
+
+      /* Simplify the function calls.  If the simplification fails, the
+	 error will be flagged up down-stream or the library will deal
+	 with it.  */
+      gfc_simplify_expr (new_ctor->expr, 0);
+
+      for (i = 0; i < n; i++)
+	if (args[i])
+	  args[i] = gfc_constructor_next (args[i]);
+
+      for (i = 1; i < n; i++)
+	if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
+			|| (args[i] == NULL && args[array_arg - 1] != NULL)))
+	  goto compliance;
+    }
+
+  free_expr0 (e);
+  *e = *expr;
+  /* Free "expr" but not the pointers it contains.  */
+  free (expr);
+  gfc_free_expr (old);
+  return true;
+
+compliance:
+  gfc_error_now ("elemental function arguments at %C are not compliant");
+
+cleanup:
+  gfc_free_expr (expr);
+  gfc_free_expr (old);
+  return false;
+}
+
+
+static bool
+check_intrinsic_op (gfc_expr *e, bool (*check_function) (gfc_expr *))
+{
+  gfc_expr *op1 = e->value.op.op1;
+  gfc_expr *op2 = e->value.op.op2;
+
+  if (!(*check_function)(op1))
+    return false;
+
+  switch (e->value.op.op)
+    {
+    case INTRINSIC_UPLUS:
+    case INTRINSIC_UMINUS:
+      if (!numeric_type (et0 (op1)))
+	goto not_numeric;
+      break;
+
+    case INTRINSIC_EQ:
+    case INTRINSIC_EQ_OS:
+    case INTRINSIC_NE:
+    case INTRINSIC_NE_OS:
+    case INTRINSIC_GT:
+    case INTRINSIC_GT_OS:
+    case INTRINSIC_GE:
+    case INTRINSIC_GE_OS:
+    case INTRINSIC_LT:
+    case INTRINSIC_LT_OS:
+    case INTRINSIC_LE:
+    case INTRINSIC_LE_OS:
+      if (!(*check_function)(op2))
+	return false;
+
+      if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
+	  && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
+	{
+	  gfc_error ("Numeric or CHARACTER operands are required in "
+		     "expression at %L", &e->where);
+	 return false;
+	}
+      break;
+
+    case INTRINSIC_PLUS:
+    case INTRINSIC_MINUS:
+    case INTRINSIC_TIMES:
+    case INTRINSIC_DIVIDE:
+    case INTRINSIC_POWER:
+      if (!(*check_function)(op2))
+	return false;
+
+      if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
+	goto not_numeric;
+
+      break;
+
+    case INTRINSIC_CONCAT:
+      if (!(*check_function)(op2))
+	return false;
+
+      if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER)
+	{
+	  gfc_error ("Concatenation operator in expression at %L "
+		     "must have two CHARACTER operands", &op1->where);
+	  return false;
+	}
+
+      if (op1->ts.kind != op2->ts.kind)
+	{
+	  gfc_error ("Concat operator at %L must concatenate strings of the "
+		     "same kind", &e->where);
+	  return false;
+	}
+
+      break;
+
+    case INTRINSIC_NOT:
+      if (et0 (op1) != BT_LOGICAL)
+	{
+	  gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
+		     "operand", &op1->where);
+	  return false;
+	}
+
+      break;
+
+    case INTRINSIC_AND:
+    case INTRINSIC_OR:
+    case INTRINSIC_EQV:
+    case INTRINSIC_NEQV:
+      if (!(*check_function)(op2))
+	return false;
+
+      if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL)
+	{
+	  gfc_error ("LOGICAL operands are required in expression at %L",
+		     &e->where);
+	  return false;
+	}
+
+      break;
+
+    case INTRINSIC_PARENTHESES:
+      break;
+
+    default:
+      gfc_error ("Only intrinsic operators can be used in expression at %L",
+		 &e->where);
+      return false;
+    }
+
+  return true;
+
+not_numeric:
+  gfc_error ("Numeric operands are required in expression at %L", &e->where);
+
+  return false;
+}
+
+/* F2003, 7.1.7 (3): In init expression, allocatable components
+   must not be data-initialized.  */
+static bool
+check_alloc_comp_init (gfc_expr *e)
+{
+  gfc_component *comp;
+  gfc_constructor *ctor;
+
+  gcc_assert (e->expr_type == EXPR_STRUCTURE);
+  gcc_assert (e->ts.type == BT_DERIVED);
+
+  for (comp = e->ts.u.derived->components,
+       ctor = gfc_constructor_first (e->value.constructor);
+       comp; comp = comp->next, ctor = gfc_constructor_next (ctor))
+    {
+      if (comp->attr.allocatable
+          && ctor->expr->expr_type != EXPR_NULL)
+        {
+	  gfc_error("Invalid initialization expression for ALLOCATABLE "
+	            "component '%s' in structure constructor at %L",
+	            comp->name, &ctor->expr->where);
+	  return false;
+	}
+    }
+
+  return true;
+}
+
+static match
+check_init_expr_arguments (gfc_expr *e)
+{
+  gfc_actual_arglist *ap;
+
+  for (ap = e->value.function.actual; ap; ap = ap->next)
+    if (!gfc_check_init_expr (ap->expr))
+      return MATCH_ERROR;
+
+  return MATCH_YES;
+}
+
+static bool check_restricted (gfc_expr *);
+
+/* F95, 7.1.6.1, Initialization expressions, (7)
+   F2003, 7.1.7 Initialization expression, (8)  */
+
+static match
+check_inquiry (gfc_expr *e, int not_restricted)
+{
+  const char *name;
+  const char *const *functions;
+
+  static const char *const inquiry_func_f95[] = {
+    "lbound", "shape", "size", "ubound",
+    "bit_size", "len", "kind",
+    "digits", "epsilon", "huge", "maxexponent", "minexponent",
+    "precision", "radix", "range", "tiny",
+    NULL
+  };
+
+  static const char *const inquiry_func_f2003[] = {
+    "lbound", "shape", "size", "ubound",
+    "bit_size", "len", "kind",
+    "digits", "epsilon", "huge", "maxexponent", "minexponent",
+    "precision", "radix", "range", "tiny",
+    "new_line", NULL
+  };
+
+  int i = 0;
+  gfc_actual_arglist *ap;
+
+  if (!e->value.function.isym
+      || !e->value.function.isym->inquiry)
+    return MATCH_NO;
+
+  /* An undeclared parameter will get us here (PR25018).  */
+  if (e->symtree == NULL)
+    return MATCH_NO;
+
+  if (e->symtree->n.sym->from_intmod)
+    {
+      if (e->symtree->n.sym->from_intmod == INTMOD_ISO_FORTRAN_ENV
+	  && e->symtree->n.sym->intmod_sym_id != ISOFORTRAN_COMPILER_OPTIONS
+	  && e->symtree->n.sym->intmod_sym_id != ISOFORTRAN_COMPILER_VERSION)
+	return MATCH_NO;
+
+      if (e->symtree->n.sym->from_intmod == INTMOD_ISO_C_BINDING
+	  && e->symtree->n.sym->intmod_sym_id != ISOCBINDING_C_SIZEOF)
+	return MATCH_NO;
+    }
+  else
+    {
+      name = e->symtree->n.sym->name;
+
+      functions = (gfc_option.warn_std & GFC_STD_F2003)
+		? inquiry_func_f2003 : inquiry_func_f95;
+
+      for (i = 0; functions[i]; i++)
+	if (strcmp (functions[i], name) == 0)
+	  break;
+
+	if (functions[i] == NULL)
+	  return MATCH_ERROR;
+    }
+
+  /* At this point we have an inquiry function with a variable argument.  The
+     type of the variable might be undefined, but we need it now, because the
+     arguments of these functions are not allowed to be undefined.  */
+
+  for (ap = e->value.function.actual; ap; ap = ap->next)
+    {
+      if (!ap->expr)
+	continue;
+
+      if (ap->expr->ts.type == BT_UNKNOWN)
+	{
+	  if (ap->expr->symtree->n.sym->ts.type == BT_UNKNOWN
+	      && !gfc_set_default_type (ap->expr->symtree->n.sym, 0, gfc_current_ns))
+	    return MATCH_NO;
+
+	  ap->expr->ts = ap->expr->symtree->n.sym->ts;
+	}
+
+	/* Assumed character length will not reduce to a constant expression
+	   with LEN, as required by the standard.  */
+	if (i == 5 && not_restricted
+	    && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER
+	    && (ap->expr->symtree->n.sym->ts.u.cl->length == NULL
+		|| ap->expr->symtree->n.sym->ts.deferred))
+	  {
+	    gfc_error ("Assumed or deferred character length variable '%s' "
+			" in constant expression at %L",
+			ap->expr->symtree->n.sym->name,
+			&ap->expr->where);
+	      return MATCH_ERROR;
+	  }
+	else if (not_restricted && !gfc_check_init_expr (ap->expr))
+	  return MATCH_ERROR;
+
+	if (not_restricted == 0
+	      && ap->expr->expr_type != EXPR_VARIABLE
+	      && !check_restricted (ap->expr))
+	  return MATCH_ERROR;
+
+	if (not_restricted == 0
+	    && ap->expr->expr_type == EXPR_VARIABLE
+	    && ap->expr->symtree->n.sym->attr.dummy
+	    && ap->expr->symtree->n.sym->attr.optional)
+	  return MATCH_NO;
+    }
+
+  return MATCH_YES;
+}
+
+
+/* F95, 7.1.6.1, Initialization expressions, (5)
+   F2003, 7.1.7 Initialization expression, (5)  */
+
+static match
+check_transformational (gfc_expr *e)
+{
+  static const char * const trans_func_f95[] = {
+    "repeat", "reshape", "selected_int_kind",
+    "selected_real_kind", "transfer", "trim", NULL
+  };
+
+  static const char * const trans_func_f2003[] =  {
+    "all", "any", "count", "dot_product", "matmul", "null", "pack",
+    "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
+    "selected_real_kind", "spread", "sum", "transfer", "transpose",
+    "trim", "unpack", NULL
+  };
+
+  int i;
+  const char *name;
+  const char *const *functions;
+
+  if (!e->value.function.isym
+      || !e->value.function.isym->transformational)
+    return MATCH_NO;
+
+  name = e->symtree->n.sym->name;
+
+  functions = (gfc_option.allow_std & GFC_STD_F2003)
+		? trans_func_f2003 : trans_func_f95;
+
+  /* NULL() is dealt with below.  */
+  if (strcmp ("null", name) == 0)
+    return MATCH_NO;
+
+  for (i = 0; functions[i]; i++)
+    if (strcmp (functions[i], name) == 0)
+       break;
+
+  if (functions[i] == NULL)
+    {
+      gfc_error("transformational intrinsic '%s' at %L is not permitted "
+		"in an initialization expression", name, &e->where);
+      return MATCH_ERROR;
+    }
+
+  return check_init_expr_arguments (e);
+}
+
+
+/* F95, 7.1.6.1, Initialization expressions, (6)
+   F2003, 7.1.7 Initialization expression, (6)  */
+
+static match
+check_null (gfc_expr *e)
+{
+  if (strcmp ("null", e->symtree->n.sym->name) != 0)
+    return MATCH_NO;
+
+  return check_init_expr_arguments (e);
+}
+
+
+static match
+check_elemental (gfc_expr *e)
+{
+  if (!e->value.function.isym
+      || !e->value.function.isym->elemental)
+    return MATCH_NO;
+
+  if (e->ts.type != BT_INTEGER
+      && e->ts.type != BT_CHARACTER
+      && !gfc_notify_std (GFC_STD_F2003, "Evaluation of nonstandard "
+			  "initialization expression at %L", &e->where))
+    return MATCH_ERROR;
+
+  return check_init_expr_arguments (e);
+}
+
+
+static match
+check_conversion (gfc_expr *e)
+{
+  if (!e->value.function.isym
+      || !e->value.function.isym->conversion)
+    return MATCH_NO;
+
+  return check_init_expr_arguments (e);
+}
+
+
+/* Verify that an expression is an initialization expression.  A side
+   effect is that the expression tree is reduced to a single constant
+   node if all goes well.  This would normally happen when the
+   expression is constructed but function references are assumed to be
+   intrinsics in the context of initialization expressions.  If
+   false is returned an error message has been generated.  */
+
+bool
+gfc_check_init_expr (gfc_expr *e)
+{
+  match m;
+  bool t;
+
+  if (e == NULL)
+    return true;
+
+  switch (e->expr_type)
+    {
+    case EXPR_OP:
+      t = check_intrinsic_op (e, gfc_check_init_expr);
+      if (t)
+	t = gfc_simplify_expr (e, 0);
+
+      break;
+
+    case EXPR_FUNCTION:
+      t = false;
+
+      {
+	gfc_intrinsic_sym* isym;
+	gfc_symbol* sym;
+
+	sym = e->symtree->n.sym;
+	if (!gfc_is_intrinsic (sym, 0, e->where)
+	    || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
+	  {
+	    gfc_error ("Function '%s' in initialization expression at %L "
+		       "must be an intrinsic function",
+		       e->symtree->n.sym->name, &e->where);
+	    break;
+	  }
+
+	if ((m = check_conversion (e)) == MATCH_NO
+	    && (m = check_inquiry (e, 1)) == MATCH_NO
+	    && (m = check_null (e)) == MATCH_NO
+	    && (m = check_transformational (e)) == MATCH_NO
+	    && (m = check_elemental (e)) == MATCH_NO)
+	  {
+	    gfc_error ("Intrinsic function '%s' at %L is not permitted "
+		       "in an initialization expression",
+		       e->symtree->n.sym->name, &e->where);
+	    m = MATCH_ERROR;
+	  }
+
+	if (m == MATCH_ERROR)
+	  return false;
+
+	/* Try to scalarize an elemental intrinsic function that has an
+	   array argument.  */
+	isym = gfc_find_function (e->symtree->n.sym->name);
+	if (isym && isym->elemental
+	    && (t = scalarize_intrinsic_call(e)))
+	  break;
+      }
+
+      if (m == MATCH_YES)
+	t = gfc_simplify_expr (e, 0);
+
+      break;
+
+    case EXPR_VARIABLE:
+      t = true;
+
+      if (gfc_check_iter_variable (e))
+	break;
+
+      if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
+	{
+	  /* A PARAMETER shall not be used to define itself, i.e.
+		REAL, PARAMETER :: x = transfer(0, x)
+	     is invalid.  */
+	  if (!e->symtree->n.sym->value)
+	    {
+	      gfc_error("PARAMETER '%s' is used at %L before its definition "
+			"is complete", e->symtree->n.sym->name, &e->where);
+	      t = false;
+	    }
+	  else
+	    t = simplify_parameter_variable (e, 0);
+
+	  break;
+	}
+
+      if (gfc_in_match_data ())
+	break;
+
+      t = false;
+
+      if (e->symtree->n.sym->as)
+	{
+	  switch (e->symtree->n.sym->as->type)
+	    {
+	      case AS_ASSUMED_SIZE:
+		gfc_error ("Assumed size array '%s' at %L is not permitted "
+			   "in an initialization expression",
+			   e->symtree->n.sym->name, &e->where);
+		break;
+
+	      case AS_ASSUMED_SHAPE:
+		gfc_error ("Assumed shape array '%s' at %L is not permitted "
+			   "in an initialization expression",
+			   e->symtree->n.sym->name, &e->where);
+		break;
+
+	      case AS_DEFERRED:
+		gfc_error ("Deferred array '%s' at %L is not permitted "
+			   "in an initialization expression",
+			   e->symtree->n.sym->name, &e->where);
+		break;
+
+	      case AS_EXPLICIT:
+		gfc_error ("Array '%s' at %L is a variable, which does "
+			   "not reduce to a constant expression",
+			   e->symtree->n.sym->name, &e->where);
+		break;
+
+	      default:
+		gcc_unreachable();
+	  }
+	}
+      else
+	gfc_error ("Parameter '%s' at %L has not been declared or is "
+		   "a variable, which does not reduce to a constant "
+		   "expression", e->symtree->n.sym->name, &e->where);
+
+      break;
+
+    case EXPR_CONSTANT:
+    case EXPR_NULL:
+      t = true;
+      break;
+
+    case EXPR_SUBSTRING:
+      t = gfc_check_init_expr (e->ref->u.ss.start);
+      if (!t)
+	break;
+
+      t = gfc_check_init_expr (e->ref->u.ss.end);
+      if (t)
+	t = gfc_simplify_expr (e, 0);
+
+      break;
+
+    case EXPR_STRUCTURE:
+      t = e->ts.is_iso_c ? true : false;
+      if (t)
+	break;
+
+      t = check_alloc_comp_init (e);
+      if (!t)
+	break;
+
+      t = gfc_check_constructor (e, gfc_check_init_expr);
+      if (!t)
+	break;
+
+      break;
+
+    case EXPR_ARRAY:
+      t = gfc_check_constructor (e, gfc_check_init_expr);
+      if (!t)
+	break;
+
+      t = gfc_expand_constructor (e, true);
+      if (!t)
+	break;
+
+      t = gfc_check_constructor_type (e);
+      break;
+
+    default:
+      gfc_internal_error ("check_init_expr(): Unknown expression type");
+    }
+
+  return t;
+}
+
+/* Reduces a general expression to an initialization expression (a constant).
+   This used to be part of gfc_match_init_expr.
+   Note that this function doesn't free the given expression on false.  */
+
+bool
+gfc_reduce_init_expr (gfc_expr *expr)
+{
+  bool t;
+
+  gfc_init_expr_flag = true;
+  t = gfc_resolve_expr (expr);
+  if (t)
+    t = gfc_check_init_expr (expr);
+  gfc_init_expr_flag = false;
+
+  if (!t)
+    return false;
+
+  if (expr->expr_type == EXPR_ARRAY)
+    {
+      if (!gfc_check_constructor_type (expr))
+	return false;
+      if (!gfc_expand_constructor (expr, true))
+	return false;
+    }
+
+  return true;
+}
+
+
+/* Match an initialization expression.  We work by first matching an
+   expression, then reducing it to a constant.  */
+
+match
+gfc_match_init_expr (gfc_expr **result)
+{
+  gfc_expr *expr;
+  match m;
+  bool t;
+
+  expr = NULL;
+
+  gfc_init_expr_flag = true;
+
+  m = gfc_match_expr (&expr);
+  if (m != MATCH_YES)
+    {
+      gfc_init_expr_flag = false;
+      return m;
+    }
+
+  t = gfc_reduce_init_expr (expr);
+  if (!t)
+    {
+      gfc_free_expr (expr);
+      gfc_init_expr_flag = false;
+      return MATCH_ERROR;
+    }
+
+  *result = expr;
+  gfc_init_expr_flag = false;
+
+  return MATCH_YES;
+}
+
+
+/* Given an actual argument list, test to see that each argument is a
+   restricted expression and optionally if the expression type is
+   integer or character.  */
+
+static bool
+restricted_args (gfc_actual_arglist *a)
+{
+  for (; a; a = a->next)
+    {
+      if (!check_restricted (a->expr))
+	return false;
+    }
+
+  return true;
+}
+
+
+/************* Restricted/specification expressions *************/
+
+
+/* Make sure a non-intrinsic function is a specification function.  */
+
+static bool
+external_spec_function (gfc_expr *e)
+{
+  gfc_symbol *f;
+
+  f = e->value.function.esym;
+
+  if (f->attr.proc == PROC_ST_FUNCTION)
+    {
+      gfc_error ("Specification function '%s' at %L cannot be a statement "
+		 "function", f->name, &e->where);
+      return false;
+    }
+
+  if (f->attr.proc == PROC_INTERNAL)
+    {
+      gfc_error ("Specification function '%s' at %L cannot be an internal "
+		 "function", f->name, &e->where);
+      return false;
+    }
+
+  if (!f->attr.pure && !f->attr.elemental)
+    {
+      gfc_error ("Specification function '%s' at %L must be PURE", f->name,
+		 &e->where);
+      return false;
+    }
+
+  if (f->attr.recursive)
+    {
+      gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
+		 f->name, &e->where);
+      return false;
+    }
+
+  return restricted_args (e->value.function.actual);
+}
+
+
+/* Check to see that a function reference to an intrinsic is a
+   restricted expression.  */
+
+static bool
+restricted_intrinsic (gfc_expr *e)
+{
+  /* TODO: Check constraints on inquiry functions.  7.1.6.2 (7).  */
+  if (check_inquiry (e, 0) == MATCH_YES)
+    return true;
+
+  return restricted_args (e->value.function.actual);
+}
+
+
+/* Check the expressions of an actual arglist.  Used by check_restricted.  */
+
+static bool
+check_arglist (gfc_actual_arglist* arg, bool (*checker) (gfc_expr*))
+{
+  for (; arg; arg = arg->next)
+    if (!checker (arg->expr))
+      return false;
+
+  return true;
+}
+
+
+/* Check the subscription expressions of a reference chain with a checking
+   function; used by check_restricted.  */
+
+static bool
+check_references (gfc_ref* ref, bool (*checker) (gfc_expr*))
+{
+  int dim;
+
+  if (!ref)
+    return true;
+
+  switch (ref->type)
+    {
+    case REF_ARRAY:
+      for (dim = 0; dim != ref->u.ar.dimen; ++dim)
+	{
+	  if (!checker (ref->u.ar.start[dim]))
+	    return false;
+	  if (!checker (ref->u.ar.end[dim]))
+	    return false;
+	  if (!checker (ref->u.ar.stride[dim]))
+	    return false;
+	}
+      break;
+
+    case REF_COMPONENT:
+      /* Nothing needed, just proceed to next reference.  */
+      break;
+
+    case REF_SUBSTRING:
+      if (!checker (ref->u.ss.start))
+	return false;
+      if (!checker (ref->u.ss.end))
+	return false;
+      break;
+
+    default:
+      gcc_unreachable ();
+      break;
+    }
+
+  return check_references (ref->next, checker);
+}
+
+
+/* Verify that an expression is a restricted expression.  Like its
+   cousin check_init_expr(), an error message is generated if we
+   return false.  */
+
+static bool
+check_restricted (gfc_expr *e)
+{
+  gfc_symbol* sym;
+  bool t;
+
+  if (e == NULL)
+    return true;
+
+  switch (e->expr_type)
+    {
+    case EXPR_OP:
+      t = check_intrinsic_op (e, check_restricted);
+      if (t)
+	t = gfc_simplify_expr (e, 0);
+
+      break;
+
+    case EXPR_FUNCTION:
+      if (e->value.function.esym)
+	{
+	  t = check_arglist (e->value.function.actual, &check_restricted);
+	  if (t)
+	    t = external_spec_function (e);
+	}
+      else
+	{
+	  if (e->value.function.isym && e->value.function.isym->inquiry)
+	    t = true;
+	  else
+	    t = check_arglist (e->value.function.actual, &check_restricted);
+
+	  if (t)
+	    t = restricted_intrinsic (e);
+	}
+      break;
+
+    case EXPR_VARIABLE:
+      sym = e->symtree->n.sym;
+      t = false;
+
+      /* If a dummy argument appears in a context that is valid for a
+	 restricted expression in an elemental procedure, it will have
+	 already been simplified away once we get here.  Therefore we
+	 don't need to jump through hoops to distinguish valid from
+	 invalid cases.  */
+      if (sym->attr.dummy && sym->ns == gfc_current_ns
+	  && sym->ns->proc_name && sym->ns->proc_name->attr.elemental)
+	{
+	  gfc_error ("Dummy argument '%s' not allowed in expression at %L",
+		     sym->name, &e->where);
+	  break;
+	}
+
+      if (sym->attr.optional)
+	{
+	  gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
+		     sym->name, &e->where);
+	  break;
+	}
+
+      if (sym->attr.intent == INTENT_OUT)
+	{
+	  gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
+		     sym->name, &e->where);
+	  break;
+	}
+
+      /* Check reference chain if any.  */
+      if (!check_references (e->ref, &check_restricted))
+	break;
+
+      /* gfc_is_formal_arg broadcasts that a formal argument list is being
+	 processed in resolve.c(resolve_formal_arglist).  This is done so
+	 that host associated dummy array indices are accepted (PR23446).
+	 This mechanism also does the same for the specification expressions
+	 of array-valued functions.  */
+      if (e->error
+	    || sym->attr.in_common
+	    || sym->attr.use_assoc
+	    || 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)
+	    || (sym->ns->proc_name != NULL
+		  && sym->ns->proc_name->attr.flavor == FL_MODULE)
+	    || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
+	{
+	  t = true;
+	  break;
+	}
+
+      gfc_error ("Variable '%s' cannot appear in the expression at %L",
+		 sym->name, &e->where);
+      /* Prevent a repetition of the error.  */
+      e->error = 1;
+      break;
+
+    case EXPR_NULL:
+    case EXPR_CONSTANT:
+      t = true;
+      break;
+
+    case EXPR_SUBSTRING:
+      t = gfc_specification_expr (e->ref->u.ss.start);
+      if (!t)
+	break;
+
+      t = gfc_specification_expr (e->ref->u.ss.end);
+      if (t)
+	t = gfc_simplify_expr (e, 0);
+
+      break;
+
+    case EXPR_STRUCTURE:
+      t = gfc_check_constructor (e, check_restricted);
+      break;
+
+    case EXPR_ARRAY:
+      t = gfc_check_constructor (e, check_restricted);
+      break;
+
+    default:
+      gfc_internal_error ("check_restricted(): Unknown expression type");
+    }
+
+  return t;
+}
+
+
+/* Check to see that an expression is a specification expression.  If
+   we return false, an error has been generated.  */
+
+bool
+gfc_specification_expr (gfc_expr *e)
+{
+  gfc_component *comp;
+
+  if (e == NULL)
+    return true;
+
+  if (e->ts.type != BT_INTEGER)
+    {
+      gfc_error ("Expression at %L must be of INTEGER type, found %s",
+		 &e->where, gfc_basic_typename (e->ts.type));
+      return false;
+    }
+
+  comp = gfc_get_proc_ptr_comp (e);
+  if (e->expr_type == EXPR_FUNCTION
+      && !e->value.function.isym
+      && !e->value.function.esym
+      && !gfc_pure (e->symtree->n.sym)
+      && (!comp || !comp->attr.pure))
+    {
+      gfc_error ("Function '%s' at %L must be PURE",
+		 e->symtree->n.sym->name, &e->where);
+      /* Prevent repeat error messages.  */
+      e->symtree->n.sym->attr.pure = 1;
+      return false;
+    }
+
+  if (e->rank != 0)
+    {
+      gfc_error ("Expression at %L must be scalar", &e->where);
+      return false;
+    }
+
+  if (!gfc_simplify_expr (e, 0))
+    return false;
+
+  return check_restricted (e);
+}
+
+
+/************** Expression conformance checks.  *************/
+
+/* Given two expressions, make sure that the arrays are conformable.  */
+
+bool
+gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, ...)
+{
+  int op1_flag, op2_flag, d;
+  mpz_t op1_size, op2_size;
+  bool t;
+
+  va_list argp;
+  char buffer[240];
+
+  if (op1->rank == 0 || op2->rank == 0)
+    return true;
+
+  va_start (argp, optype_msgid);
+  vsnprintf (buffer, 240, optype_msgid, argp);
+  va_end (argp);
+
+  if (op1->rank != op2->rank)
+    {
+      gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer),
+		 op1->rank, op2->rank, &op1->where);
+      return false;
+    }
+
+  t = true;
+
+  for (d = 0; d < op1->rank; d++)
+    {
+      op1_flag = gfc_array_dimen_size(op1, d, &op1_size);
+      op2_flag = gfc_array_dimen_size(op2, d, &op2_size);
+
+      if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
+	{
+	  gfc_error ("Different shape for %s at %L on dimension %d "
+		     "(%d and %d)", _(buffer), &op1->where, d + 1,
+		     (int) mpz_get_si (op1_size),
+		     (int) mpz_get_si (op2_size));
+
+	  t = false;
+	}
+
+      if (op1_flag)
+	mpz_clear (op1_size);
+      if (op2_flag)
+	mpz_clear (op2_size);
+
+      if (!t)
+	return false;
+    }
+
+  return true;
+}
+
+
+/* Given an assignable expression and an arbitrary expression, make
+   sure that the assignment can take place.  */
+
+bool
+gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
+{
+  gfc_symbol *sym;
+  gfc_ref *ref;
+  int has_pointer;
+
+  sym = lvalue->symtree->n.sym;
+
+  /* See if this is the component or subcomponent of a pointer.  */
+  has_pointer = sym->attr.pointer;
+  for (ref = lvalue->ref; ref; ref = ref->next)
+    if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
+      {
+	has_pointer = 1;
+	break;
+      }
+
+  /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
+     variable local to a function subprogram.  Its existence begins when
+     execution of the function is initiated and ends when execution of the
+     function is terminated...
+     Therefore, the left hand side is no longer a variable, when it is:  */
+  if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION
+      && !sym->attr.external)
+    {
+      bool bad_proc;
+      bad_proc = false;
+
+      /* (i) Use associated;  */
+      if (sym->attr.use_assoc)
+	bad_proc = true;
+
+      /* (ii) The assignment is in the main program; or  */
+      if (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)
+	  && 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)
+	    bad_proc = true;
+
+	  /* ... or is not an entry and has a different name.  */
+	  if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name)
+	    bad_proc = true;
+	}
+
+      /* (iv) Host associated and not the function symbol or the
+	      parent result.  This picks up sibling references, which
+	      cannot be entries.  */
+      if (!sym->attr.entry
+	    && sym->ns == gfc_current_ns->parent
+	    && sym != gfc_current_ns->proc_name
+	    && sym != gfc_current_ns->parent->proc_name->result)
+	bad_proc = true;
+
+      if (bad_proc)
+	{
+	  gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where);
+	  return false;
+	}
+    }
+
+  if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
+    {
+      gfc_error ("Incompatible ranks %d and %d in assignment at %L",
+		 lvalue->rank, rvalue->rank, &lvalue->where);
+      return false;
+    }
+
+  if (lvalue->ts.type == BT_UNKNOWN)
+    {
+      gfc_error ("Variable type is UNKNOWN in assignment at %L",
+		 &lvalue->where);
+      return false;
+    }
+
+  if (rvalue->expr_type == EXPR_NULL)
+    {
+      if (has_pointer && (ref == NULL || ref->next == NULL)
+	  && lvalue->symtree->n.sym->attr.data)
+        return true;
+      else
+	{
+	  gfc_error ("NULL appears on right-hand side in assignment at %L",
+		     &rvalue->where);
+	  return false;
+	}
+    }
+
+  /* This is possibly a typo: x = f() instead of x => f().  */
+  if (gfc_option.warn_surprising
+      && rvalue->expr_type == EXPR_FUNCTION && gfc_expr_attr (rvalue).pointer)
+    gfc_warning ("POINTER-valued function appears on right-hand side of "
+		 "assignment at %L", &rvalue->where);
+
+  /* Check size of array assignments.  */
+  if (lvalue->rank != 0 && rvalue->rank != 0
+      && !gfc_check_conformance (lvalue, rvalue, "array assignment"))
+    return false;
+
+  if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
+      && lvalue->symtree->n.sym->attr.data
+      && !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L used to "
+			  "initialize non-integer variable '%s'", 
+			  &rvalue->where, lvalue->symtree->n.sym->name))
+    return false;
+  else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data
+      && !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L outside "
+			  "a DATA statement and outside INT/REAL/DBLE/CMPLX",
+			  &rvalue->where))
+    return false;
+
+  /* Handle the case of a BOZ literal on the RHS.  */
+  if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER)
+    {
+      int rc;
+      if (gfc_option.warn_surprising)
+        gfc_warning ("BOZ literal at %L is bitwise transferred "
+                     "non-integer symbol '%s'", &rvalue->where,
+                     lvalue->symtree->n.sym->name);
+      if (!gfc_convert_boz (rvalue, &lvalue->ts))
+	return false;
+      if ((rc = gfc_range_check (rvalue)) != ARITH_OK)
+	{
+	  if (rc == ARITH_UNDERFLOW)
+	    gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
+		       ". This check can be disabled with the option "
+		       "-fno-range-check", &rvalue->where);
+	  else if (rc == ARITH_OVERFLOW)
+	    gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
+		       ". This check can be disabled with the option "
+		       "-fno-range-check", &rvalue->where);
+	  else if (rc == ARITH_NAN)
+	    gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
+		       ". This check can be disabled with the option "
+		       "-fno-range-check", &rvalue->where);
+	  return false;
+	}
+    }
+
+  /*  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 && gfc_option.gfc_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 ("Change of value in conversion from "
+			     " %s to %s at %L", gfc_typename (&rvalue->ts),
+			     gfc_typename (&lvalue->ts), &rvalue->where);
+
+	      mpfr_clear (rv);
+	      mpfr_clear (diff);
+	    }
+	  else
+	    gfc_warning ("Possible change of value in conversion from %s "
+			 "to %s at %L",gfc_typename (&rvalue->ts),
+			 gfc_typename (&lvalue->ts), &rvalue->where);
+
+	}
+      else if (gfc_option.warn_conversion_extra
+	       && lvalue->ts.kind > rvalue->ts.kind)
+	{
+	  gfc_warning ("Conversion from %s to %s at %L",
+		       gfc_typename (&rvalue->ts),
+		       gfc_typename (&lvalue->ts), &rvalue->where);
+	}
+    }
+
+  if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
+    return true;
+
+  /* Only DATA Statements come here.  */
+  if (!conform)
+    {
+      /* Numeric can be converted to any other numeric. And Hollerith can be
+	 converted to any other type.  */
+      if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
+	  || rvalue->ts.type == BT_HOLLERITH)
+	return true;
+
+      if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
+	return true;
+
+      gfc_error ("Incompatible types in DATA statement at %L; attempted "
+		 "conversion of %s to %s", &lvalue->where,
+		 gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
+
+      return false;
+    }
+
+  /* Assignment is the only case where character variables of different
+     kind values can be converted into one another.  */
+  if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER)
+    {
+      if (lvalue->ts.kind != rvalue->ts.kind)
+	gfc_convert_chartype (rvalue, &lvalue->ts);
+
+      return true;
+    }
+
+  return gfc_convert_type (rvalue, &lvalue->ts, 1);
+}
+
+
+/* Check that a pointer assignment is OK.  We first check lvalue, and
+   we only check rvalue if it's not an assignment to NULL() or a
+   NULLIFY statement.  */
+
+bool
+gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
+{
+  symbol_attribute attr, lhs_attr;
+  gfc_ref *ref;
+  bool is_pure, is_implicit_pure, rank_remap;
+  int proc_pointer;
+
+  lhs_attr = gfc_expr_attr (lvalue);
+  if (lvalue->ts.type == BT_UNKNOWN && !lhs_attr.proc_pointer)
+    {
+      gfc_error ("Pointer assignment target is not a POINTER at %L",
+		 &lvalue->where);
+      return false;
+    }
+
+  if (lhs_attr.flavor == FL_PROCEDURE && lhs_attr.use_assoc
+      && !lhs_attr.proc_pointer)
+    {
+      gfc_error ("'%s' in the pointer assignment at %L cannot be an "
+		 "l-value since it is a procedure",
+		 lvalue->symtree->n.sym->name, &lvalue->where);
+      return false;
+    }
+
+  proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
+
+  rank_remap = false;
+  for (ref = lvalue->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_COMPONENT)
+	proc_pointer = ref->u.c.component->attr.proc_pointer;
+
+      if (ref->type == REF_ARRAY && ref->next == NULL)
+	{
+	  int dim;
+
+	  if (ref->u.ar.type == AR_FULL)
+	    break;
+
+	  if (ref->u.ar.type != AR_SECTION)
+	    {
+	      gfc_error ("Expected bounds specification for '%s' at %L",
+			 lvalue->symtree->n.sym->name, &lvalue->where);
+	      return false;
+	    }
+
+	  if (!gfc_notify_std (GFC_STD_F2003, "Bounds specification "
+			       "for '%s' in pointer assignment at %L", 
+			       lvalue->symtree->n.sym->name, &lvalue->where))
+	    return false;
+
+	  /* When bounds are given, all lbounds are necessary and either all
+	     or none of the upper bounds; no strides are allowed.  If the
+	     upper bounds are present, we may do rank remapping.  */
+	  for (dim = 0; dim < ref->u.ar.dimen; ++dim)
+	    {
+	      if (!ref->u.ar.start[dim]
+		  || ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
+		{
+		  gfc_error ("Lower bound has to be present at %L",
+			     &lvalue->where);
+		  return false;
+		}
+	      if (ref->u.ar.stride[dim])
+		{
+		  gfc_error ("Stride must not be present at %L",
+			     &lvalue->where);
+		  return false;
+		}
+
+	      if (dim == 0)
+		rank_remap = (ref->u.ar.end[dim] != NULL);
+	      else
+		{
+		  if ((rank_remap && !ref->u.ar.end[dim])
+		      || (!rank_remap && ref->u.ar.end[dim]))
+		    {
+		      gfc_error ("Either all or none of the upper bounds"
+				 " must be specified at %L", &lvalue->where);
+		      return false;
+		    }
+		}
+	    }
+	}
+    }
+
+  is_pure = gfc_pure (NULL);
+  is_implicit_pure = gfc_implicit_pure (NULL);
+
+  /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
+     kind, etc for lvalue and rvalue must match, and rvalue must be a
+     pure variable if we're in a pure function.  */
+  if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
+    return true;
+
+  /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283.  */
+  if (lvalue->expr_type == EXPR_VARIABLE
+      && gfc_is_coindexed (lvalue))
+    {
+      gfc_ref *ref;
+      for (ref = lvalue->ref; ref; ref = ref->next)
+	if (ref->type == REF_ARRAY && ref->u.ar.codimen)
+	  {
+	    gfc_error ("Pointer object at %L shall not have a coindex",
+		       &lvalue->where);
+	    return false;
+	  }
+    }
+
+  /* Checks on rvalue for procedure pointer assignments.  */
+  if (proc_pointer)
+    {
+      char err[200];
+      gfc_symbol *s1,*s2;
+      gfc_component *comp;
+      const char *name;
+
+      attr = gfc_expr_attr (rvalue);
+      if (!((rvalue->expr_type == EXPR_NULL)
+	    || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
+	    || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer)
+	    || (rvalue->expr_type == EXPR_VARIABLE
+		&& attr.flavor == FL_PROCEDURE)))
+	{
+	  gfc_error ("Invalid procedure pointer assignment at %L",
+		     &rvalue->where);
+	  return false;
+	}
+      if (rvalue->expr_type == EXPR_VARIABLE && !attr.proc_pointer)
+	{
+      	  /* Check for intrinsics.  */
+	  gfc_symbol *sym = rvalue->symtree->n.sym;
+	  if (!sym->attr.intrinsic
+	      && (gfc_is_intrinsic (sym, 0, sym->declared_at)
+		  || gfc_is_intrinsic (sym, 1, sym->declared_at)))
+	    {
+	      sym->attr.intrinsic = 1;
+	      gfc_resolve_intrinsic (sym, &rvalue->where);
+	      attr = gfc_expr_attr (rvalue);
+	    }
+	  /* Check for result of embracing function.  */
+	  if (sym->attr.function && sym->result == sym)
+	    {
+	      gfc_namespace *ns;
+
+	      for (ns = gfc_current_ns; ns; ns = ns->parent)
+		if (sym == ns->proc_name)
+		  {
+		    gfc_error ("Function result '%s' is invalid as proc-target "
+			       "in procedure pointer assignment at %L",
+			       sym->name, &rvalue->where);
+		    return false;
+		  }
+	    }
+	}
+      if (attr.abstract)
+	{
+	  gfc_error ("Abstract interface '%s' is invalid "
+		     "in procedure pointer assignment at %L",
+		     rvalue->symtree->name, &rvalue->where);
+	  return false;
+	}
+      /* Check for F08:C729.  */
+      if (attr.flavor == FL_PROCEDURE)
+	{
+	  if (attr.proc == PROC_ST_FUNCTION)
+	    {
+	      gfc_error ("Statement function '%s' is invalid "
+			 "in procedure pointer assignment at %L",
+			 rvalue->symtree->name, &rvalue->where);
+	      return false;
+	    }
+	  if (attr.proc == PROC_INTERNAL &&
+	      !gfc_notify_std(GFC_STD_F2008, "Internal procedure '%s' "
+			      "is invalid in procedure pointer assignment "
+			      "at %L", rvalue->symtree->name, &rvalue->where))
+	    return false;
+	  if (attr.intrinsic && gfc_intrinsic_actual_ok (rvalue->symtree->name,
+							 attr.subroutine) == 0)
+	    {
+	      gfc_error ("Intrinsic '%s' at %L is invalid in procedure pointer "
+			 "assignment", rvalue->symtree->name, &rvalue->where);
+	      return false;
+	    }
+	}
+      /* Check for F08:C730.  */
+      if (attr.elemental && !attr.intrinsic)
+	{
+	  gfc_error ("Nonintrinsic elemental procedure '%s' is invalid "
+		     "in procedure pointer assignment at %L",
+		     rvalue->symtree->name, &rvalue->where);
+	  return false;
+	}
+
+      /* Ensure that the calling convention is the same. As other attributes
+	 such as DLLEXPORT may differ, one explicitly only tests for the
+	 calling conventions.  */
+      if (rvalue->expr_type == EXPR_VARIABLE
+	  && lvalue->symtree->n.sym->attr.ext_attr
+	       != rvalue->symtree->n.sym->attr.ext_attr)
+	{
+	  symbol_attribute calls;
+
+	  calls.ext_attr = 0;
+	  gfc_add_ext_attribute (&calls, EXT_ATTR_CDECL, NULL);
+	  gfc_add_ext_attribute (&calls, EXT_ATTR_STDCALL, NULL);
+	  gfc_add_ext_attribute (&calls, EXT_ATTR_FASTCALL, NULL);
+
+	  if ((calls.ext_attr & lvalue->symtree->n.sym->attr.ext_attr)
+	      != (calls.ext_attr & rvalue->symtree->n.sym->attr.ext_attr))
+	    {
+	      gfc_error ("Mismatch in the procedure pointer assignment "
+			 "at %L: mismatch in the calling convention",
+			 &rvalue->where);
+	  return false;
+	    }
+	}
+
+      comp = gfc_get_proc_ptr_comp (lvalue);
+      if (comp)
+	s1 = comp->ts.interface;
+      else
+	{
+	  s1 = lvalue->symtree->n.sym;
+	  if (s1->ts.interface)
+	    s1 = s1->ts.interface;
+	}
+
+      comp = gfc_get_proc_ptr_comp (rvalue);
+      if (comp)
+	{
+	  if (rvalue->expr_type == EXPR_FUNCTION)
+	    {
+	      s2 = comp->ts.interface->result;
+	      name = s2->name;
+	    }
+	  else
+	    {
+	      s2 = comp->ts.interface;
+	      name = comp->name;
+	    }
+	}
+      else if (rvalue->expr_type == EXPR_FUNCTION)
+	{
+	  if (rvalue->value.function.esym)
+	    s2 = rvalue->value.function.esym->result;
+	  else
+	    s2 = rvalue->symtree->n.sym->result;
+
+	  name = s2->name;
+	}
+      else
+	{
+	  s2 = rvalue->symtree->n.sym;
+	  name = s2->name;
+	}
+
+      if (s2 && s2->attr.proc_pointer && s2->ts.interface)
+	s2 = s2->ts.interface;
+
+      if (s1 == s2 || !s1 || !s2)
+	return true;
+
+      /* F08:7.2.2.4 (4)  */
+      if (s1->attr.if_source == IFSRC_UNKNOWN
+	  && gfc_explicit_interface_required (s2, err, sizeof(err)))
+	{
+	  gfc_error ("Explicit interface required for '%s' at %L: %s",
+		     s1->name, &lvalue->where, err);
+	  return false;
+	}
+      if (s2->attr.if_source == IFSRC_UNKNOWN
+	  && gfc_explicit_interface_required (s1, err, sizeof(err)))
+	{
+	  gfc_error ("Explicit interface required for '%s' at %L: %s",
+		     s2->name, &rvalue->where, err);
+	  return false;
+	}
+
+      if (!gfc_compare_interfaces (s1, s2, name, 0, 1,
+				   err, sizeof(err), NULL, NULL))
+	{
+	  gfc_error ("Interface mismatch in procedure pointer assignment "
+		     "at %L: %s", &rvalue->where, err);
+	  return false;
+	}
+
+      /* Check F2008Cor2, C729.  */
+      if (!s2->attr.intrinsic && s2->attr.if_source == IFSRC_UNKNOWN
+	  && !s2->attr.external && !s2->attr.subroutine && !s2->attr.function)
+	{
+	  gfc_error ("Procedure pointer target '%s' at %L must be either an "
+		     "intrinsic, host or use associated, referenced or have "
+		     "the EXTERNAL attribute", s2->name, &rvalue->where);
+	  return false;
+	}
+
+      return true;
+    }
+
+  if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
+    {
+      /* Check for F03:C717.  */
+      if (UNLIMITED_POLY (rvalue)
+	  && !(UNLIMITED_POLY (lvalue)
+	       || (lvalue->ts.type == BT_DERIVED
+		   && (lvalue->ts.u.derived->attr.is_bind_c
+		       || lvalue->ts.u.derived->attr.sequence))))
+	gfc_error ("Data-pointer-object &L must be unlimited "
+		   "polymorphic, a sequence derived type or of a "
+		   "type with the BIND attribute assignment at %L "
+		   "to be compatible with an unlimited polymorphic "
+		   "target", &lvalue->where);
+      else
+	gfc_error ("Different types in pointer assignment at %L; "
+		   "attempted assignment of %s to %s", &lvalue->where,
+		   gfc_typename (&rvalue->ts),
+		   gfc_typename (&lvalue->ts));
+      return false;
+    }
+
+  if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind)
+    {
+      gfc_error ("Different kind type parameters in pointer "
+		 "assignment at %L", &lvalue->where);
+      return false;
+    }
+
+  if (lvalue->rank != rvalue->rank && !rank_remap)
+    {
+      gfc_error ("Different ranks in pointer assignment at %L", &lvalue->where);
+      return false;
+    }
+
+  /* Make sure the vtab is present.  */
+  if (lvalue->ts.type == BT_CLASS && !UNLIMITED_POLY (rvalue))
+    gfc_find_vtab (&rvalue->ts);
+
+  /* Check rank remapping.  */
+  if (rank_remap)
+    {
+      mpz_t lsize, rsize;
+
+      /* If this can be determined, check that the target must be at least as
+	 large as the pointer assigned to it is.  */
+      if (gfc_array_size (lvalue, &lsize)
+	  && gfc_array_size (rvalue, &rsize)
+	  && mpz_cmp (rsize, lsize) < 0)
+	{
+	  gfc_error ("Rank remapping target is smaller than size of the"
+		     " pointer (%ld < %ld) at %L",
+		     mpz_get_si (rsize), mpz_get_si (lsize),
+		     &lvalue->where);
+	  return false;
+	}
+
+      /* The target must be either rank one or it must be simply contiguous
+	 and F2008 must be allowed.  */
+      if (rvalue->rank != 1)
+	{
+	  if (!gfc_is_simply_contiguous (rvalue, true))
+	    {
+	      gfc_error ("Rank remapping target must be rank 1 or"
+			 " simply contiguous at %L", &rvalue->where);
+	      return false;
+	    }
+	  if (!gfc_notify_std (GFC_STD_F2008, "Rank remapping target is not "
+			       "rank 1 at %L", &rvalue->where))
+	    return false;
+	}
+    }
+
+  /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X).  */
+  if (rvalue->expr_type == EXPR_NULL)
+    return true;
+
+  if (lvalue->ts.type == BT_CHARACTER)
+    {
+      bool t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment");
+      if (!t)
+	return false;
+    }
+
+  if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
+    lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
+
+  attr = gfc_expr_attr (rvalue);
+
+  if (rvalue->expr_type == EXPR_FUNCTION && !attr.pointer)
+    {
+      gfc_error ("Target expression in pointer assignment "
+		 "at %L must deliver a pointer result",
+		 &rvalue->where);
+      return false;
+    }
+
+  if (!attr.target && !attr.pointer)
+    {
+      gfc_error ("Pointer assignment target is neither TARGET "
+		 "nor POINTER at %L", &rvalue->where);
+      return false;
+    }
+
+  if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
+    {
+      gfc_error ("Bad target in pointer assignment in PURE "
+		 "procedure at %L", &rvalue->where);
+    }
+
+  if (is_implicit_pure && gfc_impure_variable (rvalue->symtree->n.sym))
+    gfc_unset_implicit_pure (gfc_current_ns->proc_name);
+
+  if (gfc_has_vector_index (rvalue))
+    {
+      gfc_error ("Pointer assignment with vector subscript "
+		 "on rhs at %L", &rvalue->where);
+      return false;
+    }
+
+  if (attr.is_protected && attr.use_assoc
+      && !(attr.pointer || attr.proc_pointer))
+    {
+      gfc_error ("Pointer assignment target has PROTECTED "
+		 "attribute at %L", &rvalue->where);
+      return false;
+    }
+
+  /* F2008, C725. For PURE also C1283.  */
+  if (rvalue->expr_type == EXPR_VARIABLE
+      && gfc_is_coindexed (rvalue))
+    {
+      gfc_ref *ref;
+      for (ref = rvalue->ref; ref; ref = ref->next)
+	if (ref->type == REF_ARRAY && ref->u.ar.codimen)
+	  {
+	    gfc_error ("Data target at %L shall not have a coindex",
+		       &rvalue->where);
+	    return false;
+	  }
+    }
+
+  /* Warn if it is the LHS pointer may lives longer than the RHS target.  */
+  if (gfc_option.warn_target_lifetime
+      && rvalue->expr_type == EXPR_VARIABLE
+      && !rvalue->symtree->n.sym->attr.save
+      && !attr.pointer && !rvalue->symtree->n.sym->attr.host_assoc
+      && !rvalue->symtree->n.sym->attr.in_common
+      && !rvalue->symtree->n.sym->attr.use_assoc
+      && !rvalue->symtree->n.sym->attr.dummy)
+    {
+      bool warn;
+      gfc_namespace *ns;
+
+      warn = lvalue->symtree->n.sym->attr.dummy
+	     || lvalue->symtree->n.sym->attr.result
+	     || lvalue->symtree->n.sym->attr.function
+	     || (lvalue->symtree->n.sym->attr.host_assoc
+		 && lvalue->symtree->n.sym->ns
+		    != rvalue->symtree->n.sym->ns)
+	     || lvalue->symtree->n.sym->attr.use_assoc
+	     || lvalue->symtree->n.sym->attr.in_common;
+
+      if (rvalue->symtree->n.sym->ns->proc_name
+	  && rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROCEDURE
+	  && rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROGRAM)
+       for (ns = rvalue->symtree->n.sym->ns;
+	    ns && ns->proc_name && ns->proc_name->attr.flavor != FL_PROCEDURE;
+	    ns = ns->parent)
+	if (ns->parent == lvalue->symtree->n.sym->ns)
+	  {
+	    warn = true;
+	    break;
+	  }
+
+      if (warn)
+	gfc_warning ("Pointer at %L in pointer assignment might outlive the "
+		     "pointer target", &lvalue->where);
+    }
+
+  return true;
+}
+
+
+/* Relative of gfc_check_assign() except that the lvalue is a single
+   symbol.  Used for initialization assignments.  */
+
+bool
+gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue)
+{
+  gfc_expr lvalue;
+  bool r;
+  bool pointer, proc_pointer;
+
+  memset (&lvalue, '\0', sizeof (gfc_expr));
+
+  lvalue.expr_type = EXPR_VARIABLE;
+  lvalue.ts = sym->ts;
+  if (sym->as)
+    lvalue.rank = sym->as->rank;
+  lvalue.symtree = XCNEW (gfc_symtree);
+  lvalue.symtree->n.sym = sym;
+  lvalue.where = sym->declared_at;
+
+  if (comp)
+    {
+      lvalue.ref = gfc_get_ref ();
+      lvalue.ref->type = REF_COMPONENT;
+      lvalue.ref->u.c.component = comp;
+      lvalue.ref->u.c.sym = sym;
+      lvalue.ts = comp->ts;
+      lvalue.rank = comp->as ? comp->as->rank : 0;
+      lvalue.where = comp->loc;
+      pointer = comp->ts.type == BT_CLASS &&  CLASS_DATA (comp)
+		? CLASS_DATA (comp)->attr.class_pointer : comp->attr.pointer;
+      proc_pointer = comp->attr.proc_pointer;
+    }
+  else
+    {
+      pointer = sym->ts.type == BT_CLASS &&  CLASS_DATA (sym)
+		? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer;
+      proc_pointer = sym->attr.proc_pointer;
+    }
+
+  if (pointer || proc_pointer)
+    r = gfc_check_pointer_assign (&lvalue, rvalue);
+  else
+    r = gfc_check_assign (&lvalue, rvalue, 1);
+
+  free (lvalue.symtree);
+  free (lvalue.ref);
+
+  if (!r)
+    return r;
+
+  if (pointer && rvalue->expr_type != EXPR_NULL)
+    {
+      /* F08:C461. Additional checks for pointer initialization.  */
+      symbol_attribute attr;
+      attr = gfc_expr_attr (rvalue);
+      if (attr.allocatable)
+	{
+	  gfc_error ("Pointer initialization target at %L "
+	             "must not be ALLOCATABLE", &rvalue->where);
+	  return false;
+	}
+      if (!attr.target || attr.pointer)
+	{
+	  gfc_error ("Pointer initialization target at %L "
+		     "must have the TARGET attribute", &rvalue->where);
+	  return false;
+	}
+
+      if (!attr.save && rvalue->expr_type == EXPR_VARIABLE
+	  && rvalue->symtree->n.sym->ns->proc_name
+	  && rvalue->symtree->n.sym->ns->proc_name->attr.is_main_program)
+	{
+	  rvalue->symtree->n.sym->ns->proc_name->attr.save = SAVE_IMPLICIT;
+	  attr.save = SAVE_IMPLICIT;
+	}
+
+      if (!attr.save)
+	{
+	  gfc_error ("Pointer initialization target at %L "
+		     "must have the SAVE attribute", &rvalue->where);
+	  return false;
+	}
+    }
+
+  if (proc_pointer && rvalue->expr_type != EXPR_NULL)
+    {
+      /* F08:C1220. Additional checks for procedure pointer initialization.  */
+      symbol_attribute attr = gfc_expr_attr (rvalue);
+      if (attr.proc_pointer)
+	{
+	  gfc_error ("Procedure pointer initialization target at %L "
+		     "may not be a procedure pointer", &rvalue->where);
+	  return false;
+	}
+    }
+
+  return true;
+}
+
+
+/* Check for default initializer; sym->value is not enough
+   as it is also set for EXPR_NULL of allocatables.  */
+
+bool
+gfc_has_default_initializer (gfc_symbol *der)
+{
+  gfc_component *c;
+
+  gcc_assert (der->attr.flavor == FL_DERIVED);
+  for (c = der->components; c; c = c->next)
+    if (c->ts.type == BT_DERIVED)
+      {
+        if (!c->attr.pointer
+	     && gfc_has_default_initializer (c->ts.u.derived))
+	  return true;
+	if (c->attr.pointer && c->initializer)
+	  return true;
+      }
+    else
+      {
+        if (c->initializer)
+	  return true;
+      }
+
+  return false;
+}
+
+
+/* Get an expression for a default initializer.  */
+
+gfc_expr *
+gfc_default_initializer (gfc_typespec *ts)
+{
+  gfc_expr *init;
+  gfc_component *comp;
+
+  /* See if we have a default initializer in this, but not in nested
+     types (otherwise we could use gfc_has_default_initializer()).  */
+  for (comp = ts->u.derived->components; comp; comp = comp->next)
+    if (comp->initializer || comp->attr.allocatable
+	|| (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
+	    && CLASS_DATA (comp)->attr.allocatable))
+      break;
+
+  if (!comp)
+    return NULL;
+
+  init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
+					     &ts->u.derived->declared_at);
+  init->ts = *ts;
+
+  for (comp = ts->u.derived->components; comp; comp = comp->next)
+    {
+      gfc_constructor *ctor = gfc_constructor_get();
+
+      if (comp->initializer)
+	{
+	  ctor->expr = gfc_copy_expr (comp->initializer);
+	  if ((comp->ts.type != comp->initializer->ts.type
+	       || comp->ts.kind != comp->initializer->ts.kind)
+	      && !comp->attr.pointer && !comp->attr.proc_pointer)
+	    gfc_convert_type_warn (ctor->expr, &comp->ts, 2, false);
+	}
+
+      if (comp->attr.allocatable
+	  || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.allocatable))
+	{
+	  ctor->expr = gfc_get_expr ();
+	  ctor->expr->expr_type = EXPR_NULL;
+	  ctor->expr->ts = comp->ts;
+	}
+
+      gfc_constructor_append (&init->value.constructor, ctor);
+    }
+
+  return init;
+}
+
+
+/* Given a symbol, create an expression node with that symbol as a
+   variable. If the symbol is array valued, setup a reference of the
+   whole array.  */
+
+gfc_expr *
+gfc_get_variable_expr (gfc_symtree *var)
+{
+  gfc_expr *e;
+
+  e = gfc_get_expr ();
+  e->expr_type = EXPR_VARIABLE;
+  e->symtree = var;
+  e->ts = var->n.sym->ts;
+
+  if (var->n.sym->attr.flavor != FL_PROCEDURE
+      && ((var->n.sym->as != NULL && var->n.sym->ts.type != BT_CLASS)
+	   || (var->n.sym->ts.type == BT_CLASS && CLASS_DATA (var->n.sym)
+	       && CLASS_DATA (var->n.sym)->as)))
+    {
+      e->rank = var->n.sym->ts.type == BT_CLASS
+		? CLASS_DATA (var->n.sym)->as->rank : var->n.sym->as->rank;
+      e->ref = gfc_get_ref ();
+      e->ref->type = REF_ARRAY;
+      e->ref->u.ar.type = AR_FULL;
+      e->ref->u.ar.as = gfc_copy_array_spec (var->n.sym->ts.type == BT_CLASS
+					     ? CLASS_DATA (var->n.sym)->as
+					     : var->n.sym->as);
+    }
+
+  return e;
+}
+
+
+/* Adds a full array reference to an expression, as needed.  */
+
+void
+gfc_add_full_array_ref (gfc_expr *e, gfc_array_spec *as)
+{
+  gfc_ref *ref;
+  for (ref = e->ref; ref; ref = ref->next)
+    if (!ref->next)
+      break;
+  if (ref)
+    {
+      ref->next = gfc_get_ref ();
+      ref = ref->next;
+    }
+  else
+    {
+      e->ref = gfc_get_ref ();
+      ref = e->ref;
+    }
+  ref->type = REF_ARRAY;
+  ref->u.ar.type = AR_FULL;
+  ref->u.ar.dimen = e->rank;
+  ref->u.ar.where = e->where;
+  ref->u.ar.as = as;
+}
+
+
+gfc_expr *
+gfc_lval_expr_from_sym (gfc_symbol *sym)
+{
+  gfc_expr *lval;
+  lval = gfc_get_expr ();
+  lval->expr_type = EXPR_VARIABLE;
+  lval->where = sym->declared_at;
+  lval->ts = sym->ts;
+  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;
+  if (lval->rank)
+    gfc_add_full_array_ref (lval, sym->ts.type == BT_CLASS ?
+			    CLASS_DATA (sym)->as : sym->as);
+  return lval;
+}
+
+
+/* Returns the array_spec of a full array expression.  A NULL is
+   returned otherwise.  */
+gfc_array_spec *
+gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
+{
+  gfc_array_spec *as;
+  gfc_ref *ref;
+
+  if (expr->rank == 0)
+    return NULL;
+
+  /* Follow any component references.  */
+  if (expr->expr_type == EXPR_VARIABLE
+      || expr->expr_type == EXPR_CONSTANT)
+    {
+      as = expr->symtree->n.sym->as;
+      for (ref = expr->ref; ref; ref = ref->next)
+	{
+	  switch (ref->type)
+	    {
+	    case REF_COMPONENT:
+	      as = ref->u.c.component->as;
+	      continue;
+
+	    case REF_SUBSTRING:
+	      continue;
+
+	    case REF_ARRAY:
+	      {
+		switch (ref->u.ar.type)
+		  {
+		  case AR_ELEMENT:
+		  case AR_SECTION:
+		  case AR_UNKNOWN:
+		    as = NULL;
+		    continue;
+
+		  case AR_FULL:
+		    break;
+		  }
+		break;
+	      }
+	    }
+	}
+    }
+  else
+    as = NULL;
+
+  return as;
+}
+
+
+/* General expression traversal function.  */
+
+bool
+gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
+		   bool (*func)(gfc_expr *, gfc_symbol *, int*),
+		   int f)
+{
+  gfc_array_ref ar;
+  gfc_ref *ref;
+  gfc_actual_arglist *args;
+  gfc_constructor *c;
+  int i;
+
+  if (!expr)
+    return false;
+
+  if ((*func) (expr, sym, &f))
+    return true;
+
+  if (expr->ts.type == BT_CHARACTER
+	&& expr->ts.u.cl
+	&& expr->ts.u.cl->length
+	&& expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
+	&& gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f))
+    return true;
+
+  switch (expr->expr_type)
+    {
+    case EXPR_PPC:
+    case EXPR_COMPCALL:
+    case EXPR_FUNCTION:
+      for (args = expr->value.function.actual; args; args = args->next)
+	{
+	  if (gfc_traverse_expr (args->expr, sym, func, f))
+	    return true;
+	}
+      break;
+
+    case EXPR_VARIABLE:
+    case EXPR_CONSTANT:
+    case EXPR_NULL:
+    case EXPR_SUBSTRING:
+      break;
+
+    case EXPR_STRUCTURE:
+    case EXPR_ARRAY:
+      for (c = gfc_constructor_first (expr->value.constructor);
+	   c; c = gfc_constructor_next (c))
+	{
+	  if (gfc_traverse_expr (c->expr, sym, func, f))
+	    return true;
+	  if (c->iterator)
+	    {
+	      if (gfc_traverse_expr (c->iterator->var, sym, func, f))
+		return true;
+	      if (gfc_traverse_expr (c->iterator->start, sym, func, f))
+		return true;
+	      if (gfc_traverse_expr (c->iterator->end, sym, func, f))
+		return true;
+	      if (gfc_traverse_expr (c->iterator->step, sym, func, f))
+		return true;
+	    }
+	}
+      break;
+
+    case EXPR_OP:
+      if (gfc_traverse_expr (expr->value.op.op1, sym, func, f))
+	return true;
+      if (gfc_traverse_expr (expr->value.op.op2, sym, func, f))
+	return true;
+      break;
+
+    default:
+      gcc_unreachable ();
+      break;
+    }
+
+  ref = expr->ref;
+  while (ref != NULL)
+    {
+      switch (ref->type)
+	{
+	case  REF_ARRAY:
+	  ar = ref->u.ar;
+	  for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
+	    {
+	      if (gfc_traverse_expr (ar.start[i], sym, func, f))
+		return true;
+	      if (gfc_traverse_expr (ar.end[i], sym, func, f))
+		return true;
+	      if (gfc_traverse_expr (ar.stride[i], sym, func, f))
+		return true;
+	    }
+	  break;
+
+	case REF_SUBSTRING:
+	  if (gfc_traverse_expr (ref->u.ss.start, sym, func, f))
+	    return true;
+	  if (gfc_traverse_expr (ref->u.ss.end, sym, func, f))
+	    return true;
+	  break;
+
+	case REF_COMPONENT:
+	  if (ref->u.c.component->ts.type == BT_CHARACTER
+		&& ref->u.c.component->ts.u.cl
+		&& ref->u.c.component->ts.u.cl->length
+		&& ref->u.c.component->ts.u.cl->length->expr_type
+		     != EXPR_CONSTANT
+		&& gfc_traverse_expr (ref->u.c.component->ts.u.cl->length,
+				      sym, func, f))
+	    return true;
+
+	  if (ref->u.c.component->as)
+	    for (i = 0; i < ref->u.c.component->as->rank
+			    + ref->u.c.component->as->corank; i++)
+	      {
+		if (gfc_traverse_expr (ref->u.c.component->as->lower[i],
+				       sym, func, f))
+		  return true;
+		if (gfc_traverse_expr (ref->u.c.component->as->upper[i],
+				       sym, func, f))
+		  return true;
+	      }
+	  break;
+
+	default:
+	  gcc_unreachable ();
+	}
+      ref = ref->next;
+    }
+  return false;
+}
+
+/* Traverse expr, marking all EXPR_VARIABLE symbols referenced.  */
+
+static bool
+expr_set_symbols_referenced (gfc_expr *expr,
+			     gfc_symbol *sym ATTRIBUTE_UNUSED,
+			     int *f ATTRIBUTE_UNUSED)
+{
+  if (expr->expr_type != EXPR_VARIABLE)
+    return false;
+  gfc_set_sym_referenced (expr->symtree->n.sym);
+  return false;
+}
+
+void
+gfc_expr_set_symbols_referenced (gfc_expr *expr)
+{
+  gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
+}
+
+
+/* Determine if an expression is a procedure pointer component and return
+   the component in that case.  Otherwise return NULL.  */
+
+gfc_component *
+gfc_get_proc_ptr_comp (gfc_expr *expr)
+{
+  gfc_ref *ref;
+
+  if (!expr || !expr->ref)
+    return NULL;
+
+  ref = expr->ref;
+  while (ref->next)
+    ref = ref->next;
+
+  if (ref->type == REF_COMPONENT
+      && ref->u.c.component->attr.proc_pointer)
+    return ref->u.c.component;
+
+  return NULL;
+}
+
+
+/* Determine if an expression is a procedure pointer component.  */
+
+bool
+gfc_is_proc_ptr_comp (gfc_expr *expr)
+{
+  return (gfc_get_proc_ptr_comp (expr) != NULL);
+}
+
+
+/* Walk an expression tree and check each variable encountered for being typed.
+   If strict is not set, a top-level variable is tolerated untyped in -std=gnu
+   mode as is a basic arithmetic expression using those; this is for things in
+   legacy-code like:
+
+     INTEGER :: arr(n), n
+     INTEGER :: arr(n + 1), n
+
+   The namespace is needed for IMPLICIT typing.  */
+
+static gfc_namespace* check_typed_ns;
+
+static bool
+expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
+                       int* f ATTRIBUTE_UNUSED)
+{
+  bool t;
+
+  if (e->expr_type != EXPR_VARIABLE)
+    return false;
+
+  gcc_assert (e->symtree);
+  t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns,
+                              true, e->where);
+
+  return (!t);
+}
+
+bool
+gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
+{
+  bool error_found;
+
+  /* If this is a top-level variable or EXPR_OP, do the check with strict given
+     to us.  */
+  if (!strict)
+    {
+      if (e->expr_type == EXPR_VARIABLE && !e->ref)
+	return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where);
+
+      if (e->expr_type == EXPR_OP)
+	{
+	  bool t = true;
+
+	  gcc_assert (e->value.op.op1);
+	  t = gfc_expr_check_typed (e->value.op.op1, ns, strict);
+
+	  if (t && e->value.op.op2)
+	    t = gfc_expr_check_typed (e->value.op.op2, ns, strict);
+
+	  return t;
+	}
+    }
+
+  /* Otherwise, walk the expression and do it strictly.  */
+  check_typed_ns = ns;
+  error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0);
+
+  return error_found ? false : true;
+}
+
+
+bool
+gfc_ref_this_image (gfc_ref *ref)
+{
+  int n;
+
+  gcc_assert (ref->type == REF_ARRAY && ref->u.ar.codimen > 0);
+
+  for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
+    if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
+      return false;
+
+  return true;
+}
+
+
+bool
+gfc_is_coindexed (gfc_expr *e)
+{
+  gfc_ref *ref;
+
+  for (ref = e->ref; ref; ref = ref->next)
+    if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
+      return !gfc_ref_this_image (ref);
+
+  return false;
+}
+
+
+/* Coarrays are variables with a corank but not being coindexed. However, also
+   the following is a coarray: A subobject of a coarray is a coarray if it does
+   not have any cosubscripts, vector subscripts, allocatable component
+   selection, or pointer component selection. (F2008, 2.4.7)  */
+
+bool
+gfc_is_coarray (gfc_expr *e)
+{
+  gfc_ref *ref;
+  gfc_symbol *sym;
+  gfc_component *comp;
+  bool coindexed;
+  bool coarray;
+  int i;
+
+  if (e->expr_type != EXPR_VARIABLE)
+    return false;
+
+  coindexed = false;
+  sym = e->symtree->n.sym;
+
+  if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
+    coarray = CLASS_DATA (sym)->attr.codimension;
+  else
+    coarray = sym->attr.codimension;
+
+  for (ref = e->ref; ref; ref = ref->next)
+    switch (ref->type)
+    {
+      case REF_COMPONENT:
+	comp = ref->u.c.component;
+	if (comp->ts.type == BT_CLASS && comp->attr.class_ok
+	    && (CLASS_DATA (comp)->attr.class_pointer
+		|| CLASS_DATA (comp)->attr.allocatable))
+	  {
+	    coindexed = false;
+	    coarray = CLASS_DATA (comp)->attr.codimension;
+	  }
+        else if (comp->attr.pointer || comp->attr.allocatable)
+	  {
+	    coindexed = false;
+	    coarray = comp->attr.codimension;
+	  }
+        break;
+
+     case REF_ARRAY:
+	if (!coarray)
+	  break;
+
+	if (ref->u.ar.codimen > 0 && !gfc_ref_this_image (ref))
+	  {
+	    coindexed = true;
+	    break;
+	  }
+
+	for (i = 0; i < ref->u.ar.dimen; i++)
+	  if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
+	    {
+	      coarray = false;
+	      break;
+	    }
+	break;
+
+     case REF_SUBSTRING:
+	break;
+    }
+
+  return coarray && !coindexed;
+}
+
+
+int
+gfc_get_corank (gfc_expr *e)
+{
+  int corank;
+  gfc_ref *ref;
+
+  if (!gfc_is_coarray (e))
+    return 0;
+
+  if (e->ts.type == BT_CLASS && e->ts.u.derived->components)
+    corank = e->ts.u.derived->components->as
+	     ? e->ts.u.derived->components->as->corank : 0;
+  else
+    corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0;
+
+  for (ref = e->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_ARRAY)
+	corank = ref->u.ar.as->corank;
+      gcc_assert (ref->type != REF_SUBSTRING);
+    }
+
+  return corank;
+}
+
+
+/* Check whether the expression has an ultimate allocatable component.
+   Being itself allocatable does not count.  */
+bool
+gfc_has_ultimate_allocatable (gfc_expr *e)
+{
+  gfc_ref *ref, *last = NULL;
+
+  if (e->expr_type != EXPR_VARIABLE)
+    return false;
+
+  for (ref = e->ref; ref; ref = ref->next)
+    if (ref->type == REF_COMPONENT)
+      last = ref;
+
+  if (last && last->u.c.component->ts.type == BT_CLASS)
+    return CLASS_DATA (last->u.c.component)->attr.alloc_comp;
+  else if (last && last->u.c.component->ts.type == BT_DERIVED)
+    return last->u.c.component->ts.u.derived->attr.alloc_comp;
+  else if (last)
+    return false;
+
+  if (e->ts.type == BT_CLASS)
+    return CLASS_DATA (e)->attr.alloc_comp;
+  else if (e->ts.type == BT_DERIVED)
+    return e->ts.u.derived->attr.alloc_comp;
+  else
+    return false;
+}
+
+
+/* Check whether the expression has an pointer component.
+   Being itself a pointer does not count.  */
+bool
+gfc_has_ultimate_pointer (gfc_expr *e)
+{
+  gfc_ref *ref, *last = NULL;
+
+  if (e->expr_type != EXPR_VARIABLE)
+    return false;
+
+  for (ref = e->ref; ref; ref = ref->next)
+    if (ref->type == REF_COMPONENT)
+      last = ref;
+
+  if (last && last->u.c.component->ts.type == BT_CLASS)
+    return CLASS_DATA (last->u.c.component)->attr.pointer_comp;
+  else if (last && last->u.c.component->ts.type == BT_DERIVED)
+    return last->u.c.component->ts.u.derived->attr.pointer_comp;
+  else if (last)
+    return false;
+
+  if (e->ts.type == BT_CLASS)
+    return CLASS_DATA (e)->attr.pointer_comp;
+  else if (e->ts.type == BT_DERIVED)
+    return e->ts.u.derived->attr.pointer_comp;
+  else
+    return false;
+}
+
+
+/* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
+   Note: A scalar is not regarded as "simply contiguous" by the standard.
+   if bool is not strict, some further checks are done - for instance,
+   a "(::1)" is accepted.  */
+
+bool
+gfc_is_simply_contiguous (gfc_expr *expr, bool strict)
+{
+  bool colon;
+  int i;
+  gfc_array_ref *ar = NULL;
+  gfc_ref *ref, *part_ref = NULL;
+  gfc_symbol *sym;
+
+  if (expr->expr_type == EXPR_FUNCTION)
+    return expr->value.function.esym
+	   ? expr->value.function.esym->result->attr.contiguous : false;
+  else if (expr->expr_type != EXPR_VARIABLE)
+    return false;
+
+  if (expr->rank == 0)
+    return false;
+
+  for (ref = expr->ref; ref; ref = ref->next)
+    {
+      if (ar)
+	return false; /* Array shall be last part-ref. */
+
+      if (ref->type == REF_COMPONENT)
+	part_ref  = ref;
+      else if (ref->type == REF_SUBSTRING)
+	return false;
+      else if (ref->u.ar.type != AR_ELEMENT)
+	ar = &ref->u.ar;
+    }
+
+  sym = expr->symtree->n.sym;
+  if (expr->ts.type != BT_CLASS
+	&& ((part_ref
+		&& !part_ref->u.c.component->attr.contiguous
+		&& part_ref->u.c.component->attr.pointer)
+	    || (!part_ref
+		&& !sym->attr.contiguous
+		&& (sym->attr.pointer
+		    || sym->as->type == AS_ASSUMED_RANK
+		    || sym->as->type == AS_ASSUMED_SHAPE))))
+    return false;
+
+  if (!ar || ar->type == AR_FULL)
+    return true;
+
+  gcc_assert (ar->type == AR_SECTION);
+
+  /* Check for simply contiguous array */
+  colon = true;
+  for (i = 0; i < ar->dimen; i++)
+    {
+      if (ar->dimen_type[i] == DIMEN_VECTOR)
+	return false;
+
+      if (ar->dimen_type[i] == DIMEN_ELEMENT)
+	{
+	  colon = false;
+	  continue;
+	}
+
+      gcc_assert (ar->dimen_type[i] == DIMEN_RANGE);
+
+
+      /* If the previous section was not contiguous, that's an error,
+	 unless we have effective only one element and checking is not
+	 strict.  */
+      if (!colon && (strict || !ar->start[i] || !ar->end[i]
+		     || ar->start[i]->expr_type != EXPR_CONSTANT
+		     || ar->end[i]->expr_type != EXPR_CONSTANT
+		     || mpz_cmp (ar->start[i]->value.integer,
+				 ar->end[i]->value.integer) != 0))
+	return false;
+
+      /* Following the standard, "(::1)" or - if known at compile time -
+	 "(lbound:ubound)" are not simply contiguous; if strict
+	 is false, they are regarded as simply contiguous.  */
+      if (ar->stride[i] && (strict || ar->stride[i]->expr_type != EXPR_CONSTANT
+			    || ar->stride[i]->ts.type != BT_INTEGER
+			    || mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0))
+	return false;
+
+      if (ar->start[i]
+	  && (strict || ar->start[i]->expr_type != EXPR_CONSTANT
+	      || !ar->as->lower[i]
+	      || ar->as->lower[i]->expr_type != EXPR_CONSTANT
+	      || mpz_cmp (ar->start[i]->value.integer,
+			  ar->as->lower[i]->value.integer) != 0))
+	colon = false;
+
+      if (ar->end[i]
+	  && (strict || ar->end[i]->expr_type != EXPR_CONSTANT
+	      || !ar->as->upper[i]
+	      || ar->as->upper[i]->expr_type != EXPR_CONSTANT
+	      || mpz_cmp (ar->end[i]->value.integer,
+			  ar->as->upper[i]->value.integer) != 0))
+	colon = false;
+    }
+
+  return true;
+}
+
+
+/* Build call to an intrinsic procedure.  The number of arguments has to be
+   passed (rather than ending the list with a NULL value) because we may
+   want to add arguments but with a NULL-expression.  */
+
+gfc_expr*
+gfc_build_intrinsic_call (gfc_namespace *ns, gfc_isym_id id, const char* name,
+			  locus where, unsigned numarg, ...)
+{
+  gfc_expr* result;
+  gfc_actual_arglist* atail;
+  gfc_intrinsic_sym* isym;
+  va_list ap;
+  unsigned i;
+  const char *mangled_name = gfc_get_string (GFC_PREFIX ("%s"), name);
+
+  isym = gfc_intrinsic_function_by_id (id);
+  gcc_assert (isym);
+
+  result = gfc_get_expr ();
+  result->expr_type = EXPR_FUNCTION;
+  result->ts = isym->ts;
+  result->where = where;
+  result->value.function.name = mangled_name;
+  result->value.function.isym = isym;
+
+  gfc_get_sym_tree (mangled_name, ns, &result->symtree, false);
+  gfc_commit_symbol (result->symtree->n.sym);
+  gcc_assert (result->symtree
+	      && (result->symtree->n.sym->attr.flavor == FL_PROCEDURE
+		  || result->symtree->n.sym->attr.flavor == FL_UNKNOWN));
+  result->symtree->n.sym->intmod_sym_id = id;
+  result->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+  result->symtree->n.sym->attr.intrinsic = 1;
+  result->symtree->n.sym->attr.artificial = 1;
+
+  va_start (ap, numarg);
+  atail = NULL;
+  for (i = 0; i < numarg; ++i)
+    {
+      if (atail)
+	{
+	  atail->next = gfc_get_actual_arglist ();
+	  atail = atail->next;
+	}
+      else
+	atail = result->value.function.actual = gfc_get_actual_arglist ();
+
+      atail->expr = va_arg (ap, gfc_expr*);
+    }
+  va_end (ap);
+
+  return result;
+}
+
+
+/* Check if an expression may appear in a variable definition context
+   (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
+   This is called from the various places when resolving
+   the pieces that make up such a context.
+   If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do
+   variables), some checks are not performed.
+
+   Optionally, a possible error message can be suppressed if context is NULL
+   and just the return status (true / false) be requested.  */
+
+bool
+gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
+			  bool own_scope, const char* context)
+{
+  gfc_symbol* sym = NULL;
+  bool is_pointer;
+  bool check_intentin;
+  bool ptr_component;
+  symbol_attribute attr;
+  gfc_ref* ref;
+  int i;
+
+  if (e->expr_type == EXPR_VARIABLE)
+    {
+      gcc_assert (e->symtree);
+      sym = e->symtree->n.sym;
+    }
+  else if (e->expr_type == EXPR_FUNCTION)
+    {
+      gcc_assert (e->symtree);
+      sym = e->value.function.esym ? e->value.function.esym : e->symtree->n.sym;
+    }
+
+  attr = gfc_expr_attr (e);
+  if (!pointer && e->expr_type == EXPR_FUNCTION && attr.pointer)
+    {
+      if (!(gfc_option.allow_std & GFC_STD_F2008))
+	{
+	  if (context)
+	    gfc_error ("Fortran 2008: Pointer functions in variable definition"
+		       " context (%s) at %L", context, &e->where);
+	  return false;
+	}
+    }
+  else if (e->expr_type != EXPR_VARIABLE)
+    {
+      if (context)
+	gfc_error ("Non-variable expression in variable definition context (%s)"
+		   " at %L", context, &e->where);
+      return false;
+    }
+
+  if (!pointer && sym->attr.flavor == FL_PARAMETER)
+    {
+      if (context)
+	gfc_error ("Named constant '%s' in variable definition context (%s)"
+		   " at %L", sym->name, context, &e->where);
+      return false;
+    }
+  if (!pointer && sym->attr.flavor != FL_VARIABLE
+      && !(sym->attr.flavor == FL_PROCEDURE && sym == sym->result)
+      && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
+    {
+      if (context)
+	gfc_error ("'%s' in variable definition context (%s) at %L is not"
+		   " a variable", sym->name, context, &e->where);
+      return false;
+    }
+
+  /* Find out whether the expr is a pointer; this also means following
+     component references to the last one.  */
+  is_pointer = (attr.pointer || attr.proc_pointer);
+  if (pointer && !is_pointer)
+    {
+      if (context)
+	gfc_error ("Non-POINTER in pointer association context (%s)"
+		   " at %L", context, &e->where);
+      return false;
+    }
+
+  /* F2008, C1303.  */
+  if (!alloc_obj
+      && (attr.lock_comp
+	  || (e->ts.type == BT_DERIVED
+	      && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+	      && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)))
+    {
+      if (context)
+	gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
+		   context, &e->where);
+      return false;
+    }
+
+  /* INTENT(IN) dummy argument.  Check this, unless the object itself is the
+     component of sub-component of a pointer; we need to distinguish
+     assignment to a pointer component from pointer-assignment to a pointer
+     component.  Note that (normal) assignment to procedure pointers is not
+     possible.  */
+  check_intentin = !own_scope;
+  ptr_component = (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
+		  ? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer;
+  for (ref = e->ref; ref && check_intentin; ref = ref->next)
+    {
+      if (ptr_component && ref->type == REF_COMPONENT)
+	check_intentin = false;
+      if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
+	{
+	  ptr_component = true;
+	  if (!pointer)
+	    check_intentin = false;
+	}
+    }
+  if (check_intentin && sym->attr.intent == INTENT_IN)
+    {
+      if (pointer && is_pointer)
+	{
+	  if (context)
+	    gfc_error ("Dummy argument '%s' with INTENT(IN) in pointer"
+		       " association context (%s) at %L",
+		       sym->name, context, &e->where);
+	  return false;
+	}
+      if (!pointer && !is_pointer && !sym->attr.pointer)
+	{
+	  if (context)
+	    gfc_error ("Dummy argument '%s' with INTENT(IN) in variable"
+		       " definition context (%s) at %L",
+		       sym->name, context, &e->where);
+	  return false;
+	}
+    }
+
+  /* PROTECTED and use-associated.  */
+  if (sym->attr.is_protected && sym->attr.use_assoc && check_intentin)
+    {
+      if (pointer && is_pointer)
+	{
+	  if (context)
+	    gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
+		       " pointer association context (%s) at %L",
+		       sym->name, context, &e->where);
+	  return false;
+	}
+      if (!pointer && !is_pointer)
+	{
+	  if (context)
+	    gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
+		       " variable definition context (%s) at %L",
+		       sym->name, context, &e->where);
+	  return false;
+	}
+    }
+
+  /* Variable not assignable from a PURE procedure but appears in
+     variable definition context.  */
+  if (!pointer && !own_scope && gfc_pure (NULL) && gfc_impure_variable (sym))
+    {
+      if (context)
+	gfc_error ("Variable '%s' can not appear in a variable definition"
+		   " context (%s) at %L in PURE procedure",
+		   sym->name, context, &e->where);
+      return false;
+    }
+
+  if (!pointer && context && gfc_implicit_pure (NULL)
+      && gfc_impure_variable (sym))
+    {
+      gfc_namespace *ns;
+      gfc_symbol *sym;
+
+      for (ns = gfc_current_ns; ns; ns = ns->parent)
+	{
+	  sym = ns->proc_name;
+	  if (sym == NULL)
+	    break;
+	  if (sym->attr.flavor == FL_PROCEDURE)
+	    {
+	      sym->attr.implicit_pure = 0;
+	      break;
+	    }
+	}
+    }
+  /* Check variable definition context for associate-names.  */
+  if (!pointer && sym->assoc)
+    {
+      const char* name;
+      gfc_association_list* assoc;
+
+      gcc_assert (sym->assoc->target);
+
+      /* If this is a SELECT TYPE temporary (the association is used internally
+	 for SELECT TYPE), silently go over to the target.  */
+      if (sym->attr.select_type_temporary)
+	{
+	  gfc_expr* t = sym->assoc->target;
+
+	  gcc_assert (t->expr_type == EXPR_VARIABLE);
+	  name = t->symtree->name;
+
+	  if (t->symtree->n.sym->assoc)
+	    assoc = t->symtree->n.sym->assoc;
+	  else
+	    assoc = sym->assoc;
+	}
+      else
+	{
+	  name = sym->name;
+	  assoc = sym->assoc;
+	}
+      gcc_assert (name && assoc);
+
+      /* Is association to a valid variable?  */
+      if (!assoc->variable)
+	{
+	  if (context)
+	    {
+	      if (assoc->target->expr_type == EXPR_VARIABLE)
+		gfc_error ("'%s' at %L associated to vector-indexed target can"
+			   " not be used in a variable definition context (%s)",
+			   name, &e->where, context);
+	      else
+		gfc_error ("'%s' at %L associated to expression can"
+			   " not be used in a variable definition context (%s)",
+			   name, &e->where, context);
+	    }
+	  return false;
+	}
+
+      /* Target must be allowed to appear in a variable definition context.  */
+      if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL))
+	{
+	  if (context)
+	    gfc_error ("Associate-name '%s' can not appear in a variable"
+		       " definition context (%s) at %L because its target"
+		       " at %L can not, either",
+		       name, context, &e->where,
+		       &assoc->target->where);
+	  return false;
+	}
+    }
+
+  /* Check for same value in vector expression subscript.  */
+
+  if (e->rank > 0)
+    for (ref = e->ref; ref != NULL; ref = ref->next)
+      if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
+	for (i = 0; i < GFC_MAX_DIMENSIONS
+	       && ref->u.ar.dimen_type[i] != 0; i++)
+	  if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
+	    {
+	      gfc_expr *arr = ref->u.ar.start[i];
+	      if (arr->expr_type == EXPR_ARRAY)
+		{
+		  gfc_constructor *c, *n;
+		  gfc_expr *ec, *en;
+		  
+		  for (c = gfc_constructor_first (arr->value.constructor);
+		       c != NULL; c = gfc_constructor_next (c))
+		    {
+		      if (c == NULL || c->iterator != NULL)
+			continue;
+		      
+		      ec = c->expr;
+
+		      for (n = gfc_constructor_next (c); n != NULL;
+			   n = gfc_constructor_next (n))
+			{
+			  if (n->iterator != NULL)
+			    continue;
+			  
+			  en = n->expr;
+			  if (gfc_dep_compare_expr (ec, en) == 0)
+			    {
+			      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;
+			    }
+			}
+		    }
+		}
+	    }
+  
+  return true;
+}
diff --git a/gcc-4.9/gcc/fortran/f95-lang.c b/gcc-4.9/gcc/fortran/f95-lang.c
new file mode 100644
index 000000000..e25e92a55
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/f95-lang.c
@@ -0,0 +1,1093 @@
+/* gfortran backend interface
+   Copyright (C) 2000-2014 Free Software Foundation, Inc.
+   Contributed by Paul Brook.
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+/* f95-lang.c-- GCC backend interface stuff */
+
+/* declare required prototypes: */
+
+#include "config.h"
+#include "system.h"
+#include "ansidecl.h"
+#include "system.h"
+#include "coretypes.h"
+#include "tree.h"
+#include "flags.h"
+#include "langhooks.h"
+#include "langhooks-def.h"
+#include "timevar.h"
+#include "tm.h"
+#include "function.h"
+#include "ggc.h"
+#include "toplev.h"
+#include "target.h"
+#include "debug.h"
+#include "diagnostic.h"
+#include "dumpfile.h"
+#include "cgraph.h"
+#include "gfortran.h"
+#include "cpp.h"
+#include "trans.h"
+#include "trans-types.h"
+#include "trans-const.h"
+
+/* Language-dependent contents of an identifier.  */
+
+struct GTY(())
+lang_identifier {
+  struct tree_identifier common;
+};
+
+/* The resulting tree type.  */
+
+union GTY((desc ("TREE_CODE (&%h.generic) == IDENTIFIER_NODE"),
+     chain_next ("CODE_CONTAINS_STRUCT (TREE_CODE (&%h.generic), TS_COMMON) ? ((union lang_tree_node *) TREE_CHAIN (&%h.generic)) : NULL")))
+lang_tree_node {
+  union tree_node GTY((tag ("0"),
+		       desc ("tree_node_structure (&%h)"))) generic;
+  struct lang_identifier GTY((tag ("1"))) identifier;
+};
+
+/* Save and restore the variables in this file and elsewhere
+   that keep track of the progress of compilation of the current function.
+   Used for nested functions.  */
+
+struct GTY(())
+language_function {
+  /* struct gfc_language_function base; */
+  struct binding_level *binding_level;
+};
+
+static void gfc_init_decl_processing (void);
+static void gfc_init_builtin_functions (void);
+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);
+static tree gfc_builtin_function (tree);
+
+#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
+#undef LANG_HOOKS_HANDLE_OPTION
+#undef LANG_HOOKS_POST_OPTIONS
+#undef LANG_HOOKS_PARSE_FILE
+#undef LANG_HOOKS_MARK_ADDRESSABLE
+#undef LANG_HOOKS_TYPE_FOR_MODE
+#undef LANG_HOOKS_TYPE_FOR_SIZE
+#undef LANG_HOOKS_GET_ALIAS_SET
+#undef LANG_HOOKS_INIT_TS
+#undef LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE
+#undef LANG_HOOKS_OMP_PREDETERMINED_SHARING
+#undef LANG_HOOKS_OMP_REPORT_DECL
+#undef LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR
+#undef LANG_HOOKS_OMP_CLAUSE_COPY_CTOR
+#undef LANG_HOOKS_OMP_CLAUSE_ASSIGN_OP
+#undef LANG_HOOKS_OMP_CLAUSE_DTOR
+#undef LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR
+#undef LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE
+#undef LANG_HOOKS_OMP_PRIVATE_OUTER_REF
+#undef LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES
+#undef LANG_HOOKS_BUILTIN_FUNCTION
+#undef LANG_HOOKS_BUILTIN_FUNCTION
+#undef LANG_HOOKS_GET_ARRAY_DESCR_INFO
+
+/* Define lang hooks.  */
+#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
+#define LANG_HOOKS_HANDLE_OPTION        gfc_handle_option
+#define LANG_HOOKS_POST_OPTIONS		gfc_post_options
+#define LANG_HOOKS_PARSE_FILE           gfc_be_parse_file
+#define LANG_HOOKS_TYPE_FOR_MODE	gfc_type_for_mode
+#define LANG_HOOKS_TYPE_FOR_SIZE	gfc_type_for_size
+#define LANG_HOOKS_GET_ALIAS_SET	gfc_get_alias_set
+#define LANG_HOOKS_INIT_TS		gfc_init_ts
+#define LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE	gfc_omp_privatize_by_reference
+#define LANG_HOOKS_OMP_PREDETERMINED_SHARING	gfc_omp_predetermined_sharing
+#define LANG_HOOKS_OMP_REPORT_DECL		gfc_omp_report_decl
+#define LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR	gfc_omp_clause_default_ctor
+#define LANG_HOOKS_OMP_CLAUSE_COPY_CTOR		gfc_omp_clause_copy_ctor
+#define LANG_HOOKS_OMP_CLAUSE_ASSIGN_OP		gfc_omp_clause_assign_op
+#define LANG_HOOKS_OMP_CLAUSE_DTOR		gfc_omp_clause_dtor
+#define LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR	gfc_omp_disregard_value_expr
+#define LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE	gfc_omp_private_debug_clause
+#define LANG_HOOKS_OMP_PRIVATE_OUTER_REF	gfc_omp_private_outer_ref
+#define LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES \
+  gfc_omp_firstprivatize_type_sizes
+#define LANG_HOOKS_BUILTIN_FUNCTION          gfc_builtin_function
+#define LANG_HOOKS_GET_ARRAY_DESCR_INFO	     gfc_get_array_descr_info
+
+struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
+
+#define NULL_BINDING_LEVEL (struct binding_level *) NULL
+
+/* A chain of binding_level structures awaiting reuse.  */
+
+static GTY(()) struct binding_level *free_binding_level;
+
+/* True means we've initialized exception handling.  */
+static bool gfc_eh_initialized_p;
+
+/* The current translation unit.  */
+static GTY(()) tree current_translation_unit;
+
+
+static void
+gfc_create_decls (void)
+{
+  /* GCC builtins.  */
+  gfc_init_builtin_functions ();
+
+  /* Runtime/IO library functions.  */
+  gfc_build_builtin_function_decls ();
+
+  gfc_init_constants ();
+
+  /* Build our translation-unit decl.  */
+  current_translation_unit = build_translation_unit_decl (NULL_TREE);
+}
+
+
+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);
+}
+
+
+/* Initialize everything.  */
+
+static bool
+gfc_init (void)
+{
+  if (!gfc_cpp_enabled ())
+    {
+      linemap_add (line_table, LC_ENTER, false, gfc_source_file, 1);
+      linemap_add (line_table, LC_RENAME, false, "<built-in>", 0);
+    }
+  else
+    gfc_cpp_init_0 ();
+
+  gfc_init_decl_processing ();
+  gfc_static_ctors = NULL_TREE;
+
+  if (gfc_cpp_enabled ())
+    gfc_cpp_init ();
+
+  gfc_init_1 ();
+
+  if (!gfc_new_file ())
+    fatal_error ("can't open input file: %s", gfc_source_file);
+
+  if (flag_preprocess_only)
+    return false;
+
+  return true;
+}
+
+
+static void
+gfc_finish (void)
+{
+  gfc_cpp_done ();
+  gfc_done_1 ();
+  gfc_release_include_path ();
+  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
+   functions from GNAT.  */
+
+/* For each binding contour we allocate a binding_level structure which
+   records the entities defined or declared in that contour.  Contours
+   include:
+
+        the global one
+        one for each subprogram definition
+        one for each compound statement (declare block)
+
+   Binding contours are used to create GCC tree BLOCK nodes.  */
+
+struct GTY(())
+binding_level {
+  /* A chain of ..._DECL nodes for all variables, constants, functions,
+     parameters and type declarations.  These ..._DECL nodes are chained
+     through the DECL_CHAIN field.  */
+  tree names;
+  /* For each level (except the global one), a chain of BLOCK nodes for all
+     the levels that were entered and exited one level down from this one.  */
+  tree blocks;
+  /* The binding level containing this one (the enclosing binding level).  */
+  struct binding_level *level_chain;
+};
+
+/* The binding level currently in effect.  */
+static GTY(()) struct binding_level *current_binding_level = NULL;
+
+/* The outermost binding level. This binding level is created when the
+   compiler is started and it will exist through the entire compilation.  */
+static GTY(()) struct binding_level *global_binding_level;
+
+/* Binding level structures are initialized by copying this one.  */
+static struct binding_level clear_binding_level = { NULL, NULL, NULL };
+
+
+/* Return true if we are in the global binding level.  */
+
+bool
+global_bindings_p (void)
+{
+  return current_binding_level == global_binding_level;
+}
+
+tree
+getdecls (void)
+{
+  return current_binding_level->names;
+}
+
+/* Enter a new binding level. */
+
+void
+pushlevel (void)
+{
+  struct binding_level *newlevel = ggc_alloc_binding_level ();
+
+  *newlevel = clear_binding_level;
+
+  /* Add this level to the front of the chain (stack) of levels that are
+     active.  */
+  newlevel->level_chain = current_binding_level;
+  current_binding_level = newlevel;
+}
+
+/* Exit a binding level.
+   Pop the level off, and restore the state of the identifier-decl mappings
+   that were in effect when this level was entered.
+
+   If KEEP is nonzero, this level had explicit declarations, so
+   and create a "block" (a BLOCK node) for the level
+   to record its declarations and subblocks for symbol table output.
+
+   If FUNCTIONBODY is nonzero, this level is the body of a function,
+   so create a block as if KEEP were set and also clear out all
+   label names.  */
+
+tree
+poplevel (int keep, int functionbody)
+{
+  /* Points to a BLOCK tree node. This is the BLOCK node constructed for the
+     binding level that we are about to exit and which is returned by this
+     routine.  */
+  tree block_node = NULL_TREE;
+  tree decl_chain = current_binding_level->names;
+  tree subblock_chain = current_binding_level->blocks;
+  tree subblock_node;
+
+  /* If there were any declarations in the current binding level, or if this
+     binding level is a function body, or if there are any nested blocks then
+     create a BLOCK node to record them for the life of this function.  */
+  if (keep || functionbody)
+    block_node = build_block (keep ? decl_chain : 0, subblock_chain, 0, 0);
+
+  /* Record the BLOCK node just built as the subblock its enclosing scope.  */
+  for (subblock_node = subblock_chain; subblock_node;
+       subblock_node = BLOCK_CHAIN (subblock_node))
+    BLOCK_SUPERCONTEXT (subblock_node) = block_node;
+
+  /* Clear out the meanings of the local variables of this level.  */
+
+  for (subblock_node = decl_chain; subblock_node;
+       subblock_node = DECL_CHAIN (subblock_node))
+    if (DECL_NAME (subblock_node) != 0)
+      /* If the identifier was used or addressed via a local extern decl,
+         don't forget that fact.  */
+      if (DECL_EXTERNAL (subblock_node))
+	{
+	  if (TREE_USED (subblock_node))
+	    TREE_USED (DECL_NAME (subblock_node)) = 1;
+	  if (TREE_ADDRESSABLE (subblock_node))
+	    TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (subblock_node)) = 1;
+	}
+
+  /* Pop the current level.  */
+  current_binding_level = current_binding_level->level_chain;
+
+  if (functionbody)
+    /* This is the top level block of a function. */
+    DECL_INITIAL (current_function_decl) = block_node;
+  else if (current_binding_level == global_binding_level)
+    /* When using gfc_start_block/gfc_finish_block from middle-end hooks,
+       don't add newly created BLOCKs as subblocks of global_binding_level.  */
+    ;
+  else if (block_node)
+    {
+      current_binding_level->blocks
+	= block_chainon (current_binding_level->blocks, block_node);
+    }
+
+  /* If we did not make a block for the level just exited, any blocks made for
+     inner levels (since they cannot be recorded as subblocks in that level)
+     must be carried forward so they will later become subblocks of something
+     else.  */
+  else if (subblock_chain)
+    current_binding_level->blocks
+      = block_chainon (current_binding_level->blocks, subblock_chain);
+  if (block_node)
+    TREE_USED (block_node) = 1;
+
+  return block_node;
+}
+
+
+/* Records a ..._DECL node DECL as belonging to the current lexical scope.
+   Returns the ..._DECL node.  */
+
+tree
+pushdecl (tree decl)
+{
+  if (global_bindings_p ())
+    DECL_CONTEXT (decl) = current_translation_unit;
+  else
+    {
+      /* External objects aren't nested.  For debug info insert a copy
+         of the decl into the binding level.  */
+      if (DECL_EXTERNAL (decl))
+	{
+	  tree orig = decl;
+	  decl = copy_node (decl);
+	  DECL_CONTEXT (orig) = NULL_TREE;
+	}
+      DECL_CONTEXT (decl) = current_function_decl;
+    }
+
+  /* Put the declaration on the list.  */
+  DECL_CHAIN (decl) = current_binding_level->names;
+  current_binding_level->names = decl;
+
+  /* For the declaration of a type, set its name if it is not already set.  */
+
+  if (TREE_CODE (decl) == TYPE_DECL && TYPE_NAME (TREE_TYPE (decl)) == 0)
+    {
+      if (DECL_SOURCE_LINE (decl) == 0)
+	TYPE_NAME (TREE_TYPE (decl)) = decl;
+      else
+	TYPE_NAME (TREE_TYPE (decl)) = DECL_NAME (decl);
+    }
+
+  return decl;
+}
+
+
+/* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL.  */
+
+tree
+pushdecl_top_level (tree x)
+{
+  tree t;
+  struct binding_level *b = current_binding_level;
+
+  current_binding_level = global_binding_level;
+  t = pushdecl (x);
+  current_binding_level = b;
+  return t;
+}
+
+#ifndef CHAR_TYPE_SIZE
+#define CHAR_TYPE_SIZE BITS_PER_UNIT
+#endif
+
+#ifndef INT_TYPE_SIZE
+#define INT_TYPE_SIZE BITS_PER_WORD
+#endif
+
+#undef SIZE_TYPE
+#define SIZE_TYPE "long unsigned int"
+
+/* Create tree nodes for the basic scalar types of Fortran 95,
+   and some nodes representing standard constants (0, 1, (void *) 0).
+   Initialize the global binding level.
+   Make definitions for built-in primitive functions.  */
+static void
+gfc_init_decl_processing (void)
+{
+  current_function_decl = NULL;
+  current_binding_level = NULL_BINDING_LEVEL;
+  free_binding_level = NULL_BINDING_LEVEL;
+
+  /* Make the binding_level structure for global names. We move all
+     variables that are in a COMMON block to this binding level.  */
+  pushlevel ();
+  global_binding_level = current_binding_level;
+
+  /* Build common tree nodes. char_type_node is unsigned because we
+     only use it for actual characters, not for INTEGER(1). Also, we
+     want double_type_node to actually have double precision.  */
+  build_common_tree_nodes (false, false);
+
+  void_list_node = build_tree_list (NULL_TREE, void_type_node);
+
+  /* Set up F95 type nodes.  */
+  gfc_init_kinds ();
+  gfc_init_types ();
+  gfc_init_c_interop_kinds ();
+}
+
+
+/* Return the typed-based alias set for T, which may be an expression
+   or a type.  Return -1 if we don't do anything special.  */
+
+static alias_set_type
+gfc_get_alias_set (tree t)
+{
+  tree u;
+
+  /* Permit type-punning when accessing an EQUIVALENCEd variable or
+     mixed type entry master's return value.  */
+  for (u = t; handled_component_p (u); u = TREE_OPERAND (u, 0))
+    if (TREE_CODE (u) == COMPONENT_REF
+	&& TREE_CODE (TREE_TYPE (TREE_OPERAND (u, 0))) == UNION_TYPE)
+      return 0;
+
+  return -1;
+}
+
+/* Builtin function initialization.  */
+
+static tree
+gfc_builtin_function (tree decl)
+{
+  pushdecl (decl);
+  return decl;
+}
+
+/* So far we need just these 7 attribute types.  */
+#define ATTR_NULL			0
+#define ATTR_LEAF_LIST			(ECF_LEAF)
+#define ATTR_NOTHROW_LEAF_LIST		(ECF_NOTHROW | ECF_LEAF)
+#define ATTR_NOTHROW_LEAF_MALLOC_LIST	(ECF_NOTHROW | ECF_LEAF | ECF_MALLOC)
+#define ATTR_CONST_NOTHROW_LEAF_LIST	(ECF_NOTHROW | ECF_LEAF | ECF_CONST)
+#define ATTR_NOTHROW_LIST		(ECF_NOTHROW)
+#define ATTR_CONST_NOTHROW_LIST		(ECF_NOTHROW | ECF_CONST)
+
+static void
+gfc_define_builtin (const char *name, tree type, enum built_in_function code,
+		    const char *library_name, int attr)
+{
+  tree decl;
+
+  decl = add_builtin_function (name, type, code, BUILT_IN_NORMAL,
+			       library_name, NULL_TREE);
+  set_call_expr_flags (decl, attr);
+
+  set_builtin_decl (code, decl, true);
+}
+
+
+#define DO_DEFINE_MATH_BUILTIN(code, name, argtype, tbase) \
+    gfc_define_builtin ("__builtin_" name "l", tbase##longdouble[argtype], \
+			BUILT_IN_ ## code ## L, name "l", \
+			ATTR_CONST_NOTHROW_LEAF_LIST); \
+    gfc_define_builtin ("__builtin_" name, tbase##double[argtype], \
+			BUILT_IN_ ## code, name, \
+			ATTR_CONST_NOTHROW_LEAF_LIST); \
+    gfc_define_builtin ("__builtin_" name "f", tbase##float[argtype], \
+			BUILT_IN_ ## code ## F, name "f", \
+			ATTR_CONST_NOTHROW_LEAF_LIST);
+
+#define DEFINE_MATH_BUILTIN(code, name, argtype) \
+    DO_DEFINE_MATH_BUILTIN (code, name, argtype, mfunc_)
+
+#define DEFINE_MATH_BUILTIN_C(code, name, argtype) \
+    DO_DEFINE_MATH_BUILTIN (code, name, argtype, mfunc_) \
+    DO_DEFINE_MATH_BUILTIN (C##code, "c" name, argtype, mfunc_c)
+
+
+/* Create function types for builtin functions.  */
+
+static void
+build_builtin_fntypes (tree *fntype, tree type)
+{
+  /* type (*) (type) */
+  fntype[0] = build_function_type_list (type, type, NULL_TREE);
+  /* type (*) (type, type) */
+  fntype[1] = build_function_type_list (type, type, type, NULL_TREE);
+  /* type (*) (type, int) */
+  fntype[2] = build_function_type_list (type,
+                                        type, integer_type_node, NULL_TREE);
+  /* type (*) (void) */
+  fntype[3] = build_function_type_list (type, NULL_TREE);
+  /* type (*) (type, &int) */
+  fntype[4] = build_function_type_list (type, type,
+                                        build_pointer_type (integer_type_node),
+                                        NULL_TREE);
+  /* type (*) (int, type) */
+  fntype[5] = build_function_type_list (type,
+                                        integer_type_node, type, NULL_TREE);
+}
+
+
+static tree
+builtin_type_for_size (int size, bool unsignedp)
+{
+  tree type = gfc_type_for_size (size, unsignedp);
+  return type ? type : error_mark_node;
+}
+
+/* Initialization of builtin function nodes.  */
+
+static void
+gfc_init_builtin_functions (void)
+{
+  enum builtin_type
+  {
+#define DEF_PRIMITIVE_TYPE(NAME, VALUE) NAME,
+#define DEF_FUNCTION_TYPE_0(NAME, RETURN) NAME,
+#define DEF_FUNCTION_TYPE_1(NAME, RETURN, ARG1) NAME,
+#define DEF_FUNCTION_TYPE_2(NAME, RETURN, ARG1, ARG2) NAME,
+#define DEF_FUNCTION_TYPE_3(NAME, RETURN, ARG1, ARG2, ARG3) NAME,
+#define DEF_FUNCTION_TYPE_4(NAME, RETURN, ARG1, ARG2, ARG3, ARG4) NAME,
+#define DEF_FUNCTION_TYPE_5(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) NAME,
+#define DEF_FUNCTION_TYPE_6(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6) NAME,
+#define DEF_FUNCTION_TYPE_7(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7) NAME,
+#define DEF_FUNCTION_TYPE_8(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7, ARG8) NAME,
+#define DEF_FUNCTION_TYPE_VAR_0(NAME, RETURN) NAME,
+#define DEF_POINTER_TYPE(NAME, TYPE) NAME,
+#include "types.def"
+#undef DEF_PRIMITIVE_TYPE
+#undef DEF_FUNCTION_TYPE_0
+#undef DEF_FUNCTION_TYPE_1
+#undef DEF_FUNCTION_TYPE_2
+#undef DEF_FUNCTION_TYPE_3
+#undef DEF_FUNCTION_TYPE_4
+#undef DEF_FUNCTION_TYPE_5
+#undef DEF_FUNCTION_TYPE_6
+#undef DEF_FUNCTION_TYPE_7
+#undef DEF_FUNCTION_TYPE_8
+#undef DEF_FUNCTION_TYPE_VAR_0
+#undef DEF_POINTER_TYPE
+    BT_LAST
+  };
+
+  tree mfunc_float[6];
+  tree mfunc_double[6];
+  tree mfunc_longdouble[6];
+  tree mfunc_cfloat[6];
+  tree mfunc_cdouble[6];
+  tree mfunc_clongdouble[6];
+  tree func_cfloat_float, func_float_cfloat;
+  tree func_cdouble_double, func_double_cdouble;
+  tree func_clongdouble_longdouble, func_longdouble_clongdouble;
+  tree func_float_floatp_floatp;
+  tree func_double_doublep_doublep;
+  tree func_longdouble_longdoublep_longdoublep;
+  tree ftype, ptype;
+  tree builtin_types[(int) BT_LAST + 1];
+
+  build_builtin_fntypes (mfunc_float, float_type_node);
+  build_builtin_fntypes (mfunc_double, double_type_node);
+  build_builtin_fntypes (mfunc_longdouble, long_double_type_node);
+  build_builtin_fntypes (mfunc_cfloat, complex_float_type_node);
+  build_builtin_fntypes (mfunc_cdouble, complex_double_type_node);
+  build_builtin_fntypes (mfunc_clongdouble, complex_long_double_type_node);
+
+  func_cfloat_float = build_function_type_list (float_type_node,
+                                                complex_float_type_node,
+                                                NULL_TREE);
+
+  func_float_cfloat = build_function_type_list (complex_float_type_node,
+                                                float_type_node, NULL_TREE);
+
+  func_cdouble_double = build_function_type_list (double_type_node,
+                                                  complex_double_type_node,
+                                                  NULL_TREE);
+
+  func_double_cdouble = build_function_type_list (complex_double_type_node,
+                                                  double_type_node, NULL_TREE);
+
+  func_clongdouble_longdouble =
+    build_function_type_list (long_double_type_node,
+                              complex_long_double_type_node, NULL_TREE);
+
+  func_longdouble_clongdouble =
+    build_function_type_list (complex_long_double_type_node,
+                              long_double_type_node, NULL_TREE);
+
+  ptype = build_pointer_type (float_type_node);
+  func_float_floatp_floatp =
+    build_function_type_list (void_type_node, ptype, ptype, NULL_TREE);
+
+  ptype = build_pointer_type (double_type_node);
+  func_double_doublep_doublep =
+    build_function_type_list (void_type_node, ptype, ptype, NULL_TREE);
+
+  ptype = build_pointer_type (long_double_type_node);
+  func_longdouble_longdoublep_longdoublep =
+    build_function_type_list (void_type_node, ptype, ptype, NULL_TREE);
+
+/* Non-math builtins are defined manually, so they're not included here.  */
+#define OTHER_BUILTIN(ID,NAME,TYPE,CONST)
+
+#include "mathbuiltins.def"
+
+  gfc_define_builtin ("__builtin_roundl", mfunc_longdouble[0], 
+		      BUILT_IN_ROUNDL, "roundl", ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_round", mfunc_double[0], 
+		      BUILT_IN_ROUND, "round", ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_roundf", mfunc_float[0], 
+		      BUILT_IN_ROUNDF, "roundf", ATTR_CONST_NOTHROW_LEAF_LIST);
+
+  gfc_define_builtin ("__builtin_truncl", mfunc_longdouble[0],
+		      BUILT_IN_TRUNCL, "truncl", ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_trunc", mfunc_double[0],
+		      BUILT_IN_TRUNC, "trunc", ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_truncf", mfunc_float[0],
+		      BUILT_IN_TRUNCF, "truncf", ATTR_CONST_NOTHROW_LEAF_LIST);
+
+  gfc_define_builtin ("__builtin_cabsl", func_clongdouble_longdouble, 
+		      BUILT_IN_CABSL, "cabsl", ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_cabs", func_cdouble_double, 
+		      BUILT_IN_CABS, "cabs", ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_cabsf", func_cfloat_float, 
+		      BUILT_IN_CABSF, "cabsf", ATTR_CONST_NOTHROW_LEAF_LIST);
+ 
+  gfc_define_builtin ("__builtin_copysignl", mfunc_longdouble[1], 
+		      BUILT_IN_COPYSIGNL, "copysignl",
+		      ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_copysign", mfunc_double[1], 
+		      BUILT_IN_COPYSIGN, "copysign",
+		      ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_copysignf", mfunc_float[1], 
+		      BUILT_IN_COPYSIGNF, "copysignf",
+		      ATTR_CONST_NOTHROW_LEAF_LIST);
+ 
+  gfc_define_builtin ("__builtin_nextafterl", mfunc_longdouble[1], 
+		      BUILT_IN_NEXTAFTERL, "nextafterl",
+		      ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_nextafter", mfunc_double[1], 
+		      BUILT_IN_NEXTAFTER, "nextafter",
+		      ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_nextafterf", mfunc_float[1], 
+		      BUILT_IN_NEXTAFTERF, "nextafterf",
+		      ATTR_CONST_NOTHROW_LEAF_LIST);
+ 
+  gfc_define_builtin ("__builtin_frexpl", mfunc_longdouble[4], 
+		      BUILT_IN_FREXPL, "frexpl", ATTR_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_frexp", mfunc_double[4], 
+		      BUILT_IN_FREXP, "frexp", ATTR_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_frexpf", mfunc_float[4], 
+		      BUILT_IN_FREXPF, "frexpf", ATTR_NOTHROW_LEAF_LIST);
+ 
+  gfc_define_builtin ("__builtin_fabsl", mfunc_longdouble[0], 
+		      BUILT_IN_FABSL, "fabsl", ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_fabs", mfunc_double[0], 
+		      BUILT_IN_FABS, "fabs", ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_fabsf", mfunc_float[0], 
+		      BUILT_IN_FABSF, "fabsf", ATTR_CONST_NOTHROW_LEAF_LIST);
+ 
+  gfc_define_builtin ("__builtin_scalbnl", mfunc_longdouble[5], 
+		      BUILT_IN_SCALBNL, "scalbnl", ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_scalbn", mfunc_double[5], 
+		      BUILT_IN_SCALBN, "scalbn", ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_scalbnf", mfunc_float[5], 
+		      BUILT_IN_SCALBNF, "scalbnf", ATTR_CONST_NOTHROW_LEAF_LIST);
+ 
+  gfc_define_builtin ("__builtin_fmodl", mfunc_longdouble[1], 
+		      BUILT_IN_FMODL, "fmodl", ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_fmod", mfunc_double[1], 
+		      BUILT_IN_FMOD, "fmod", ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_fmodf", mfunc_float[1], 
+		      BUILT_IN_FMODF, "fmodf", ATTR_CONST_NOTHROW_LEAF_LIST);
+
+  /* iround{f,,l}, lround{f,,l} and llround{f,,l} */
+  ftype = build_function_type_list (integer_type_node,
+                                    float_type_node, NULL_TREE); 
+  gfc_define_builtin("__builtin_iroundf", ftype, BUILT_IN_IROUNDF,
+		     "iroundf", ATTR_CONST_NOTHROW_LEAF_LIST);
+  ftype = build_function_type_list (long_integer_type_node,
+                                    float_type_node, NULL_TREE); 
+  gfc_define_builtin ("__builtin_lroundf", ftype, BUILT_IN_LROUNDF,
+		      "lroundf", ATTR_CONST_NOTHROW_LEAF_LIST);
+  ftype = build_function_type_list (long_long_integer_type_node,
+                                    float_type_node, NULL_TREE); 
+  gfc_define_builtin ("__builtin_llroundf", ftype, BUILT_IN_LLROUNDF,
+		      "llroundf", ATTR_CONST_NOTHROW_LEAF_LIST);
+
+  ftype = build_function_type_list (integer_type_node,
+                                    double_type_node, NULL_TREE); 
+  gfc_define_builtin("__builtin_iround", ftype, BUILT_IN_IROUND,
+		     "iround", ATTR_CONST_NOTHROW_LEAF_LIST);
+  ftype = build_function_type_list (long_integer_type_node,
+                                    double_type_node, NULL_TREE); 
+  gfc_define_builtin ("__builtin_lround", ftype, BUILT_IN_LROUND,
+		      "lround", ATTR_CONST_NOTHROW_LEAF_LIST);
+  ftype = build_function_type_list (long_long_integer_type_node,
+                                    double_type_node, NULL_TREE); 
+  gfc_define_builtin ("__builtin_llround", ftype, BUILT_IN_LLROUND,
+		      "llround", ATTR_CONST_NOTHROW_LEAF_LIST);
+
+  ftype = build_function_type_list (integer_type_node,
+                                    long_double_type_node, NULL_TREE); 
+  gfc_define_builtin("__builtin_iroundl", ftype, BUILT_IN_IROUNDL,
+		     "iroundl", ATTR_CONST_NOTHROW_LEAF_LIST);
+  ftype = build_function_type_list (long_integer_type_node,
+                                    long_double_type_node, NULL_TREE); 
+  gfc_define_builtin ("__builtin_lroundl", ftype, BUILT_IN_LROUNDL,
+		      "lroundl", ATTR_CONST_NOTHROW_LEAF_LIST);
+  ftype = build_function_type_list (long_long_integer_type_node,
+                                    long_double_type_node, NULL_TREE); 
+  gfc_define_builtin ("__builtin_llroundl", ftype, BUILT_IN_LLROUNDL,
+		      "llroundl", ATTR_CONST_NOTHROW_LEAF_LIST);
+
+  /* These are used to implement the ** operator.  */
+  gfc_define_builtin ("__builtin_powl", mfunc_longdouble[1], 
+		      BUILT_IN_POWL, "powl", ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_pow", mfunc_double[1], 
+		      BUILT_IN_POW, "pow", ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_powf", mfunc_float[1], 
+		      BUILT_IN_POWF, "powf", ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_cpowl", mfunc_clongdouble[1], 
+		      BUILT_IN_CPOWL, "cpowl", ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_cpow", mfunc_cdouble[1], 
+		      BUILT_IN_CPOW, "cpow", ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_cpowf", mfunc_cfloat[1], 
+		      BUILT_IN_CPOWF, "cpowf", ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_powil", mfunc_longdouble[2], 
+		      BUILT_IN_POWIL, "powil", ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_powi", mfunc_double[2], 
+		      BUILT_IN_POWI, "powi", ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_powif", mfunc_float[2], 
+		      BUILT_IN_POWIF, "powif", ATTR_CONST_NOTHROW_LEAF_LIST);
+
+
+  if (targetm.libc_has_function (function_c99_math_complex))
+    {
+      gfc_define_builtin ("__builtin_cbrtl", mfunc_longdouble[0],
+			  BUILT_IN_CBRTL, "cbrtl",
+			  ATTR_CONST_NOTHROW_LEAF_LIST);
+      gfc_define_builtin ("__builtin_cbrt", mfunc_double[0],
+			  BUILT_IN_CBRT, "cbrt",
+			  ATTR_CONST_NOTHROW_LEAF_LIST);
+      gfc_define_builtin ("__builtin_cbrtf", mfunc_float[0],
+			  BUILT_IN_CBRTF, "cbrtf",
+			  ATTR_CONST_NOTHROW_LEAF_LIST);
+      gfc_define_builtin ("__builtin_cexpil", func_longdouble_clongdouble, 
+			  BUILT_IN_CEXPIL, "cexpil",
+			  ATTR_CONST_NOTHROW_LEAF_LIST);
+      gfc_define_builtin ("__builtin_cexpi", func_double_cdouble,
+			  BUILT_IN_CEXPI, "cexpi",
+			  ATTR_CONST_NOTHROW_LEAF_LIST);
+      gfc_define_builtin ("__builtin_cexpif", func_float_cfloat,
+			  BUILT_IN_CEXPIF, "cexpif",
+			  ATTR_CONST_NOTHROW_LEAF_LIST);
+    }
+
+  if (targetm.libc_has_function (function_sincos))
+    {
+      gfc_define_builtin ("__builtin_sincosl",
+			  func_longdouble_longdoublep_longdoublep,
+			  BUILT_IN_SINCOSL, "sincosl", ATTR_NOTHROW_LEAF_LIST);
+      gfc_define_builtin ("__builtin_sincos", func_double_doublep_doublep,
+			  BUILT_IN_SINCOS, "sincos", ATTR_NOTHROW_LEAF_LIST);
+      gfc_define_builtin ("__builtin_sincosf", func_float_floatp_floatp,
+			  BUILT_IN_SINCOSF, "sincosf", ATTR_NOTHROW_LEAF_LIST);
+    }
+
+  /* For LEADZ, TRAILZ, POPCNT and POPPAR.  */
+  ftype = build_function_type_list (integer_type_node,
+                                    unsigned_type_node, NULL_TREE);
+  gfc_define_builtin ("__builtin_clz", ftype, BUILT_IN_CLZ,
+		      "__builtin_clz", ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_ctz", ftype, BUILT_IN_CTZ,
+		      "__builtin_ctz", ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_parity", ftype, BUILT_IN_PARITY,
+		      "__builtin_parity", ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_popcount", ftype, BUILT_IN_POPCOUNT,
+		      "__builtin_popcount", ATTR_CONST_NOTHROW_LEAF_LIST);
+
+  ftype = build_function_type_list (integer_type_node,
+                                    long_unsigned_type_node, NULL_TREE);
+  gfc_define_builtin ("__builtin_clzl", ftype, BUILT_IN_CLZL,
+		      "__builtin_clzl", ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_ctzl", ftype, BUILT_IN_CTZL,
+		      "__builtin_ctzl", ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_parityl", ftype, BUILT_IN_PARITYL,
+		      "__builtin_parityl", ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_popcountl", ftype, BUILT_IN_POPCOUNTL,
+		      "__builtin_popcountl", ATTR_CONST_NOTHROW_LEAF_LIST);
+
+  ftype = build_function_type_list (integer_type_node,
+                                    long_long_unsigned_type_node, NULL_TREE);
+  gfc_define_builtin ("__builtin_clzll", ftype, BUILT_IN_CLZLL,
+		      "__builtin_clzll", ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_ctzll", ftype, BUILT_IN_CTZLL,
+		      "__builtin_ctzll", ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_parityll", ftype, BUILT_IN_PARITYLL,
+		      "__builtin_parityll", ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_popcountll", ftype, BUILT_IN_POPCOUNTLL,
+		      "__builtin_popcountll", ATTR_CONST_NOTHROW_LEAF_LIST);
+
+  /* Other builtin functions we use.  */
+
+  ftype = build_function_type_list (long_integer_type_node,
+                                    long_integer_type_node,
+                                    long_integer_type_node, NULL_TREE);
+  gfc_define_builtin ("__builtin_expect", ftype, BUILT_IN_EXPECT,
+		      "__builtin_expect", ATTR_CONST_NOTHROW_LEAF_LIST);
+
+  ftype = build_function_type_list (void_type_node,
+                                    pvoid_type_node, NULL_TREE);
+  gfc_define_builtin ("__builtin_free", ftype, BUILT_IN_FREE,
+		      "free", ATTR_NOTHROW_LEAF_LIST);
+
+  ftype = build_function_type_list (pvoid_type_node,
+                                    size_type_node, NULL_TREE);
+  gfc_define_builtin ("__builtin_malloc", ftype, BUILT_IN_MALLOC,
+		      "malloc", ATTR_NOTHROW_LEAF_MALLOC_LIST);
+
+  ftype = build_function_type_list (pvoid_type_node, size_type_node,
+				    size_type_node, NULL_TREE);
+  gfc_define_builtin ("__builtin_calloc", ftype, BUILT_IN_CALLOC,
+		      "calloc", ATTR_NOTHROW_LEAF_MALLOC_LIST);
+  DECL_IS_MALLOC (builtin_decl_explicit (BUILT_IN_CALLOC)) = 1;
+
+  ftype = build_function_type_list (pvoid_type_node,
+                                    size_type_node, pvoid_type_node,
+                                    NULL_TREE);
+  gfc_define_builtin ("__builtin_realloc", ftype, BUILT_IN_REALLOC,
+		      "realloc", ATTR_NOTHROW_LEAF_LIST);
+
+  ftype = build_function_type_list (integer_type_node,
+                                    void_type_node, NULL_TREE);
+  gfc_define_builtin ("__builtin_isnan", ftype, BUILT_IN_ISNAN,
+		      "__builtin_isnan", ATTR_CONST_NOTHROW_LEAF_LIST);
+
+#define DEF_PRIMITIVE_TYPE(ENUM, VALUE) \
+  builtin_types[(int) ENUM] = VALUE;
+#define DEF_FUNCTION_TYPE_0(ENUM, RETURN)                       \
+  builtin_types[(int) ENUM]                                     \
+    = build_function_type_list (builtin_types[(int) RETURN],	\
+                                NULL_TREE);
+#define DEF_FUNCTION_TYPE_1(ENUM, RETURN, ARG1)				\
+  builtin_types[(int) ENUM]						\
+    = build_function_type_list (builtin_types[(int) RETURN],            \
+                                builtin_types[(int) ARG1],              \
+                                NULL_TREE);
+#define DEF_FUNCTION_TYPE_2(ENUM, RETURN, ARG1, ARG2)           \
+  builtin_types[(int) ENUM]                                     \
+    = build_function_type_list (builtin_types[(int) RETURN],    \
+                                builtin_types[(int) ARG1],      \
+                                builtin_types[(int) ARG2],      \
+                                NULL_TREE);
+#define DEF_FUNCTION_TYPE_3(ENUM, RETURN, ARG1, ARG2, ARG3)             \
+  builtin_types[(int) ENUM]                                             \
+    = build_function_type_list (builtin_types[(int) RETURN],            \
+                                builtin_types[(int) ARG1],              \
+                                builtin_types[(int) ARG2],              \
+                                builtin_types[(int) ARG3],              \
+                                NULL_TREE);
+#define DEF_FUNCTION_TYPE_4(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4)	\
+  builtin_types[(int) ENUM]						\
+    = build_function_type_list (builtin_types[(int) RETURN],            \
+                                builtin_types[(int) ARG1],              \
+                                builtin_types[(int) ARG2],              \
+                                builtin_types[(int) ARG3],		\
+                                builtin_types[(int) ARG4],              \
+                                NULL_TREE);
+#define DEF_FUNCTION_TYPE_5(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5)	\
+  builtin_types[(int) ENUM]						\
+    = build_function_type_list (builtin_types[(int) RETURN],            \
+                                builtin_types[(int) ARG1],              \
+                                builtin_types[(int) ARG2],              \
+                                builtin_types[(int) ARG3],		\
+                                builtin_types[(int) ARG4],              \
+                                builtin_types[(int) ARG5],              \
+                                NULL_TREE);
+#define DEF_FUNCTION_TYPE_6(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
+			    ARG6)					\
+  builtin_types[(int) ENUM]						\
+    = build_function_type_list (builtin_types[(int) RETURN],            \
+                                builtin_types[(int) ARG1],              \
+                                builtin_types[(int) ARG2],              \
+                                builtin_types[(int) ARG3],		\
+                                builtin_types[(int) ARG4],		\
+                                builtin_types[(int) ARG5],              \
+                                builtin_types[(int) ARG6],              \
+                                NULL_TREE);
+#define DEF_FUNCTION_TYPE_7(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
+			    ARG6, ARG7)					\
+  builtin_types[(int) ENUM]						\
+    = build_function_type_list (builtin_types[(int) RETURN],            \
+                                builtin_types[(int) ARG1],              \
+                                builtin_types[(int) ARG2],              \
+                                builtin_types[(int) ARG3],		\
+                                builtin_types[(int) ARG4],		\
+                                builtin_types[(int) ARG5],              \
+                                builtin_types[(int) ARG6],              \
+                                builtin_types[(int) ARG7],              \
+                                NULL_TREE);
+#define DEF_FUNCTION_TYPE_8(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
+			    ARG6, ARG7, ARG8)				\
+  builtin_types[(int) ENUM]						\
+    = build_function_type_list (builtin_types[(int) RETURN],		\
+				builtin_types[(int) ARG1],		\
+				builtin_types[(int) ARG2],		\
+				builtin_types[(int) ARG3],		\
+				builtin_types[(int) ARG4],		\
+				builtin_types[(int) ARG5],		\
+				builtin_types[(int) ARG6],		\
+				builtin_types[(int) ARG7],		\
+				builtin_types[(int) ARG8],		\
+				NULL_TREE);
+#define DEF_FUNCTION_TYPE_VAR_0(ENUM, RETURN)				\
+  builtin_types[(int) ENUM]						\
+    = build_varargs_function_type_list (builtin_types[(int) RETURN],    \
+                                        NULL_TREE);
+#define DEF_POINTER_TYPE(ENUM, TYPE)			\
+  builtin_types[(int) ENUM]				\
+    = build_pointer_type (builtin_types[(int) TYPE]);
+#include "types.def"
+#undef DEF_PRIMITIVE_TYPE
+#undef DEF_FUNCTION_TYPE_1
+#undef DEF_FUNCTION_TYPE_2
+#undef DEF_FUNCTION_TYPE_3
+#undef DEF_FUNCTION_TYPE_4
+#undef DEF_FUNCTION_TYPE_5
+#undef DEF_FUNCTION_TYPE_6
+#undef DEF_FUNCTION_TYPE_VAR_0
+#undef DEF_POINTER_TYPE
+  builtin_types[(int) BT_LAST] = NULL_TREE;
+
+  /* Initialize synchronization builtins.  */
+#undef DEF_SYNC_BUILTIN
+#define DEF_SYNC_BUILTIN(code, name, type, attr) \
+    gfc_define_builtin (name, builtin_types[type], code, name, \
+			attr);
+#include "../sync-builtins.def"
+#undef DEF_SYNC_BUILTIN
+
+  if (gfc_option.gfc_flag_openmp || flag_tree_parallelize_loops)
+    {
+#undef DEF_GOMP_BUILTIN
+#define DEF_GOMP_BUILTIN(code, name, type, attr) \
+      gfc_define_builtin ("__builtin_" name, builtin_types[type], \
+			  code, name, attr);
+#include "../omp-builtins.def"
+#undef DEF_GOMP_BUILTIN
+    }
+
+  gfc_define_builtin ("__builtin_trap", builtin_types[BT_FN_VOID],
+		      BUILT_IN_TRAP, NULL, ATTR_NOTHROW_LEAF_LIST);
+  TREE_THIS_VOLATILE (builtin_decl_explicit (BUILT_IN_TRAP)) = 1;
+
+  gfc_define_builtin ("__emutls_get_address",
+		      builtin_types[BT_FN_PTR_PTR],
+		      BUILT_IN_EMUTLS_GET_ADDRESS,
+		      "__emutls_get_address", ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__emutls_register_common",
+		      builtin_types[BT_FN_VOID_PTR_WORD_WORD_PTR],
+		      BUILT_IN_EMUTLS_REGISTER_COMMON,
+		      "__emutls_register_common", ATTR_NOTHROW_LEAF_LIST);
+
+  build_common_builtin_nodes ();
+  targetm.init_builtins ();
+}
+
+#undef DEFINE_MATH_BUILTIN_C
+#undef DEFINE_MATH_BUILTIN
+
+static void
+gfc_init_ts (void)
+{
+  tree_contains_struct[NAMESPACE_DECL][TS_DECL_NON_COMMON] = 1;
+  tree_contains_struct[NAMESPACE_DECL][TS_DECL_WITH_VIS] = 1;
+  tree_contains_struct[NAMESPACE_DECL][TS_DECL_WRTL] = 1;
+  tree_contains_struct[NAMESPACE_DECL][TS_DECL_COMMON] = 1;
+  tree_contains_struct[NAMESPACE_DECL][TS_DECL_MINIMAL] = 1;
+}
+
+void
+gfc_maybe_initialize_eh (void)
+{
+  if (!flag_exceptions || gfc_eh_initialized_p)
+    return;
+
+  gfc_eh_initialized_p = true;
+  using_eh_for_cleanups ();
+}
+
+
+#include "gt-fortran-f95-lang.h"
+#include "gtype-fortran.h"
diff --git a/gcc-4.9/gcc/fortran/frontend-passes.c b/gcc-4.9/gcc/fortran/frontend-passes.c
new file mode 100644
index 000000000..e663868d3
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/frontend-passes.c
@@ -0,0 +1,2151 @@
+/* Pass manager for Fortran front end.
+   Copyright (C) 2010-2014 Free Software Foundation, Inc.
+   Contributed by Thomas König.
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "gfortran.h"
+#include "arith.h"
+#include "flags.h"
+#include "dependency.h"
+#include "constructor.h"
+#include "opts.h"
+
+/* Forward declarations.  */
+
+static void strip_function_call (gfc_expr *);
+static void optimize_namespace (gfc_namespace *);
+static void optimize_assignment (gfc_code *);
+static bool optimize_op (gfc_expr *);
+static bool optimize_comparison (gfc_expr *, gfc_intrinsic_op);
+static bool optimize_trim (gfc_expr *);
+static bool optimize_lexical_comparison (gfc_expr *);
+static void optimize_minmaxloc (gfc_expr **);
+static bool is_empty_string (gfc_expr *e);
+static void doloop_warn (gfc_namespace *);
+static void optimize_reduction (gfc_namespace *);
+static int callback_reduction (gfc_expr **, int *, void *);
+
+/* How deep we are inside an argument list.  */
+
+static int count_arglist;
+
+/* Pointer to an array of gfc_expr ** we operate on, plus its size
+   and counter.  */
+
+static gfc_expr ***expr_array;
+static int expr_size, expr_count;
+
+/* Pointer to the gfc_code we currently work on - to be able to insert
+   a block before the statement.  */
+
+static gfc_code **current_code;
+
+/* Pointer to the block to be inserted, and the statement we are
+   changing within the block.  */
+
+static gfc_code *inserted_block, **changed_statement;
+
+/* The namespace we are currently dealing with.  */
+
+static gfc_namespace *current_ns;
+
+/* If we are within any forall loop.  */
+
+static int forall_level;
+
+/* Keep track of whether we are within an OMP workshare.  */
+
+static bool in_omp_workshare;
+
+/* Keep track of iterators for array constructors.  */
+
+static int iterator_level;
+
+/* Keep track of DO loop levels.  */
+
+static gfc_code **doloop_list;
+static int doloop_size, doloop_level;
+
+/* Vector of gfc_expr * to keep track of DO loops.  */
+
+struct my_struct *evec;
+
+/* Entry point - run all passes for a namespace. */
+
+void
+gfc_run_passes (gfc_namespace *ns)
+{
+
+  /* Warn about dubious DO loops where the index might
+     change.  */
+
+  doloop_size = 20;
+  doloop_level = 0;
+  doloop_list = XNEWVEC(gfc_code *, doloop_size);
+  doloop_warn (ns);
+  XDELETEVEC (doloop_list);
+
+  if (gfc_option.flag_frontend_optimize)
+    {
+      expr_size = 20;
+      expr_array = XNEWVEC(gfc_expr **, expr_size);
+
+      optimize_namespace (ns);
+      optimize_reduction (ns);
+      if (gfc_option.dump_fortran_optimized)
+	gfc_dump_parse_tree (ns, stdout);
+
+      XDELETEVEC (expr_array);
+    }
+}
+
+/* Callback for each gfc_code node invoked through gfc_code_walker
+   from optimize_namespace.  */
+
+static int
+optimize_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
+	       void *data ATTRIBUTE_UNUSED)
+{
+
+  gfc_exec_op op;
+
+  op = (*c)->op;
+
+  if (op == EXEC_CALL || op == EXEC_COMPCALL || op == EXEC_ASSIGN_CALL
+      || op == EXEC_CALL_PPC)
+    count_arglist = 1;
+  else
+    count_arglist = 0;
+
+  current_code = c;
+  inserted_block = NULL;
+  changed_statement = NULL;
+
+  if (op == EXEC_ASSIGN)
+    optimize_assignment (*c);
+  return 0;
+}
+
+/* Callback for each gfc_expr node invoked through gfc_code_walker
+   from optimize_namespace.  */
+
+static int
+optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+	       void *data ATTRIBUTE_UNUSED)
+{
+  bool function_expr;
+
+  if ((*e)->expr_type == EXPR_FUNCTION)
+    {
+      count_arglist ++;
+      function_expr = true;
+    }
+  else
+    function_expr = false;
+
+  if (optimize_trim (*e))
+    gfc_simplify_expr (*e, 0);
+
+  if (optimize_lexical_comparison (*e))
+    gfc_simplify_expr (*e, 0);
+
+  if ((*e)->expr_type == EXPR_OP && optimize_op (*e))
+    gfc_simplify_expr (*e, 0);
+
+  if ((*e)->expr_type == EXPR_FUNCTION && (*e)->value.function.isym)
+    switch ((*e)->value.function.isym->id)
+      {
+      case GFC_ISYM_MINLOC:
+      case GFC_ISYM_MAXLOC:
+	optimize_minmaxloc (e);
+	break;
+      default:
+	break;
+      }
+
+  if (function_expr)
+    count_arglist --;
+
+  return 0;
+}
+
+/* Auxiliary function to handle the arguments to reduction intrnisics.  If the
+   function is a scalar, just copy it; otherwise returns the new element, the
+   old one can be freed.  */
+
+static gfc_expr *
+copy_walk_reduction_arg (gfc_constructor *c, gfc_expr *fn)
+{
+  gfc_expr *fcn, *e = c->expr;
+
+  fcn = gfc_copy_expr (e);
+  if (c->iterator)
+    {
+      gfc_constructor_base newbase;
+      gfc_expr *new_expr;
+      gfc_constructor *new_c;
+
+      newbase = NULL;
+      new_expr = gfc_get_expr ();
+      new_expr->expr_type = EXPR_ARRAY;
+      new_expr->ts = e->ts;
+      new_expr->where = e->where;
+      new_expr->rank = 1;
+      new_c = gfc_constructor_append_expr (&newbase, fcn, &(e->where));
+      new_c->iterator = c->iterator;
+      new_expr->value.constructor = newbase;
+      c->iterator = NULL;
+
+      fcn = new_expr;
+    }
+
+  if (fcn->rank != 0)
+    {
+      gfc_isym_id id = fn->value.function.isym->id;
+
+      if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT)
+	fcn = gfc_build_intrinsic_call (current_ns, id,
+					fn->value.function.isym->name,
+					fn->where, 3, fcn, NULL, NULL);
+      else if (id == GFC_ISYM_ANY || id == GFC_ISYM_ALL)
+	fcn = gfc_build_intrinsic_call (current_ns, id,
+					fn->value.function.isym->name,
+					fn->where, 2, fcn, NULL);
+      else
+	gfc_internal_error ("Illegal id in copy_walk_reduction_arg");
+
+      fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
+    }
+
+  return fcn;
+}
+
+/* Callback function for optimzation of reductions to scalars.  Transform ANY
+   ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
+   correspondingly.  Handly only the simple cases without MASK and DIM.  */
+
+static int
+callback_reduction (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+		    void *data ATTRIBUTE_UNUSED)
+{
+  gfc_expr *fn, *arg;
+  gfc_intrinsic_op op;
+  gfc_isym_id id;
+  gfc_actual_arglist *a;
+  gfc_actual_arglist *dim;
+  gfc_constructor *c;
+  gfc_expr *res, *new_expr;
+  gfc_actual_arglist *mask;
+
+  fn = *e;
+
+  if (fn->rank != 0 || fn->expr_type != EXPR_FUNCTION
+      || fn->value.function.isym == NULL)
+    return 0;
+
+  id = fn->value.function.isym->id;
+
+  if (id != GFC_ISYM_SUM && id != GFC_ISYM_PRODUCT
+      && id != GFC_ISYM_ANY && id != GFC_ISYM_ALL)
+    return 0;
+
+  a = fn->value.function.actual;
+
+  /* Don't handle MASK or DIM.  */
+
+  dim = a->next;
+
+  if (dim->expr != NULL)
+    return 0;
+
+  if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT)
+    {
+      mask = dim->next;
+      if ( mask->expr != NULL)
+	return 0;
+    }
+
+  arg = a->expr;
+
+  if (arg->expr_type != EXPR_ARRAY)
+    return 0;
+
+  switch (id)
+    {
+    case GFC_ISYM_SUM:
+      op = INTRINSIC_PLUS;
+      break;
+
+    case GFC_ISYM_PRODUCT:
+      op = INTRINSIC_TIMES;
+      break;
+
+    case GFC_ISYM_ANY:
+      op = INTRINSIC_OR;
+      break;
+
+    case GFC_ISYM_ALL:
+      op = INTRINSIC_AND;
+      break;
+
+    default:
+      return 0;
+    }
+
+  c = gfc_constructor_first (arg->value.constructor);
+
+  /* Don't do any simplififcation if we have
+     - no element in the constructor or
+     - only have a single element in the array which contains an
+     iterator.  */
+
+  if (c == NULL)
+    return 0;
+
+  res = copy_walk_reduction_arg (c, fn);
+
+  c = gfc_constructor_next (c);
+  while (c)
+    {
+      new_expr = gfc_get_expr ();
+      new_expr->ts = fn->ts;
+      new_expr->expr_type = EXPR_OP;
+      new_expr->rank = fn->rank;
+      new_expr->where = fn->where;
+      new_expr->value.op.op = op;
+      new_expr->value.op.op1 = res;
+      new_expr->value.op.op2 = copy_walk_reduction_arg (c, fn);
+      res = new_expr;
+      c = gfc_constructor_next (c);
+    }
+
+  gfc_simplify_expr (res, 0);
+  *e = res;
+  gfc_free_expr (fn);
+
+  return 0;
+}
+
+/* Callback function for common function elimination, called from cfe_expr_0.
+   Put all eligible function expressions into expr_array.  */
+
+static int
+cfe_register_funcs (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+	  void *data ATTRIBUTE_UNUSED)
+{
+
+  if ((*e)->expr_type != EXPR_FUNCTION)
+    return 0;
+
+  /* We don't do character functions with unknown charlens.  */
+  if ((*e)->ts.type == BT_CHARACTER 
+      && ((*e)->ts.u.cl == NULL || (*e)->ts.u.cl->length == NULL
+	  || (*e)->ts.u.cl->length->expr_type != EXPR_CONSTANT))
+    return 0;
+
+  /* We don't do function elimination within FORALL statements, it can
+     lead to wrong-code in certain circumstances.  */
+
+  if (forall_level > 0)
+    return 0;
+
+  /* Function elimination inside an iterator could lead to functions which
+     depend on iterator variables being moved outside.  FIXME: We should check
+     if the functions do indeed depend on the iterator variable.  */
+
+  if (iterator_level > 0)
+    return 0;
+
+  /* If we don't know the shape at compile time, we create an allocatable
+     temporary variable to hold the intermediate result, but only if
+     allocation on assignment is active.  */
+
+  if ((*e)->rank > 0 && (*e)->shape == NULL && !gfc_option.flag_realloc_lhs)
+    return 0;
+  
+  /* Skip the test for pure functions if -faggressive-function-elimination
+     is specified.  */
+  if ((*e)->value.function.esym)
+    {
+      /* Don't create an array temporary for elemental functions.  */
+      if ((*e)->value.function.esym->attr.elemental && (*e)->rank > 0)
+	return 0;
+
+      /* Only eliminate potentially impure functions if the
+	 user specifically requested it.  */
+      if (!gfc_option.flag_aggressive_function_elimination
+	  && !(*e)->value.function.esym->attr.pure
+	  && !(*e)->value.function.esym->attr.implicit_pure)
+	return 0;
+    }
+
+  if ((*e)->value.function.isym)
+    {
+      /* Conversions are handled on the fly by the middle end,
+	 transpose during trans-* stages and TRANSFER by the middle end.  */
+      if ((*e)->value.function.isym->id == GFC_ISYM_CONVERSION
+	  || (*e)->value.function.isym->id == GFC_ISYM_TRANSFER
+	  || gfc_inline_intrinsic_function_p (*e))
+	return 0;
+
+      /* Don't create an array temporary for elemental functions,
+	 as this would be wasteful of memory.
+	 FIXME: Create a scalar temporary during scalarization.  */
+      if ((*e)->value.function.isym->elemental && (*e)->rank > 0)
+	return 0;
+
+      if (!(*e)->value.function.isym->pure)
+	return 0;
+    }
+
+  if (expr_count >= expr_size)
+    {
+      expr_size += expr_size;
+      expr_array = XRESIZEVEC(gfc_expr **, expr_array, expr_size);
+    }
+  expr_array[expr_count] = e;
+  expr_count ++;
+  return 0;
+}
+
+/* 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.  */
+
+static gfc_expr*
+create_var (gfc_expr * e)
+{
+  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 the block hasn't already been created, do so.  */
+  if (inserted_block == NULL)
+    {
+      inserted_block = XCNEW (gfc_code);
+      inserted_block->op = EXEC_BLOCK;
+      inserted_block->loc = (*current_code)->loc;
+      ns = gfc_build_block_ns (current_ns);
+      inserted_block->ext.block.ns = ns;
+      inserted_block->ext.block.assoc = NULL;
+
+      ns->code = *current_code;
+
+      /* If the statement has a label,  make sure it is transferred to
+	 the newly created block.  */
+
+      if ((*current_code)->here) 
+	{
+	  inserted_block->here = (*current_code)->here;
+	  (*current_code)->here = NULL;
+	}
+
+      inserted_block->next = (*current_code)->next;
+      changed_statement = &(inserted_block->ext.block.ns->code);
+      (*current_code)->next = NULL;
+      /* Insert the BLOCK at the right position.  */
+      *current_code = inserted_block;
+      ns->parent = current_ns;
+    }
+  else
+    ns = inserted_block->ext.block.ns;
+
+  sprintf(name, "__var_%d",num++);
+  if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
+    gcc_unreachable ();
+
+  symbol = symtree->n.sym;
+  symbol->ts = e->ts;
+
+  if (e->rank > 0)
+    {
+      symbol->as = gfc_get_array_spec ();
+      symbol->as->rank = e->rank;
+
+      if (e->shape == NULL)
+	{
+	  /* We don't know the shape at compile time, so we use an
+	     allocatable. */
+	  symbol->as->type = AS_DEFERRED;
+	  symbol->attr.allocatable = 1;
+	}
+      else
+	{
+	  symbol->as->type = AS_EXPLICIT;
+	  /* Copy the shape.  */
+	  for (i=0; i<e->rank; i++)
+	    {
+	      gfc_expr *p, *q;
+      
+	      p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+					 &(e->where));
+	      mpz_set_si (p->value.integer, 1);
+	      symbol->as->lower[i] = p;
+	      
+	      q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
+					 &(e->where));
+	      mpz_set (q->value.integer, e->shape[i]);
+	      symbol->as->upper[i] = q;
+	    }
+	}
+    }
+
+  symbol->attr.flavor = FL_VARIABLE;
+  symbol->attr.referenced = 1;
+  symbol->attr.dimension = e->rank > 0;
+  gfc_commit_symbol (symbol);
+
+  result = gfc_get_expr ();
+  result->expr_type = EXPR_VARIABLE;
+  result->ts = e->ts;
+  result->rank = e->rank;
+  result->shape = gfc_copy_shape (e->shape, e->rank);
+  result->symtree = symtree;
+  result->where = e->where;
+  if (e->rank > 0)
+    {
+      result->ref = gfc_get_ref ();
+      result->ref->type = REF_ARRAY;
+      result->ref->u.ar.type = AR_FULL;
+      result->ref->u.ar.where = e->where;
+      result->ref->u.ar.as = symbol->ts.type == BT_CLASS
+			     ? CLASS_DATA (symbol)->as : symbol->as;
+      if (gfc_option.warn_array_temp)
+	gfc_warning ("Creating array temporary at %L", &(e->where));
+    }
+
+  /* Generate the new assignment.  */
+  n = XCNEW (gfc_code);
+  n->op = EXEC_ASSIGN;
+  n->loc = (*current_code)->loc;
+  n->next = *changed_statement;
+  n->expr1 = gfc_copy_expr (result);
+  n->expr2 = e;
+  *changed_statement = n;
+
+  return result;
+}
+
+/* Warn about function elimination.  */
+
+static void
+warn_function_elimination (gfc_expr *e)
+{
+  if (e->expr_type != EXPR_FUNCTION)
+    return;
+  if (e->value.function.esym)
+    gfc_warning ("Removing call to function '%s' at %L",
+		 e->value.function.esym->name, &(e->where));
+  else if (e->value.function.isym)
+    gfc_warning ("Removing call to function '%s' at %L",
+		 e->value.function.isym->name, &(e->where));
+}
+/* Callback function for the code walker for doing common function
+   elimination.  This builds up the list of functions in the expression
+   and goes through them to detect duplicates, which it then replaces
+   by variables.  */
+
+static int
+cfe_expr_0 (gfc_expr **e, int *walk_subtrees,
+	  void *data ATTRIBUTE_UNUSED)
+{
+  int i,j;
+  gfc_expr *newvar;
+
+  /* Don't do this optimization within OMP workshare. */
+
+  if (in_omp_workshare)
+    {
+      *walk_subtrees = 0;
+      return 0;
+    }
+
+  expr_count = 0;
+
+  gfc_expr_walker (e, cfe_register_funcs, NULL);
+
+  /* Walk through all the functions.  */
+
+  for (i=1; i<expr_count; i++)
+    {
+      /* Skip if the function has been replaced by a variable already.  */
+      if ((*(expr_array[i]))->expr_type == EXPR_VARIABLE)
+	continue;
+
+      newvar = NULL;
+      for (j=0; j<i; j++)
+	{
+	  if (gfc_dep_compare_functions (*(expr_array[i]),
+					*(expr_array[j]), true)	== 0)
+	    {
+	      if (newvar == NULL)
+		newvar = create_var (*(expr_array[i]));
+
+	      if (gfc_option.warn_function_elimination)
+		warn_function_elimination (*(expr_array[j]));
+
+	      free (*(expr_array[j]));
+	      *(expr_array[j]) = gfc_copy_expr (newvar);
+	    }
+	}
+      if (newvar)
+	*(expr_array[i]) = newvar;
+    }
+
+  /* We did all the necessary walking in this function.  */
+  *walk_subtrees = 0;
+  return 0;
+}
+
+/* Callback function for common function elimination, called from
+   gfc_code_walker.  This keeps track of the current code, in order
+   to insert statements as needed.  */
+
+static int
+cfe_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
+	  void *data ATTRIBUTE_UNUSED)
+{
+  current_code = c;
+  inserted_block = NULL;
+  changed_statement = NULL;
+  return 0;
+}
+
+/* Dummy function for expression call back, for use when we
+   really don't want to do any walking.  */
+
+static int
+dummy_expr_callback (gfc_expr **e ATTRIBUTE_UNUSED, int *walk_subtrees,
+		     void *data ATTRIBUTE_UNUSED)
+{
+  *walk_subtrees = 0;
+  return 0;
+}
+
+/* Dummy function for code callback, for use when we really
+   don't want to do anything.  */
+static int
+dummy_code_callback (gfc_code **e ATTRIBUTE_UNUSED,
+		     int *walk_subtrees ATTRIBUTE_UNUSED,
+		     void *data ATTRIBUTE_UNUSED)
+{
+  return 0;
+}
+
+/* Code callback function for converting
+   do while(a)
+   end do
+   into the equivalent
+   do
+     if (.not. a) exit
+   end do
+   This is because common function elimination would otherwise place the
+   temporary variables outside the loop.  */
+
+static int
+convert_do_while (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
+		  void *data ATTRIBUTE_UNUSED)
+{
+  gfc_code *co = *c;
+  gfc_code *c_if1, *c_if2, *c_exit;
+  gfc_code *loopblock;
+  gfc_expr *e_not, *e_cond;
+
+  if (co->op != EXEC_DO_WHILE)
+    return 0;
+
+  if (co->expr1 == NULL || co->expr1->expr_type == EXPR_CONSTANT)
+    return 0;
+
+  e_cond = co->expr1;
+
+  /* Generate the condition of the if statement, which is .not. the original
+     statement.  */
+  e_not = gfc_get_expr ();
+  e_not->ts = e_cond->ts;
+  e_not->where = e_cond->where;
+  e_not->expr_type = EXPR_OP;
+  e_not->value.op.op = INTRINSIC_NOT;
+  e_not->value.op.op1 = e_cond;
+
+  /* Generate the EXIT statement.  */
+  c_exit = XCNEW (gfc_code);
+  c_exit->op = EXEC_EXIT;
+  c_exit->ext.which_construct = co;
+  c_exit->loc = co->loc;
+
+  /* Generate the IF statement.  */
+  c_if2 = XCNEW (gfc_code);
+  c_if2->op = EXEC_IF;
+  c_if2->expr1 = e_not;
+  c_if2->next = c_exit;
+  c_if2->loc = co->loc;
+
+  /* ... plus the one to chain it to.  */
+  c_if1 = XCNEW (gfc_code);
+  c_if1->op = EXEC_IF;
+  c_if1->block = c_if2;
+  c_if1->loc = co->loc;
+
+  /* Make the DO WHILE loop into a DO block by replacing the condition
+     with a true constant.  */
+  co->expr1 = gfc_get_logical_expr (gfc_default_integer_kind, &co->loc, true);
+
+  /* Hang the generated if statement into the loop body.  */
+
+  loopblock = co->block->next;
+  co->block->next = c_if1;
+  c_if1->next = loopblock;
+
+  return 0;
+}
+
+/* Code callback function for converting
+   if (a) then
+   ...
+   else if (b) then
+   end if
+
+   into
+   if (a) then
+   else
+     if (b) then
+     end if
+   end if
+
+   because otherwise common function elimination would place the BLOCKs
+   into the wrong place.  */
+
+static int
+convert_elseif (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
+		void *data ATTRIBUTE_UNUSED)
+{
+  gfc_code *co = *c;
+  gfc_code *c_if1, *c_if2, *else_stmt;
+
+  if (co->op != EXEC_IF)
+    return 0;
+
+  /* This loop starts out with the first ELSE statement.  */
+  else_stmt = co->block->block;
+
+  while (else_stmt != NULL)
+    {
+      gfc_code *next_else;
+
+      /* If there is no condition, we're done.  */
+      if (else_stmt->expr1 == NULL)
+	break;
+
+      next_else = else_stmt->block;
+
+      /* Generate the new IF statement.  */
+      c_if2 = XCNEW (gfc_code);
+      c_if2->op = EXEC_IF;
+      c_if2->expr1 = else_stmt->expr1;
+      c_if2->next = else_stmt->next;
+      c_if2->loc = else_stmt->loc;
+      c_if2->block = next_else;
+
+      /* ... plus the one to chain it to.  */
+      c_if1 = XCNEW (gfc_code);
+      c_if1->op = EXEC_IF;
+      c_if1->block = c_if2;
+      c_if1->loc = else_stmt->loc;
+
+      /* Insert the new IF after the ELSE.  */
+      else_stmt->expr1 = NULL;
+      else_stmt->next = c_if1;
+      else_stmt->block = NULL;
+
+      else_stmt = next_else;
+    }
+  /*  Don't walk subtrees.  */
+  return 0;
+}
+/* Optimize a namespace, including all contained namespaces.  */
+
+static void
+optimize_namespace (gfc_namespace *ns)
+{
+
+  current_ns = ns;
+  forall_level = 0;
+  iterator_level = 0;
+  in_omp_workshare = false;
+
+  gfc_code_walker (&ns->code, convert_do_while, dummy_expr_callback, NULL);
+  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);
+
+  /* BLOCKs are handled in the expression walker below.  */
+  for (ns = ns->contained; ns; ns = ns->sibling)
+    {
+      if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
+	optimize_namespace (ns);
+    }
+}
+
+static void
+optimize_reduction (gfc_namespace *ns)
+{
+  current_ns = ns;
+  gfc_code_walker (&ns->code, dummy_code_callback, callback_reduction, NULL);
+
+/* BLOCKs are handled in the expression walker below.  */
+  for (ns = ns->contained; ns; ns = ns->sibling)
+    {
+      if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
+	optimize_reduction (ns);
+    }
+}
+
+/* Replace code like
+   a = matmul(b,c) + d
+   with
+   a = matmul(b,c) ;   a = a + d
+   where the array function is not elemental and not allocatable
+   and does not depend on the left-hand side.
+*/
+
+static bool
+optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op)
+{
+  gfc_expr *e;
+
+  e = *rhs;
+  if (e->expr_type == EXPR_OP)
+    {
+      switch (e->value.op.op)
+	{
+	  /* Unary operators and exponentiation: Only look at a single
+	     operand.  */
+	case INTRINSIC_NOT:
+	case INTRINSIC_UPLUS:
+	case INTRINSIC_UMINUS:
+	case INTRINSIC_PARENTHESES:
+	case INTRINSIC_POWER:
+	  if (optimize_binop_array_assignment (c, &e->value.op.op1, seen_op))
+	    return true;
+	  break;
+
+	default:
+	  /* Binary operators.  */
+	  if (optimize_binop_array_assignment (c, &e->value.op.op1, true))
+	    return true;
+
+	  if (optimize_binop_array_assignment (c, &e->value.op.op2, true))
+	    return true;
+
+	  break;
+	}
+    }
+  else if (seen_op && e->expr_type == EXPR_FUNCTION && e->rank > 0
+	   && ! (e->value.function.esym 
+		 && (e->value.function.esym->attr.elemental 
+		     || e->value.function.esym->attr.allocatable
+		     || e->value.function.esym->ts.type != c->expr1->ts.type
+		     || e->value.function.esym->ts.kind != c->expr1->ts.kind))
+	   && ! (e->value.function.isym
+		 && (e->value.function.isym->elemental
+		     || e->ts.type != c->expr1->ts.type
+		     || e->ts.kind != c->expr1->ts.kind))
+	   && ! gfc_inline_intrinsic_function_p (e))
+    {
+
+      gfc_code *n;
+      gfc_expr *new_expr;
+
+      /* Insert a new assignment statement after the current one.  */
+      n = XCNEW (gfc_code);
+      n->op = EXEC_ASSIGN;
+      n->loc = c->loc;
+      n->next = c->next;
+      c->next = n;
+
+      n->expr1 = gfc_copy_expr (c->expr1);
+      n->expr2 = c->expr2;
+      new_expr = gfc_copy_expr (c->expr1);
+      c->expr2 = e;
+      *rhs = new_expr;
+      
+      return true;
+
+    }
+
+  /* Nothing to optimize.  */
+  return false;
+}
+
+/* Remove unneeded TRIMs at the end of expressions.  */
+
+static bool
+remove_trim (gfc_expr *rhs)
+{
+  bool ret;
+
+  ret = false;
+
+  /* Check for a // b // trim(c).  Looping is probably not
+     necessary because the parser usually generates
+     (// (// a b ) trim(c) ) , but better safe than sorry.  */
+
+  while (rhs->expr_type == EXPR_OP
+	 && rhs->value.op.op == INTRINSIC_CONCAT)
+    rhs = rhs->value.op.op2;
+
+  while (rhs->expr_type == EXPR_FUNCTION && rhs->value.function.isym
+	 && rhs->value.function.isym->id == GFC_ISYM_TRIM)
+    {
+      strip_function_call (rhs);
+      /* Recursive call to catch silly stuff like trim ( a // trim(b)).  */
+      remove_trim (rhs);
+      ret = true;
+    }
+
+  return ret;
+}
+
+/* Optimizations for an assignment.  */
+
+static void
+optimize_assignment (gfc_code * c)
+{
+  gfc_expr *lhs, *rhs;
+
+  lhs = c->expr1;
+  rhs = c->expr2;
+
+  if (lhs->ts.type == BT_CHARACTER && !lhs->ts.deferred)
+    {
+      /* Optimize  a = trim(b)  to  a = b.  */
+      remove_trim (rhs);
+
+      /* Replace a = '   ' by a = '' to optimize away a memcpy.  */
+      if (is_empty_string (rhs))
+	rhs->value.character.length = 0;
+    }
+
+  if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0)
+    optimize_binop_array_assignment (c, &rhs, false);
+}
+
+
+/* Remove an unneeded function call, modifying the expression.
+   This replaces the function call with the value of its
+   first argument.  The rest of the argument list is freed.  */
+
+static void
+strip_function_call (gfc_expr *e)
+{
+  gfc_expr *e1;
+  gfc_actual_arglist *a;
+
+  a = e->value.function.actual;
+
+  /* We should have at least one argument.  */
+  gcc_assert (a->expr != NULL);
+
+  e1 = a->expr;
+
+  /* Free the remaining arglist, if any.  */
+  if (a->next)
+    gfc_free_actual_arglist (a->next);
+
+  /* Graft the argument expression onto the original function.  */
+  *e = *e1;
+  free (e1);
+
+}
+
+/* Optimization of lexical comparison functions.  */
+
+static bool
+optimize_lexical_comparison (gfc_expr *e)
+{
+  if (e->expr_type != EXPR_FUNCTION || e->value.function.isym == NULL)
+    return false;
+
+  switch (e->value.function.isym->id)
+    {
+    case GFC_ISYM_LLE:
+      return optimize_comparison (e, INTRINSIC_LE);
+
+    case GFC_ISYM_LGE:
+      return optimize_comparison (e, INTRINSIC_GE);
+
+    case GFC_ISYM_LGT:
+      return optimize_comparison (e, INTRINSIC_GT);
+
+    case GFC_ISYM_LLT:
+      return optimize_comparison (e, INTRINSIC_LT);
+
+    default:
+      break;
+    }
+  return false;
+}
+
+/* Combine stuff like [a]>b into [a>b], for easier optimization later.  Do not
+   do CHARACTER because of possible pessimization involving character
+   lengths.  */
+
+static bool
+combine_array_constructor (gfc_expr *e)
+{
+
+  gfc_expr *op1, *op2;
+  gfc_expr *scalar;
+  gfc_expr *new_expr;
+  gfc_constructor *c, *new_c;
+  gfc_constructor_base oldbase, newbase;
+  bool scalar_first;
+
+  /* Array constructors have rank one.  */
+  if (e->rank != 1)
+    return false;
+
+  op1 = e->value.op.op1;
+  op2 = e->value.op.op2;
+
+  if (op1->expr_type == EXPR_ARRAY && op2->rank == 0)
+    scalar_first = false;
+  else if (op2->expr_type == EXPR_ARRAY && op1->rank == 0)
+    {
+      scalar_first = true;
+      op1 = e->value.op.op2;
+      op2 = e->value.op.op1;
+    }
+  else
+    return false;
+
+  if (op2->ts.type == BT_CHARACTER)
+    return false;
+
+  if (op2->expr_type == EXPR_CONSTANT)
+    scalar = gfc_copy_expr (op2);
+  else
+    scalar = create_var (gfc_copy_expr (op2));
+
+  oldbase = op1->value.constructor;
+  newbase = NULL;
+  e->expr_type = EXPR_ARRAY;
+
+  for (c = gfc_constructor_first (oldbase); c;
+       c = gfc_constructor_next (c))
+    {
+      new_expr = gfc_get_expr ();
+      new_expr->ts = e->ts;
+      new_expr->expr_type = EXPR_OP;
+      new_expr->rank = c->expr->rank;
+      new_expr->where = c->where;
+      new_expr->value.op.op = e->value.op.op;
+
+      if (scalar_first)
+	{
+	  new_expr->value.op.op1 = gfc_copy_expr (scalar);
+	  new_expr->value.op.op2 = gfc_copy_expr (c->expr);
+	}
+      else
+	{
+	  new_expr->value.op.op1 = gfc_copy_expr (c->expr);
+	  new_expr->value.op.op2 = gfc_copy_expr (scalar);
+	}
+
+      new_c = gfc_constructor_append_expr (&newbase, new_expr, &(e->where));
+      new_c->iterator = c->iterator;
+      c->iterator = NULL;
+    }
+
+  gfc_free_expr (op1);
+  gfc_free_expr (op2);
+  gfc_free_expr (scalar);
+
+  e->value.constructor = newbase;
+  return true;
+}
+
+/* Change (-1)**k into 1-ishift(iand(k,1),1) and
+ 2**k into ishift(1,k) */
+
+static bool
+optimize_power (gfc_expr *e)
+{
+  gfc_expr *op1, *op2;
+  gfc_expr *iand, *ishft;
+
+  if (e->ts.type != BT_INTEGER)
+    return false;
+
+  op1 = e->value.op.op1;
+
+  if (op1 == NULL || op1->expr_type != EXPR_CONSTANT)
+    return false;
+
+  if (mpz_cmp_si (op1->value.integer, -1L) == 0)
+    {
+      gfc_free_expr (op1);
+
+      op2 = e->value.op.op2;
+
+      if (op2 == NULL)
+	return false;
+
+      iand = gfc_build_intrinsic_call (current_ns, GFC_ISYM_IAND,
+				       "_internal_iand", e->where, 2, op2,
+				       gfc_get_int_expr (e->ts.kind,
+							 &e->where, 1));
+				   
+      ishft = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ISHFT,
+					"_internal_ishft", e->where, 2, iand,
+					gfc_get_int_expr (e->ts.kind,
+							  &e->where, 1));
+
+      e->value.op.op = INTRINSIC_MINUS;
+      e->value.op.op1 = gfc_get_int_expr (e->ts.kind, &e->where, 1);
+      e->value.op.op2 = ishft;
+      return true;
+    }
+  else if (mpz_cmp_si (op1->value.integer, 2L) == 0)
+    {
+      gfc_free_expr (op1);
+
+      op2 = e->value.op.op2;
+      if (op2 == NULL)
+	return false;
+
+      ishft = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ISHFT,
+					"_internal_ishft", e->where, 2,
+					gfc_get_int_expr (e->ts.kind,
+							  &e->where, 1),
+					op2);
+      *e = *ishft;
+      return true;
+    }
+
+  else if (mpz_cmp_si (op1->value.integer, 1L) == 0)
+    {
+      op2 = e->value.op.op2;
+      if (op2 == NULL)
+	return false;
+
+      gfc_free_expr (op1);
+      gfc_free_expr (op2);
+
+      e->expr_type = EXPR_CONSTANT;
+      e->value.op.op1 = NULL;
+      e->value.op.op2 = NULL;
+      mpz_init_set_si (e->value.integer, 1);
+      /* Typespec and location are still OK.  */
+      return true;
+    }
+
+  return false;
+}
+
+/* Recursive optimization of operators.  */
+
+static bool
+optimize_op (gfc_expr *e)
+{
+  bool changed;
+
+  gfc_intrinsic_op op = e->value.op.op;
+
+  changed = false;
+
+  /* Only use new-style comparisons.  */
+  switch(op)
+    {
+    case INTRINSIC_EQ_OS:
+      op = INTRINSIC_EQ;
+      break;
+
+    case INTRINSIC_GE_OS:
+      op = INTRINSIC_GE;
+      break;
+
+    case INTRINSIC_LE_OS:
+      op = INTRINSIC_LE;
+      break;
+
+    case INTRINSIC_NE_OS:
+      op = INTRINSIC_NE;
+      break;
+
+    case INTRINSIC_GT_OS:
+      op = INTRINSIC_GT;
+      break;
+
+    case INTRINSIC_LT_OS:
+      op = INTRINSIC_LT;
+      break;
+
+    default:
+      break;
+    }
+
+  switch (op)
+    {
+    case INTRINSIC_EQ:
+    case INTRINSIC_GE:
+    case INTRINSIC_LE:
+    case INTRINSIC_NE:
+    case INTRINSIC_GT:
+    case INTRINSIC_LT:
+      changed = optimize_comparison (e, op);
+
+      /* Fall through */
+      /* Look at array constructors.  */
+    case INTRINSIC_PLUS:
+    case INTRINSIC_MINUS:
+    case INTRINSIC_TIMES:
+    case INTRINSIC_DIVIDE:
+      return combine_array_constructor (e) || changed;
+
+    case INTRINSIC_POWER:
+      return optimize_power (e);
+      break;
+
+    default:
+      break;
+    }
+
+  return false;
+}
+
+
+/* Return true if a constant string contains only blanks.  */
+
+static bool
+is_empty_string (gfc_expr *e)
+{
+  int i;
+
+  if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
+    return false;
+
+  for (i=0; i < e->value.character.length; i++)
+    {
+      if (e->value.character.string[i] != ' ')
+	return false;
+    }
+
+  return true;
+}
+
+
+/* Insert a call to the intrinsic len_trim. Use a different name for
+   the symbol tree so we don't run into trouble when the user has
+   renamed len_trim for some reason.  */
+
+static gfc_expr*
+get_len_trim_call (gfc_expr *str, int kind)
+{
+  gfc_expr *fcn;
+  gfc_actual_arglist *actual_arglist, *next;
+
+  fcn = gfc_get_expr ();
+  fcn->expr_type = EXPR_FUNCTION;
+  fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM);
+  actual_arglist = gfc_get_actual_arglist ();
+  actual_arglist->expr = str;
+  next = gfc_get_actual_arglist ();
+  next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, kind);
+  actual_arglist->next = next;
+
+  fcn->value.function.actual = actual_arglist;
+  fcn->where = str->where;
+  fcn->ts.type = BT_INTEGER;
+  fcn->ts.kind = gfc_charlen_int_kind;
+
+  gfc_get_sym_tree ("__internal_len_trim", current_ns, &fcn->symtree, false);
+  fcn->symtree->n.sym->ts = fcn->ts;
+  fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+  fcn->symtree->n.sym->attr.function = 1;
+  fcn->symtree->n.sym->attr.elemental = 1;
+  fcn->symtree->n.sym->attr.referenced = 1;
+  fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
+  gfc_commit_symbol (fcn->symtree->n.sym);
+
+  return fcn;
+}
+
+/* Optimize expressions for equality.  */
+
+static bool
+optimize_comparison (gfc_expr *e, gfc_intrinsic_op op)
+{
+  gfc_expr *op1, *op2;
+  bool change;
+  int eq;
+  bool result;
+  gfc_actual_arglist *firstarg, *secondarg;
+
+  if (e->expr_type == EXPR_OP)
+    {
+      firstarg = NULL;
+      secondarg = NULL;
+      op1 = e->value.op.op1;
+      op2 = e->value.op.op2;
+    }
+  else if (e->expr_type == EXPR_FUNCTION)
+    {
+      /* One of the lexical comparison functions.  */
+      firstarg = e->value.function.actual;
+      secondarg = firstarg->next;
+      op1 = firstarg->expr;
+      op2 = secondarg->expr;
+    }
+  else
+    gcc_unreachable ();
+
+  /* Strip off unneeded TRIM calls from string comparisons.  */
+
+  change = remove_trim (op1);
+
+  if (remove_trim (op2))
+    change = true;
+
+  /* An expression of type EXPR_CONSTANT is only valid for scalars.  */
+  /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
+     handles them well). However, there are also cases that need a non-scalar
+     argument. For example the any intrinsic. See PR 45380.  */
+  if (e->rank > 0)
+    return change;
+
+  /* Replace a == '' with len_trim(a) == 0 and a /= '' with
+     len_trim(a) != 0 */
+  if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
+      && (op == INTRINSIC_EQ || op == INTRINSIC_NE))
+    {
+      bool empty_op1, empty_op2;
+      empty_op1 = is_empty_string (op1);
+      empty_op2 = is_empty_string (op2);
+
+      if (empty_op1 || empty_op2)
+	{
+	  gfc_expr *fcn;
+	  gfc_expr *zero;
+	  gfc_expr *str;
+
+	  /* This can only happen when an error for comparing
+	     characters of different kinds has already been issued.  */
+	  if (empty_op1 && empty_op2)
+	    return false;
+
+	  zero = gfc_get_int_expr (gfc_charlen_int_kind, &e->where, 0);
+	  str = empty_op1 ? op2 : op1;
+
+	  fcn = get_len_trim_call (str, gfc_charlen_int_kind);
+
+
+	  if (empty_op1)
+	    gfc_free_expr (op1);
+	  else
+	    gfc_free_expr (op2);
+
+	  op1 = fcn;
+	  op2 = zero;
+	  e->value.op.op1 = fcn;
+	  e->value.op.op2 = zero;
+	}
+    }
+
+
+  /* Don't compare REAL or COMPLEX expressions when honoring NaNs.  */
+
+  if (flag_finite_math_only
+      || (op1->ts.type != BT_REAL && op2->ts.type != BT_REAL
+	  && op1->ts.type != BT_COMPLEX && op2->ts.type != BT_COMPLEX))
+    {
+      eq = gfc_dep_compare_expr (op1, op2);
+      if (eq <= -2)
+	{
+	  /* Replace A // B < A // C with B < C, and A // B < C // B
+	     with A < C.  */
+	  if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
+	      && op1->expr_type == EXPR_OP
+	      && op1->value.op.op == INTRINSIC_CONCAT
+	      && op2->expr_type == EXPR_OP
+	      && op2->value.op.op == INTRINSIC_CONCAT)
+	    {
+	      gfc_expr *op1_left = op1->value.op.op1;
+	      gfc_expr *op2_left = op2->value.op.op1;
+	      gfc_expr *op1_right = op1->value.op.op2;
+	      gfc_expr *op2_right = op2->value.op.op2;
+
+	      if (gfc_dep_compare_expr (op1_left, op2_left) == 0)
+		{
+		  /* Watch out for 'A ' // x vs. 'A' // x.  */
+
+		  if (op1_left->expr_type == EXPR_CONSTANT
+			&& op2_left->expr_type == EXPR_CONSTANT
+			&& op1_left->value.character.length
+			   != op2_left->value.character.length)
+		    return change;
+		  else
+		    {
+		      free (op1_left);
+		      free (op2_left);
+		      if (firstarg)
+			{
+			  firstarg->expr = op1_right;
+			  secondarg->expr = op2_right;
+			}
+		      else
+			{
+			  e->value.op.op1 = op1_right;
+			  e->value.op.op2 = op2_right;
+			}
+		      optimize_comparison (e, op);
+		      return true;
+		    }
+		}
+	      if (gfc_dep_compare_expr (op1_right, op2_right) == 0)
+		{
+		  free (op1_right);
+		  free (op2_right);
+		  if (firstarg)
+		    {
+		      firstarg->expr = op1_left;
+		      secondarg->expr = op2_left;
+		    }
+		  else
+		    {
+		      e->value.op.op1 = op1_left;
+		      e->value.op.op2 = op2_left;
+		    }
+
+		  optimize_comparison (e, op);
+		  return true;
+		}
+	    }
+	}
+      else
+	{
+	  /* eq can only be -1, 0 or 1 at this point.  */
+	  switch (op)
+	    {
+	    case INTRINSIC_EQ:
+	      result = eq == 0;
+	      break;
+	      
+	    case INTRINSIC_GE:
+	      result = eq >= 0;
+	      break;
+
+	    case INTRINSIC_LE:
+	      result = eq <= 0;
+	      break;
+
+	    case INTRINSIC_NE:
+	      result = eq != 0;
+	      break;
+
+	    case INTRINSIC_GT:
+	      result = eq > 0;
+	      break;
+
+	    case INTRINSIC_LT:
+	      result = eq < 0;
+	      break;
+	      
+	    default:
+	      gfc_internal_error ("illegal OP in optimize_comparison");
+	      break;
+	    }
+
+	  /* Replace the expression by a constant expression.  The typespec
+	     and where remains the way it is.  */
+	  free (op1);
+	  free (op2);
+	  e->expr_type = EXPR_CONSTANT;
+	  e->value.logical = result;
+	  return true;
+	}
+    }
+
+  return change;
+}
+
+/* Optimize a trim function by replacing it with an equivalent substring
+   involving a call to len_trim.  This only works for expressions where
+   variables are trimmed.  Return true if anything was modified.  */
+
+static bool
+optimize_trim (gfc_expr *e)
+{
+  gfc_expr *a;
+  gfc_ref *ref;
+  gfc_expr *fcn;
+  gfc_ref **rr = NULL;
+
+  /* Don't do this optimization within an argument list, because
+     otherwise aliasing issues may occur.  */
+
+  if (count_arglist != 1)
+    return false;
+
+  if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_FUNCTION
+      || e->value.function.isym == NULL
+      || e->value.function.isym->id != GFC_ISYM_TRIM)
+    return false;
+
+  a = e->value.function.actual->expr;
+
+  if (a->expr_type != EXPR_VARIABLE)
+    return false;
+
+  /* Follow all references to find the correct place to put the newly
+     created reference.  FIXME:  Also handle substring references and
+     array references.  Array references cause strange regressions at
+     the moment.  */
+
+  if (a->ref)
+    {
+      for (rr = &(a->ref); *rr; rr = &((*rr)->next))
+	{
+	  if ((*rr)->type == REF_SUBSTRING || (*rr)->type == REF_ARRAY)
+	    return false;
+	}
+    }
+
+  strip_function_call (e);
+
+  if (e->ref == NULL)
+    rr = &(e->ref);
+
+  /* Create the reference.  */
+
+  ref = gfc_get_ref ();
+  ref->type = REF_SUBSTRING;
+
+  /* Set the start of the reference.  */
+
+  ref->u.ss.start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+
+  /* Build the function call to len_trim(x, gfc_default_integer_kind).  */
+
+  fcn = get_len_trim_call (gfc_copy_expr (e), gfc_default_integer_kind);
+
+  /* Set the end of the reference to the call to len_trim.  */
+
+  ref->u.ss.end = fcn;
+  gcc_assert (rr != NULL && *rr == NULL);
+  *rr = ref;
+  return true;
+}
+
+/* Optimize minloc(b), where b is rank 1 array, into
+   (/ minloc(b, dim=1) /), and similarly for maxloc,
+   as the latter forms are expanded inline.  */
+
+static void
+optimize_minmaxloc (gfc_expr **e)
+{
+  gfc_expr *fn = *e;
+  gfc_actual_arglist *a;
+  char *name, *p;
+
+  if (fn->rank != 1
+      || fn->value.function.actual == NULL
+      || fn->value.function.actual->expr == NULL
+      || fn->value.function.actual->expr->rank != 1)
+    return;
+
+  *e = gfc_get_array_expr (fn->ts.type, fn->ts.kind, &fn->where);
+  (*e)->shape = fn->shape;
+  fn->rank = 0;
+  fn->shape = NULL;
+  gfc_constructor_append_expr (&(*e)->value.constructor, fn, &fn->where);
+
+  name = XALLOCAVEC (char, strlen (fn->value.function.name) + 1);
+  strcpy (name, fn->value.function.name);
+  p = strstr (name, "loc0");
+  p[3] = '1';
+  fn->value.function.name = gfc_get_string (name);
+  if (fn->value.function.actual->next)
+    {
+      a = fn->value.function.actual->next;
+      gcc_assert (a->expr == NULL);
+    }
+  else
+    {
+      a = gfc_get_actual_arglist ();
+      fn->value.function.actual->next = a;
+    }
+  a->expr = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+				   &fn->where);
+  mpz_set_ui (a->expr->value.integer, 1);
+}
+
+/* Callback function for code checking that we do not pass a DO variable to an
+   INTENT(OUT) or INTENT(INOUT) dummy variable.  */
+
+static int
+doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
+	 void *data ATTRIBUTE_UNUSED)
+{
+  gfc_code *co;
+  int i;
+  gfc_formal_arglist *f;
+  gfc_actual_arglist *a;
+
+  co = *c;
+
+  switch (co->op)
+    {
+    case EXEC_DO:
+
+      /* Grow the temporary storage if necessary.  */
+      if (doloop_level >= doloop_size)
+	{
+	  doloop_size = 2 * doloop_size;
+	  doloop_list = XRESIZEVEC (gfc_code *, doloop_list, doloop_size);
+	}
+
+      /* Mark the DO loop variable if there is one.  */
+      if (co->ext.iterator && co->ext.iterator->var)
+	doloop_list[doloop_level] = co;
+      else
+	doloop_list[doloop_level] = NULL;
+      break;
+
+    case EXEC_CALL:
+
+      if (co->resolved_sym == NULL)
+	break;
+
+      f = gfc_sym_get_dummy_args (co->resolved_sym);
+
+      /* Withot a formal arglist, there is only unknown INTENT,
+	 which we don't check for.  */
+      if (f == NULL)
+	break;
+
+      a = co->ext.actual;
+
+      while (a && f)
+	{
+	  for (i=0; i<doloop_level; i++)
+	    {
+	      gfc_symbol *do_sym;
+	      
+	      if (doloop_list[i] == NULL)
+		break;
+
+	      do_sym = doloop_list[i]->ext.iterator->var->symtree->n.sym;
+	      
+	      if (a->expr && a->expr->symtree
+		  && a->expr->symtree->n.sym == do_sym)
+		{
+		  if (f->sym->attr.intent == INTENT_OUT)
+		    gfc_error_now("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);
+		  else if (f->sym->attr.intent == INTENT_INOUT)
+		    gfc_error_now("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);
+		}
+	    }
+	  a = a->next;
+	  f = f->next;
+	}
+      break;
+
+    default:
+      break;
+    }
+  return 0;
+}
+
+/* Callback function for functions checking that we do not pass a DO variable
+   to an INTENT(OUT) or INTENT(INOUT) dummy variable.  */
+
+static int
+do_function (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+	     void *data ATTRIBUTE_UNUSED)
+{
+  gfc_formal_arglist *f;
+  gfc_actual_arglist *a;
+  gfc_expr *expr;
+  int i;
+
+  expr = *e;
+  if (expr->expr_type != EXPR_FUNCTION)
+    return 0;
+
+  /* Intrinsic functions don't modify their arguments.  */
+
+  if (expr->value.function.isym)
+    return 0;
+
+  f = gfc_sym_get_dummy_args (expr->symtree->n.sym);
+
+  /* Without a formal arglist, there is only unknown INTENT,
+     which we don't check for.  */
+  if (f == NULL)
+    return 0;
+
+  a = expr->value.function.actual;
+
+  while (a && f)
+    {
+      for (i=0; i<doloop_level; i++)
+	{
+	  gfc_symbol *do_sym;
+	 
+    
+	  if (doloop_list[i] == NULL)
+	    break;
+
+	  do_sym = doloop_list[i]->ext.iterator->var->symtree->n.sym;
+	  
+	  if (a->expr && a->expr->symtree
+	      && a->expr->symtree->n.sym == do_sym)
+	    {
+	      if (f->sym->attr.intent == INTENT_OUT)
+		gfc_error_now("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);
+	      else if (f->sym->attr.intent == INTENT_INOUT)
+		gfc_error_now("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);
+	    }
+	}
+      a = a->next;
+      f = f->next;
+    }
+
+  return 0;
+}
+
+static void
+doloop_warn (gfc_namespace *ns)
+{
+  gfc_code_walker (&ns->code, doloop_code, do_function, NULL);
+}
+
+
+#define WALK_SUBEXPR(NODE) \
+  do							\
+    {							\
+      result = gfc_expr_walker (&(NODE), exprfn, data);	\
+      if (result)					\
+	return result;					\
+    }							\
+  while (0)
+#define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
+
+/* Walk expression *E, calling EXPRFN on each expression in it.  */
+
+int
+gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data)
+{
+  while (*e)
+    {
+      int walk_subtrees = 1;
+      gfc_actual_arglist *a;
+      gfc_ref *r;
+      gfc_constructor *c;
+
+      int result = exprfn (e, &walk_subtrees, data);
+      if (result)
+	return result;
+      if (walk_subtrees)
+	switch ((*e)->expr_type)
+	  {
+	  case EXPR_OP:
+	    WALK_SUBEXPR ((*e)->value.op.op1);
+	    WALK_SUBEXPR_TAIL ((*e)->value.op.op2);
+	    break;
+	  case EXPR_FUNCTION:
+	    for (a = (*e)->value.function.actual; a; a = a->next)
+	      WALK_SUBEXPR (a->expr);
+	    break;
+	  case EXPR_COMPCALL:
+	  case EXPR_PPC:
+	    WALK_SUBEXPR ((*e)->value.compcall.base_object);
+	    for (a = (*e)->value.compcall.actual; a; a = a->next)
+	      WALK_SUBEXPR (a->expr);
+	    break;
+
+	  case EXPR_STRUCTURE:
+	  case EXPR_ARRAY:
+	    for (c = gfc_constructor_first ((*e)->value.constructor); c;
+		 c = gfc_constructor_next (c))
+	      {
+		if (c->iterator == NULL)
+		  WALK_SUBEXPR (c->expr);
+		else
+		  {
+		    iterator_level ++;
+		    WALK_SUBEXPR (c->expr);
+		    iterator_level --;
+		    WALK_SUBEXPR (c->iterator->var);
+		    WALK_SUBEXPR (c->iterator->start);
+		    WALK_SUBEXPR (c->iterator->end);
+		    WALK_SUBEXPR (c->iterator->step);
+		  }
+	      }
+
+	    if ((*e)->expr_type != EXPR_ARRAY)
+	      break;
+
+	    /* Fall through to the variable case in order to walk the
+	       reference.  */
+
+	  case EXPR_SUBSTRING:
+	  case EXPR_VARIABLE:
+	    for (r = (*e)->ref; r; r = r->next)
+	      {
+		gfc_array_ref *ar;
+		int i;
+
+		switch (r->type)
+		  {
+		  case REF_ARRAY:
+		    ar = &r->u.ar;
+		    if (ar->type == AR_SECTION || ar->type == AR_ELEMENT)
+		      {
+			for (i=0; i< ar->dimen; i++)
+			  {
+			    WALK_SUBEXPR (ar->start[i]);
+			    WALK_SUBEXPR (ar->end[i]);
+			    WALK_SUBEXPR (ar->stride[i]);
+			  }
+		      }
+
+		    break;
+
+		  case REF_SUBSTRING:
+		    WALK_SUBEXPR (r->u.ss.start);
+		    WALK_SUBEXPR (r->u.ss.end);
+		    break;
+
+		  case REF_COMPONENT:
+		    break;
+		  }
+	      }
+
+	  default:
+	    break;
+	  }
+      return 0;
+    }
+  return 0;
+}
+
+#define WALK_SUBCODE(NODE) \
+  do								\
+    {								\
+      result = gfc_code_walker (&(NODE), codefn, exprfn, data);	\
+      if (result)						\
+	return result;						\
+    }								\
+  while (0)
+
+/* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
+   on each expression in it.  If any of the hooks returns non-zero, that
+   value is immediately returned.  If the hook sets *WALK_SUBTREES to 0,
+   no subcodes or subexpressions are traversed.  */
+
+int
+gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
+		 void *data)
+{
+  for (; *c; c = &(*c)->next)
+    {
+      int walk_subtrees = 1;
+      int result = codefn (c, &walk_subtrees, data);
+      if (result)
+	return result;
+
+      if (walk_subtrees)
+	{
+	  gfc_code *b;
+	  gfc_actual_arglist *a;
+	  gfc_code *co;
+	  gfc_association_list *alist;
+	  bool saved_in_omp_workshare;
+
+	  /* There might be statement insertions before the current code,
+	     which must not affect the expression walker.  */
+
+	  co = *c;
+	  saved_in_omp_workshare = in_omp_workshare;
+
+	  switch (co->op)
+	    {
+
+	    case EXEC_BLOCK:
+	      WALK_SUBCODE (co->ext.block.ns->code);
+	      for (alist = co->ext.block.assoc; alist; alist = alist->next)
+		WALK_SUBEXPR (alist->target);
+	      break;
+
+	    case EXEC_DO:
+	      doloop_level ++;
+	      WALK_SUBEXPR (co->ext.iterator->var);
+	      WALK_SUBEXPR (co->ext.iterator->start);
+	      WALK_SUBEXPR (co->ext.iterator->end);
+	      WALK_SUBEXPR (co->ext.iterator->step);
+	      break;
+
+	    case EXEC_CALL:
+	    case EXEC_ASSIGN_CALL:
+	      for (a = co->ext.actual; a; a = a->next)
+		WALK_SUBEXPR (a->expr);
+	      break;
+
+	    case EXEC_CALL_PPC:
+	      WALK_SUBEXPR (co->expr1);
+	      for (a = co->ext.actual; a; a = a->next)
+		WALK_SUBEXPR (a->expr);
+	      break;
+
+	    case EXEC_SELECT:
+	      WALK_SUBEXPR (co->expr1);
+	      for (b = co->block; b; b = b->block)
+		{
+		  gfc_case *cp;
+		  for (cp = b->ext.block.case_list; cp; cp = cp->next)
+		    {
+		      WALK_SUBEXPR (cp->low);
+		      WALK_SUBEXPR (cp->high);
+		    }
+		  WALK_SUBCODE (b->next);
+		}
+	      continue;
+
+	    case EXEC_ALLOCATE:
+	    case EXEC_DEALLOCATE:
+	      {
+		gfc_alloc *a;
+		for (a = co->ext.alloc.list; a; a = a->next)
+		  WALK_SUBEXPR (a->expr);
+		break;
+	      }
+
+	    case EXEC_FORALL:
+	    case EXEC_DO_CONCURRENT:
+	      {
+		gfc_forall_iterator *fa;
+		for (fa = co->ext.forall_iterator; fa; fa = fa->next)
+		  {
+		    WALK_SUBEXPR (fa->var);
+		    WALK_SUBEXPR (fa->start);
+		    WALK_SUBEXPR (fa->end);
+		    WALK_SUBEXPR (fa->stride);
+		  }
+		if (co->op == EXEC_FORALL)
+		  forall_level ++;
+		break;
+	      }
+
+	    case EXEC_OPEN:
+	      WALK_SUBEXPR (co->ext.open->unit);
+	      WALK_SUBEXPR (co->ext.open->file);
+	      WALK_SUBEXPR (co->ext.open->status);
+	      WALK_SUBEXPR (co->ext.open->access);
+	      WALK_SUBEXPR (co->ext.open->form);
+	      WALK_SUBEXPR (co->ext.open->recl);
+	      WALK_SUBEXPR (co->ext.open->blank);
+	      WALK_SUBEXPR (co->ext.open->position);
+	      WALK_SUBEXPR (co->ext.open->action);
+	      WALK_SUBEXPR (co->ext.open->delim);
+	      WALK_SUBEXPR (co->ext.open->pad);
+	      WALK_SUBEXPR (co->ext.open->iostat);
+	      WALK_SUBEXPR (co->ext.open->iomsg);
+	      WALK_SUBEXPR (co->ext.open->convert);
+	      WALK_SUBEXPR (co->ext.open->decimal);
+	      WALK_SUBEXPR (co->ext.open->encoding);
+	      WALK_SUBEXPR (co->ext.open->round);
+	      WALK_SUBEXPR (co->ext.open->sign);
+	      WALK_SUBEXPR (co->ext.open->asynchronous);
+	      WALK_SUBEXPR (co->ext.open->id);
+	      WALK_SUBEXPR (co->ext.open->newunit);
+	      break;
+
+	    case EXEC_CLOSE:
+	      WALK_SUBEXPR (co->ext.close->unit);
+	      WALK_SUBEXPR (co->ext.close->status);
+	      WALK_SUBEXPR (co->ext.close->iostat);
+	      WALK_SUBEXPR (co->ext.close->iomsg);
+	      break;
+
+	    case EXEC_BACKSPACE:
+	    case EXEC_ENDFILE:
+	    case EXEC_REWIND:
+	    case EXEC_FLUSH:
+	      WALK_SUBEXPR (co->ext.filepos->unit);
+	      WALK_SUBEXPR (co->ext.filepos->iostat);
+	      WALK_SUBEXPR (co->ext.filepos->iomsg);
+	      break;
+
+	    case EXEC_INQUIRE:
+	      WALK_SUBEXPR (co->ext.inquire->unit);
+	      WALK_SUBEXPR (co->ext.inquire->file);
+	      WALK_SUBEXPR (co->ext.inquire->iomsg);
+	      WALK_SUBEXPR (co->ext.inquire->iostat);
+	      WALK_SUBEXPR (co->ext.inquire->exist);
+	      WALK_SUBEXPR (co->ext.inquire->opened);
+	      WALK_SUBEXPR (co->ext.inquire->number);
+	      WALK_SUBEXPR (co->ext.inquire->named);
+	      WALK_SUBEXPR (co->ext.inquire->name);
+	      WALK_SUBEXPR (co->ext.inquire->access);
+	      WALK_SUBEXPR (co->ext.inquire->sequential);
+	      WALK_SUBEXPR (co->ext.inquire->direct);
+	      WALK_SUBEXPR (co->ext.inquire->form);
+	      WALK_SUBEXPR (co->ext.inquire->formatted);
+	      WALK_SUBEXPR (co->ext.inquire->unformatted);
+	      WALK_SUBEXPR (co->ext.inquire->recl);
+	      WALK_SUBEXPR (co->ext.inquire->nextrec);
+	      WALK_SUBEXPR (co->ext.inquire->blank);
+	      WALK_SUBEXPR (co->ext.inquire->position);
+	      WALK_SUBEXPR (co->ext.inquire->action);
+	      WALK_SUBEXPR (co->ext.inquire->read);
+	      WALK_SUBEXPR (co->ext.inquire->write);
+	      WALK_SUBEXPR (co->ext.inquire->readwrite);
+	      WALK_SUBEXPR (co->ext.inquire->delim);
+	      WALK_SUBEXPR (co->ext.inquire->encoding);
+	      WALK_SUBEXPR (co->ext.inquire->pad);
+	      WALK_SUBEXPR (co->ext.inquire->iolength);
+	      WALK_SUBEXPR (co->ext.inquire->convert);
+	      WALK_SUBEXPR (co->ext.inquire->strm_pos);
+	      WALK_SUBEXPR (co->ext.inquire->asynchronous);
+	      WALK_SUBEXPR (co->ext.inquire->decimal);
+	      WALK_SUBEXPR (co->ext.inquire->pending);
+	      WALK_SUBEXPR (co->ext.inquire->id);
+	      WALK_SUBEXPR (co->ext.inquire->sign);
+	      WALK_SUBEXPR (co->ext.inquire->size);
+	      WALK_SUBEXPR (co->ext.inquire->round);
+	      break;
+
+	    case EXEC_WAIT:
+	      WALK_SUBEXPR (co->ext.wait->unit);
+	      WALK_SUBEXPR (co->ext.wait->iostat);
+	      WALK_SUBEXPR (co->ext.wait->iomsg);
+	      WALK_SUBEXPR (co->ext.wait->id);
+	      break;
+
+	    case EXEC_READ:
+	    case EXEC_WRITE:
+	      WALK_SUBEXPR (co->ext.dt->io_unit);
+	      WALK_SUBEXPR (co->ext.dt->format_expr);
+	      WALK_SUBEXPR (co->ext.dt->rec);
+	      WALK_SUBEXPR (co->ext.dt->advance);
+	      WALK_SUBEXPR (co->ext.dt->iostat);
+	      WALK_SUBEXPR (co->ext.dt->size);
+	      WALK_SUBEXPR (co->ext.dt->iomsg);
+	      WALK_SUBEXPR (co->ext.dt->id);
+	      WALK_SUBEXPR (co->ext.dt->pos);
+	      WALK_SUBEXPR (co->ext.dt->asynchronous);
+	      WALK_SUBEXPR (co->ext.dt->blank);
+	      WALK_SUBEXPR (co->ext.dt->decimal);
+	      WALK_SUBEXPR (co->ext.dt->delim);
+	      WALK_SUBEXPR (co->ext.dt->pad);
+	      WALK_SUBEXPR (co->ext.dt->round);
+	      WALK_SUBEXPR (co->ext.dt->sign);
+	      WALK_SUBEXPR (co->ext.dt->extra_comma);
+	      break;
+
+	    case EXEC_OMP_PARALLEL:
+	    case EXEC_OMP_PARALLEL_DO:
+	    case EXEC_OMP_PARALLEL_SECTIONS:
+
+	      in_omp_workshare = false;
+
+	      /* This goto serves as a shortcut to avoid code
+		 duplication or a larger if or switch statement.  */
+	      goto check_omp_clauses;
+	      
+	    case EXEC_OMP_WORKSHARE:
+	    case EXEC_OMP_PARALLEL_WORKSHARE:
+
+	      in_omp_workshare = true;
+
+	      /* Fall through  */
+	      
+	    case EXEC_OMP_DO:
+	    case EXEC_OMP_SECTIONS:
+	    case EXEC_OMP_SINGLE:
+	    case EXEC_OMP_END_SINGLE:
+	    case EXEC_OMP_TASK:
+
+	      /* Come to this label only from the
+		 EXEC_OMP_PARALLEL_* cases above.  */
+
+	    check_omp_clauses:
+
+	      if (co->ext.omp_clauses)
+		{
+		  WALK_SUBEXPR (co->ext.omp_clauses->if_expr);
+		  WALK_SUBEXPR (co->ext.omp_clauses->final_expr);
+		  WALK_SUBEXPR (co->ext.omp_clauses->num_threads);
+		  WALK_SUBEXPR (co->ext.omp_clauses->chunk_size);
+		}
+	      break;
+	    default:
+	      break;
+	    }
+
+	  WALK_SUBEXPR (co->expr1);
+	  WALK_SUBEXPR (co->expr2);
+	  WALK_SUBEXPR (co->expr3);
+	  WALK_SUBEXPR (co->expr4);
+	  for (b = co->block; b; b = b->block)
+	    {
+	      WALK_SUBEXPR (b->expr1);
+	      WALK_SUBEXPR (b->expr2);
+	      WALK_SUBCODE (b->next);
+	    }
+
+	  if (co->op == EXEC_FORALL)
+	    forall_level --;
+
+	  if (co->op == EXEC_DO)
+	    doloop_level --;
+
+	  in_omp_workshare = saved_in_omp_workshare;
+	}
+    }
+  return 0;
+}
diff --git a/gcc-4.9/gcc/fortran/gfc-internals.texi b/gcc-4.9/gcc/fortran/gfc-internals.texi
new file mode 100644
index 000000000..44516a039
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/gfc-internals.texi
@@ -0,0 +1,825 @@
+\input texinfo  @c -*-texinfo-*-
+@c %**start of header
+@setfilename gfc-internals.info
+@set copyrights-gfortran 2007-2014
+
+@include gcc-common.texi
+
+@synindex tp cp
+
+@settitle GNU Fortran Compiler Internals
+
+@c %**end of header
+
+@c Use with @@smallbook.
+
+@c %** start of document
+
+@c Cause even numbered pages to be printed on the left hand side of
+@c the page and odd numbered pages to be printed on the right hand
+@c side of the page.  Using this, you can print on both sides of a
+@c sheet of paper and have the text on the same part of the sheet.
+
+@c The text on right hand pages is pushed towards the right hand
+@c margin and the text on left hand pages is pushed toward the left
+@c hand margin.
+@c (To provide the reverse effect, set bindingoffset to -0.75in.)
+
+@c @tex
+@c \global\bindingoffset=0.75in
+@c \global\normaloffset =0.75in
+@c @end tex
+
+@copying
+Copyright @copyright{} @value{copyrights-gfortran} Free Software Foundation, Inc.
+
+Permission is granted to copy, distribute and/or modify this document
+under the terms of the GNU Free Documentation License, Version 1.3 or
+any later version published by the Free Software Foundation; with the
+Invariant Sections being ``Funding Free Software'', the Front-Cover
+Texts being (a) (see below), and with the Back-Cover Texts being (b)
+(see below).  A copy of the license is included in the section entitled
+``GNU Free Documentation License''.
+
+(a) The FSF's Front-Cover Text is:
+
+     A GNU Manual
+
+(b) The FSF's Back-Cover Text is:
+
+     You have freedom to copy and modify this GNU Manual, like GNU
+     software.  Copies published by the Free Software Foundation raise
+     funds for GNU development.
+@end copying
+
+@ifinfo
+@dircategory Software development
+@direntry
+* gfortran: (gfortran).                  The GNU Fortran Compiler.
+@end direntry
+This file documents the internals of the GNU Fortran
+compiler, (@command{gfortran}).
+
+Published by the Free Software Foundation
+51 Franklin Street, Fifth Floor
+Boston, MA 02110-1301 USA
+
+@insertcopying
+@end ifinfo
+
+
+@setchapternewpage odd
+@titlepage
+@title GNU Fortran Internals
+@versionsubtitle
+@author The @t{gfortran} team
+@page
+@vskip 0pt plus 1filll
+Published by the Free Software Foundation@*
+51 Franklin Street, Fifth Floor@*
+Boston, MA 02110-1301, USA@*
+@c Last printed ??ber, 19??.@*
+@c Printed copies are available for $? each.@*
+@c ISBN ???
+@sp 1
+@insertcopying
+@end titlepage
+
+@summarycontents
+@contents
+
+@page
+
+@c ---------------------------------------------------------------------
+@c TexInfo table of contents.
+@c ---------------------------------------------------------------------
+
+@ifnottex
+@node Top
+@top Introduction
+@cindex Introduction
+
+This manual documents the internals of @command{gfortran}, 
+the GNU Fortran compiler.
+
+@ifset DEVELOPMENT
+@emph{Warning:} This document, and the compiler it describes, are still
+under development.  While efforts are made to keep it up-to-date, it might
+not accurately reflect the status of the most recent GNU Fortran compiler.
+@end ifset
+
+@comment
+@comment  When you add a new menu item, please keep the right hand
+@comment  aligned to the same column.  Do not use tabs.  This provides
+@comment  better formatting.
+@comment
+@menu
+* Introduction::           About this manual.
+* User Interface::         Code that Interacts with the User.
+* Frontend Data Structures::
+                           Data structures used by the frontend
+* Object Orientation::     Internals of Fortran 2003 OOP features.
+* LibGFortran::            The LibGFortran Runtime Library.
+* GNU Free Documentation License::
+                           How you can copy and share this manual.
+* Index::                  Index of this documentation.
+@end menu
+@end ifnottex
+
+@c ---------------------------------------------------------------------
+@c Introduction
+@c ---------------------------------------------------------------------
+
+@node Introduction
+@chapter Introduction
+
+@c The following duplicates the text on the TexInfo table of contents.
+@iftex
+This manual documents the internals of @command{gfortran}, the GNU Fortran
+compiler.
+
+@ifset DEVELOPMENT
+@emph{Warning:} This document, and the compiler it describes, are still
+under development.  While efforts are made to keep it up-to-date, it
+might not accurately reflect the status of the most recent GNU Fortran
+compiler.
+@end ifset
+@end iftex
+
+At present, this manual is very much a work in progress, containing 
+miscellaneous notes about the internals of the compiler.  It is hoped
+that at some point in the future it will become a reasonably complete
+guide; in the interim, GNU Fortran developers are strongly encouraged to
+contribute to it as a way of keeping notes while working on the 
+compiler.
+
+
+@c ---------------------------------------------------------------------
+@c Code that Interacts with the User
+@c ---------------------------------------------------------------------
+
+@node User Interface
+@chapter Code that Interacts with the User
+
+@menu
+* Command-Line Options::    Command-Line Options.
+* Error Handling::          Error Handling.
+@end menu
+
+
+@c ---------------------------------------------------------------------
+@c Command-Line Options
+@c ---------------------------------------------------------------------
+
+@node Command-Line Options
+@section Command-Line Options
+
+Command-line options for @command{gfortran} involve four interrelated
+pieces within the Fortran compiler code.
+
+The relevant command-line flag is defined in @file{lang.opt}, according
+to the documentation in @ref{Options,, Options, gccint, GNU Compiler
+Collection Internals}.  This is then processed by the overall GCC
+machinery to create the code that enables @command{gfortran} and
+@command{gcc} to recognize the option in the command-line arguments and
+call the relevant handler function.
+
+This generated code calls the @code{gfc_handle_option} code in
+@file{options.c} with an enumerator variable indicating which option is
+to be processed, and the relevant integer or string values associated
+with that option flag.  Typically, @code{gfc_handle_option} uses these
+arguments to set global flags which record the option states.
+
+The global flags that record the option states are stored in the
+@code{gfc_option_t} struct, which is defined in @file{gfortran.h}.
+Before the options are processed, initial values for these flags are set
+in @code{gfc_init_option} in @file{options.c}; these become the default
+values for the options.
+
+
+
+@c ---------------------------------------------------------------------
+@c Error Handling
+@c ---------------------------------------------------------------------
+
+@node Error Handling
+@section Error Handling
+
+The GNU Fortran compiler's parser operates by testing each piece of
+source code against a variety of matchers.  In some cases, if these
+matchers do not match the source code, they will store an error message
+in a buffer.  If the parser later finds a matcher that does correctly
+match the source code, then the buffered error is discarded.  However,
+if the parser cannot find a match, then the buffered error message is
+reported to the user.  This enables the compiler to provide more
+meaningful error messages even in the many cases where (erroneous)
+Fortran syntax is ambiguous due to things like the absence of reserved
+keywords.
+
+As an example of how this works, consider the following line:
+@smallexample
+IF = 3
+@end smallexample
+Hypothetically, this may get passed to the matcher for an @code{IF}
+statement.  Since this could plausibly be an erroneous @code{IF}
+statement, the matcher will buffer an error message reporting the
+absence of an expected @samp{(} following an @code{IF}.  Since no
+matchers reported an error-free match, however, the parser will also try
+matching this against a variable assignment.  When @code{IF} is a valid
+variable, this will be parsed as an assignment statement, and the error
+discarded.  However, when @code{IF} is not a valid variable, this
+buffered error message will be reported to the user.
+
+The error handling code is implemented in @file{error.c}.  Errors are
+normally entered into the buffer with the @code{gfc_error} function.
+Warnings go through a similar buffering process, and are entered into
+the buffer with @code{gfc_warning}.  There is also a special-purpose
+function, @code{gfc_notify_std}, for things which have an error/warning
+status that depends on the currently-selected language standard.
+
+The @code{gfc_error_check} function checks the buffer for errors,
+reports the error message to the user if one exists, clears the buffer,
+and returns a flag to the user indicating whether or not an error
+existed.  To check the state of the buffer without changing its state or
+reporting the errors, the @code{gfc_error_flag_test} function can be
+used.  The @code{gfc_clear_error} function will clear out any errors in
+the buffer, without reporting them.  The @code{gfc_warning_check} and
+@code{gfc_clear_warning} functions provide equivalent functionality for
+the warning buffer.
+
+Only one error and one warning can be in the buffers at a time, and
+buffering another will overwrite the existing one.  In cases where one
+may wish to work on a smaller piece of source code without disturbing an
+existing error state, the @code{gfc_push_error}, @code{gfc_pop_error},
+and @code{gfc_free_error} mechanism exists to implement a stack for the
+error buffer.
+
+For cases where an error or warning should be reported immediately
+rather than buffered, the @code{gfc_error_now} and
+@code{gfc_warning_now} functions can be used.  Normally, the compiler
+will continue attempting to parse the program after an error has
+occurred, but if this is not appropriate, the @code{gfc_fatal_error}
+function should be used instead.  For errors that are always the result
+of a bug somewhere in the compiler, the @code{gfc_internal_error}
+function should be used.
+
+The syntax for the strings used to produce the error/warning message in
+the various error and warning functions is similar to the @code{printf}
+syntax, with @samp{%}-escapes to insert variable values.  The details,
+and the allowable codes, are documented in the @code{error_print}
+function in @file{error.c}.
+
+@c ---------------------------------------------------------------------
+@c Frontend Data Structures
+@c ---------------------------------------------------------------------
+
+@node Frontend Data Structures
+@chapter Frontend Data Structures
+@cindex data structures
+
+This chapter should describe the details necessary to understand how
+the various @code{gfc_*} data are used and interact.  In general it is
+advisable to read the code in @file{dump-parse-tree.c} as its routines
+should exhaust all possible valid combinations of content for these
+structures.
+
+@menu
+* gfc_code:: Representation of Executable Statements.
+* gfc_expr:: Representation of Values and Expressions.
+@end menu
+
+
+@c gfc_code
+@c --------
+
+@node gfc_code
+@section @code{gfc_code}
+@cindex statement chaining
+@tindex @code{gfc_code}
+@tindex @code{struct gfc_code}
+
+The executable statements in a program unit are represented by a
+nested chain of @code{gfc_code} structures.  The type of statement is
+identified by the @code{op} member of the structure, the different
+possible values are enumerated in @code{gfc_exec_op}.  A special
+member of this @code{enum} is @code{EXEC_NOP} which is used to
+represent the various @code{END} statements if they carry a label.
+Depending on the type of statement some of the other fields will be
+filled in.  Fields that are generally applicable are the @code{next}
+and @code{here} fields.  The former points to the next statement in
+the current block or is @code{NULL} if the current statement is the
+last in a block, @code{here} points to the statement label of the
+current statement.
+
+If the current statement is one of @code{IF}, @code{DO}, @code{SELECT}
+it starts a block, i.e.@: a nested level in the program.  In order to
+represent this, the @code{block} member is set to point to a
+@code{gfc_code} structure whose @code{next} member starts the chain of
+statements inside the block; this structure's @code{op} member should be set to
+the same value as the parent structure's @code{op} member.  The @code{SELECT}
+and @code{IF} statements may contain various blocks (the chain of @code{ELSE IF}
+and @code{ELSE} blocks or the various @code{CASE}s, respectively).  These chains
+are linked-lists formed by the @code{block} members.
+
+Consider the following example code:
+
+@example
+IF (foo < 20) THEN
+  PRINT *, "Too small"
+  foo = 20
+ELSEIF (foo > 50) THEN
+  PRINT *, "Too large"
+  foo = 50
+ELSE
+  PRINT *, "Good"
+END IF
+@end example
+
+This statement-block will be represented in the internal gfortran tree as
+follows, were the horizontal link-chains are those induced by the @code{next}
+members and vertical links down are those of @code{block}. @samp{==|} and
+@samp{--|} mean @code{NULL} pointers to mark the end of a chain:
+
+@example
+... ==> IF ==> ...
+        |
+        +--> IF foo < 20 ==> PRINT *, "Too small" ==> foo = 20 ==|
+             |
+             +--> IF foo > 50 ==> PRINT *, "Too large" ==> foo = 50 ==|
+                  |
+                  +--> ELSE ==> PRINT *, "Good" ==|
+                       |
+                       +--|
+@end example
+
+
+@subsection IF Blocks
+
+Conditionals are represented by @code{gfc_code} structures with their
+@code{op} member set to @code{EXEC_IF}.  This structure's @code{block}
+member must point to another @code{gfc_code} node that is the header of the
+if-block.  This header's @code{op} member must be set to @code{EXEC_IF}, too,
+its @code{expr} member holds the condition to check for, and its @code{next}
+should point to the code-chain of the statements to execute if the condition is
+true.
+
+If in addition an @code{ELSEIF} or @code{ELSE} block is present, the
+@code{block} member of the if-block-header node points to yet another
+@code{gfc_code} structure that is the header of the elseif- or else-block.  Its
+structure is identical to that of the if-block-header, except that in case of an
+@code{ELSE} block without a new condition the @code{expr} member should be
+@code{NULL}.  This block can itself have its @code{block} member point to the
+next @code{ELSEIF} or @code{ELSE} block if there's a chain of them.
+
+
+@subsection Loops
+
+@code{DO} loops are stored in the tree as @code{gfc_code} nodes with their
+@code{op} set to @code{EXEC_DO} for a @code{DO} loop with iterator variable and
+to @code{EXEC_DO_WHILE} for infinite @code{DO}s and @code{DO WHILE} blocks.
+Their @code{block} member should point to a @code{gfc_code} structure heading
+the code-chain of the loop body; its @code{op} member should be set to
+@code{EXEC_DO} or @code{EXEC_DO_WHILE}, too, respectively.
+
+For @code{DO WHILE} loops, the loop condition is stored on the top
+@code{gfc_code} structure's @code{expr} member; @code{DO} forever loops are
+simply @code{DO WHILE} loops with a constant @code{.TRUE.} loop condition in
+the internal representation.
+
+Similarly, @code{DO} loops with an iterator have instead of the condition their
+@code{ext.iterator} member set to the correct values for the loop iterator
+variable and its range.
+
+
+@subsection @code{SELECT} Statements
+
+A @code{SELECT} block is introduced by a @code{gfc_code} structure with an
+@code{op} member of @code{EXEC_SELECT} and @code{expr} containing the expression
+to evaluate and test.  Its @code{block} member starts a list of @code{gfc_code}
+structures linked together by their @code{block} members that stores the various
+@code{CASE} parts.
+
+Each @code{CASE} node has its @code{op} member set to @code{EXEC_SELECT}, too,
+its @code{next} member points to the code-chain to be executed in the current
+case-block, and @code{extx.case_list} contains the case-values this block
+corresponds to.  The @code{block} member links to the next case in the list.
+
+
+@subsection @code{BLOCK} and @code{ASSOCIATE}
+
+The code related to a @code{BLOCK} statement is stored inside an
+@code{gfc_code} structure (say @var{c})
+with @code{c.op} set to @code{EXEC_BLOCK}.  The
+@code{gfc_namespace} holding the locally defined variables of the
+@code{BLOCK} is stored in @code{c.ext.block.ns}.  The code inside the
+construct is in @code{c.code}.
+
+@code{ASSOCIATE} constructs are based on @code{BLOCK} and thus also have
+the internal storage structure described above (including @code{EXEC_BLOCK}).
+However, for them @code{c.ext.block.assoc} is set additionally and points
+to a linked list of @code{gfc_association_list} structures.  Those
+structures basically store a link of associate-names to target expressions.
+The associate-names themselves are still also added to the @code{BLOCK}'s
+namespace as ordinary symbols, but they have their @code{gfc_symbol}'s
+member @code{assoc} set also pointing to the association-list structure.
+This way associate-names can be distinguished from ordinary variables
+and their target expressions identified.
+
+For association to expressions (as opposed to variables), at the very beginning
+of the @code{BLOCK} construct assignments are automatically generated to
+set the corresponding variables to their target expressions' values, and
+later on the compiler simply disallows using such associate-names in contexts
+that may change the value.
+
+
+@c gfc_expr
+@c --------
+
+@node gfc_expr
+@section @code{gfc_expr}
+@tindex @code{gfc_expr}
+@tindex @code{struct gfc_expr}
+
+Expressions and ``values'', including constants, variable-, array- and
+component-references as well as complex expressions consisting of operators and
+function calls are internally represented as one or a whole tree of
+@code{gfc_expr} objects.  The member @code{expr_type} specifies the overall
+type of an expression (for instance, @code{EXPR_CONSTANT} for constants or
+@code{EXPR_VARIABLE} for variable references).  The members @code{ts} and
+@code{rank} as well as @code{shape}, which can be @code{NULL}, specify
+the type, rank and, if applicable, shape of the whole expression or expression
+tree of which the current structure is the root.  @code{where} is the locus of
+this expression in the source code.
+
+Depending on the flavor of the expression being described by the object
+(that is, the value of its @code{expr_type} member), the corresponding structure
+in the @code{value} union will usually contain additional data describing the
+expression's value in a type-specific manner.  The @code{ref} member is used to
+build chains of (array-, component- and substring-) references if the expression
+in question contains such references, see below for details.
+
+
+@subsection Constants
+
+Scalar constants are represented by @code{gfc_expr} nodes with their
+@code{expr_type} set to @code{EXPR_CONSTANT}.  The constant's value shall
+already be known at compile-time and is stored in the @code{logical},
+@code{integer}, @code{real}, @code{complex} or @code{character} struct inside
+@code{value}, depending on the constant's type specification.
+
+
+@subsection Operators
+
+Operator-expressions are expressions that are the result of the execution of
+some operator on one or two operands.  The expressions have an @code{expr_type}
+of @code{EXPR_OP}.  Their @code{value.op} structure contains additional data.
+
+@code{op1} and optionally @code{op2} if the operator is binary point to the
+two operands, and @code{operator} or @code{uop} describe the operator that
+should be evaluated on these operands, where @code{uop} describes a user-defined
+operator.
+
+
+@subsection Function Calls
+
+If the expression is the return value of a function-call, its @code{expr_type}
+is set to @code{EXPR_FUNCTION}, and @code{symtree} must point to the symtree
+identifying the function to be called.  @code{value.function.actual} holds the
+actual arguments given to the function as a linked list of
+@code{gfc_actual_arglist} nodes.
+
+The other members of @code{value.function} describe the function being called
+in more detail, containing a link to the intrinsic symbol or user-defined
+function symbol if the call is to an intrinsic or external function,
+respectively.  These values are determined during resolution-phase from the
+structure's @code{symtree} member.
+
+A special case of function calls are ``component calls'' to type-bound
+procedures; those have the @code{expr_type} @code{EXPR_COMPCALL} with
+@code{value.compcall} containing the argument list and the procedure called,
+while @code{symtree} and @code{ref} describe the object on which the procedure
+was called in the same way as a @code{EXPR_VARIABLE} expression would.
+@xref{Type-bound Procedures}.
+
+
+@subsection Array- and Structure-Constructors
+
+Array- and structure-constructors (one could probably call them ``array-'' and
+``derived-type constants'') are @code{gfc_expr} structures with their
+@code{expr_type} member set to @code{EXPR_ARRAY} or @code{EXPR_STRUCTURE},
+respectively.  For structure constructors, @code{symtree} points to the
+derived-type symbol for the type being constructed.
+
+The values for initializing each array element or structure component are
+stored as linked-list of @code{gfc_constructor} nodes in the
+@code{value.constructor} member.
+
+
+@subsection Null
+
+@code{NULL} is a special value for pointers; it can be of different base types.
+Such a @code{NULL} value is represented in the internal tree by a
+@code{gfc_expr} node with @code{expr_type} @code{EXPR_NULL}.  If the base type
+of the @code{NULL} expression is known, it is stored in @code{ts} (that's for
+instance the case for default-initializers of @code{ALLOCATABLE} components),
+but this member can also be set to @code{BT_UNKNOWN} if the information is not
+available (for instance, when the expression is a pointer-initializer
+@code{NULL()}).
+
+
+@subsection Variables and Reference Expressions
+
+Variable references are @code{gfc_expr} structures with their @code{expr_type}
+set to @code{EXPR_VARIABLE}; their @code{symtree} should point to the variable
+that is referenced.
+
+For this type of expression, it's also possible to chain array-, component-
+or substring-references to the original expression to get something like
+@samp{struct%component(2:5)}, where @code{component} is either an array or
+a @code{CHARACTER} member of @code{struct} that is of some derived-type.  Such a
+chain of references is achieved by a linked list headed by @code{ref} of the
+@code{gfc_expr} node.  For the example above it would be (@samp{==|} is the
+last @code{NULL} pointer):
+
+@smallexample
+EXPR_VARIABLE(struct) ==> REF_COMPONENT(component) ==> REF_ARRAY(2:5) ==|
+@end smallexample
+
+If @code{component} is a string rather than an array, the last element would be
+a @code{REF_SUBSTRING} reference, of course.  If the variable itself or some
+component referenced is an array and the expression should reference the whole
+array rather than being followed by an array-element or -section reference, a
+@code{REF_ARRAY} reference must be built as the last element in the chain with
+an array-reference type of @code{AR_FULL}. Consider this example code:
+
+@smallexample
+TYPE :: mytype
+  INTEGER :: array(42)
+END TYPE mytype
+
+TYPE(mytype) :: variable
+INTEGER :: local_array(5)
+
+CALL do_something (variable%array, local_array)
+@end smallexample
+
+The @code{gfc_expr} nodes representing the arguments to the @samp{do_something}
+call will have a reference-chain like this:
+
+@smallexample
+EXPR_VARIABLE(variable) ==> REF_COMPONENT(array) ==> REF_ARRAY(FULL) ==|
+EXPR_VARIABLE(local_array) ==> REF_ARRAY(FULL) ==|
+@end smallexample
+
+
+@subsection Constant Substring References
+
+@code{EXPR_SUBSTRING} is a special type of expression that encodes a substring
+reference of a constant string, as in the following code snippet:
+
+@smallexample
+x = "abcde"(1:2)
+@end smallexample
+
+In this case, @code{value.character} contains the full string's data as if it
+was a string constant, but the @code{ref} member is also set and points to a
+substring reference as described in the subsection above.
+
+
+@c ---------------------------------------------------------------------
+@c F2003 OOP
+@c ---------------------------------------------------------------------
+
+@node Object Orientation
+@chapter Internals of Fortran 2003 OOP Features
+
+@menu
+* Type-bound Procedures:: Type-bound procedures.
+* Type-bound Operators::  Type-bound operators.
+@end menu
+
+
+@c Type-bound procedures
+@c ---------------------
+
+@node Type-bound Procedures
+@section Type-bound Procedures
+
+Type-bound procedures are stored in the @code{tb_sym_root} of the namespace
+@code{f2k_derived} associated with the derived-type symbol as @code{gfc_symtree}
+nodes.  The name and symbol of these symtrees corresponds to the binding-name
+of the procedure, i.e. the name that is used to call it from the context of an
+object of the derived-type.
+
+In addition, this type of symtrees stores in @code{n.tb} a struct of type
+@code{gfc_typebound_proc} containing the additional data needed:  The
+binding attributes (like @code{PASS} and @code{NOPASS}, @code{NON_OVERRIDABLE} 
+or the access-specifier), the binding's target(s) and, if the current binding
+overrides or extends an inherited binding of the same name, @code{overridden}
+points to this binding's @code{gfc_typebound_proc} structure.
+
+
+@subsection Specific Bindings
+@c --------------------------
+
+For specific bindings (declared with @code{PROCEDURE}), if they have a
+passed-object argument, the passed-object dummy argument is first saved by its
+name, and later during resolution phase the corresponding argument is looked for
+and its position remembered as @code{pass_arg_num} in @code{gfc_typebound_proc}.
+The binding's target procedure is pointed-to by @code{u.specific}.
+
+@code{DEFERRED} bindings are just like ordinary specific bindings, except
+that their @code{deferred} flag is set of course and that @code{u.specific}
+points to their ``interface'' defining symbol (might be an abstract interface)
+instead of the target procedure.
+
+At the moment, all type-bound procedure calls are statically dispatched and
+transformed into ordinary procedure calls at resolution time; their actual
+argument list is updated to include at the right position the passed-object
+argument, if applicable, and then a simple procedure call to the binding's
+target procedure is built.  To handle dynamic dispatch in the future, this will
+be extended to allow special code generation during the trans-phase to dispatch
+based on the object's dynamic type.
+
+
+@subsection Generic Bindings
+@c -------------------------
+
+Bindings declared as @code{GENERIC} store the specific bindings they target as
+a linked list using nodes of type @code{gfc_tbp_generic} in @code{u.generic}.
+For each specific target, the parser records its symtree and during resolution
+this symtree is bound to the corresponding @code{gfc_typebound_proc} structure
+of the specific target.
+
+Calls to generic bindings are handled entirely in the resolution-phase, where
+for the actual argument list present the matching specific binding is found
+and the call's target procedure (@code{value.compcall.tbp}) is re-pointed to
+the found specific binding and this call is subsequently handled by the logic
+for specific binding calls.
+
+
+@subsection Calls to Type-bound Procedures
+@c ---------------------------------------
+
+Calls to type-bound procedures are stored in the parse-tree as @code{gfc_expr}
+nodes of type @code{EXPR_COMPCALL}.  Their @code{value.compcall.actual} saves
+the actual argument list of the call and @code{value.compcall.tbp} points to the
+@code{gfc_typebound_proc} structure of the binding to be called.  The object
+in whose context the procedure was called is saved by combination of
+@code{symtree} and @code{ref}, as if the expression was of type
+@code{EXPR_VARIABLE}.
+
+For code like this:
+@smallexample
+CALL myobj%procedure (arg1, arg2)
+@end smallexample
+@noindent
+the @code{CALL} is represented in the parse-tree as a @code{gfc_code} node of
+type @code{EXEC_COMPCALL}.  The @code{expr} member of this node holds an
+expression of type @code{EXPR_COMPCALL} of the same structure as mentioned above
+except that its target procedure is of course a @code{SUBROUTINE} and not a
+@code{FUNCTION}.
+
+Expressions that are generated internally (as expansion of a type-bound
+operator call) may also use additional flags and members.
+@code{value.compcall.ignore_pass} signals that even though a @code{PASS}
+attribute may be present the actual argument list should not be updated because
+it already contains the passed-object.
+@code{value.compcall.base_object} overrides, if it is set, the base-object
+(that is normally stored in @code{symtree} and @code{ref} as mentioned above);
+this is needed because type-bound operators can be called on a base-object that
+need not be of type @code{EXPR_VARIABLE} and thus representable in this way.
+Finally, if @code{value.compcall.assign} is set, the call was produced in
+expansion of a type-bound assignment; this means that proper dependency-checking
+needs to be done when relevant.
+
+
+@c Type-bound operators
+@c --------------------
+
+@node Type-bound Operators
+@section Type-bound Operators
+
+Type-bound operators are in fact basically just @code{GENERIC} procedure
+bindings and are represented much in the same way as those (see
+@ref{Type-bound Procedures}).
+
+They come in two flavours:
+User-defined operators (like @code{.MYOPERATOR.})
+are stored in the @code{f2k_derived} namespace's @code{tb_uop_root}
+symtree exactly like ordinary type-bound procedures are stored in
+@code{tb_sym_root}; their symtrees' names are the operator-names (e.g.
+@samp{myoperator} in the example).
+Intrinsic operators on the other hand are stored in the namespace's
+array member @code{tb_op} indexed by the intrinsic operator's enum
+value.  Those need not be packed into @code{gfc_symtree} structures and are
+only @code{gfc_typebound_proc} instances.
+
+When an operator call or assignment is found that can not be handled in
+another way (i.e. neither matches an intrinsic nor interface operator
+definition) but that contains a derived-type expression, all type-bound
+operators defined on that derived-type are checked for a match with
+the operator call.  If there's indeed a relevant definition, the
+operator call is replaced with an internally generated @code{GENERIC}
+type-bound procedure call to the respective definition and that call is
+further processed.
+
+
+@c ---------------------------------------------------------------------
+@c LibGFortran
+@c ---------------------------------------------------------------------
+
+@node LibGFortran
+@chapter The LibGFortran Runtime Library
+
+@menu
+* Symbol Versioning::    Symbol Versioning.
+@end menu
+
+
+@c ---------------------------------------------------------------------
+@c Symbol Versioning
+@c ---------------------------------------------------------------------
+
+@node Symbol Versioning
+@section Symbol Versioning
+@comment Based on http://gcc.gnu.org/wiki/SymbolVersioning,
+@comment as of 2006-11-05, written by Janne Blomqvist.
+
+In general, this capability exists only on a few platforms, thus there
+is a need for configure magic so that it is used only on those targets
+where it is supported. 
+
+The central concept in symbol versioning is the so-called map file,
+which specifies the version node(s) exported symbols are labeled with.
+Also, the map file is used to hide local symbols. 
+
+Some relevant references:
+@itemize @bullet
+@item
+@uref{http://www.gnu.org/software/binutils/manual/ld-2.9.1/html_node/ld_25.html,
+GNU @command{ld} manual}
+
+@item
+@uref{http://people.redhat.com/drepper/symbol-versioning, ELF Symbol
+Versioning - Ulrich Depper}
+
+@item
+@uref{http://people.redhat.com/drepper/dsohowto.pdf, How to Write Shared
+Libraries - Ulrich Drepper (see Chapter 3)}
+
+@end itemize
+
+If one adds a new symbol to a library that should be exported, the new
+symbol should be mentioned in the map file and a new version node
+defined, e.g., if one adds a new symbols @code{foo} and @code{bar} to
+libgfortran for the next GCC release, the following should be added to
+the map file: 
+@smallexample
+GFORTRAN_1.1 @{
+    global:
+        foo;
+        bar;
+@} GFORTRAN_1.0;
+@end smallexample
+@noindent
+where @code{GFORTRAN_1.0} is the version node of the current release,
+and @code{GFORTRAN_1.1} is the version node of the next release where
+foo and bar are made available. 
+
+If one wants to change an existing interface, it is possible by using
+some asm trickery (from the @command{ld} manual referenced above): 
+
+@smallexample
+__asm__(".symver original_foo,foo@@");
+__asm__(".symver old_foo,foo@@VERS_1.1");
+__asm__(".symver old_foo1,foo@@VERS_1.2");
+__asm__(".symver new_foo,foo@@VERS_2.0");
+@end smallexample
+
+In this example, @code{foo@@} represents the symbol @code{foo} bound to
+the unspecified base version of the symbol. The source file that
+contains this example would define 4 C functions: @code{original_foo},
+@code{old_foo}, @code{old_foo1}, and @code{new_foo}. 
+
+In this case the map file must contain @code{foo} in @code{VERS_1.1}
+and @code{VERS_1.2} as well as in @code{VERS_2.0}.
+
+
+@c ---------------------------------------------------------------------
+@c GNU Free Documentation License
+@c ---------------------------------------------------------------------
+
+@include fdl.texi
+
+
+@c ---------------------------------------------------------------------
+@c Index
+@c ---------------------------------------------------------------------
+
+@node Index
+@unnumbered Index
+
+@printindex cp
+
+@bye
diff --git a/gcc-4.9/gcc/fortran/gfortran.h b/gcc-4.9/gcc/fortran/gfortran.h
new file mode 100644
index 000000000..14c202dd4
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/gfortran.h
@@ -0,0 +1,3025 @@
+/* gfortran header file
+   Copyright (C) 2000-2014 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+#ifndef GCC_GFORTRAN_H
+#define GCC_GFORTRAN_H
+
+/* It's probably insane to have this large of a header file, but it
+   seemed like everything had to be recompiled anyway when a change
+   was made to a header file, and there were ordering issues with
+   multiple header files.  Besides, Microsoft's winnt.h was 250k last
+   time I looked, so by comparison this is perfectly reasonable.  */
+
+#ifndef GCC_CORETYPES_H
+#error "gfortran.h must be included after coretypes.h"
+#endif
+
+/* Declarations common to the front-end and library are put in
+   libgfortran/libgfortran_frontend.h  */
+#include "libgfortran.h"
+
+
+#include "intl.h"
+#include "input.h"
+#include "splay-tree.h"
+#include "vec.h"
+
+/* Major control parameters.  */
+
+#define GFC_MAX_SYMBOL_LEN 63   /* Must be at least 63 for F2003.  */
+#define GFC_LETTERS 26		/* Number of letters in the alphabet.  */
+
+#define MAX_SUBRECORD_LENGTH 2147483639   /* 2**31-9 */
+
+
+#define gfc_is_whitespace(c) ((c==' ') || (c=='\t'))
+
+/* Stringization.  */
+#define stringize(x) expand_macro(x)
+#define expand_macro(x) # x
+
+/* For the runtime library, a standard prefix is a requirement to
+   avoid cluttering the namespace with things nobody asked for.  It's
+   ugly to look at and a pain to type when you add the prefix by hand,
+   so we hide it behind a macro.  */
+#define PREFIX(x) "_gfortran_" x
+#define PREFIX_LEN 10
+
+/* A prefix for internal variables, which are not user-visible.  */
+#if !defined (NO_DOT_IN_LABEL)
+# define GFC_PREFIX(x) "_F." x
+#elif !defined (NO_DOLLAR_IN_LABEL)
+# define GFC_PREFIX(x) "_F$" x
+#else
+# define GFC_PREFIX(x) "_F_" x
+#endif
+
+#define BLANK_COMMON_NAME "__BLNK__"
+
+/* Macro to initialize an mstring structure.  */
+#define minit(s, t) { s, NULL, t }
+
+/* Structure for storing strings to be matched by gfc_match_string.  */
+typedef struct
+{
+  const char *string;
+  const char *mp;
+  int tag;
+}
+mstring;
+
+
+
+/*************************** Enums *****************************/
+
+/* Used when matching and resolving data I/O transfer statements.  */
+
+typedef enum
+{ M_READ, M_WRITE, M_PRINT, M_INQUIRE }
+io_kind;
+
+
+/* These are flags for identifying whether we are reading a character literal
+   between quotes or normal source code.  */
+
+typedef enum
+{ NONSTRING = 0, INSTRING_WARN, INSTRING_NOWARN }
+gfc_instring;
+
+/* This is returned by gfc_notification_std to know if, given the flags
+   that were given (-std=, -pedantic) we should issue an error, a warning
+   or nothing.  */
+
+typedef enum
+{ SILENT, WARNING, ERROR }
+notification;
+
+/* Matchers return one of these three values.  The difference between
+   MATCH_NO and MATCH_ERROR is that MATCH_ERROR means that a match was
+   successful, but that something non-syntactic is wrong and an error
+   has already been issued.  */
+
+typedef enum
+{ MATCH_NO = 1, MATCH_YES, MATCH_ERROR }
+match;
+
+/* Used for different Fortran source forms in places like scanner.c.  */
+typedef enum
+{ FORM_FREE, FORM_FIXED, FORM_UNKNOWN }
+gfc_source_form;
+
+/* Expression node types.  */
+typedef enum
+{ EXPR_OP = 1, EXPR_FUNCTION, EXPR_CONSTANT, EXPR_VARIABLE,
+  EXPR_SUBSTRING, EXPR_STRUCTURE, EXPR_ARRAY, EXPR_NULL, EXPR_COMPCALL, EXPR_PPC
+}
+expr_t;
+
+/* Array types.  */
+typedef enum
+{ AS_EXPLICIT = 1, AS_ASSUMED_SHAPE, AS_DEFERRED,
+  AS_ASSUMED_SIZE, AS_IMPLIED_SHAPE, AS_ASSUMED_RANK,
+  AS_UNKNOWN
+}
+array_type;
+
+typedef enum
+{ AR_FULL = 1, AR_ELEMENT, AR_SECTION, AR_UNKNOWN }
+ar_type;
+
+/* Statement label types. ST_LABEL_DO_TARGET is used for obsolescent warnings
+   related to shared DO terminations and DO targets which are neither END DO
+   nor CONTINUE; otherwise it is identical to ST_LABEL_TARGET.  */
+typedef enum
+{ ST_LABEL_UNKNOWN = 1, ST_LABEL_TARGET, ST_LABEL_DO_TARGET,
+  ST_LABEL_BAD_TARGET, ST_LABEL_FORMAT
+}
+gfc_sl_type;
+
+/* Intrinsic operators.  */
+typedef enum
+{ GFC_INTRINSIC_BEGIN = 0,
+  INTRINSIC_NONE = -1, INTRINSIC_UPLUS = GFC_INTRINSIC_BEGIN,
+  INTRINSIC_UMINUS, INTRINSIC_PLUS, INTRINSIC_MINUS, INTRINSIC_TIMES,
+  INTRINSIC_DIVIDE, INTRINSIC_POWER, INTRINSIC_CONCAT,
+  INTRINSIC_AND, INTRINSIC_OR, INTRINSIC_EQV, INTRINSIC_NEQV,
+  /* ==, /=, >, >=, <, <=  */
+  INTRINSIC_EQ, INTRINSIC_NE, INTRINSIC_GT, INTRINSIC_GE,
+  INTRINSIC_LT, INTRINSIC_LE,
+  /* .EQ., .NE., .GT., .GE., .LT., .LE. (OS = Old-Style)  */
+  INTRINSIC_EQ_OS, INTRINSIC_NE_OS, INTRINSIC_GT_OS, INTRINSIC_GE_OS,
+  INTRINSIC_LT_OS, INTRINSIC_LE_OS,
+  INTRINSIC_NOT, INTRINSIC_USER, INTRINSIC_ASSIGN,
+  INTRINSIC_PARENTHESES, GFC_INTRINSIC_END /* Sentinel */
+}
+gfc_intrinsic_op;
+
+/* This macro is the number of intrinsic operators that exist.
+   Assumptions are made about the numbering of the interface_op enums.  */
+#define GFC_INTRINSIC_OPS GFC_INTRINSIC_END
+
+/* Arithmetic results.  */
+typedef enum
+{ ARITH_OK = 1, ARITH_OVERFLOW, ARITH_UNDERFLOW, ARITH_NAN,
+  ARITH_DIV0, ARITH_INCOMMENSURATE, ARITH_ASYMMETRIC, ARITH_PROHIBIT
+}
+arith;
+
+/* Statements.  */
+typedef enum
+{
+  ST_ARITHMETIC_IF, ST_ALLOCATE, ST_ATTR_DECL, ST_ASSOCIATE,
+  ST_BACKSPACE, ST_BLOCK, ST_BLOCK_DATA,
+  ST_CALL, ST_CASE, ST_CLOSE, ST_COMMON, ST_CONTINUE, ST_CONTAINS, ST_CYCLE,
+  ST_DATA, ST_DATA_DECL, ST_DEALLOCATE, ST_DO, ST_ELSE, ST_ELSEIF,
+  ST_ELSEWHERE, ST_END_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_OMP_ATOMIC, ST_OMP_BARRIER, ST_OMP_CRITICAL, ST_OMP_END_ATOMIC,
+  ST_OMP_END_CRITICAL, ST_OMP_END_DO, ST_OMP_END_MASTER, ST_OMP_END_ORDERED,
+  ST_OMP_END_PARALLEL, ST_OMP_END_PARALLEL_DO, ST_OMP_END_PARALLEL_SECTIONS,
+  ST_OMP_END_PARALLEL_WORKSHARE, ST_OMP_END_SECTIONS, ST_OMP_END_SINGLE,
+  ST_OMP_END_WORKSHARE, ST_OMP_DO, ST_OMP_FLUSH, ST_OMP_MASTER, ST_OMP_ORDERED,
+  ST_OMP_PARALLEL, ST_OMP_PARALLEL_DO, ST_OMP_PARALLEL_SECTIONS,
+  ST_OMP_PARALLEL_WORKSHARE, ST_OMP_SECTIONS, ST_OMP_SECTION, ST_OMP_SINGLE,
+  ST_OMP_THREADPRIVATE, ST_OMP_WORKSHARE, ST_OMP_TASK, ST_OMP_END_TASK,
+  ST_OMP_TASKWAIT, ST_OMP_TASKYIELD, ST_PROCEDURE, ST_GENERIC, ST_CRITICAL,
+  ST_END_CRITICAL, ST_GET_FCN_CHARACTERISTICS, ST_LOCK, ST_UNLOCK, ST_NONE
+}
+gfc_statement;
+
+/* Types of interfaces that we can have.  Assignment interfaces are
+   considered to be intrinsic operators.  */
+typedef enum
+{
+  INTERFACE_NAMELESS = 1, INTERFACE_GENERIC,
+  INTERFACE_INTRINSIC_OP, INTERFACE_USER_OP, INTERFACE_ABSTRACT
+}
+interface_type;
+
+/* Symbol flavors: these are all mutually exclusive.
+   10 elements = 4 bits.  */
+typedef enum sym_flavor
+{
+  FL_UNKNOWN = 0, FL_PROGRAM, FL_BLOCK_DATA, FL_MODULE, FL_VARIABLE,
+  FL_PARAMETER, FL_LABEL, FL_PROCEDURE, FL_DERIVED, FL_NAMELIST,
+  FL_VOID
+}
+sym_flavor;
+
+/* Procedure types.  7 elements = 3 bits.  */
+typedef enum procedure_type
+{ PROC_UNKNOWN, PROC_MODULE, PROC_INTERNAL, PROC_DUMMY,
+  PROC_INTRINSIC, PROC_ST_FUNCTION, PROC_EXTERNAL
+}
+procedure_type;
+
+/* Intent types.  */
+typedef enum sym_intent
+{ INTENT_UNKNOWN = 0, INTENT_IN, INTENT_OUT, INTENT_INOUT
+}
+sym_intent;
+
+/* Access types.  */
+typedef enum gfc_access
+{ ACCESS_UNKNOWN = 0, ACCESS_PUBLIC, ACCESS_PRIVATE
+}
+gfc_access;
+
+/* Flags to keep track of where an interface came from.
+   3 elements = 2 bits.  */
+typedef enum ifsrc
+{ IFSRC_UNKNOWN = 0,	/* Interface unknown, only return type may be known.  */
+  IFSRC_DECL,		/* FUNCTION or SUBROUTINE declaration.  */
+  IFSRC_IFBODY		/* INTERFACE statement or PROCEDURE statement
+			   with explicit interface.  */
+}
+ifsrc;
+
+/* Whether a SAVE attribute was set explicitly or implicitly.  */
+typedef enum save_state
+{ SAVE_NONE = 0, SAVE_EXPLICIT, SAVE_IMPLICIT
+}
+save_state;
+
+/* Strings for all symbol attributes.  We use these for dumping the
+   parse tree, in error messages, and also when reading and writing
+   modules.  In symbol.c.  */
+extern const mstring flavors[];
+extern const mstring procedures[];
+extern const mstring intents[];
+extern const mstring access_types[];
+extern const mstring ifsrc_types[];
+extern const mstring save_status[];
+
+/* Enumeration of all the generic intrinsic functions.  Used by the
+   backend for identification of a function.  */
+
+enum gfc_isym_id
+{
+  /* GFC_ISYM_NONE is used for intrinsics which will never be seen by
+     the backend (e.g. KIND).  */
+  GFC_ISYM_NONE = 0,
+  GFC_ISYM_ABORT,
+  GFC_ISYM_ABS,
+  GFC_ISYM_ACCESS,
+  GFC_ISYM_ACHAR,
+  GFC_ISYM_ACOS,
+  GFC_ISYM_ACOSH,
+  GFC_ISYM_ADJUSTL,
+  GFC_ISYM_ADJUSTR,
+  GFC_ISYM_AIMAG,
+  GFC_ISYM_AINT,
+  GFC_ISYM_ALARM,
+  GFC_ISYM_ALL,
+  GFC_ISYM_ALLOCATED,
+  GFC_ISYM_AND,
+  GFC_ISYM_ANINT,
+  GFC_ISYM_ANY,
+  GFC_ISYM_ASIN,
+  GFC_ISYM_ASINH,
+  GFC_ISYM_ASSOCIATED,
+  GFC_ISYM_ATAN,
+  GFC_ISYM_ATAN2,
+  GFC_ISYM_ATANH,
+  GFC_ISYM_ATOMIC_DEF,
+  GFC_ISYM_ATOMIC_REF,
+  GFC_ISYM_BGE,
+  GFC_ISYM_BGT,
+  GFC_ISYM_BIT_SIZE,
+  GFC_ISYM_BLE,
+  GFC_ISYM_BLT,
+  GFC_ISYM_BTEST,
+  GFC_ISYM_CEILING,
+  GFC_ISYM_CHAR,
+  GFC_ISYM_CHDIR,
+  GFC_ISYM_CHMOD,
+  GFC_ISYM_CMPLX,
+  GFC_ISYM_COMMAND_ARGUMENT_COUNT,
+  GFC_ISYM_COMPILER_OPTIONS,
+  GFC_ISYM_COMPILER_VERSION,
+  GFC_ISYM_COMPLEX,
+  GFC_ISYM_CONJG,
+  GFC_ISYM_CONVERSION,
+  GFC_ISYM_COS,
+  GFC_ISYM_COSH,
+  GFC_ISYM_COUNT,
+  GFC_ISYM_CPU_TIME,
+  GFC_ISYM_CSHIFT,
+  GFC_ISYM_CTIME,
+  GFC_ISYM_C_ASSOCIATED,
+  GFC_ISYM_C_F_POINTER,
+  GFC_ISYM_C_F_PROCPOINTER,
+  GFC_ISYM_C_FUNLOC,
+  GFC_ISYM_C_LOC,
+  GFC_ISYM_C_SIZEOF,
+  GFC_ISYM_DATE_AND_TIME,
+  GFC_ISYM_DBLE,
+  GFC_ISYM_DIGITS,
+  GFC_ISYM_DIM,
+  GFC_ISYM_DOT_PRODUCT,
+  GFC_ISYM_DPROD,
+  GFC_ISYM_DSHIFTL,
+  GFC_ISYM_DSHIFTR,
+  GFC_ISYM_DTIME,
+  GFC_ISYM_EOSHIFT,
+  GFC_ISYM_EPSILON,
+  GFC_ISYM_ERF,
+  GFC_ISYM_ERFC,
+  GFC_ISYM_ERFC_SCALED,
+  GFC_ISYM_ETIME,
+  GFC_ISYM_EXECUTE_COMMAND_LINE,
+  GFC_ISYM_EXIT,
+  GFC_ISYM_EXP,
+  GFC_ISYM_EXPONENT,
+  GFC_ISYM_EXTENDS_TYPE_OF,
+  GFC_ISYM_FDATE,
+  GFC_ISYM_FGET,
+  GFC_ISYM_FGETC,
+  GFC_ISYM_FLOOR,
+  GFC_ISYM_FLUSH,
+  GFC_ISYM_FNUM,
+  GFC_ISYM_FPUT,
+  GFC_ISYM_FPUTC,
+  GFC_ISYM_FRACTION,
+  GFC_ISYM_FREE,
+  GFC_ISYM_FSEEK,
+  GFC_ISYM_FSTAT,
+  GFC_ISYM_FTELL,
+  GFC_ISYM_TGAMMA,
+  GFC_ISYM_GERROR,
+  GFC_ISYM_GETARG,
+  GFC_ISYM_GET_COMMAND,
+  GFC_ISYM_GET_COMMAND_ARGUMENT,
+  GFC_ISYM_GETCWD,
+  GFC_ISYM_GETENV,
+  GFC_ISYM_GET_ENVIRONMENT_VARIABLE,
+  GFC_ISYM_GETGID,
+  GFC_ISYM_GETLOG,
+  GFC_ISYM_GETPID,
+  GFC_ISYM_GETUID,
+  GFC_ISYM_GMTIME,
+  GFC_ISYM_HOSTNM,
+  GFC_ISYM_HUGE,
+  GFC_ISYM_HYPOT,
+  GFC_ISYM_IACHAR,
+  GFC_ISYM_IALL,
+  GFC_ISYM_IAND,
+  GFC_ISYM_IANY,
+  GFC_ISYM_IARGC,
+  GFC_ISYM_IBCLR,
+  GFC_ISYM_IBITS,
+  GFC_ISYM_IBSET,
+  GFC_ISYM_ICHAR,
+  GFC_ISYM_IDATE,
+  GFC_ISYM_IEOR,
+  GFC_ISYM_IERRNO,
+  GFC_ISYM_IMAGE_INDEX,
+  GFC_ISYM_INDEX,
+  GFC_ISYM_INT,
+  GFC_ISYM_INT2,
+  GFC_ISYM_INT8,
+  GFC_ISYM_IOR,
+  GFC_ISYM_IPARITY,
+  GFC_ISYM_IRAND,
+  GFC_ISYM_ISATTY,
+  GFC_ISYM_IS_IOSTAT_END,
+  GFC_ISYM_IS_IOSTAT_EOR,
+  GFC_ISYM_ISNAN,
+  GFC_ISYM_ISHFT,
+  GFC_ISYM_ISHFTC,
+  GFC_ISYM_ITIME,
+  GFC_ISYM_J0,
+  GFC_ISYM_J1,
+  GFC_ISYM_JN,
+  GFC_ISYM_JN2,
+  GFC_ISYM_KILL,
+  GFC_ISYM_KIND,
+  GFC_ISYM_LBOUND,
+  GFC_ISYM_LCOBOUND,
+  GFC_ISYM_LEADZ,
+  GFC_ISYM_LEN,
+  GFC_ISYM_LEN_TRIM,
+  GFC_ISYM_LGAMMA,
+  GFC_ISYM_LGE,
+  GFC_ISYM_LGT,
+  GFC_ISYM_LINK,
+  GFC_ISYM_LLE,
+  GFC_ISYM_LLT,
+  GFC_ISYM_LOC,
+  GFC_ISYM_LOG,
+  GFC_ISYM_LOG10,
+  GFC_ISYM_LOGICAL,
+  GFC_ISYM_LONG,
+  GFC_ISYM_LSHIFT,
+  GFC_ISYM_LSTAT,
+  GFC_ISYM_LTIME,
+  GFC_ISYM_MALLOC,
+  GFC_ISYM_MASKL,
+  GFC_ISYM_MASKR,
+  GFC_ISYM_MATMUL,
+  GFC_ISYM_MAX,
+  GFC_ISYM_MAXEXPONENT,
+  GFC_ISYM_MAXLOC,
+  GFC_ISYM_MAXVAL,
+  GFC_ISYM_MCLOCK,
+  GFC_ISYM_MCLOCK8,
+  GFC_ISYM_MERGE,
+  GFC_ISYM_MERGE_BITS,
+  GFC_ISYM_MIN,
+  GFC_ISYM_MINEXPONENT,
+  GFC_ISYM_MINLOC,
+  GFC_ISYM_MINVAL,
+  GFC_ISYM_MOD,
+  GFC_ISYM_MODULO,
+  GFC_ISYM_MOVE_ALLOC,
+  GFC_ISYM_MVBITS,
+  GFC_ISYM_NEAREST,
+  GFC_ISYM_NEW_LINE,
+  GFC_ISYM_NINT,
+  GFC_ISYM_NORM2,
+  GFC_ISYM_NOT,
+  GFC_ISYM_NULL,
+  GFC_ISYM_NUM_IMAGES,
+  GFC_ISYM_OR,
+  GFC_ISYM_PACK,
+  GFC_ISYM_PARITY,
+  GFC_ISYM_PERROR,
+  GFC_ISYM_POPCNT,
+  GFC_ISYM_POPPAR,
+  GFC_ISYM_PRECISION,
+  GFC_ISYM_PRESENT,
+  GFC_ISYM_PRODUCT,
+  GFC_ISYM_RADIX,
+  GFC_ISYM_RAND,
+  GFC_ISYM_RANDOM_NUMBER,
+  GFC_ISYM_RANDOM_SEED,
+  GFC_ISYM_RANGE,
+  GFC_ISYM_RANK,
+  GFC_ISYM_REAL,
+  GFC_ISYM_RENAME,
+  GFC_ISYM_REPEAT,
+  GFC_ISYM_RESHAPE,
+  GFC_ISYM_RRSPACING,
+  GFC_ISYM_RSHIFT,
+  GFC_ISYM_SAME_TYPE_AS,
+  GFC_ISYM_SC_KIND,
+  GFC_ISYM_SCALE,
+  GFC_ISYM_SCAN,
+  GFC_ISYM_SECNDS,
+  GFC_ISYM_SECOND,
+  GFC_ISYM_SET_EXPONENT,
+  GFC_ISYM_SHAPE,
+  GFC_ISYM_SHIFTA,
+  GFC_ISYM_SHIFTL,
+  GFC_ISYM_SHIFTR,
+  GFC_ISYM_BACKTRACE,
+  GFC_ISYM_SIGN,
+  GFC_ISYM_SIGNAL,
+  GFC_ISYM_SI_KIND,
+  GFC_ISYM_SIN,
+  GFC_ISYM_SINH,
+  GFC_ISYM_SIZE,
+  GFC_ISYM_SLEEP,
+  GFC_ISYM_SIZEOF,
+  GFC_ISYM_SPACING,
+  GFC_ISYM_SPREAD,
+  GFC_ISYM_SQRT,
+  GFC_ISYM_SRAND,
+  GFC_ISYM_SR_KIND,
+  GFC_ISYM_STAT,
+  GFC_ISYM_STORAGE_SIZE,
+  GFC_ISYM_STRIDE,
+  GFC_ISYM_SUM,
+  GFC_ISYM_SYMLINK,
+  GFC_ISYM_SYMLNK,
+  GFC_ISYM_SYSTEM,
+  GFC_ISYM_SYSTEM_CLOCK,
+  GFC_ISYM_TAN,
+  GFC_ISYM_TANH,
+  GFC_ISYM_THIS_IMAGE,
+  GFC_ISYM_TIME,
+  GFC_ISYM_TIME8,
+  GFC_ISYM_TINY,
+  GFC_ISYM_TRAILZ,
+  GFC_ISYM_TRANSFER,
+  GFC_ISYM_TRANSPOSE,
+  GFC_ISYM_TRIM,
+  GFC_ISYM_TTYNAM,
+  GFC_ISYM_UBOUND,
+  GFC_ISYM_UCOBOUND,
+  GFC_ISYM_UMASK,
+  GFC_ISYM_UNLINK,
+  GFC_ISYM_UNPACK,
+  GFC_ISYM_VERIFY,
+  GFC_ISYM_XOR,
+  GFC_ISYM_Y0,
+  GFC_ISYM_Y1,
+  GFC_ISYM_YN,
+  GFC_ISYM_YN2
+};
+typedef enum gfc_isym_id gfc_isym_id;
+
+
+typedef enum
+{
+  GFC_INIT_REAL_OFF = 0,
+  GFC_INIT_REAL_ZERO,
+  GFC_INIT_REAL_NAN,
+  GFC_INIT_REAL_SNAN,
+  GFC_INIT_REAL_INF,
+  GFC_INIT_REAL_NEG_INF
+}
+init_local_real;
+
+typedef enum
+{
+  GFC_INIT_LOGICAL_OFF = 0,
+  GFC_INIT_LOGICAL_FALSE,
+  GFC_INIT_LOGICAL_TRUE
+}
+init_local_logical;
+
+typedef enum
+{
+  GFC_INIT_CHARACTER_OFF = 0,
+  GFC_INIT_CHARACTER_ON
+}
+init_local_character;
+
+typedef enum
+{
+  GFC_INIT_INTEGER_OFF = 0,
+  GFC_INIT_INTEGER_ON
+}
+init_local_integer;
+
+typedef enum
+{
+  GFC_FCOARRAY_NONE = 0,
+  GFC_FCOARRAY_SINGLE,
+  GFC_FCOARRAY_LIB
+}
+gfc_fcoarray;
+
+typedef enum
+{
+  GFC_ENABLE_REVERSE,
+  GFC_FORWARD_SET,
+  GFC_REVERSE_SET,
+  GFC_INHIBIT_REVERSE
+}
+gfc_reverse;
+
+/************************* Structures *****************************/
+
+/* Used for keeping things in balanced binary trees.  */
+#define BBT_HEADER(self) int priority; struct self *left, *right
+
+#define NAMED_INTCST(a,b,c,d) a,
+#define NAMED_KINDARRAY(a,b,c,d) a,
+#define NAMED_FUNCTION(a,b,c,d) a,
+#define NAMED_SUBROUTINE(a,b,c,d) a,
+#define NAMED_DERIVED_TYPE(a,b,c,d) a,
+typedef enum
+{
+  ISOFORTRANENV_INVALID = -1,
+#include "iso-fortran-env.def"
+  ISOFORTRANENV_LAST, ISOFORTRANENV_NUMBER = ISOFORTRANENV_LAST
+}
+iso_fortran_env_symbol;
+#undef NAMED_INTCST
+#undef NAMED_KINDARRAY
+#undef NAMED_FUNCTION
+#undef NAMED_SUBROUTINE
+#undef NAMED_DERIVED_TYPE
+
+#define NAMED_INTCST(a,b,c,d) a,
+#define NAMED_REALCST(a,b,c,d) a,
+#define NAMED_CMPXCST(a,b,c,d) a,
+#define NAMED_LOGCST(a,b,c) a,
+#define NAMED_CHARKNDCST(a,b,c) a,
+#define NAMED_CHARCST(a,b,c) a,
+#define DERIVED_TYPE(a,b,c) a,
+#define NAMED_FUNCTION(a,b,c,d) a,
+#define NAMED_SUBROUTINE(a,b,c,d) a,
+typedef enum
+{
+  ISOCBINDING_INVALID = -1,
+#include "iso-c-binding.def"
+  ISOCBINDING_LAST,
+  ISOCBINDING_NUMBER = ISOCBINDING_LAST
+}
+iso_c_binding_symbol;
+#undef NAMED_INTCST
+#undef NAMED_REALCST
+#undef NAMED_CMPXCST
+#undef NAMED_LOGCST
+#undef NAMED_CHARKNDCST
+#undef NAMED_CHARCST
+#undef DERIVED_TYPE
+#undef NAMED_FUNCTION
+#undef NAMED_SUBROUTINE
+
+typedef enum
+{
+  INTMOD_NONE = 0, INTMOD_ISO_FORTRAN_ENV, INTMOD_ISO_C_BINDING
+}
+intmod_id;
+
+typedef struct
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  int value;  /* Used for both integer and character values.  */
+  bt f90_type;
+}
+CInteropKind_t;
+
+/* Array of structs, where the structs represent the C interop kinds.
+   The list will be implemented based on a hash of the kind name since
+   these could be accessed multiple times.
+   Declared in trans-types.c as a global, since it's in that file
+   that the list is initialized.  */
+extern CInteropKind_t c_interop_kinds_table[];
+
+
+/* Structure and list of supported extension attributes.  */
+typedef enum
+{
+  EXT_ATTR_DLLIMPORT = 0,
+  EXT_ATTR_DLLEXPORT,
+  EXT_ATTR_STDCALL,
+  EXT_ATTR_CDECL,
+  EXT_ATTR_FASTCALL,
+  EXT_ATTR_NO_ARG_CHECK,
+  EXT_ATTR_LAST, EXT_ATTR_NUM = EXT_ATTR_LAST
+}
+ext_attr_id_t;
+
+typedef struct
+{
+  const char *name;
+  unsigned id;
+  const char *middle_end_name;
+}
+ext_attr_t;
+
+extern const ext_attr_t ext_attr_list[];
+
+/* Symbol attribute structure.  */
+typedef struct
+{
+  /* Variable attributes.  */
+  unsigned allocatable:1, dimension:1, codimension:1, external:1, intrinsic:1,
+    optional:1, pointer:1, target:1, value:1, volatile_:1, temporary:1,
+    dummy:1, result:1, assign:1, threadprivate:1, not_always_present:1,
+    implied_index:1, subref_array_pointer:1, proc_pointer:1, asynchronous:1,
+    contiguous:1;
+
+  /* For CLASS containers, the pointer attribute is sometimes set internally
+     even though it was not directly specified.  In this case, keep the
+     "real" (original) value here.  */
+  unsigned class_pointer:1;
+
+  ENUM_BITFIELD (save_state) save:2;
+
+  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.  */
+    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.  */
+    host_assoc:1;		/* Symbol has been host associated.  */
+
+  unsigned in_namelist:1, in_common:1, in_equivalence:1;
+  unsigned function:1, subroutine:1, procedure:1;
+  unsigned generic:1, generic_copy:1;
+  unsigned implicit_type:1;	/* Type defined via implicit rules.  */
+  unsigned untyped:1;		/* No implicit type could be found.  */
+
+  unsigned is_bind_c:1;		/* say if is bound to C.  */
+  unsigned extension:8;		/* extension level of a derived type.  */
+  unsigned is_class:1;		/* is a CLASS container.  */
+  unsigned class_ok:1;		/* is a CLASS object with correct attributes.  */
+  unsigned vtab:1;		/* is a derived type vtab, pointed to by CLASS objects.  */
+  unsigned vtype:1;		/* is a derived type of a vtab.  */
+
+  /* These flags are both in the typespec and attribute.  The attribute
+     list is what gets read from/written to a module file.  The typespec
+     is created from a decl being processed.  */
+  unsigned is_c_interop:1;	/* It's c interoperable.  */
+  unsigned is_iso_c:1;		/* Symbol is from iso_c_binding.  */
+
+  /* Function/subroutine attributes */
+  unsigned sequence:1, elemental:1, pure:1, recursive:1;
+  unsigned unmaskable:1, masked:1, contained:1, mod_proc:1, abstract:1;
+
+  /* Set if a (public) symbol [e.g. generic name] exposes this symbol,
+     which is relevant for private module procedures.  */
+  unsigned public_used:1;
+
+  /* This is set if a contained procedure could be declared pure.  This is
+     used for certain optimizations that require the result or arguments
+     cannot alias.  Note that this is zero for PURE procedures.  */
+  unsigned implicit_pure:1;
+
+  /* This is set if the subroutine doesn't return.  Currently, this
+     is only possible for intrinsic subroutines.  */
+  unsigned noreturn:1;
+
+  /* Set if this procedure is an alternate entry point.  These procedures
+     don't have any code associated, and the backend will turn them into
+     thunks to the master function.  */
+  unsigned entry:1;
+
+  /* Set if this is the master function for a procedure with multiple
+     entry points.  */
+  unsigned entry_master:1;
+
+  /* Set if this is the master function for a function with multiple
+     entry points where characteristics of the entry points differ.  */
+  unsigned mixed_entry_master:1;
+
+  /* Set if a function must always be referenced by an explicit interface.  */
+  unsigned always_explicit:1;
+
+  /* Set if the symbol is generated and, hence, standard violations
+     shouldn't be flaged.  */
+  unsigned artificial:1;
+
+  /* Set if the symbol has been referenced in an expression.  No further
+     modification of type or type parameters is permitted.  */
+  unsigned referenced:1;
+
+  /* Set if this is the symbol for the main program.  */
+  unsigned is_main_program:1;
+
+  /* Mutually exclusive multibit attributes.  */
+  ENUM_BITFIELD (gfc_access) access:2;
+  ENUM_BITFIELD (sym_intent) intent:2;
+  ENUM_BITFIELD (sym_flavor) flavor:4;
+  ENUM_BITFIELD (ifsrc) if_source:2;
+
+  ENUM_BITFIELD (procedure_type) proc:3;
+
+  /* Special attributes for Cray pointers, pointees.  */
+  unsigned cray_pointer:1, cray_pointee:1;
+
+  /* The symbol is a derived type with allocatable components, pointer
+     components or private components, procedure pointer components,
+     possibly nested.  zero_comp is true if the derived type has no
+     component at all.  defined_assign_comp is true if the derived
+     type or a (sub-)component has a typebound defined assignment.
+     unlimited_polymorphic flags the type of the container for these
+     entities.  */
+  unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1,
+	   private_comp:1, zero_comp:1, coarray_comp:1, lock_comp:1,
+	   defined_assign_comp:1, unlimited_polymorphic:1;
+
+  /* This is a temporary selector for SELECT TYPE or an associate
+     variable for SELECT_TYPE or ASSOCIATE.  */
+  unsigned select_type_temporary:1, associate_var:1;
+
+  /* Attributes set by compiler extensions (!GCC$ ATTRIBUTES).  */
+  unsigned ext_attr:EXT_ATTR_NUM;
+
+  /* Is a parameter associated with a deferred type component.  */
+  unsigned deferred_parameter:1;
+
+  /* The namespace where the attribute has been set.  */
+  struct gfc_namespace *volatile_ns, *asynchronous_ns;
+}
+symbol_attribute;
+
+
+/* We need to store source lines as sequences of multibyte source
+   characters. We define here a type wide enough to hold any multibyte
+   source character, just like libcpp does.  A 32-bit type is enough.  */
+
+#if HOST_BITS_PER_INT >= 32
+typedef unsigned int gfc_char_t;
+#elif HOST_BITS_PER_LONG >= 32
+typedef unsigned long gfc_char_t;
+#elif defined(HAVE_LONG_LONG) && (HOST_BITS_PER_LONGLONG >= 32)
+typedef unsigned long long gfc_char_t;
+#else
+# error "Cannot find an integer type with at least 32 bits"
+#endif
+
+
+/* The following three structures are used to identify a location in
+   the sources.
+
+   gfc_file is used to maintain a tree of the source files and how
+   they include each other
+
+   gfc_linebuf holds a single line of source code and information
+   which file it resides in
+
+   locus point to the sourceline and the character in the source
+   line.
+*/
+
+typedef struct gfc_file
+{
+  struct gfc_file *next, *up;
+  int inclusion_line, line;
+  char *filename;
+} gfc_file;
+
+typedef struct gfc_linebuf
+{
+  source_location location;
+  struct gfc_file *file;
+  struct gfc_linebuf *next;
+
+  int truncated;
+  bool dbg_emitted;
+
+  gfc_char_t line[1];
+} gfc_linebuf;
+
+#define gfc_linebuf_header_size (offsetof (gfc_linebuf, line))
+
+#define gfc_linebuf_linenum(LBUF) (LOCATION_LINE ((LBUF)->location))
+
+typedef struct
+{
+  gfc_char_t *nextc;
+  gfc_linebuf *lb;
+} locus;
+
+/* In order for the "gfc" format checking to work correctly, you must
+   have declared a typedef locus first.  */
+#if GCC_VERSION >= 4001
+#define ATTRIBUTE_GCC_GFC(m, n) __attribute__ ((__format__ (__gcc_gfc__, m, n))) ATTRIBUTE_NONNULL(m)
+#else
+#define ATTRIBUTE_GCC_GFC(m, n) ATTRIBUTE_NONNULL(m)
+#endif
+
+
+/* Suppress error messages or re-enable them.  */
+
+void gfc_push_suppress_errors (void);
+void gfc_pop_suppress_errors (void);
+
+
+/* Character length structures hold the expression that gives the
+   length of a character variable.  We avoid putting these into
+   gfc_typespec because doing so prevents us from doing structure
+   copies and forces us to deallocate any typespecs we create, as well
+   as structures that contain typespecs.  They also can have multiple
+   character typespecs pointing to them.
+
+   These structures form a singly linked list within the current
+   namespace and are deallocated with the namespace.  It is possible to
+   end up with gfc_charlen structures that have nothing pointing to them.  */
+
+typedef struct gfc_charlen
+{
+  struct gfc_expr *length;
+  struct gfc_charlen *next;
+  bool length_from_typespec; /* Length from explicit array ctor typespec?  */
+  tree backend_decl;
+  tree passed_length; /* Length argument explicitly passed.  */
+
+  int resolved;
+}
+gfc_charlen;
+
+#define gfc_get_charlen() XCNEW (gfc_charlen)
+
+/* Type specification structure.  */
+typedef struct
+{
+  bt type;
+  int kind;
+
+  union
+  {
+    struct gfc_symbol *derived;	/* For derived types only.  */
+    gfc_charlen *cl;		/* For character types only.  */
+    int pad;			/* For hollerith types only.  */
+  }
+  u;
+
+  struct gfc_symbol *interface;	/* For PROCEDURE declarations.  */
+  int is_c_interop;
+  int is_iso_c;
+  bt f90_type;
+  bool deferred;
+}
+gfc_typespec;
+
+/* Array specification.  */
+typedef struct
+{
+  int rank;	/* A scalar has a rank of 0, an assumed-rank array has -1.  */
+  int corank;
+  array_type type, cotype;
+  struct gfc_expr *lower[GFC_MAX_DIMENSIONS], *upper[GFC_MAX_DIMENSIONS];
+
+  /* These two fields are used with the Cray Pointer extension.  */
+  bool cray_pointee; /* True iff this spec belongs to a cray pointee.  */
+  bool cp_was_assumed; /* AS_ASSUMED_SIZE cp arrays are converted to
+			AS_EXPLICIT, but we want to remember that we
+			did this.  */
+
+}
+gfc_array_spec;
+
+#define gfc_get_array_spec() XCNEW (gfc_array_spec)
+
+
+/* Components of derived types.  */
+typedef struct gfc_component
+{
+  const char *name;
+  gfc_typespec ts;
+
+  symbol_attribute attr;
+  gfc_array_spec *as;
+
+  tree backend_decl;
+  /* Used to cache a FIELD_DECL matching this same component
+     but applied to a different backend containing type that was
+     generated by gfc_nonrestricted_type.  */
+  tree norestrict_decl;
+  locus loc;
+  struct gfc_expr *initializer;
+  struct gfc_component *next;
+
+  /* Needed for procedure pointer components.  */
+  struct gfc_typebound_proc *tb;
+}
+gfc_component;
+
+#define gfc_get_component() XCNEW (gfc_component)
+
+/* Formal argument lists are lists of symbols.  */
+typedef struct gfc_formal_arglist
+{
+  /* Symbol representing the argument at this position in the arglist.  */
+  struct gfc_symbol *sym;
+  /* Points to the next formal argument.  */
+  struct gfc_formal_arglist *next;
+}
+gfc_formal_arglist;
+
+#define gfc_get_formal_arglist() XCNEW (gfc_formal_arglist)
+
+
+/* The gfc_actual_arglist structure is for actual arguments.  */
+typedef struct gfc_actual_arglist
+{
+  const char *name;
+  /* Alternate return label when the expr member is null.  */
+  struct gfc_st_label *label;
+
+  /* This is set to the type of an eventual omitted optional
+     argument. This is used to determine if a hidden string length
+     argument has to be added to a function call.  */
+  bt missing_arg_type;
+
+  struct gfc_expr *expr;
+  struct gfc_actual_arglist *next;
+}
+gfc_actual_arglist;
+
+#define gfc_get_actual_arglist() XCNEW (gfc_actual_arglist)
+
+
+/* Because a symbol can belong to multiple namelists, they must be
+   linked externally to the symbol itself.  */
+typedef struct gfc_namelist
+{
+  struct gfc_symbol *sym;
+  struct gfc_namelist *next;
+}
+gfc_namelist;
+
+#define gfc_get_namelist() XCNEW (gfc_namelist)
+
+enum
+{
+  OMP_LIST_PRIVATE,
+  OMP_LIST_FIRSTPRIVATE,
+  OMP_LIST_LASTPRIVATE,
+  OMP_LIST_COPYPRIVATE,
+  OMP_LIST_SHARED,
+  OMP_LIST_COPYIN,
+  OMP_LIST_PLUS,
+  OMP_LIST_REDUCTION_FIRST = OMP_LIST_PLUS,
+  OMP_LIST_MULT,
+  OMP_LIST_SUB,
+  OMP_LIST_AND,
+  OMP_LIST_OR,
+  OMP_LIST_EQV,
+  OMP_LIST_NEQV,
+  OMP_LIST_MAX,
+  OMP_LIST_MIN,
+  OMP_LIST_IAND,
+  OMP_LIST_IOR,
+  OMP_LIST_IEOR,
+  OMP_LIST_REDUCTION_LAST = OMP_LIST_IEOR,
+  OMP_LIST_NUM
+};
+
+/* Because a symbol can belong to multiple namelists, they must be
+   linked externally to the symbol itself.  */
+
+enum gfc_omp_sched_kind
+{
+  OMP_SCHED_NONE,
+  OMP_SCHED_STATIC,
+  OMP_SCHED_DYNAMIC,
+  OMP_SCHED_GUIDED,
+  OMP_SCHED_RUNTIME,
+  OMP_SCHED_AUTO
+};
+
+enum gfc_omp_default_sharing
+{
+  OMP_DEFAULT_UNKNOWN,
+  OMP_DEFAULT_NONE,
+  OMP_DEFAULT_PRIVATE,
+  OMP_DEFAULT_SHARED,
+  OMP_DEFAULT_FIRSTPRIVATE
+};
+
+typedef struct gfc_omp_clauses
+{
+  struct gfc_expr *if_expr;
+  struct gfc_expr *final_expr;
+  struct gfc_expr *num_threads;
+  gfc_namelist *lists[OMP_LIST_NUM];
+  enum gfc_omp_sched_kind sched_kind;
+  struct gfc_expr *chunk_size;
+  enum gfc_omp_default_sharing default_sharing;
+  int collapse;
+  bool nowait, ordered, untied, mergeable;
+}
+gfc_omp_clauses;
+
+#define gfc_get_omp_clauses() XCNEW (gfc_omp_clauses)
+
+
+/* The gfc_st_label structure is a BBT attached to a namespace that
+   records the usage of statement labels within that space.  */
+
+typedef struct gfc_st_label
+{
+  BBT_HEADER(gfc_st_label);
+
+  int value;
+
+  gfc_sl_type defined, referenced;
+
+  struct gfc_expr *format;
+
+  tree backend_decl;
+
+  locus where;
+}
+gfc_st_label;
+
+
+/* gfc_interface()-- Interfaces are lists of symbols strung together.  */
+typedef struct gfc_interface
+{
+  struct gfc_symbol *sym;
+  locus where;
+  struct gfc_interface *next;
+}
+gfc_interface;
+
+#define gfc_get_interface() XCNEW (gfc_interface)
+
+/* User operator nodes.  These are like stripped down symbols.  */
+typedef struct
+{
+  const char *name;
+
+  gfc_interface *op;
+  struct gfc_namespace *ns;
+  gfc_access access;
+}
+gfc_user_op;
+
+
+/* A list of specific bindings that are associated with a generic spec.  */
+typedef struct gfc_tbp_generic
+{
+  /* The parser sets specific_st, upon resolution we look for the corresponding
+     gfc_typebound_proc and set specific for further use.  */
+  struct gfc_symtree* specific_st;
+  struct gfc_typebound_proc* specific;
+
+  struct gfc_tbp_generic* next;
+  bool is_operator;
+}
+gfc_tbp_generic;
+
+#define gfc_get_tbp_generic() XCNEW (gfc_tbp_generic)
+
+
+/* Data needed for type-bound procedures.  */
+typedef struct gfc_typebound_proc
+{
+  locus where; /* Where the PROCEDURE/GENERIC definition was.  */
+
+  union
+  {
+    struct gfc_symtree* specific; /* The interface if DEFERRED.  */
+    gfc_tbp_generic* generic;
+  }
+  u;
+
+  gfc_access access;
+  const char* pass_arg; /* Argument-name for PASS.  NULL if not specified.  */
+
+  /* The overridden type-bound proc (or GENERIC with this name in the
+     parent-type) or NULL if non.  */
+  struct gfc_typebound_proc* overridden;
+
+  /* Once resolved, we use the position of pass_arg in the formal arglist of
+     the binding-target procedure to identify it.  The first argument has
+     number 1 here, the second 2, and so on.  */
+  unsigned pass_arg_num;
+
+  unsigned nopass:1; /* Whether we have NOPASS (PASS otherwise).  */
+  unsigned non_overridable:1;
+  unsigned deferred:1;
+  unsigned is_generic:1;
+  unsigned function:1, subroutine:1;
+  unsigned error:1; /* Ignore it, when an error occurred during resolution.  */
+  unsigned ppc:1;
+}
+gfc_typebound_proc;
+
+
+/* Symbol nodes.  These are important things.  They are what the
+   standard refers to as "entities".  The possibly multiple names that
+   refer to the same entity are accomplished by a binary tree of
+   symtree structures that is balanced by the red-black method-- more
+   than one symtree node can point to any given symbol.  */
+
+typedef struct gfc_symbol
+{
+  const char *name;	/* Primary name, before renaming */
+  const char *module;	/* Module this symbol came from */
+  locus declared_at;
+
+  gfc_typespec ts;
+  symbol_attribute attr;
+
+  /* The formal member points to the formal argument list if the
+     symbol is a function or subroutine name.  If the symbol is a
+     generic name, the generic member points to the list of
+     interfaces.  */
+
+  gfc_interface *generic;
+  gfc_access component_access;
+
+  gfc_formal_arglist *formal;
+  struct gfc_namespace *formal_ns;
+  struct gfc_namespace *f2k_derived;
+
+  struct gfc_expr *value;	/* Parameter/Initializer value */
+  gfc_array_spec *as;
+  struct gfc_symbol *result;	/* function result symbol */
+  gfc_component *components;	/* Derived type components */
+
+  /* Defined only for Cray pointees; points to their pointer.  */
+  struct gfc_symbol *cp_pointer;
+
+  int entry_id;			/* Used in resolve.c for entries.  */
+
+  /* CLASS hashed name for declared and dynamic types in the class.  */
+  int hash_value;
+
+  struct gfc_symbol *common_next;	/* Links for COMMON syms */
+
+  /* This is in fact a gfc_common_head but it is only used for pointer
+     comparisons to check if symbols are in the same common block.  */
+  struct gfc_common_head* common_head;
+
+  /* Make sure setup code for dummy arguments is generated in the correct
+     order.  */
+  int dummy_order;
+
+  gfc_namelist *namelist, *namelist_tail;
+
+  /* Change management fields.  Symbols that might be modified by the
+     current statement have the mark member nonzero and are kept in a
+     singly linked list through the tlink field.  Of these symbols,
+     symbols with old_symbol equal to NULL are symbols created within
+     the current statement.  Otherwise, old_symbol points to a copy of
+     the old symbol.  */
+
+  struct gfc_symbol *old_symbol, *tlink;
+  unsigned mark:1, gfc_new:1;
+  /* Nonzero if all equivalences associated with this symbol have been
+     processed.  */
+  unsigned equiv_built:1;
+  /* Set if this variable is used as an index name in a FORALL.  */
+  unsigned forall_index:1;
+  /* Used to avoid multiple resolutions of a single symbol.  */
+  unsigned resolved:1;
+
+  int refs;
+  struct gfc_namespace *ns;	/* namespace containing this symbol */
+
+  tree backend_decl;
+
+  /* Identity of the intrinsic module the symbol comes from, or
+     INTMOD_NONE if it's not imported from a intrinsic module.  */
+  intmod_id from_intmod;
+  /* Identity of the symbol from intrinsic modules, from enums maintained
+     separately by each intrinsic module.  Used together with from_intmod,
+     it uniquely identifies a symbol from an intrinsic module.  */
+  int intmod_sym_id;
+
+  /* This may be repetitive, since the typespec now has a binding
+     label field.  */
+  const char* binding_label;
+  /* Store a reference to the common_block, if this symbol is in one.  */
+  struct gfc_common_head *common_block;
+
+  /* Link to corresponding association-list if this is an associate name.  */
+  struct gfc_association_list *assoc;
+}
+gfc_symbol;
+
+
+struct gfc_undo_change_set
+{
+  vec<gfc_symbol *> syms;
+  vec<gfc_typebound_proc *> tbps;
+  gfc_undo_change_set *previous;
+};
+
+
+/* This structure is used to keep track of symbols in common blocks.  */
+typedef struct gfc_common_head
+{
+  locus where;
+  char use_assoc, saved, threadprivate;
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  struct gfc_symbol *head;
+  const char* binding_label;
+  int is_bind_c;
+  int refs;
+}
+gfc_common_head;
+
+#define gfc_get_common_head() XCNEW (gfc_common_head)
+
+
+/* A list of all the alternate entry points for a procedure.  */
+
+typedef struct gfc_entry_list
+{
+  /* The symbol for this entry point.  */
+  gfc_symbol *sym;
+  /* The zero-based id of this entry point.  */
+  int id;
+  /* The LABEL_EXPR marking this entry point.  */
+  tree label;
+  /* The next item in the list.  */
+  struct gfc_entry_list *next;
+}
+gfc_entry_list;
+
+#define gfc_get_entry_list() XCNEW (gfc_entry_list)
+
+/* Lists of rename info for the USE statement.  */
+
+typedef struct gfc_use_rename
+{
+  char local_name[GFC_MAX_SYMBOL_LEN + 1], use_name[GFC_MAX_SYMBOL_LEN + 1];
+  struct gfc_use_rename *next;
+  int found;
+  gfc_intrinsic_op op;
+  locus where;
+}
+gfc_use_rename;
+
+#define gfc_get_use_rename() XCNEW (gfc_use_rename);
+
+/* A list of all USE statements in a namespace.  */
+
+typedef struct gfc_use_list
+{
+  const char *module_name;
+  bool intrinsic;
+  bool non_intrinsic;
+  bool only_flag;
+  struct gfc_use_rename *rename;
+  locus where;
+  /* Next USE statement.  */
+  struct gfc_use_list *next;
+}
+gfc_use_list;
+
+#define gfc_get_use_list() XCNEW (gfc_use_list)
+
+/* Within a namespace, symbols are pointed to by symtree nodes that
+   are linked together in a balanced binary tree.  There can be
+   several symtrees pointing to the same symbol node via USE
+   statements.  */
+
+typedef struct gfc_symtree
+{
+  BBT_HEADER (gfc_symtree);
+  const char *name;
+  int ambiguous;
+  union
+  {
+    gfc_symbol *sym;		/* Symbol associated with this node */
+    gfc_user_op *uop;
+    gfc_common_head *common;
+    gfc_typebound_proc *tb;
+  }
+  n;
+}
+gfc_symtree;
+
+/* A linked list of derived types in the namespace.  */
+typedef struct gfc_dt_list
+{
+  struct gfc_symbol *derived;
+  struct gfc_dt_list *next;
+}
+gfc_dt_list;
+
+#define gfc_get_dt_list() XCNEW (gfc_dt_list)
+
+  /* A list of all derived types.  */
+  extern gfc_dt_list *gfc_derived_types;
+
+/* A namespace describes the contents of procedure, module, interface block
+   or BLOCK construct.  */
+/* ??? Anything else use these?  */
+
+typedef struct gfc_namespace
+{
+  /* Tree containing all the symbols in this namespace.  */
+  gfc_symtree *sym_root;
+  /* Tree containing all the user-defined operators in the namespace.  */
+  gfc_symtree *uop_root;
+  /* Tree containing all the common blocks.  */
+  gfc_symtree *common_root;
+
+  /* Tree containing type-bound procedures.  */
+  gfc_symtree *tb_sym_root;
+  /* Type-bound user operators.  */
+  gfc_symtree *tb_uop_root;
+  /* For derived-types, store type-bound intrinsic operators here.  */
+  gfc_typebound_proc *tb_op[GFC_INTRINSIC_OPS];
+  /* Linked list of finalizer procedures.  */
+  struct gfc_finalizer *finalizers;
+
+  /* If set_flag[letter] is set, an implicit type has been set for letter.  */
+  int set_flag[GFC_LETTERS];
+  /* Keeps track of the implicit types associated with the letters.  */
+  gfc_typespec default_type[GFC_LETTERS];
+  /* Store the positions of IMPLICIT statements.  */
+  locus implicit_loc[GFC_LETTERS];
+
+  /* If this is a namespace of a procedure, this points to the procedure.  */
+  struct gfc_symbol *proc_name;
+  /* If this is the namespace of a unit which contains executable
+     code, this points to it.  */
+  struct gfc_code *code;
+
+  /* Points to the equivalences set up in this namespace.  */
+  struct gfc_equiv *equiv, *old_equiv;
+
+  /* Points to the equivalence groups produced by trans_common.  */
+  struct gfc_equiv_list *equiv_lists;
+
+  gfc_interface *op[GFC_INTRINSIC_OPS];
+
+  /* Points to the parent namespace, i.e. the namespace of a module or
+     procedure in which the procedure belonging to this namespace is
+     contained. The parent namespace points to this namespace either
+     directly via CONTAINED, or indirectly via the chain built by
+     SIBLING.  */
+  struct gfc_namespace *parent;
+  /* CONTAINED points to the first contained namespace. Sibling
+     namespaces are chained via SIBLING.  */
+  struct gfc_namespace  *contained, *sibling;
+
+  gfc_common_head blank_common;
+  gfc_access default_access, operator_access[GFC_INTRINSIC_OPS];
+
+  gfc_st_label *st_labels;
+  /* This list holds information about all the data initializers in
+     this namespace.  */
+  struct gfc_data *data;
+
+  gfc_charlen *cl_list, *old_cl_list;
+
+  gfc_dt_list *derived_types;
+
+  int save_all, seen_save, seen_implicit_none;
+
+  /* Normally we don't need to refcount namespaces.  However when we read
+     a module containing a function with multiple entry points, this
+     will appear as several functions with the same formal namespace.  */
+  int refs;
+
+  /* A list of all alternate entry points to this procedure (or NULL).  */
+  gfc_entry_list *entries;
+
+  /* A list of USE statements in this namespace.  */
+  gfc_use_list *use_stmts;
+
+  /* Set to 1 if namespace is a BLOCK DATA program unit.  */
+  unsigned is_block_data:1;
+
+  /* Set to 1 if namespace is an interface body with "IMPORT" used.  */
+  unsigned has_import_set:1;
+
+  /* Set to 1 if resolved has been called for this namespace.
+     Holds -1 during resolution.  */
+  signed resolved:2;
+
+  /* Set to 1 if code has been generated for this namespace.  */
+  unsigned translated:1;
+
+  /* Set to 1 if symbols in this namespace should be 'construct entities',
+     i.e. for BLOCK local variables.  */
+  unsigned construct_entities:1;
+}
+gfc_namespace;
+
+extern gfc_namespace *gfc_current_ns;
+extern gfc_namespace *gfc_global_ns_list;
+
+/* Global symbols are symbols of global scope. Currently we only use
+   this to detect collisions already when parsing.
+   TODO: Extend to verify procedure calls.  */
+
+enum gfc_symbol_type
+{
+  GSYM_UNKNOWN=1, GSYM_PROGRAM, GSYM_FUNCTION, GSYM_SUBROUTINE,
+  GSYM_MODULE, GSYM_COMMON, GSYM_BLOCK_DATA
+};
+
+typedef struct gfc_gsymbol
+{
+  BBT_HEADER(gfc_gsymbol);
+
+  const char *name;
+  const char *sym_name;
+  const char *mod_name;
+  const char *binding_label;
+  enum gfc_symbol_type type;
+
+  int defined, used;
+  locus where;
+  gfc_namespace *ns;
+}
+gfc_gsymbol;
+
+extern gfc_gsymbol *gfc_gsym_root;
+
+/* Information on interfaces being built.  */
+typedef struct
+{
+  interface_type type;
+  gfc_symbol *sym;
+  gfc_namespace *ns;
+  gfc_user_op *uop;
+  gfc_intrinsic_op op;
+}
+gfc_interface_info;
+
+extern gfc_interface_info current_interface;
+
+
+/* Array reference.  */
+
+enum gfc_array_ref_dimen_type
+{
+  DIMEN_ELEMENT = 1, DIMEN_RANGE, DIMEN_VECTOR, DIMEN_STAR, DIMEN_THIS_IMAGE, DIMEN_UNKNOWN
+};
+
+typedef struct gfc_array_ref
+{
+  ar_type type;
+  int dimen;			/* # of components in the reference */
+  int codimen;
+  bool in_allocate;		/* For coarray checks. */
+  locus where;
+  gfc_array_spec *as;
+
+  locus c_where[GFC_MAX_DIMENSIONS];	/* All expressions can be NULL */
+  struct gfc_expr *start[GFC_MAX_DIMENSIONS], *end[GFC_MAX_DIMENSIONS],
+    *stride[GFC_MAX_DIMENSIONS];
+
+  enum gfc_array_ref_dimen_type dimen_type[GFC_MAX_DIMENSIONS];
+}
+gfc_array_ref;
+
+#define gfc_get_array_ref() XCNEW (gfc_array_ref)
+
+
+/* Component reference nodes.  A variable is stored as an expression
+   node that points to the base symbol.  After that, a singly linked
+   list of component reference nodes gives the variable's complete
+   resolution.  The array_ref component may be present and comes
+   before the component component.  */
+
+typedef enum
+  { REF_ARRAY, REF_COMPONENT, REF_SUBSTRING }
+ref_type;
+
+typedef struct gfc_ref
+{
+  ref_type type;
+
+  union
+  {
+    struct gfc_array_ref ar;
+
+    struct
+    {
+      gfc_component *component;
+      gfc_symbol *sym;
+    }
+    c;
+
+    struct
+    {
+      struct gfc_expr *start, *end;	/* Substring */
+      gfc_charlen *length;
+    }
+    ss;
+
+  }
+  u;
+
+  struct gfc_ref *next;
+}
+gfc_ref;
+
+#define gfc_get_ref() XCNEW (gfc_ref)
+
+
+/* Structures representing intrinsic symbols and their arguments lists.  */
+typedef struct gfc_intrinsic_arg
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+
+  gfc_typespec ts;
+  unsigned optional:1, value:1;
+  ENUM_BITFIELD (sym_intent) intent:2;
+  gfc_actual_arglist *actual;
+
+  struct gfc_intrinsic_arg *next;
+
+}
+gfc_intrinsic_arg;
+
+
+/* Specifies the various kinds of check functions used to verify the
+   argument lists of intrinsic functions. fX with X an integer refer
+   to check functions of intrinsics with X arguments. f1m is used for
+   the MAX and MIN intrinsics which can have an arbitrary number of
+   arguments, f3ml is used for the MINLOC and MAXLOC intrinsics as
+   these have special semantics.  */
+
+typedef union
+{
+  bool (*f0)(void);
+  bool (*f1)(struct gfc_expr *);
+  bool (*f1m)(gfc_actual_arglist *);
+  bool (*f2)(struct gfc_expr *, struct gfc_expr *);
+  bool (*f3)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *);
+  bool (*f3ml)(gfc_actual_arglist *);
+  bool (*f3red)(gfc_actual_arglist *);
+  bool (*f4)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *,
+	    struct gfc_expr *);
+  bool (*f5)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *,
+	    struct gfc_expr *, struct gfc_expr *);
+}
+gfc_check_f;
+
+/* Like gfc_check_f, these specify the type of the simplification
+   function associated with an intrinsic. The fX are just like in
+   gfc_check_f. cc is used for type conversion functions.  */
+
+typedef union
+{
+  struct gfc_expr *(*f0)(void);
+  struct gfc_expr *(*f1)(struct gfc_expr *);
+  struct gfc_expr *(*f2)(struct gfc_expr *, struct gfc_expr *);
+  struct gfc_expr *(*f3)(struct gfc_expr *, struct gfc_expr *,
+			 struct gfc_expr *);
+  struct gfc_expr *(*f4)(struct gfc_expr *, struct gfc_expr *,
+			 struct gfc_expr *, struct gfc_expr *);
+  struct gfc_expr *(*f5)(struct gfc_expr *, struct gfc_expr *,
+			 struct gfc_expr *, struct gfc_expr *,
+			 struct gfc_expr *);
+  struct gfc_expr *(*cc)(struct gfc_expr *, bt, int);
+}
+gfc_simplify_f;
+
+/* Again like gfc_check_f, these specify the type of the resolution
+   function associated with an intrinsic. The fX are just like in
+   gfc_check_f. f1m is used for MIN and MAX, s1 is used for abort().  */
+
+typedef union
+{
+  void (*f0)(struct gfc_expr *);
+  void (*f1)(struct gfc_expr *, struct gfc_expr *);
+  void (*f1m)(struct gfc_expr *, struct gfc_actual_arglist *);
+  void (*f2)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *);
+  void (*f3)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *,
+	     struct gfc_expr *);
+  void (*f4)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *,
+	     struct gfc_expr *, struct gfc_expr *);
+  void (*f5)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *,
+	     struct gfc_expr *, struct gfc_expr *, struct gfc_expr *);
+  void (*s1)(struct gfc_code *);
+}
+gfc_resolve_f;
+
+
+typedef struct gfc_intrinsic_sym
+{
+  const char *name, *lib_name;
+  gfc_intrinsic_arg *formal;
+  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;
+
+  int standard;
+
+  gfc_simplify_f simplify;
+  gfc_check_f check;
+  gfc_resolve_f resolve;
+  struct gfc_intrinsic_sym *specific_head, *next;
+  gfc_isym_id id;
+
+}
+gfc_intrinsic_sym;
+
+
+/* Expression nodes.  The expression node types deserve explanations,
+   since the last couple can be easily misconstrued:
+
+   EXPR_OP         Operator node pointing to one or two other nodes
+   EXPR_FUNCTION   Function call, symbol points to function's name
+   EXPR_CONSTANT   A scalar constant: Logical, String, Real, Int or Complex
+   EXPR_VARIABLE   An Lvalue with a root symbol and possible reference list
+		   which expresses structure, array and substring refs.
+   EXPR_NULL       The NULL pointer value (which also has a basic type).
+   EXPR_SUBSTRING  A substring of a constant string
+   EXPR_STRUCTURE  A structure constructor
+   EXPR_ARRAY      An array constructor.
+   EXPR_COMPCALL   Function (or subroutine) call of a procedure pointer
+		   component or type-bound procedure.  */
+
+#include <mpfr.h>
+#include <mpc.h>
+#define GFC_RND_MODE GMP_RNDN
+#define GFC_MPC_RND_MODE MPC_RNDNN
+
+typedef splay_tree gfc_constructor_base;
+
+typedef struct gfc_expr
+{
+  expr_t expr_type;
+
+  gfc_typespec ts;	/* These two refer to the overall expression */
+
+  int rank;		/* 0 indicates a scalar, -1 an assumed-rank array.  */
+  mpz_t *shape;		/* Can be NULL if shape is unknown at compile time */
+
+  /* Nonnull for functions and structure constructors, may also used to hold the
+     base-object for component calls.  */
+  gfc_symtree *symtree;
+
+  gfc_ref *ref;
+
+  locus where;
+
+  /* Used to store the base expression in component calls, when the expression
+     is not a variable.  */
+  struct gfc_expr *base_expr;
+
+  /* is_boz is true if the integer is regarded as BOZ bit pattern and is_snan
+     denotes a signalling not-a-number.  */
+  unsigned int is_boz : 1, is_snan : 1;
+
+  /* Sometimes, when an error has been emitted, it is necessary to prevent
+      it from recurring.  */
+  unsigned int error : 1;
+
+  /* Mark an expression where a user operator has been substituted by
+     a function call in interface.c(gfc_extend_expr).  */
+  unsigned int user_operator : 1;
+
+  /* Mark an expression as being a MOLD argument of ALLOCATE.  */
+  unsigned int mold : 1;
+
+  /* If an expression comes from a Hollerith constant or compile-time
+     evaluation of a transfer statement, it may have a prescribed target-
+     memory representation, and these cannot always be backformed from
+     the value.  */
+  struct
+  {
+    int length;
+    char *string;
+  }
+  representation;
+
+  union
+  {
+    int logical;
+
+    io_kind iokind;
+
+    mpz_t integer;
+
+    mpfr_t real;
+
+    mpc_t complex;
+
+    struct
+    {
+      gfc_intrinsic_op op;
+      gfc_user_op *uop;
+      struct gfc_expr *op1, *op2;
+    }
+    op;
+
+    struct
+    {
+      gfc_actual_arglist *actual;
+      const char *name;	/* Points to the ultimate name of the function */
+      gfc_intrinsic_sym *isym;
+      gfc_symbol *esym;
+    }
+    function;
+
+    struct
+    {
+      gfc_actual_arglist* actual;
+      const char* name;
+      /* Base-object, whose component was called.  NULL means that it should
+	 be taken from symtree/ref.  */
+      struct gfc_expr* base_object;
+      gfc_typebound_proc* tbp; /* Should overlap with esym.  */
+
+      /* For type-bound operators, we want to call PASS procedures but already
+	 have the full arglist; mark this, so that it is not extended by the
+	 PASS argument.  */
+      unsigned ignore_pass:1;
+
+      /* Do assign-calls rather than calls, that is appropriate dependency
+	 checking.  */
+      unsigned assign:1;
+    }
+    compcall;
+
+    struct
+    {
+      int length;
+      gfc_char_t *string;
+    }
+    character;
+
+    gfc_constructor_base constructor;
+  }
+  value;
+
+}
+gfc_expr;
+
+
+#define gfc_get_shape(rank) (XCNEWVEC (mpz_t, (rank)))
+
+/* Structures for information associated with different kinds of
+   numbers.  The first set of integer parameters define all there is
+   to know about a particular kind.  The rest of the elements are
+   computed from the first elements.  */
+
+typedef struct
+{
+  /* Values really representable by the target.  */
+  mpz_t huge, pedantic_min_int, min_int;
+
+  int kind, radix, digits, bit_size, range;
+
+  /* True if the C type of the given name maps to this precision.
+     Note that more than one bit can be set.  */
+  unsigned int c_char : 1;
+  unsigned int c_short : 1;
+  unsigned int c_int : 1;
+  unsigned int c_long : 1;
+  unsigned int c_long_long : 1;
+}
+gfc_integer_info;
+
+extern gfc_integer_info gfc_integer_kinds[];
+
+
+typedef struct
+{
+  int kind, bit_size;
+
+  /* True if the C++ type bool, C99 type _Bool, maps to this precision.  */
+  unsigned int c_bool : 1;
+}
+gfc_logical_info;
+
+extern gfc_logical_info gfc_logical_kinds[];
+
+
+typedef struct
+{
+  mpfr_t epsilon, huge, tiny, subnormal;
+  int kind, radix, digits, min_exponent, max_exponent;
+  int range, precision;
+
+  /* The precision of the type as reported by GET_MODE_PRECISION.  */
+  int mode_precision;
+
+  /* True if the C type of the given name maps to this precision.
+     Note that more than one bit can be set.  */
+  unsigned int c_float : 1;
+  unsigned int c_double : 1;
+  unsigned int c_long_double : 1;
+  unsigned int c_float128 : 1;
+}
+gfc_real_info;
+
+extern gfc_real_info gfc_real_kinds[];
+
+typedef struct
+{
+  int kind, bit_size;
+  const char *name;
+}
+gfc_character_info;
+
+extern gfc_character_info gfc_character_kinds[];
+
+
+/* Equivalence structures.  Equivalent lvalues are linked along the
+   *eq pointer, equivalence sets are strung along the *next node.  */
+typedef struct gfc_equiv
+{
+  struct gfc_equiv *next, *eq;
+  gfc_expr *expr;
+  const char *module;
+  int used;
+}
+gfc_equiv;
+
+#define gfc_get_equiv() XCNEW (gfc_equiv)
+
+/* Holds a single equivalence member after processing.  */
+typedef struct gfc_equiv_info
+{
+  gfc_symbol *sym;
+  HOST_WIDE_INT offset;
+  HOST_WIDE_INT length;
+  struct gfc_equiv_info *next;
+} gfc_equiv_info;
+
+/* Holds equivalence groups, after they have been processed.  */
+typedef struct gfc_equiv_list
+{
+  gfc_equiv_info *equiv;
+  struct gfc_equiv_list *next;
+} gfc_equiv_list;
+
+/* gfc_case stores the selector list of a case statement.  The *low
+   and *high pointers can point to the same expression in the case of
+   a single value.  If *high is NULL, the selection is from *low
+   upwards, if *low is NULL the selection is *high downwards.
+
+   This structure has separate fields to allow single and double linked
+   lists of CASEs at the same time.  The singe linked list along the NEXT
+   field is a list of cases for a single CASE label.  The double linked
+   list along the LEFT/RIGHT fields is used to detect overlap and to
+   build a table of the cases for SELECT constructs with a CHARACTER
+   case expression.  */
+
+typedef struct gfc_case
+{
+  /* Where we saw this case.  */
+  locus where;
+  int n;
+
+  /* Case range values.  If (low == high), it's a single value.  If one of
+     the labels is NULL, it's an unbounded case.  If both are NULL, this
+     represents the default case.  */
+  gfc_expr *low, *high;
+
+  /* Only used for SELECT TYPE.  */
+  gfc_typespec ts;
+
+  /* Next case label in the list of cases for a single CASE label.  */
+  struct gfc_case *next;
+
+  /* Used for detecting overlap, and for code generation.  */
+  struct gfc_case *left, *right;
+
+  /* True if this case label can never be matched.  */
+  int unreachable;
+}
+gfc_case;
+
+#define gfc_get_case() XCNEW (gfc_case)
+
+
+typedef struct
+{
+  gfc_expr *var, *start, *end, *step;
+}
+gfc_iterator;
+
+#define gfc_get_iterator() XCNEW (gfc_iterator)
+
+
+/* Allocation structure for ALLOCATE, DEALLOCATE and NULLIFY statements.  */
+
+typedef struct gfc_alloc
+{
+  gfc_expr *expr;
+  struct gfc_alloc *next;
+}
+gfc_alloc;
+
+#define gfc_get_alloc() XCNEW (gfc_alloc)
+
+
+typedef struct
+{
+  gfc_expr *unit, *file, *status, *access, *form, *recl,
+    *blank, *position, *action, *delim, *pad, *iostat, *iomsg, *convert,
+    *decimal, *encoding, *round, *sign, *asynchronous, *id, *newunit;
+  gfc_st_label *err;
+}
+gfc_open;
+
+
+typedef struct
+{
+  gfc_expr *unit, *status, *iostat, *iomsg;
+  gfc_st_label *err;
+}
+gfc_close;
+
+
+typedef struct
+{
+  gfc_expr *unit, *iostat, *iomsg;
+  gfc_st_label *err;
+}
+gfc_filepos;
+
+
+typedef struct
+{
+  gfc_expr *unit, *file, *iostat, *exist, *opened, *number, *named,
+    *name, *access, *sequential, *direct, *form, *formatted,
+    *unformatted, *recl, *nextrec, *blank, *position, *action, *read,
+    *write, *readwrite, *delim, *pad, *iolength, *iomsg, *convert, *strm_pos,
+    *asynchronous, *decimal, *encoding, *pending, *round, *sign, *size, *id,
+    *iqstream;
+
+  gfc_st_label *err;
+
+}
+gfc_inquire;
+
+
+typedef struct
+{
+  gfc_expr *unit, *iostat, *iomsg, *id;
+  gfc_st_label *err, *end, *eor;
+}
+gfc_wait;
+
+
+typedef struct
+{
+  gfc_expr *io_unit, *format_expr, *rec, *advance, *iostat, *size, *iomsg,
+	   *id, *pos, *asynchronous, *blank, *decimal, *delim, *pad, *round,
+	   *sign, *extra_comma, *dt_io_kind;
+
+  gfc_symbol *namelist;
+  /* A format_label of `format_asterisk' indicates the "*" format */
+  gfc_st_label *format_label;
+  gfc_st_label *err, *end, *eor;
+
+  locus eor_where, end_where, err_where;
+}
+gfc_dt;
+
+
+typedef struct gfc_forall_iterator
+{
+  gfc_expr *var, *start, *end, *stride;
+  struct gfc_forall_iterator *next;
+}
+gfc_forall_iterator;
+
+
+/* Linked list to store associations in an ASSOCIATE statement.  */
+
+typedef struct gfc_association_list
+{
+  struct gfc_association_list *next;
+
+  /* Whether this is association to a variable that can be changed; otherwise,
+     it's association to an expression and the name may not be used as
+     lvalue.  */
+  unsigned variable:1;
+
+  /* True if this struct is currently only linked to from a gfc_symbol rather
+     than as part of a real list in gfc_code->ext.block.assoc.  This may
+     happen for SELECT TYPE temporaries and must be considered
+     for memory handling.  */
+  unsigned dangling:1;
+
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_symtree *st; /* Symtree corresponding to name.  */
+  locus where;
+
+  gfc_expr *target;
+}
+gfc_association_list;
+#define gfc_get_association_list() XCNEW (gfc_association_list)
+
+
+/* Executable statements that fill gfc_code structures.  */
+typedef enum
+{
+  EXEC_NOP = 1, EXEC_END_NESTED_BLOCK, EXEC_END_BLOCK, EXEC_ASSIGN,
+  EXEC_LABEL_ASSIGN, EXEC_POINTER_ASSIGN, EXEC_CRITICAL, EXEC_ERROR_STOP,
+  EXEC_GOTO, EXEC_CALL, EXEC_COMPCALL, EXEC_ASSIGN_CALL, EXEC_RETURN,
+  EXEC_ENTRY, EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE, EXEC_INIT_ASSIGN,
+  EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_CONCURRENT, EXEC_DO_WHILE,
+  EXEC_SELECT, EXEC_BLOCK, EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT,
+  EXEC_CALL_PPC, EXEC_ALLOCATE, EXEC_DEALLOCATE, EXEC_END_PROCEDURE,
+  EXEC_SELECT_TYPE, EXEC_SYNC_ALL, EXEC_SYNC_MEMORY, EXEC_SYNC_IMAGES,
+  EXEC_OPEN, EXEC_CLOSE, EXEC_WAIT,
+  EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END,
+  EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH,
+  EXEC_LOCK, EXEC_UNLOCK,
+  EXEC_OMP_CRITICAL, EXEC_OMP_DO, EXEC_OMP_FLUSH, EXEC_OMP_MASTER,
+  EXEC_OMP_ORDERED, EXEC_OMP_PARALLEL, EXEC_OMP_PARALLEL_DO,
+  EXEC_OMP_PARALLEL_SECTIONS, EXEC_OMP_PARALLEL_WORKSHARE,
+  EXEC_OMP_SECTIONS, EXEC_OMP_SINGLE, EXEC_OMP_WORKSHARE,
+  EXEC_OMP_ATOMIC, EXEC_OMP_BARRIER, EXEC_OMP_END_NOWAIT,
+  EXEC_OMP_END_SINGLE, EXEC_OMP_TASK, EXEC_OMP_TASKWAIT,
+  EXEC_OMP_TASKYIELD
+}
+gfc_exec_op;
+
+typedef enum
+{
+  GFC_OMP_ATOMIC_UPDATE,
+  GFC_OMP_ATOMIC_READ,
+  GFC_OMP_ATOMIC_WRITE,
+  GFC_OMP_ATOMIC_CAPTURE
+}
+gfc_omp_atomic_op;
+
+typedef struct gfc_code
+{
+  gfc_exec_op op;
+
+  struct gfc_code *block, *next;
+  locus loc;
+
+  gfc_st_label *here, *label1, *label2, *label3;
+  gfc_symtree *symtree;
+  gfc_expr *expr1, *expr2, *expr3, *expr4;
+  /* A name isn't sufficient to identify a subroutine, we need the actual
+     symbol for the interface definition.
+  const char *sub_name;  */
+  gfc_symbol *resolved_sym;
+  gfc_intrinsic_sym *resolved_isym;
+
+  union
+  {
+    gfc_actual_arglist *actual;
+    gfc_iterator *iterator;
+
+    struct
+    {
+      gfc_typespec ts;
+      gfc_alloc *list;
+    }
+    alloc;
+
+    struct
+    {
+      gfc_namespace *ns;
+      gfc_association_list *assoc;
+      gfc_case *case_list;
+    }
+    block;
+
+    gfc_open *open;
+    gfc_close *close;
+    gfc_filepos *filepos;
+    gfc_inquire *inquire;
+    gfc_wait *wait;
+    gfc_dt *dt;
+    gfc_forall_iterator *forall_iterator;
+    struct gfc_code *which_construct;
+    int stop_code;
+    gfc_entry_list *entry;
+    gfc_omp_clauses *omp_clauses;
+    const char *omp_name;
+    gfc_namelist *omp_namelist;
+    bool omp_bool;
+    gfc_omp_atomic_op omp_atomic;
+  }
+  ext;		/* Points to additional structures required by statement */
+
+  /* Cycle and break labels in constructs.  */
+  tree cycle_label;
+  tree exit_label;
+}
+gfc_code;
+
+
+/* Storage for DATA statements.  */
+typedef struct gfc_data_variable
+{
+  gfc_expr *expr;
+  gfc_iterator iter;
+  struct gfc_data_variable *list, *next;
+}
+gfc_data_variable;
+
+
+typedef struct gfc_data_value
+{
+  mpz_t repeat;
+  gfc_expr *expr;
+  struct gfc_data_value *next;
+}
+gfc_data_value;
+
+
+typedef struct gfc_data
+{
+  gfc_data_variable *var;
+  gfc_data_value *value;
+  locus where;
+
+  struct gfc_data *next;
+}
+gfc_data;
+
+
+/* Structure for holding compile options */
+typedef struct
+{
+  char *module_dir;
+  gfc_source_form source_form;
+  /* Maximum line lengths in fixed- and free-form source, respectively.
+     When fixed_line_length or free_line_length are 0, the whole line is used,
+     regardless of length.
+
+     If the user requests a fixed_line_length <7 then gfc_init_options()
+     emits a fatal error.  */
+  int fixed_line_length;
+  int free_line_length;
+  /* Maximum number of continuation lines in fixed- and free-form source,
+     respectively.  */
+  int max_continue_fixed;
+  int max_continue_free;
+  int max_identifier_length;
+  int dump_fortran_original;
+  int dump_fortran_optimized;
+
+  int warn_aliasing;
+  int warn_ampersand;
+  int gfc_warn_conversion;
+  int warn_c_binding_type;
+  int warn_conversion_extra;
+  int warn_function_elimination;
+  int warn_implicit_interface;
+  int warn_implicit_procedure;
+  int warn_line_truncation;
+  int warn_surprising;
+  int warn_tabs;
+  int warn_underflow;
+  int warn_intrinsic_shadow;
+  int warn_intrinsics_std;
+  int warn_character_truncation;
+  int warn_array_temp;
+  int warn_align_commons;
+  int warn_real_q_constant;
+  int warn_unused_dummy_argument;
+  int warn_zerotrip;
+  int warn_realloc_lhs;
+  int warn_realloc_lhs_all;
+  int warn_compare_reals;
+  int warn_target_lifetime;
+  int max_errors;
+
+  int flag_all_intrinsics;
+  int flag_default_double;
+  int flag_default_integer;
+  int flag_default_real;
+  int flag_integer4_kind;
+  int flag_real4_kind;
+  int flag_real8_kind;
+  int flag_dollar_ok;
+  int flag_underscoring;
+  int flag_second_underscore;
+  int flag_implicit_none;
+  int flag_max_stack_var_size;
+  int flag_max_array_constructor;
+  int flag_range_check;
+  int flag_pack_derived;
+  int flag_repack_arrays;
+  int flag_preprocessed;
+  int flag_f2c;
+  int flag_automatic;
+  int flag_backslash;
+  int flag_backtrace;
+  int flag_allow_leading_underscore;
+  int flag_external_blas;
+  int blas_matmul_limit;
+  int flag_cray_pointer;
+  int flag_d_lines;
+  int gfc_flag_openmp;
+  int gfc_flag_openmp_simd;
+  int flag_sign_zero;
+  int flag_stack_arrays;
+  int flag_module_private;
+  int flag_recursive;
+  int flag_init_local_zero;
+  int flag_init_integer;
+  int flag_init_integer_value;
+  int flag_init_real;
+  int flag_init_logical;
+  int flag_init_character;
+  char flag_init_character_value;
+  int flag_align_commons;
+  int flag_protect_parens;
+  int flag_realloc_lhs;
+  int flag_aggressive_function_elimination;
+  int flag_frontend_optimize;
+
+  int fpe;
+  int fpe_summary;
+  int rtcheck;
+  gfc_fcoarray coarray;
+
+  int warn_std;
+  int allow_std;
+  int convert;
+  int record_marker;
+  int max_subrecord_length;
+}
+gfc_option_t;
+
+extern gfc_option_t gfc_option;
+
+/* Constructor nodes for array and structure constructors.  */
+typedef struct gfc_constructor
+{
+  gfc_constructor_base base;
+  mpz_t offset;               /* Offset within a constructor, used as
+				 key within base. */
+
+  gfc_expr *expr;
+  gfc_iterator *iterator;
+  locus where;
+
+  union
+  {
+     gfc_component *component; /* Record the component being initialized.  */
+  }
+  n;
+  mpz_t repeat; /* Record the repeat number of initial values in data
+		  statement like "data a/5*10/".  */
+}
+gfc_constructor;
+
+
+typedef struct iterator_stack
+{
+  gfc_symtree *variable;
+  mpz_t value;
+  struct iterator_stack *prev;
+}
+iterator_stack;
+extern iterator_stack *iter_stack;
+
+
+/* Used for (possibly nested) SELECT TYPE statements.  */
+typedef struct gfc_select_type_stack
+{
+  gfc_symbol *selector;			/* Current selector variable.  */
+  gfc_symtree *tmp;			/* Current temporary variable.  */
+  struct gfc_select_type_stack *prev;	/* Previous element on stack.  */
+}
+gfc_select_type_stack;
+extern gfc_select_type_stack *select_type_stack;
+#define gfc_get_select_type_stack() XCNEW (gfc_select_type_stack)
+
+
+/* Node in the linked list used for storing finalizer procedures.  */
+
+typedef struct gfc_finalizer
+{
+  struct gfc_finalizer* next;
+  locus where; /* Where the FINAL declaration occurred.  */
+
+  /* Up to resolution, we want the gfc_symbol, there we lookup the corresponding
+     symtree and later need only that.  This way, we can access and call the
+     finalizers from every context as they should be "always accessible".  I
+     don't make this a union because we need the information whether proc_sym is
+     still referenced or not for dereferencing it on deleting a gfc_finalizer
+     structure.  */
+  gfc_symbol*  proc_sym;
+  gfc_symtree* proc_tree;
+}
+gfc_finalizer;
+#define gfc_get_finalizer() XCNEW (gfc_finalizer)
+
+
+/************************ Function prototypes *************************/
+
+/* decl.c */
+bool gfc_in_match_data (void);
+match gfc_match_char_spec (gfc_typespec *);
+
+/* scanner.c */
+void gfc_scanner_done_1 (void);
+void gfc_scanner_init_1 (void);
+
+void gfc_add_include_path (const char *, bool, bool, bool);
+void gfc_add_intrinsic_modules_path (const char *);
+void gfc_release_include_path (void);
+FILE *gfc_open_included_file (const char *, bool, bool);
+
+int gfc_at_end (void);
+int gfc_at_eof (void);
+int gfc_at_bol (void);
+int gfc_at_eol (void);
+void gfc_advance_line (void);
+int gfc_check_include (void);
+int gfc_define_undef_line (void);
+
+int gfc_wide_is_printable (gfc_char_t);
+int gfc_wide_is_digit (gfc_char_t);
+int gfc_wide_fits_in_byte (gfc_char_t);
+gfc_char_t gfc_wide_tolower (gfc_char_t);
+gfc_char_t gfc_wide_toupper (gfc_char_t);
+size_t gfc_wide_strlen (const gfc_char_t *);
+int gfc_wide_strncasecmp (const gfc_char_t *, const char *, size_t);
+gfc_char_t *gfc_wide_memset (gfc_char_t *, gfc_char_t, size_t);
+char *gfc_widechar_to_char (const gfc_char_t *, int);
+gfc_char_t *gfc_char_to_widechar (const char *);
+
+#define gfc_get_wide_string(n) XCNEWVEC (gfc_char_t, n)
+
+void gfc_skip_comments (void);
+gfc_char_t gfc_next_char_literal (gfc_instring);
+gfc_char_t gfc_next_char (void);
+char gfc_next_ascii_char (void);
+gfc_char_t gfc_peek_char (void);
+char gfc_peek_ascii_char (void);
+void gfc_error_recovery (void);
+void gfc_gobble_whitespace (void);
+bool gfc_new_file (void);
+const char * gfc_read_orig_filename (const char *, const char **);
+
+extern gfc_source_form gfc_current_form;
+extern const char *gfc_source_file;
+extern locus gfc_current_locus;
+
+void gfc_start_source_files (void);
+void gfc_end_source_files (void);
+
+/* misc.c */
+void gfc_clear_ts (gfc_typespec *);
+FILE *gfc_open_file (const char *);
+const char *gfc_basic_typename (bt);
+const char *gfc_typename (gfc_typespec *);
+const char *gfc_op2string (gfc_intrinsic_op);
+const char *gfc_code2string (const mstring *, int);
+int gfc_string2code (const mstring *, const char *);
+const char *gfc_intent_string (sym_intent);
+
+void gfc_init_1 (void);
+void gfc_init_2 (void);
+void gfc_done_1 (void);
+void gfc_done_2 (void);
+
+int get_c_kind (const char *, CInteropKind_t *);
+
+/* options.c */
+unsigned int gfc_option_lang_mask (void);
+void gfc_init_options_struct (struct gcc_options *);
+void gfc_init_options (unsigned int,
+		       struct cl_decoded_option *);
+bool gfc_handle_option (size_t, const char *, int, int, location_t,
+			const struct cl_option_handlers *);
+bool gfc_post_options (const char **);
+char *gfc_get_option_string (void);
+
+/* f95-lang.c */
+void gfc_maybe_initialize_eh (void);
+
+/* iresolve.c */
+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_buffer_error (int);
+
+const char *gfc_print_wide_char (gfc_char_t);
+
+void gfc_warning (const char *, ...) ATTRIBUTE_GCC_GFC(1,2);
+void gfc_warning_now (const char *, ...) ATTRIBUTE_GCC_GFC(1,2);
+void gfc_clear_warning (void);
+void gfc_warning_check (void);
+
+void gfc_error (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);
+void gfc_clear_error (void);
+int gfc_error_check (void);
+int gfc_error_flag_test (void);
+
+notification gfc_notification_std (int);
+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));
+
+void gfc_push_error (gfc_error_buf *);
+void gfc_pop_error (gfc_error_buf *);
+void gfc_free_error (gfc_error_buf *);
+
+void gfc_get_errors (int *, int *);
+void gfc_errors_to_warnings (int);
+
+/* arith.c */
+void gfc_arith_init_1 (void);
+void gfc_arith_done_1 (void);
+arith gfc_check_integer_range (mpz_t p, int kind);
+bool gfc_check_character_range (gfc_char_t, int);
+
+/* trans-types.c */
+bool gfc_check_any_c_kind (gfc_typespec *);
+int gfc_validate_kind (bt, int, bool);
+int gfc_get_int_kind_from_width_isofortranenv (int size);
+int gfc_get_real_kind_from_width_isofortranenv (int size);
+tree gfc_get_derived_type (gfc_symbol * derived);
+extern int gfc_index_integer_kind;
+extern int gfc_default_integer_kind;
+extern int gfc_max_integer_kind;
+extern int gfc_default_real_kind;
+extern int gfc_default_double_kind;
+extern int gfc_default_character_kind;
+extern int gfc_default_logical_kind;
+extern int gfc_default_complex_kind;
+extern int gfc_c_int_kind;
+extern int gfc_atomic_int_kind;
+extern int gfc_atomic_logical_kind;
+extern int gfc_intio_kind;
+extern int gfc_charlen_int_kind;
+extern int gfc_numeric_storage_size;
+extern int gfc_character_storage_size;
+
+/* symbol.c */
+void gfc_clear_new_implicit (void);
+bool gfc_add_new_implicit_range (int, int);
+bool gfc_merge_new_implicit (gfc_typespec *);
+void gfc_set_implicit_none (void);
+void gfc_check_function_type (gfc_namespace *);
+bool gfc_is_intrinsic_typename (const char *);
+
+gfc_typespec *gfc_get_default_type (const char *, gfc_namespace *);
+bool gfc_set_default_type (gfc_symbol *, int, gfc_namespace *);
+
+void gfc_set_sym_referenced (gfc_symbol *);
+
+bool gfc_add_attribute (symbol_attribute *, locus *);
+bool gfc_add_ext_attribute (symbol_attribute *, ext_attr_id_t, locus *);
+bool gfc_add_allocatable (symbol_attribute *, locus *);
+bool gfc_add_codimension (symbol_attribute *, const char *, locus *);
+bool gfc_add_contiguous (symbol_attribute *, const char *, locus *);
+bool gfc_add_dimension (symbol_attribute *, const char *, locus *);
+bool gfc_add_external (symbol_attribute *, locus *);
+bool gfc_add_intrinsic (symbol_attribute *, locus *);
+bool gfc_add_optional (symbol_attribute *, locus *);
+bool gfc_add_pointer (symbol_attribute *, locus *);
+bool gfc_add_cray_pointer (symbol_attribute *, locus *);
+bool gfc_add_cray_pointee (symbol_attribute *, locus *);
+match gfc_mod_pointee_as (gfc_array_spec *);
+bool gfc_add_protected (symbol_attribute *, const char *, locus *);
+bool gfc_add_result (symbol_attribute *, const char *, locus *);
+bool gfc_add_save (symbol_attribute *, save_state, const char *, locus *);
+bool gfc_add_threadprivate (symbol_attribute *, const char *, locus *);
+bool gfc_add_saved_common (symbol_attribute *, locus *);
+bool gfc_add_target (symbol_attribute *, locus *);
+bool gfc_add_dummy (symbol_attribute *, const char *, locus *);
+bool gfc_add_generic (symbol_attribute *, const char *, locus *);
+bool gfc_add_common (symbol_attribute *, locus *);
+bool gfc_add_in_common (symbol_attribute *, const char *, locus *);
+bool gfc_add_in_equivalence (symbol_attribute *, const char *, locus *);
+bool gfc_add_data (symbol_attribute *, const char *, locus *);
+bool gfc_add_in_namelist (symbol_attribute *, const char *, locus *);
+bool gfc_add_sequence (symbol_attribute *, const char *, locus *);
+bool gfc_add_elemental (symbol_attribute *, locus *);
+bool gfc_add_pure (symbol_attribute *, locus *);
+bool gfc_add_recursive (symbol_attribute *, locus *);
+bool gfc_add_function (symbol_attribute *, const char *, locus *);
+bool gfc_add_subroutine (symbol_attribute *, const char *, locus *);
+bool gfc_add_volatile (symbol_attribute *, const char *, locus *);
+bool gfc_add_asynchronous (symbol_attribute *, const char *, locus *);
+bool gfc_add_proc (symbol_attribute *attr, const char *name, locus *where);
+bool gfc_add_abstract (symbol_attribute* attr, locus* where);
+
+bool gfc_add_access (symbol_attribute *, gfc_access, const char *, locus *);
+bool gfc_add_is_bind_c (symbol_attribute *, const char *, locus *, int);
+bool gfc_add_extension (symbol_attribute *, locus *);
+bool gfc_add_value (symbol_attribute *, const char *, locus *);
+bool gfc_add_flavor (symbol_attribute *, sym_flavor, const char *, locus *);
+bool gfc_add_entry (symbol_attribute *, const char *, locus *);
+bool gfc_add_procedure (symbol_attribute *, procedure_type,
+		       const char *, locus *);
+bool gfc_add_intent (symbol_attribute *, sym_intent, locus *);
+bool gfc_add_explicit_interface (gfc_symbol *, ifsrc,
+				gfc_formal_arglist *, locus *);
+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 *);
+
+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 *);
+gfc_component *gfc_find_component (gfc_symbol *, const char *, bool, bool);
+
+gfc_st_label *gfc_get_st_label (int);
+void gfc_free_st_label (gfc_st_label *);
+void gfc_define_st_label (gfc_st_label *, gfc_sl_type, locus *);
+bool gfc_reference_st_label (gfc_st_label *, gfc_sl_type);
+
+gfc_namespace *gfc_get_namespace (gfc_namespace *, int);
+gfc_symtree *gfc_new_symtree (gfc_symtree **, const char *);
+gfc_symtree *gfc_find_symtree (gfc_symtree *, const char *);
+void gfc_delete_symtree (gfc_symtree **, const char *);
+gfc_symtree *gfc_get_unique_symtree (gfc_namespace *);
+gfc_user_op *gfc_get_uop (const char *);
+gfc_user_op *gfc_find_uop (const char *, gfc_namespace *);
+void gfc_free_symbol (gfc_symbol *);
+void gfc_release_symbol (gfc_symbol *);
+gfc_symbol *gfc_new_symbol (const char *, gfc_namespace *);
+gfc_symtree* gfc_find_symtree_in_proc (const char *, gfc_namespace *);
+int gfc_find_symbol (const char *, gfc_namespace *, int, gfc_symbol **);
+int gfc_find_sym_tree (const char *, gfc_namespace *, int, gfc_symtree **);
+int gfc_get_symbol (const char *, gfc_namespace *, gfc_symbol **);
+bool gfc_verify_c_interop (gfc_typespec *);
+bool gfc_verify_c_interop_param (gfc_symbol *);
+bool verify_bind_c_sym (gfc_symbol *, gfc_typespec *, int, gfc_common_head *);
+bool verify_bind_c_derived_type (gfc_symbol *);
+bool verify_com_block_vars_c_interop (gfc_common_head *);
+gfc_symtree *generate_isocbinding_symbol (const char *, iso_c_binding_symbol,
+					  const char *, gfc_symtree *, bool);
+int gfc_get_sym_tree (const char *, gfc_namespace *, gfc_symtree **, bool);
+int gfc_get_ha_symbol (const char *, gfc_symbol **);
+int gfc_get_ha_sym_tree (const char *, gfc_symtree **);
+
+void gfc_new_undo_checkpoint (gfc_undo_change_set &);
+void gfc_drop_last_undo_checkpoint (void);
+void gfc_restore_last_undo_checkpoint (void);
+void gfc_undo_symbols (void);
+void gfc_commit_symbols (void);
+void gfc_commit_symbol (gfc_symbol *);
+gfc_charlen *gfc_new_charlen (gfc_namespace *, gfc_charlen *);
+void gfc_free_charlen (gfc_charlen *, gfc_charlen *);
+void gfc_free_namespace (gfc_namespace *);
+
+void gfc_symbol_init_2 (void);
+void gfc_symbol_done_2 (void);
+
+void gfc_traverse_symtree (gfc_symtree *, void (*)(gfc_symtree *));
+void gfc_traverse_ns (gfc_namespace *, void (*)(gfc_symbol *));
+void gfc_traverse_user_op (gfc_namespace *, void (*)(gfc_user_op *));
+void gfc_save_all (gfc_namespace *);
+
+void gfc_enforce_clean_symbol_state (void);
+void gfc_free_dt_list (void);
+
+
+gfc_gsymbol *gfc_get_gsymbol (const char *);
+gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);
+
+gfc_typebound_proc* gfc_get_typebound_proc (gfc_typebound_proc*);
+gfc_symbol* gfc_get_derived_super_type (gfc_symbol*);
+gfc_symbol* gfc_get_ultimate_derived_super_type (gfc_symbol*);
+bool gfc_type_is_extension_of (gfc_symbol *, gfc_symbol *);
+bool gfc_type_compatible (gfc_typespec *, gfc_typespec *);
+
+void gfc_copy_formal_args_intr (gfc_symbol *, gfc_intrinsic_sym *);
+
+void gfc_free_finalizer (gfc_finalizer *el); /* Needed in resolve.c, too  */
+
+bool gfc_check_symbol_typed (gfc_symbol*, gfc_namespace*, bool, locus);
+gfc_namespace* gfc_find_proc_namespace (gfc_namespace*);
+
+bool gfc_is_associate_pointer (gfc_symbol*);
+gfc_symbol * gfc_find_dt_in_generic (gfc_symbol *);
+gfc_formal_arglist *gfc_sym_get_dummy_args (gfc_symbol *);
+
+/* intrinsic.c -- true if working in an init-expr, false otherwise.  */
+extern bool gfc_init_expr_flag;
+
+/* Given a symbol that we have decided is intrinsic, mark it as such
+   by placing it into a special module that is otherwise impossible to
+   read or write.  */
+
+#define gfc_intrinsic_symbol(SYM) SYM->module = gfc_get_string ("(intrinsic)")
+
+void gfc_intrinsic_init_1 (void);
+void gfc_intrinsic_done_1 (void);
+
+char gfc_type_letter (bt);
+gfc_symbol * gfc_get_intrinsic_sub_symbol (const char *);
+bool gfc_convert_type (gfc_expr *, gfc_typespec *, int);
+bool gfc_convert_type_warn (gfc_expr *, gfc_typespec *, int, int);
+bool gfc_convert_chartype (gfc_expr *, gfc_typespec *);
+int gfc_generic_intrinsic (const char *);
+int gfc_specific_intrinsic (const char *);
+bool gfc_is_intrinsic (gfc_symbol*, int, locus);
+int gfc_intrinsic_actual_ok (const char *, const bool);
+gfc_intrinsic_sym *gfc_find_function (const char *);
+gfc_intrinsic_sym *gfc_find_subroutine (const char *);
+gfc_intrinsic_sym *gfc_intrinsic_function_by_id (gfc_isym_id);
+gfc_intrinsic_sym *gfc_intrinsic_subroutine_by_id (gfc_isym_id);
+gfc_isym_id gfc_isym_id_by_intmod (intmod_id, int);
+gfc_isym_id gfc_isym_id_by_intmod_sym (gfc_symbol *);
+
+
+match gfc_intrinsic_func_interface (gfc_expr *, int);
+match gfc_intrinsic_sub_interface (gfc_code *, int);
+
+void gfc_warn_intrinsic_shadow (const gfc_symbol*, bool, bool);
+bool gfc_check_intrinsic_standard (const gfc_intrinsic_sym*, const char**,
+				      bool, locus);
+
+/* match.c -- FIXME */
+void gfc_free_iterator (gfc_iterator *, int);
+void gfc_free_forall_iterator (gfc_forall_iterator *);
+void gfc_free_alloc_list (gfc_alloc *);
+void gfc_free_namelist (gfc_namelist *);
+void gfc_free_equiv (gfc_equiv *);
+void gfc_free_equiv_until (gfc_equiv *, gfc_equiv *);
+void gfc_free_data (gfc_data *);
+void gfc_free_case_list (gfc_case *);
+
+/* matchexp.c -- FIXME too?  */
+gfc_expr *gfc_get_parentheses (gfc_expr *);
+
+/* openmp.c */
+struct gfc_omp_saved_state { void *ptrs[2]; int ints[1]; };
+void gfc_free_omp_clauses (gfc_omp_clauses *);
+void gfc_resolve_omp_directive (gfc_code *, gfc_namespace *);
+void gfc_resolve_do_iterator (gfc_code *, gfc_symbol *);
+void gfc_resolve_omp_parallel_blocks (gfc_code *, gfc_namespace *);
+void gfc_resolve_omp_do_blocks (gfc_code *, gfc_namespace *);
+void gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *);
+void gfc_omp_restore_state (struct gfc_omp_saved_state *);
+
+/* expr.c */
+void gfc_free_actual_arglist (gfc_actual_arglist *);
+gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *);
+const char *gfc_extract_int (gfc_expr *, int *);
+bool is_subref_array (gfc_expr *);
+bool gfc_is_simply_contiguous (gfc_expr *, bool);
+bool gfc_check_init_expr (gfc_expr *);
+
+gfc_expr *gfc_build_conversion (gfc_expr *);
+void gfc_free_ref_list (gfc_ref *);
+void gfc_type_convert_binary (gfc_expr *, int);
+int gfc_is_constant_expr (gfc_expr *);
+bool gfc_simplify_expr (gfc_expr *, int);
+int gfc_has_vector_index (gfc_expr *);
+
+gfc_expr *gfc_get_expr (void);
+gfc_expr *gfc_get_array_expr (bt type, int kind, locus *);
+gfc_expr *gfc_get_null_expr (locus *);
+gfc_expr *gfc_get_operator_expr (locus *, gfc_intrinsic_op,gfc_expr *, gfc_expr *);
+gfc_expr *gfc_get_structure_constructor_expr (bt, int, locus *);
+gfc_expr *gfc_get_constant_expr (bt, int, locus *);
+gfc_expr *gfc_get_character_expr (int, locus *, const char *, int len);
+gfc_expr *gfc_get_int_expr (int, locus *, int);
+gfc_expr *gfc_get_logical_expr (int, locus *, bool);
+gfc_expr *gfc_get_iokind_expr (locus *, io_kind);
+
+void gfc_clear_shape (mpz_t *shape, int rank);
+void gfc_free_shape (mpz_t **shape, int rank);
+void gfc_free_expr (gfc_expr *);
+void gfc_replace_expr (gfc_expr *, gfc_expr *);
+mpz_t *gfc_copy_shape (mpz_t *, int);
+mpz_t *gfc_copy_shape_excluding (mpz_t *, int, gfc_expr *);
+gfc_expr *gfc_copy_expr (gfc_expr *);
+gfc_ref* gfc_copy_ref (gfc_ref*);
+
+bool gfc_specification_expr (gfc_expr *);
+
+int gfc_numeric_ts (gfc_typespec *);
+int gfc_kind_max (gfc_expr *, gfc_expr *);
+
+bool gfc_check_conformance (gfc_expr *, gfc_expr *, const char *, ...) ATTRIBUTE_PRINTF_3;
+bool gfc_check_assign (gfc_expr *, gfc_expr *, int);
+bool gfc_check_pointer_assign (gfc_expr *, gfc_expr *);
+bool gfc_check_assign_symbol (gfc_symbol *, gfc_component *, gfc_expr *);
+
+bool gfc_has_default_initializer (gfc_symbol *);
+gfc_expr *gfc_default_initializer (gfc_typespec *);
+gfc_expr *gfc_get_variable_expr (gfc_symtree *);
+void gfc_add_full_array_ref (gfc_expr *, gfc_array_spec *);
+gfc_expr * gfc_lval_expr_from_sym (gfc_symbol *);
+
+gfc_array_spec *gfc_get_full_arrayspec_from_expr (gfc_expr *expr);
+
+bool gfc_traverse_expr (gfc_expr *, gfc_symbol *,
+			bool (*)(gfc_expr *, gfc_symbol *, int*),
+			int);
+void gfc_expr_set_symbols_referenced (gfc_expr *);
+bool gfc_expr_check_typed (gfc_expr*, gfc_namespace*, bool);
+
+gfc_component * gfc_get_proc_ptr_comp (gfc_expr *);
+bool gfc_is_proc_ptr_comp (gfc_expr *);
+
+bool gfc_ref_this_image (gfc_ref *ref);
+bool gfc_is_coindexed (gfc_expr *);
+bool gfc_is_coarray (gfc_expr *);
+int gfc_get_corank (gfc_expr *);
+bool gfc_has_ultimate_allocatable (gfc_expr *);
+bool gfc_has_ultimate_pointer (gfc_expr *);
+
+gfc_expr* gfc_build_intrinsic_call (gfc_namespace *, gfc_isym_id, const char*,
+				    locus, unsigned, ...);
+bool gfc_check_vardef_context (gfc_expr*, bool, bool, bool, const char*);
+
+
+/* st.c */
+extern gfc_code new_st;
+
+void gfc_clear_new_st (void);
+gfc_code *gfc_get_code (gfc_exec_op);
+gfc_code *gfc_append_code (gfc_code *, gfc_code *);
+void gfc_free_statement (gfc_code *);
+void gfc_free_statements (gfc_code *);
+void gfc_free_association_list (gfc_association_list *);
+
+/* resolve.c */
+bool gfc_resolve_expr (gfc_expr *);
+void gfc_resolve (gfc_namespace *);
+void gfc_resolve_blocks (gfc_code *, gfc_namespace *);
+int gfc_impure_variable (gfc_symbol *);
+int gfc_pure (gfc_symbol *);
+int gfc_implicit_pure (gfc_symbol *);
+void gfc_unset_implicit_pure (gfc_symbol *);
+int gfc_elemental (gfc_symbol *);
+bool gfc_resolve_iterator (gfc_iterator *, bool, bool);
+bool find_forall_index (gfc_expr *, gfc_symbol *, int);
+bool gfc_resolve_index (gfc_expr *, int);
+bool gfc_resolve_dim_arg (gfc_expr *);
+int gfc_is_formal_arg (void);
+void gfc_resolve_substring_charlen (gfc_expr *);
+match gfc_iso_c_sub_interface(gfc_code *, gfc_symbol *);
+gfc_expr *gfc_expr_to_initialize (gfc_expr *);
+bool gfc_type_is_extensible (gfc_symbol *);
+bool gfc_resolve_intrinsic (gfc_symbol *, locus *);
+bool gfc_explicit_interface_required (gfc_symbol *, char *, int);
+extern int gfc_do_concurrent_flag;
+
+
+/* array.c */
+gfc_iterator *gfc_copy_iterator (gfc_iterator *);
+
+void gfc_free_array_spec (gfc_array_spec *);
+gfc_array_ref *gfc_copy_array_ref (gfc_array_ref *);
+
+bool gfc_set_array_spec (gfc_symbol *, gfc_array_spec *, locus *);
+gfc_array_spec *gfc_copy_array_spec (gfc_array_spec *);
+bool gfc_resolve_array_spec (gfc_array_spec *, int);
+
+int gfc_compare_array_spec (gfc_array_spec *, gfc_array_spec *);
+
+void gfc_simplify_iterator_var (gfc_expr *);
+bool gfc_expand_constructor (gfc_expr *, bool);
+int gfc_constant_ac (gfc_expr *);
+int gfc_expanded_ac (gfc_expr *);
+bool gfc_resolve_character_array_constructor (gfc_expr *);
+bool gfc_resolve_array_constructor (gfc_expr *);
+bool gfc_check_constructor_type (gfc_expr *);
+bool gfc_check_iter_variable (gfc_expr *);
+bool gfc_check_constructor (gfc_expr *, bool (*)(gfc_expr *));
+bool gfc_array_size (gfc_expr *, mpz_t *);
+bool gfc_array_dimen_size (gfc_expr *, int, mpz_t *);
+bool gfc_array_ref_shape (gfc_array_ref *, mpz_t *);
+gfc_array_ref *gfc_find_array_ref (gfc_expr *);
+tree gfc_conv_array_initializer (tree type, gfc_expr *);
+bool spec_size (gfc_array_spec *, mpz_t *);
+bool spec_dimen_size (gfc_array_spec *, int, mpz_t *);
+int gfc_is_compile_time_shape (gfc_array_spec *);
+
+bool gfc_ref_dimen_size (gfc_array_ref *, int dimen, mpz_t *, mpz_t *);
+
+
+/* interface.c -- FIXME: some of these should be in symbol.c */
+void gfc_free_interface (gfc_interface *);
+int gfc_compare_derived_types (gfc_symbol *, gfc_symbol *);
+int gfc_compare_types (gfc_typespec *, gfc_typespec *);
+int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, const char *, int, int,
+			    char *, int, const char *, const char *);
+void gfc_check_interfaces (gfc_namespace *);
+bool gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *);
+void gfc_ppc_use (gfc_component *, gfc_actual_arglist **, locus *);
+gfc_symbol *gfc_search_interface (gfc_interface *, int,
+				  gfc_actual_arglist **);
+match gfc_extend_expr (gfc_expr *);
+void gfc_free_formal_arglist (gfc_formal_arglist *);
+bool gfc_extend_assign (gfc_code *, gfc_namespace *);
+bool gfc_check_new_interface (gfc_interface *, gfc_symbol *, locus);
+bool gfc_add_interface (gfc_symbol *);
+gfc_interface *gfc_current_interface_head (void);
+void gfc_set_current_interface_head (gfc_interface *);
+gfc_symtree* gfc_find_sym_in_symtree (gfc_symbol*);
+bool gfc_arglist_matches_symbol (gfc_actual_arglist**, gfc_symbol*);
+bool gfc_check_operator_interface (gfc_symbol*, gfc_intrinsic_op, locus);
+int gfc_has_vector_subscript (gfc_expr*);
+gfc_intrinsic_op gfc_equivalent_op (gfc_intrinsic_op);
+bool gfc_check_typebound_override (gfc_symtree*, gfc_symtree*);
+
+/* io.c */
+extern gfc_st_label format_asterisk;
+
+void gfc_free_open (gfc_open *);
+bool gfc_resolve_open (gfc_open *);
+void gfc_free_close (gfc_close *);
+bool gfc_resolve_close (gfc_close *);
+void gfc_free_filepos (gfc_filepos *);
+bool gfc_resolve_filepos (gfc_filepos *);
+void gfc_free_inquire (gfc_inquire *);
+bool gfc_resolve_inquire (gfc_inquire *);
+void gfc_free_dt (gfc_dt *);
+bool gfc_resolve_dt (gfc_dt *, locus *);
+void gfc_free_wait (gfc_wait *);
+bool gfc_resolve_wait (gfc_wait *);
+
+/* module.c */
+void gfc_module_init_2 (void);
+void gfc_module_done_2 (void);
+void gfc_dump_module (const char *, int);
+bool gfc_check_symbol_access (gfc_symbol *);
+void gfc_free_use_stmts (gfc_use_list *);
+
+/* primary.c */
+symbol_attribute gfc_variable_attr (gfc_expr *, gfc_typespec *);
+symbol_attribute gfc_expr_attr (gfc_expr *);
+match gfc_match_rvalue (gfc_expr **);
+match gfc_match_varspec (gfc_expr*, int, bool, bool);
+int gfc_check_digit (char, int);
+bool gfc_is_function_return_value (gfc_symbol *, gfc_namespace *);
+bool gfc_convert_to_structure_constructor (gfc_expr *, gfc_symbol *,
+					      gfc_expr **,
+					      gfc_actual_arglist **, bool);
+
+/* trans.c */
+void gfc_generate_code (gfc_namespace *);
+void gfc_generate_module_code (gfc_namespace *);
+void gfc_init_coarray_decl (bool);
+
+/* trans-intrinsic.c */
+bool gfc_inline_intrinsic_function_p (gfc_expr *);
+
+/* bbt.c */
+typedef int (*compare_fn) (void *, void *);
+void gfc_insert_bbt (void *, void *, compare_fn);
+void gfc_delete_bbt (void *, void *, compare_fn);
+
+/* dump-parse-tree.c */
+void gfc_dump_parse_tree (gfc_namespace *, FILE *);
+
+/* parse.c */
+bool gfc_parse_file (void);
+void gfc_global_used (gfc_gsymbol *, locus *);
+gfc_namespace* gfc_build_block_ns (gfc_namespace *);
+
+/* dependency.c */
+int gfc_dep_compare_functions (gfc_expr *, gfc_expr *, bool);
+int gfc_dep_compare_expr (gfc_expr *, gfc_expr *);
+bool gfc_dep_difference (gfc_expr *, gfc_expr *, mpz_t *);
+
+/* check.c */
+bool gfc_check_same_strlen (const gfc_expr*, const gfc_expr*, const char*);
+bool gfc_calculate_transfer_sizes (gfc_expr*, gfc_expr*, gfc_expr*,
+				      size_t*, size_t*, size_t*);
+
+/* class.c */
+void gfc_fix_class_refs (gfc_expr *e);
+void gfc_add_component_ref (gfc_expr *, const char *);
+void gfc_add_class_array_ref (gfc_expr *);
+#define gfc_add_data_component(e)     gfc_add_component_ref(e,"_data")
+#define gfc_add_vptr_component(e)     gfc_add_component_ref(e,"_vptr")
+#define gfc_add_hash_component(e)     gfc_add_component_ref(e,"_hash")
+#define gfc_add_size_component(e)     gfc_add_component_ref(e,"_size")
+#define gfc_add_def_init_component(e) gfc_add_component_ref(e,"_def_init")
+#define gfc_add_final_component(e)    gfc_add_component_ref(e,"_final")
+bool gfc_is_class_array_ref (gfc_expr *, bool *);
+bool gfc_is_class_scalar_expr (gfc_expr *);
+bool gfc_is_class_container_ref (gfc_expr *e);
+gfc_expr *gfc_class_initializer (gfc_typespec *, gfc_expr *);
+unsigned int gfc_hash_value (gfc_symbol *);
+bool gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
+			     gfc_array_spec **);
+gfc_symbol *gfc_find_derived_vtab (gfc_symbol *);
+gfc_symbol *gfc_find_vtab (gfc_typespec *);
+gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, bool*,
+				      const char*, bool, locus*);
+gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, bool*,
+					 const char*, bool, locus*);
+gfc_typebound_proc* gfc_find_typebound_intrinsic_op (gfc_symbol*, bool*,
+						     gfc_intrinsic_op, bool,
+						     locus*);
+gfc_symtree* gfc_get_tbp_symtree (gfc_symtree**, const char*);
+bool gfc_is_finalizable (gfc_symbol *, gfc_expr **);
+
+#define CLASS_DATA(sym) sym->ts.u.derived->components
+#define UNLIMITED_POLY(sym) \
+	(sym != NULL && sym->ts.type == BT_CLASS \
+	 && CLASS_DATA (sym) \
+	 && CLASS_DATA (sym)->ts.u.derived \
+	 && CLASS_DATA (sym)->ts.u.derived->attr.unlimited_polymorphic)
+
+/* frontend-passes.c */
+
+void gfc_run_passes (gfc_namespace *);
+
+typedef int (*walk_code_fn_t) (gfc_code **, int *, void *);
+typedef int (*walk_expr_fn_t) (gfc_expr **, int *, void *);
+
+int gfc_expr_walker (gfc_expr **, walk_expr_fn_t, void *);
+int gfc_code_walker (gfc_code **, walk_code_fn_t, walk_expr_fn_t, void *);
+
+#endif /* GCC_GFORTRAN_H  */
diff --git a/gcc-4.9/gcc/fortran/gfortran.texi b/gcc-4.9/gcc/fortran/gfortran.texi
new file mode 100644
index 000000000..725ee8dfc
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/gfortran.texi
@@ -0,0 +1,3423 @@
+\input texinfo  @c -*-texinfo-*-
+@c %**start of header
+@setfilename gfortran.info
+@set copyrights-gfortran 1999-2014
+
+@include gcc-common.texi
+
+@settitle The GNU Fortran Compiler
+
+@c Create a separate index for command line options
+@defcodeindex op
+@c Merge the standard indexes into a single one.
+@syncodeindex fn cp
+@syncodeindex vr cp
+@syncodeindex ky cp
+@syncodeindex pg cp
+@syncodeindex tp cp
+
+@c TODO: The following "Part" definitions are included here temporarily
+@c until they are incorporated into the official Texinfo distribution.
+@c They borrow heavily from Texinfo's \unnchapentry definitions.
+
+@tex
+\gdef\part#1#2{%
+  \pchapsepmacro
+  \gdef\thischapter{}
+  \begingroup
+    \vglue\titlepagetopglue
+    \titlefonts \rm
+    \leftline{Part #1:@* #2}
+    \vskip4pt \hrule height 4pt width \hsize \vskip4pt
+  \endgroup
+  \writetocentry{part}{#2}{#1}
+}
+\gdef\blankpart{%
+  \writetocentry{blankpart}{}{}
+}
+% Part TOC-entry definition for summary contents.
+\gdef\dosmallpartentry#1#2#3#4{%
+  \vskip .5\baselineskip plus.2\baselineskip
+  \begingroup
+    \let\rm=\bf \rm
+    \tocentry{Part #2: #1}{\doshortpageno\bgroup#4\egroup}
+  \endgroup
+}
+\gdef\dosmallblankpartentry#1#2#3#4{%
+  \vskip .5\baselineskip plus.2\baselineskip
+}
+% Part TOC-entry definition for regular contents.  This has to be
+% equated to an existing entry to not cause problems when the PDF
+% outline is created.
+\gdef\dopartentry#1#2#3#4{%
+  \unnchapentry{Part #2: #1}{}{#3}{#4}
+}
+\gdef\doblankpartentry#1#2#3#4{}
+@end tex
+
+@c %**end of header
+
+@c Use with @@smallbook.
+
+@c %** start of document
+
+@c Cause even numbered pages to be printed on the left hand side of
+@c the page and odd numbered pages to be printed on the right hand
+@c side of the page.  Using this, you can print on both sides of a
+@c sheet of paper and have the text on the same part of the sheet.
+
+@c The text on right hand pages is pushed towards the right hand
+@c margin and the text on left hand pages is pushed toward the left
+@c hand margin.
+@c (To provide the reverse effect, set bindingoffset to -0.75in.)
+
+@c @tex
+@c \global\bindingoffset=0.75in
+@c \global\normaloffset =0.75in
+@c @end tex
+
+@copying
+Copyright @copyright{} @value{copyrights-gfortran} Free Software Foundation, Inc.
+
+Permission is granted to copy, distribute and/or modify this document
+under the terms of the GNU Free Documentation License, Version 1.3 or
+any later version published by the Free Software Foundation; with the
+Invariant Sections being ``Funding Free Software'', the Front-Cover
+Texts being (a) (see below), and with the Back-Cover Texts being (b)
+(see below).  A copy of the license is included in the section entitled
+``GNU Free Documentation License''.
+
+(a) The FSF's Front-Cover Text is:
+
+     A GNU Manual
+
+(b) The FSF's Back-Cover Text is:
+
+     You have freedom to copy and modify this GNU Manual, like GNU
+     software.  Copies published by the Free Software Foundation raise
+     funds for GNU development.
+@end copying
+
+@ifinfo
+@dircategory Software development
+@direntry
+* gfortran: (gfortran).                  The GNU Fortran Compiler.
+@end direntry
+This file documents the use and the internals of
+the GNU Fortran compiler, (@command{gfortran}).
+
+Published by the Free Software Foundation
+51 Franklin Street, Fifth Floor
+Boston, MA 02110-1301 USA
+
+@insertcopying
+@end ifinfo
+
+
+@setchapternewpage odd
+@titlepage
+@title Using GNU Fortran
+@versionsubtitle
+@author The @t{gfortran} team
+@page
+@vskip 0pt plus 1filll
+Published by the Free Software Foundation@*
+51 Franklin Street, Fifth Floor@*
+Boston, MA 02110-1301, USA@*
+@c Last printed ??ber, 19??.@*
+@c Printed copies are available for $? each.@*
+@c ISBN ???
+@sp 1
+@insertcopying
+@end titlepage
+
+@c TODO: The following "Part" definitions are included here temporarily
+@c until they are incorporated into the official Texinfo distribution.
+
+@tex
+\global\let\partentry=\dosmallpartentry
+\global\let\blankpartentry=\dosmallblankpartentry
+@end tex
+@summarycontents
+
+@tex
+\global\let\partentry=\dopartentry
+\global\let\blankpartentry=\doblankpartentry
+@end tex
+@contents
+
+@page
+
+@c ---------------------------------------------------------------------
+@c TexInfo table of contents.
+@c ---------------------------------------------------------------------
+
+@ifnottex
+@node Top
+@top Introduction
+@cindex Introduction
+
+This manual documents the use of @command{gfortran}, 
+the GNU Fortran compiler.  You can find in this manual how to invoke
+@command{gfortran}, as well as its features and incompatibilities.
+
+@ifset DEVELOPMENT
+@emph{Warning:} This document, and the compiler it describes, are still
+under development.  While efforts are made to keep it up-to-date, it might
+not accurately reflect the status of the most recent GNU Fortran compiler.
+@end ifset
+
+@comment
+@comment  When you add a new menu item, please keep the right hand
+@comment  aligned to the same column.  Do not use tabs.  This provides
+@comment  better formatting.
+@comment
+@menu
+* Introduction::
+
+Part I: Invoking GNU Fortran
+* Invoking GNU Fortran:: Command options supported by @command{gfortran}.
+* Runtime::              Influencing runtime behavior with environment variables.
+
+Part II: Language Reference
+* Fortran 2003 and 2008 status::  Fortran 2003 and 2008 features supported by GNU Fortran.
+* Compiler Characteristics::      User-visible implementation details.
+* Extensions::                    Language extensions implemented by GNU Fortran.
+* Mixed-Language Programming::    Interoperability with C
+* Intrinsic Procedures:: Intrinsic procedures supported by GNU Fortran.
+* Intrinsic Modules::    Intrinsic modules supported by GNU Fortran.
+
+* Contributing::         How you can help.
+* Copying::              GNU General Public License says
+                         how you can copy and share GNU Fortran.
+* GNU Free Documentation License::
+                         How you can copy and share this manual.
+* Funding::              How to help assure continued work for free software.
+* Option Index::         Index of command line options
+* Keyword Index::        Index of concepts
+@end menu
+@end ifnottex
+
+@c ---------------------------------------------------------------------
+@c Introduction
+@c ---------------------------------------------------------------------
+
+@node Introduction
+@chapter Introduction
+
+@c The following duplicates the text on the TexInfo table of contents.
+@iftex
+This manual documents the use of @command{gfortran}, the GNU Fortran
+compiler.  You can find in this manual how to invoke @command{gfortran},
+as well as its features and incompatibilities.
+
+@ifset DEVELOPMENT
+@emph{Warning:} This document, and the compiler it describes, are still
+under development.  While efforts are made to keep it up-to-date, it
+might not accurately reflect the status of the most recent GNU Fortran
+compiler.
+@end ifset
+@end iftex
+
+The GNU Fortran compiler front end was
+designed initially as a free replacement for,
+or alternative to, the Unix @command{f95} command;
+@command{gfortran} is the command you will use to invoke the compiler.
+
+@menu
+* About GNU Fortran::    What you should know about the GNU Fortran compiler.
+* GNU Fortran and GCC::  You can compile Fortran, C, or other programs.
+* Preprocessing and conditional compilation:: The Fortran preprocessor
+* GNU Fortran and G77::  Why we chose to start from scratch.
+* Project Status::       Status of GNU Fortran, roadmap, proposed extensions.
+* Standards::            Standards supported by GNU Fortran.
+@end menu
+
+
+@c ---------------------------------------------------------------------
+@c About GNU Fortran
+@c ---------------------------------------------------------------------
+
+@node About GNU Fortran
+@section About GNU Fortran
+
+The GNU Fortran compiler supports the Fortran 77, 90 and 95 standards
+completely, parts of the Fortran 2003 and Fortran 2008 standards, and
+several vendor extensions.  The development goal is to provide the
+following features:
+
+@itemize @bullet
+@item
+Read a user's program,
+stored in a file and containing instructions written
+in Fortran 77, Fortran 90, Fortran 95, Fortran 2003 or Fortran 2008.
+This file contains @dfn{source code}.
+
+@item
+Translate the user's program into instructions a computer
+can carry out more quickly than it takes to translate the
+instructions in the first
+place.  The result after compilation of a program is
+@dfn{machine code},
+code designed to be efficiently translated and processed
+by a machine such as your computer.
+Humans usually are not as good writing machine code
+as they are at writing Fortran (or C++, Ada, or Java),
+because it is easy to make tiny mistakes writing machine code.
+
+@item
+Provide the user with information about the reasons why
+the compiler is unable to create a binary from the source code.
+Usually this will be the case if the source code is flawed.
+The Fortran 90 standard requires that the compiler can point out
+mistakes to the user.
+An incorrect usage of the language causes an @dfn{error message}.
+
+The compiler will also attempt to diagnose cases where the
+user's program contains a correct usage of the language,
+but instructs the computer to do something questionable.
+This kind of diagnostics message is called a @dfn{warning message}.
+
+@item
+Provide optional information about the translation passes
+from the source code to machine code.
+This can help a user of the compiler to find the cause of
+certain bugs which may not be obvious in the source code,
+but may be more easily found at a lower level compiler output.
+It also helps developers to find bugs in the compiler itself.
+
+@item
+Provide information in the generated machine code that can
+make it easier to find bugs in the program (using a debugging tool,
+called a @dfn{debugger}, such as the GNU Debugger @command{gdb}). 
+
+@item
+Locate and gather machine code already generated to
+perform actions requested by statements in the user's program.
+This machine code is organized into @dfn{modules} and is located
+and @dfn{linked} to the user program. 
+@end itemize
+
+The GNU Fortran compiler consists of several components:
+
+@itemize @bullet
+@item
+A version of the @command{gcc} command
+(which also might be installed as the system's @command{cc} command)
+that also understands and accepts Fortran source code.
+The @command{gcc} command is the @dfn{driver} program for
+all the languages in the GNU Compiler Collection (GCC);
+With @command{gcc},
+you can compile the source code of any language for
+which a front end is available in GCC.
+
+@item
+The @command{gfortran} command itself,
+which also might be installed as the
+system's @command{f95} command.
+@command{gfortran} is just another driver program,
+but specifically for the Fortran compiler only.
+The difference with @command{gcc} is that @command{gfortran}
+will automatically link the correct libraries to your program.
+
+@item
+A collection of run-time libraries.
+These libraries contain the machine code needed to support
+capabilities of the Fortran language that are not directly
+provided by the machine code generated by the
+@command{gfortran} compilation phase,
+such as intrinsic functions and subroutines,
+and routines for interaction with files and the operating system.
+@c and mechanisms to spawn,
+@c unleash and pause threads in parallelized code.
+
+@item
+The Fortran compiler itself, (@command{f951}).
+This is the GNU Fortran parser and code generator,
+linked to and interfaced with the GCC backend library.
+@command{f951} ``translates'' the source code to
+assembler code.  You would typically not use this
+program directly;
+instead, the @command{gcc} or @command{gfortran} driver
+programs will call it for you.
+@end itemize
+
+
+@c ---------------------------------------------------------------------
+@c GNU Fortran and GCC
+@c ---------------------------------------------------------------------
+
+@node GNU Fortran and GCC
+@section GNU Fortran and GCC
+@cindex GNU Compiler Collection
+@cindex GCC
+
+GNU Fortran is a part of GCC, the @dfn{GNU Compiler Collection}.  GCC
+consists of a collection of front ends for various languages, which
+translate the source code into a language-independent form called
+@dfn{GENERIC}.  This is then processed by a common middle end which
+provides optimization, and then passed to one of a collection of back
+ends which generate code for different computer architectures and
+operating systems.
+
+Functionally, this is implemented with a driver program (@command{gcc})
+which provides the command-line interface for the compiler.  It calls
+the relevant compiler front-end program (e.g., @command{f951} for
+Fortran) for each file in the source code, and then calls the assembler
+and linker as appropriate to produce the compiled output.  In a copy of
+GCC which has been compiled with Fortran language support enabled,
+@command{gcc} will recognize files with @file{.f}, @file{.for}, @file{.ftn},
+@file{.f90}, @file{.f95}, @file{.f03} and @file{.f08} extensions as
+Fortran source code, and compile it accordingly.  A @command{gfortran}
+driver program is also provided, which is identical to @command{gcc}
+except that it automatically links the Fortran runtime libraries into the
+compiled program.
+
+Source files with @file{.f}, @file{.for}, @file{.fpp}, @file{.ftn}, @file{.F},
+@file{.FOR}, @file{.FPP}, and @file{.FTN} extensions are treated as fixed form.
+Source files with @file{.f90}, @file{.f95}, @file{.f03}, @file{.f08},
+@file{.F90}, @file{.F95}, @file{.F03} and @file{.F08} extensions are
+treated as free form.  The capitalized versions of either form are run
+through preprocessing.  Source files with the lower case @file{.fpp}
+extension are also run through preprocessing.
+
+This manual specifically documents the Fortran front end, which handles
+the programming language's syntax and semantics.  The aspects of GCC
+which relate to the optimization passes and the back-end code generation
+are documented in the GCC manual; see 
+@ref{Top,,Introduction,gcc,Using the GNU Compiler Collection (GCC)}.
+The two manuals together provide a complete reference for the GNU
+Fortran compiler.
+
+
+@c ---------------------------------------------------------------------
+@c Preprocessing and conditional compilation
+@c ---------------------------------------------------------------------
+
+@node Preprocessing and conditional compilation
+@section Preprocessing and conditional compilation
+@cindex CPP
+@cindex FPP
+@cindex Conditional compilation
+@cindex Preprocessing
+@cindex preprocessor, include file handling
+
+Many Fortran compilers including GNU Fortran allow passing the source code
+through a C preprocessor (CPP; sometimes also called the Fortran preprocessor,
+FPP) to allow for conditional compilation.  In the case of GNU Fortran,
+this is the GNU C Preprocessor in the traditional mode.  On systems with
+case-preserving file names, the preprocessor is automatically invoked if the
+filename extension is @file{.F}, @file{.FOR}, @file{.FTN}, @file{.fpp},
+@file{.FPP}, @file{.F90}, @file{.F95}, @file{.F03} or @file{.F08}.  To manually
+invoke the preprocessor on any file, use @option{-cpp}, to disable
+preprocessing on files where the preprocessor is run automatically, use
+@option{-nocpp}.
+
+If a preprocessed file includes another file with the Fortran @code{INCLUDE}
+statement, the included file is not preprocessed.  To preprocess included
+files, use the equivalent preprocessor statement @code{#include}.
+
+If GNU Fortran invokes the preprocessor, @code{__GFORTRAN__}
+is defined and @code{__GNUC__}, @code{__GNUC_MINOR__} and
+@code{__GNUC_PATCHLEVEL__} can be used to determine the version of the
+compiler.  See @ref{Top,,Overview,cpp,The C Preprocessor} for details.
+
+While CPP is the de-facto standard for preprocessing Fortran code,
+Part 3 of the Fortran 95 standard (ISO/IEC 1539-3:1998) defines
+Conditional Compilation, which is not widely used and not directly
+supported by the GNU Fortran compiler.  You can use the program coco
+to preprocess such files (@uref{http://www.daniellnagle.com/coco.html}).
+
+
+@c ---------------------------------------------------------------------
+@c GNU Fortran and G77
+@c ---------------------------------------------------------------------
+
+@node GNU Fortran and G77
+@section GNU Fortran and G77
+@cindex Fortran 77
+@cindex @command{g77}
+
+The GNU Fortran compiler is the successor to @command{g77}, the Fortran 
+77 front end included in GCC prior to version 4.  It is an entirely new 
+program that has been designed to provide Fortran 95 support and 
+extensibility for future Fortran language standards, as well as providing 
+backwards compatibility for Fortran 77 and nearly all of the GNU language 
+extensions supported by @command{g77}.
+
+
+@c ---------------------------------------------------------------------
+@c Project Status
+@c ---------------------------------------------------------------------
+
+@node Project Status
+@section Project Status
+
+@quotation
+As soon as @command{gfortran} can parse all of the statements correctly,
+it will be in the ``larva'' state.
+When we generate code, the ``puppa'' state.
+When @command{gfortran} is done,
+we'll see if it will be a beautiful butterfly,
+or just a big bug....
+
+--Andy Vaught, April 2000
+@end quotation
+
+The start of the GNU Fortran 95 project was announced on
+the GCC homepage in March 18, 2000
+(even though Andy had already been working on it for a while,
+of course).
+
+The GNU Fortran compiler is able to compile nearly all
+standard-compliant Fortran 95, Fortran 90, and Fortran 77 programs,
+including a number of standard and non-standard extensions, and can be
+used on real-world programs.  In particular, the supported extensions
+include OpenMP, Cray-style pointers, and several Fortran 2003 and Fortran
+2008 features, including TR 15581.  However, it is still under
+development and has a few remaining rough edges.
+
+At present, the GNU Fortran compiler passes the
+@uref{http://www.fortran-2000.com/ArnaudRecipes/fcvs21_f95.html, 
+NIST Fortran 77 Test Suite}, and produces acceptable results on the
+@uref{http://www.netlib.org/lapack/faq.html#1.21, LAPACK Test Suite}.
+It also provides respectable performance on 
+the @uref{http://www.polyhedron.com/pb05.html, Polyhedron Fortran
+compiler benchmarks} and the
+@uref{http://www.llnl.gov/asci_benchmarks/asci/limited/lfk/README.html,
+Livermore Fortran Kernels test}.  It has been used to compile a number of
+large real-world programs, including
+@uref{http://mysite.verizon.net/serveall/moene.pdf, the HIRLAM
+weather-forecasting code} and
+@uref{http://www.theochem.uwa.edu.au/tonto/, the Tonto quantum 
+chemistry package}; see @url{http://gcc.gnu.org/@/wiki/@/GfortranApps} for an
+extended list.
+
+Among other things, the GNU Fortran compiler is intended as a replacement
+for G77.  At this point, nearly all programs that could be compiled with
+G77 can be compiled with GNU Fortran, although there are a few minor known
+regressions.
+
+The primary work remaining to be done on GNU Fortran falls into three
+categories: bug fixing (primarily regarding the treatment of invalid code
+and providing useful error messages), improving the compiler optimizations
+and the performance of compiled code, and extending the compiler to support
+future standards---in particular, Fortran 2003 and Fortran 2008.
+
+
+@c ---------------------------------------------------------------------
+@c Standards
+@c ---------------------------------------------------------------------
+
+@node Standards
+@section Standards
+@cindex Standards
+
+@menu
+* Varying Length Character Strings::
+@end menu
+
+The GNU Fortran compiler implements
+ISO/IEC 1539:1997 (Fortran 95).  As such, it can also compile essentially all
+standard-compliant Fortran 90 and Fortran 77 programs.   It also supports
+the ISO/IEC TR-15581 enhancements to allocatable arrays.
+
+GNU Fortran also have a partial support for ISO/IEC 1539-1:2004 (Fortran
+2003), ISO/IEC 1539-1:2010 (Fortran 2008), the Technical Specification
+@code{Further Interoperability of Fortran with C} (ISO/IEC TS 29113:2012).
+Full support of those standards and future Fortran standards is planned.
+The current status of the support is can be found in the
+@ref{Fortran 2003 status}, @ref{Fortran 2008 status} and
+@ref{TS 29113 status} sections of the documentation.
+
+Additionally, the GNU Fortran compilers supports the OpenMP specification
+(version 3.1, @url{http://openmp.org/@/wp/@/openmp-specifications/}).
+
+@node Varying Length Character Strings
+@subsection Varying Length Character Strings
+@cindex Varying length character strings
+@cindex Varying length strings
+@cindex strings, varying length
+
+The Fortran 95 standard specifies in Part 2 (ISO/IEC 1539-2:2000)
+varying length character strings.  While GNU Fortran currently does not
+support such strings directly, there exist two Fortran implementations
+for them, which work with GNU Fortran.  They can be found at
+@uref{http://www.fortran.com/@/iso_varying_string.f95} and at
+@uref{ftp://ftp.nag.co.uk/@/sc22wg5/@/ISO_VARYING_STRING/}.
+
+Deferred-length character strings of Fortran 2003 supports part of
+the features of @code{ISO_VARYING_STRING} and should be considered as
+replacement. (Namely, allocatable or pointers of the type
+@code{character(len=:)}.)
+
+
+@c =====================================================================
+@c PART I: INVOCATION REFERENCE
+@c =====================================================================
+
+@tex
+\part{I}{Invoking GNU Fortran}
+@end tex
+
+@c ---------------------------------------------------------------------
+@c Compiler Options
+@c ---------------------------------------------------------------------
+
+@include invoke.texi
+
+
+@c ---------------------------------------------------------------------
+@c Runtime
+@c ---------------------------------------------------------------------
+
+@node Runtime
+@chapter Runtime:  Influencing runtime behavior with environment variables
+@cindex environment variable
+
+The behavior of the @command{gfortran} can be influenced by
+environment variables.
+
+Malformed environment variables are silently ignored.
+
+@menu
+* TMPDIR:: Directory for scratch files
+* GFORTRAN_STDIN_UNIT:: Unit number for standard input
+* GFORTRAN_STDOUT_UNIT:: Unit number for standard output
+* GFORTRAN_STDERR_UNIT:: Unit number for standard error
+* GFORTRAN_UNBUFFERED_ALL:: Do not buffer I/O for all units.
+* GFORTRAN_UNBUFFERED_PRECONNECTED:: Do not buffer I/O for preconnected units.
+* GFORTRAN_SHOW_LOCUS::  Show location for runtime errors
+* GFORTRAN_OPTIONAL_PLUS:: Print leading + where permitted
+* GFORTRAN_DEFAULT_RECL:: Default record length for new files
+* GFORTRAN_LIST_SEPARATOR::  Separator for list output
+* GFORTRAN_CONVERT_UNIT::  Set endianness for unformatted I/O
+* GFORTRAN_ERROR_BACKTRACE:: Show backtrace on run-time errors
+@end menu
+
+@node TMPDIR
+@section @env{TMPDIR}---Directory for scratch files
+
+When opening a file with @code{STATUS='SCRATCH'}, GNU Fortran tries to
+create the file in one of the potential directories by testing each
+directory in the order below.
+
+@enumerate
+@item
+The environment variable @env{TMPDIR}, if it exists.
+
+@item
+On the MinGW target, the directory returned by the @code{GetTempPath}
+function. Alternatively, on the Cygwin target, the @env{TMP} and
+@env{TEMP} environment variables, if they exist, in that order.
+
+@item
+The @code{P_tmpdir} macro if it is defined, otherwise the directory
+@file{/tmp}.
+@end enumerate
+
+@node GFORTRAN_STDIN_UNIT
+@section @env{GFORTRAN_STDIN_UNIT}---Unit number for standard input
+
+This environment variable can be used to select the unit number
+preconnected to standard input.  This must be a positive integer.
+The default value is 5.
+
+@node GFORTRAN_STDOUT_UNIT
+@section @env{GFORTRAN_STDOUT_UNIT}---Unit number for standard output
+
+This environment variable can be used to select the unit number
+preconnected to standard output.  This must be a positive integer.
+The default value is 6.
+
+@node GFORTRAN_STDERR_UNIT
+@section @env{GFORTRAN_STDERR_UNIT}---Unit number for standard error
+
+This environment variable can be used to select the unit number
+preconnected to standard error.  This must be a positive integer.
+The default value is 0.
+
+@node GFORTRAN_UNBUFFERED_ALL
+@section @env{GFORTRAN_UNBUFFERED_ALL}---Do not buffer I/O on all units
+
+This environment variable controls whether all I/O is unbuffered.  If
+the first letter is @samp{y}, @samp{Y} or @samp{1}, all I/O is
+unbuffered.  This will slow down small sequential reads and writes.  If
+the first letter is @samp{n}, @samp{N} or @samp{0}, I/O is buffered.
+This is the default.
+
+@node GFORTRAN_UNBUFFERED_PRECONNECTED
+@section @env{GFORTRAN_UNBUFFERED_PRECONNECTED}---Do not buffer I/O on preconnected units
+
+The environment variable named @env{GFORTRAN_UNBUFFERED_PRECONNECTED} controls
+whether I/O on a preconnected unit (i.e.@: STDOUT or STDERR) is unbuffered.  If 
+the first letter is @samp{y}, @samp{Y} or @samp{1}, I/O is unbuffered.  This
+will slow down small sequential reads and writes.  If the first letter
+is @samp{n}, @samp{N} or @samp{0}, I/O is buffered.  This is the default.
+
+@node GFORTRAN_SHOW_LOCUS
+@section @env{GFORTRAN_SHOW_LOCUS}---Show location for runtime errors
+
+If the first letter is @samp{y}, @samp{Y} or @samp{1}, filename and
+line numbers for runtime errors are printed.  If the first letter is
+@samp{n}, @samp{N} or @samp{0}, do not print filename and line numbers
+for runtime errors.  The default is to print the location.
+
+@node GFORTRAN_OPTIONAL_PLUS
+@section @env{GFORTRAN_OPTIONAL_PLUS}---Print leading + where permitted
+
+If the first letter is @samp{y}, @samp{Y} or @samp{1},
+a plus sign is printed
+where permitted by the Fortran standard.  If the first letter
+is @samp{n}, @samp{N} or @samp{0}, a plus sign is not printed
+in most cases.  Default is not to print plus signs.
+
+@node GFORTRAN_DEFAULT_RECL
+@section @env{GFORTRAN_DEFAULT_RECL}---Default record length for new files
+
+This environment variable specifies the default record length, in
+bytes, for files which are opened without a @code{RECL} tag in the
+@code{OPEN} statement.  This must be a positive integer.  The
+default value is 1073741824 bytes (1 GB).
+
+@node GFORTRAN_LIST_SEPARATOR
+@section @env{GFORTRAN_LIST_SEPARATOR}---Separator for list output
+
+This environment variable specifies the separator when writing
+list-directed output.  It may contain any number of spaces and
+at most one comma.  If you specify this on the command line,
+be sure to quote spaces, as in
+@smallexample
+$ GFORTRAN_LIST_SEPARATOR='  ,  ' ./a.out
+@end smallexample
+when @command{a.out} is the compiled Fortran program that you want to run.
+Default is a single space.
+
+@node GFORTRAN_CONVERT_UNIT
+@section @env{GFORTRAN_CONVERT_UNIT}---Set endianness for unformatted I/O
+
+By setting the @env{GFORTRAN_CONVERT_UNIT} variable, it is possible
+to change the representation of data for unformatted files.
+The syntax for the @env{GFORTRAN_CONVERT_UNIT} variable is:
+@smallexample
+GFORTRAN_CONVERT_UNIT: mode | mode ';' exception | exception ;
+mode: 'native' | 'swap' | 'big_endian' | 'little_endian' ;
+exception: mode ':' unit_list | unit_list ;
+unit_list: unit_spec | unit_list unit_spec ;
+unit_spec: INTEGER | INTEGER '-' INTEGER ;
+@end smallexample
+The variable consists of an optional default mode, followed by
+a list of optional exceptions, which are separated by semicolons
+from the preceding default and each other.  Each exception consists
+of a format and a comma-separated list of units.  Valid values for
+the modes are the same as for the @code{CONVERT} specifier:
+
+@itemize @w{}
+@item @code{NATIVE} Use the native format.  This is the default.
+@item @code{SWAP} Swap between little- and big-endian.
+@item @code{LITTLE_ENDIAN} Use the little-endian format
+for unformatted files.
+@item @code{BIG_ENDIAN} Use the big-endian format for unformatted files.
+@end itemize
+A missing mode for an exception is taken to mean @code{BIG_ENDIAN}.
+Examples of values for @env{GFORTRAN_CONVERT_UNIT} are:
+@itemize @w{}
+@item @code{'big_endian'}  Do all unformatted I/O in big_endian mode.
+@item @code{'little_endian;native:10-20,25'}  Do all unformatted I/O 
+in little_endian mode, except for units 10 to 20 and 25, which are in
+native format.
+@item @code{'10-20'}  Units 10 to 20 are big-endian, the rest is native.
+@end itemize
+
+Setting the environment variables should be done on the command
+line or via the @command{export}
+command for @command{sh}-compatible shells and via @command{setenv}
+for @command{csh}-compatible shells.
+
+Example for @command{sh}:
+@smallexample
+$ gfortran foo.f90
+$ GFORTRAN_CONVERT_UNIT='big_endian;native:10-20' ./a.out
+@end smallexample
+
+Example code for @command{csh}:
+@smallexample
+% gfortran foo.f90
+% setenv GFORTRAN_CONVERT_UNIT 'big_endian;native:10-20'
+% ./a.out
+@end smallexample
+
+Using anything but the native representation for unformatted data
+carries a significant speed overhead.  If speed in this area matters
+to you, it is best if you use this only for data that needs to be
+portable.
+
+@xref{CONVERT specifier}, for an alternative way to specify the
+data representation for unformatted files.  @xref{Runtime Options}, for
+setting a default data representation for the whole program.  The
+@code{CONVERT} specifier overrides the @option{-fconvert} compile options.
+
+@emph{Note that the values specified via the GFORTRAN_CONVERT_UNIT
+environment variable will override the CONVERT specifier in the
+open statement}.  This is to give control over data formats to
+users who do not have the source code of their program available.
+
+@node GFORTRAN_ERROR_BACKTRACE
+@section @env{GFORTRAN_ERROR_BACKTRACE}---Show backtrace on run-time errors
+
+If the @env{GFORTRAN_ERROR_BACKTRACE} variable is set to @samp{y},
+@samp{Y} or @samp{1} (only the first letter is relevant) then a
+backtrace is printed when a serious run-time error occurs.  To disable
+the backtracing, set the variable to @samp{n}, @samp{N}, @samp{0}.
+Default is to print a backtrace unless the @option{-fno-backtrace}
+compile option was used.
+
+@c =====================================================================
+@c PART II: LANGUAGE REFERENCE
+@c =====================================================================
+
+@tex
+\part{II}{Language Reference}
+@end tex
+
+@c ---------------------------------------------------------------------
+@c Fortran 2003 and 2008 Status
+@c ---------------------------------------------------------------------
+
+@node Fortran 2003 and 2008 status
+@chapter Fortran 2003 and 2008 Status
+
+@menu
+* Fortran 2003 status::
+* Fortran 2008 status::
+* TS 29113 status::
+@end menu
+
+@node Fortran 2003 status
+@section Fortran 2003 status
+
+GNU Fortran supports several Fortran 2003 features; an incomplete
+list can be found below.  See also the
+@uref{http://gcc.gnu.org/wiki/Fortran2003, wiki page} about Fortran 2003.
+
+@itemize
+@item Procedure pointers including procedure-pointer components with
+@code{PASS} attribute.
+
+@item Procedures which are bound to a derived type (type-bound procedures)
+including @code{PASS}, @code{PROCEDURE} and @code{GENERIC}, and
+operators bound to a type.
+
+@item Abstract interfaces and type extension with the possibility to
+override type-bound procedures or to have deferred binding.
+
+@item Polymorphic entities (``@code{CLASS}'') for derived types and unlimited
+polymorphism (``@code{CLASS(*)}'') -- including @code{SAME_TYPE_AS},
+@code{EXTENDS_TYPE_OF} and @code{SELECT TYPE} for scalars and arrays and
+finalization.
+
+@item Generic interface names, which have the same name as derived types,
+are now supported. This allows one to write constructor functions.  Note
+that Fortran does not support static constructor functions.  For static
+variables, only default initialization or structure-constructor
+initialization are available.
+
+@item The @code{ASSOCIATE} construct.
+
+@item Interoperability with C including enumerations, 
+
+@item In structure constructors the components with default values may be
+omitted.
+
+@item Extensions to the @code{ALLOCATE} statement, allowing for a
+type-specification with type parameter and for allocation and initialization
+from a @code{SOURCE=} expression; @code{ALLOCATE} and @code{DEALLOCATE}
+optionally return an error message string via @code{ERRMSG=}.
+
+@item Reallocation on assignment: If an intrinsic assignment is
+used, an allocatable variable on the left-hand side is automatically allocated
+(if unallocated) or reallocated (if the shape is different). Currently, scalar
+deferred character length left-hand sides are correctly handled but arrays
+are not yet fully implemented.
+
+@item Deferred-length character variables and scalar deferred-length character
+components of derived types are supported. (Note that array-valued compoents
+are not yet implemented.)
+
+@item Transferring of allocations via @code{MOVE_ALLOC}.
+
+@item The @code{PRIVATE} and @code{PUBLIC} attributes may be given individually
+to derived-type components.
+
+@item In pointer assignments, the lower bound may be specified and
+the remapping of elements is supported.
+
+@item For pointers an @code{INTENT} may be specified which affect the
+association status not the value of the pointer target.
+
+@item Intrinsics @code{command_argument_count}, @code{get_command},
+@code{get_command_argument}, and @code{get_environment_variable}.
+
+@item Support for Unicode characters (ISO 10646) and UTF-8, including
+the @code{SELECTED_CHAR_KIND} and @code{NEW_LINE} intrinsic functions.
+
+@item Support for binary, octal and hexadecimal (BOZ) constants in the
+intrinsic functions @code{INT}, @code{REAL}, @code{CMPLX} and @code{DBLE}.
+
+@item Support for namelist variables with allocatable and pointer
+attribute and nonconstant length type parameter.
+
+@item
+@cindex array, constructors
+@cindex @code{[...]}
+Array constructors using square brackets.  That is, @code{[...]} rather
+than @code{(/.../)}.  Type-specification for array constructors like
+@code{(/ some-type :: ... /)}.
+
+@item Extensions to the specification and initialization expressions,
+including the support for intrinsics with real and complex arguments.
+
+@item Support for the asynchronous input/output syntax; however, the
+data transfer is currently always synchronously performed. 
+
+@item
+@cindex @code{FLUSH} statement
+@cindex statement, @code{FLUSH}
+@code{FLUSH} statement.
+
+@item
+@cindex @code{IOMSG=} specifier
+@code{IOMSG=} specifier for I/O statements.
+
+@item
+@cindex @code{ENUM} statement
+@cindex @code{ENUMERATOR} statement
+@cindex statement, @code{ENUM}
+@cindex statement, @code{ENUMERATOR}
+@opindex @code{fshort-enums}
+Support for the declaration of enumeration constants via the
+@code{ENUM} and @code{ENUMERATOR} statements.  Interoperability with
+@command{gcc} is guaranteed also for the case where the
+@command{-fshort-enums} command line option is given.
+
+@item
+@cindex TR 15581
+TR 15581:
+@itemize
+@item
+@cindex @code{ALLOCATABLE} dummy arguments
+@code{ALLOCATABLE} dummy arguments.
+@item
+@cindex @code{ALLOCATABLE} function results
+@code{ALLOCATABLE} function results
+@item
+@cindex @code{ALLOCATABLE} components of derived types
+@code{ALLOCATABLE} components of derived types
+@end itemize
+
+@item
+@cindex @code{STREAM} I/O
+@cindex @code{ACCESS='STREAM'} I/O
+The @code{OPEN} statement supports the @code{ACCESS='STREAM'} specifier,
+allowing I/O without any record structure.
+
+@item
+Namelist input/output for internal files.
+
+@item Minor I/O features: Rounding during formatted output, using of
+a decimal comma instead of a decimal point, setting whether a plus sign
+should appear for positive numbers. On system where @code{strtod} honours
+the rounding mode, the rounding mode is also supported for input.
+
+@item
+@cindex @code{PROTECTED} statement
+@cindex statement, @code{PROTECTED}
+The @code{PROTECTED} statement and attribute.
+
+@item
+@cindex @code{VALUE} statement
+@cindex statement, @code{VALUE}
+The @code{VALUE} statement and attribute.
+
+@item
+@cindex @code{VOLATILE} statement
+@cindex statement, @code{VOLATILE}
+The @code{VOLATILE} statement and attribute.
+
+@item
+@cindex @code{IMPORT} statement
+@cindex statement, @code{IMPORT}
+The @code{IMPORT} statement, allowing to import
+host-associated derived types.
+
+@item The intrinsic modules @code{ISO_FORTRAN_ENVIRONMENT} is supported,
+which contains parameters of the I/O units, storage sizes. Additionally,
+procedures for C interoperability are available in the @code{ISO_C_BINDING}
+module.
+
+@item
+@cindex @code{USE, INTRINSIC} statement
+@cindex statement, @code{USE, INTRINSIC}
+@cindex @code{ISO_FORTRAN_ENV} statement
+@cindex statement, @code{ISO_FORTRAN_ENV}
+@code{USE} statement with @code{INTRINSIC} and @code{NON_INTRINSIC}
+attribute; supported intrinsic modules: @code{ISO_FORTRAN_ENV},
+@code{ISO_C_BINDING}, @code{OMP_LIB} and @code{OMP_LIB_KINDS}.
+
+@item
+Renaming of operators in the @code{USE} statement.
+
+@end itemize
+
+
+@node Fortran 2008 status
+@section Fortran 2008 status
+
+The latest version of the Fortran standard is ISO/IEC 1539-1:2010, informally
+known as Fortran 2008.  The official version is available from International
+Organization for Standardization (ISO) or its national member organizations.
+The the final draft (FDIS) can be downloaded free of charge from
+@url{http://www.nag.co.uk/@/sc22wg5/@/links.html}.  Fortran is developed by the
+Working Group 5 of Sub-Committee 22 of the Joint Technical Committee 1 of the
+International Organization for Standardization and the International
+Electrotechnical Commission (IEC).  This group is known as
+@uref{http://www.nag.co.uk/sc22wg5/, WG5}.
+
+The GNU Fortran compiler supports several of the new features of Fortran 2008;
+the @uref{http://gcc.gnu.org/wiki/Fortran2008Status, wiki} has some information
+about the current Fortran 2008 implementation status.  In particular, the
+following is implemented.
+
+@itemize
+@item The @option{-std=f2008} option and support for the file extensions 
+@file{.f08} and @file{.F08}.
+
+@item The @code{OPEN} statement now supports the @code{NEWUNIT=} option,
+which returns a unique file unit, thus preventing inadvertent use of the
+same unit in different parts of the program.
+
+@item The @code{g0} format descriptor and unlimited format items.
+
+@item The mathematical intrinsics @code{ASINH}, @code{ACOSH}, @code{ATANH},
+@code{ERF}, @code{ERFC}, @code{GAMMA}, @code{LOG_GAMMA}, @code{BESSEL_J0},
+@code{BESSEL_J1}, @code{BESSEL_JN}, @code{BESSEL_Y0}, @code{BESSEL_Y1},
+@code{BESSEL_YN}, @code{HYPOT}, @code{NORM2}, and @code{ERFC_SCALED}.
+
+@item Using complex arguments with @code{TAN}, @code{SINH}, @code{COSH},
+@code{TANH}, @code{ASIN}, @code{ACOS}, and @code{ATAN} is now possible;
+@code{ATAN}(@var{Y},@var{X}) is now an alias for @code{ATAN2}(@var{Y},@var{X}).
+
+@item Support of the @code{PARITY} intrinsic functions.
+
+@item The following bit intrinsics: @code{LEADZ} and @code{TRAILZ} for
+counting the number of leading and trailing zero bits, @code{POPCNT} and
+@code{POPPAR} for counting the number of one bits and returning the parity;
+@code{BGE}, @code{BGT}, @code{BLE}, and @code{BLT} for bitwise comparisons;
+@code{DSHIFTL} and @code{DSHIFTR} for combined left and right shifts,
+@code{MASKL} and @code{MASKR} for simple left and right justified masks,
+@code{MERGE_BITS} for a bitwise merge using a mask, @code{SHIFTA},
+@code{SHIFTL} and @code{SHIFTR} for shift operations, and the
+transformational bit intrinsics @code{IALL}, @code{IANY} and @code{IPARITY}.
+
+@item Support of the @code{EXECUTE_COMMAND_LINE} intrinsic subroutine.
+
+@item Support for the @code{STORAGE_SIZE} intrinsic inquiry function.
+
+@item The @code{INT@{8,16,32@}} and @code{REAL@{32,64,128@}} kind type
+parameters and the array-valued named constants @code{INTEGER_KINDS},
+@code{LOGICAL_KINDS}, @code{REAL_KINDS} and @code{CHARACTER_KINDS} of
+the intrinsic module @code{ISO_FORTRAN_ENV}.
+
+@item The module procedures @code{C_SIZEOF} of the intrinsic module
+@code{ISO_C_BINDINGS} and @code{COMPILER_VERSION} and @code{COMPILER_OPTIONS}
+of @code{ISO_FORTRAN_ENV}.
+
+@item Coarray support for serial programs with @option{-fcoarray=single} flag
+and experimental support for multiple images with the @option{-fcoarray=lib}
+flag.
+
+@item The @code{DO CONCURRENT} construct is supported.
+
+@item The @code{BLOCK} construct is supported.
+
+@item The @code{STOP} and the new @code{ERROR STOP} statements now
+support all constant expressions. Both show the signals which were signaling
+at termination.
+
+@item Support for the @code{CONTIGUOUS} attribute.
+
+@item Support for @code{ALLOCATE} with @code{MOLD}.
+
+@item Support for the @code{IMPURE} attribute for procedures, which
+allows for @code{ELEMENTAL} procedures without the restrictions of
+@code{PURE}.
+
+@item Null pointers (including @code{NULL()}) and not-allocated variables
+can be used as actual argument to optional non-pointer, non-allocatable
+dummy arguments, denoting an absent argument.
+
+@item Non-pointer variables with @code{TARGET} attribute can be used as
+actual argument to @code{POINTER} dummies with @code{INTENT(IN)}.
+
+@item Pointers including procedure pointers and those in a derived
+type (pointer components) can now be initialized by a target instead
+of only by @code{NULL}.
+
+@item The @code{EXIT} statement (with construct-name) can be now be
+used to leave not only the @code{DO} but also the @code{ASSOCIATE},
+@code{BLOCK}, @code{IF}, @code{SELECT CASE} and @code{SELECT TYPE}
+constructs.
+
+@item Internal procedures can now be used as actual argument.
+
+@item Minor features: obsolesce diagnostics for @code{ENTRY} with
+@option{-std=f2008}; a line may start with a semicolon; for internal
+and module procedures @code{END} can be used instead of
+@code{END SUBROUTINE} and @code{END FUNCTION}; @code{SELECTED_REAL_KIND}
+now also takes a @code{RADIX} argument; intrinsic types are supported
+for @code{TYPE}(@var{intrinsic-type-spec}); multiple type-bound procedures
+can be declared in a single @code{PROCEDURE} statement; implied-shape
+arrays are supported for named constants (@code{PARAMETER}).
+@end itemize
+
+
+
+@node TS 29113 status
+@section Technical Specification 29113 Status
+
+GNU Fortran supports some of the new features of the Technical
+Specification (TS) 29113 on Further Interoperability of Fortran with C.
+The @uref{http://gcc.gnu.org/wiki/TS29113Status, wiki} has some information
+about the current TS 29113 implementation status.  In particular, the
+following is implemented.
+
+See also @ref{Further Interoperability of Fortran with C}.
+
+@itemize
+@item The @option{-std=f2008ts} option.
+
+@item The @code{OPTIONAL} attribute is allowed for dummy arguments
+of @code{BIND(C) procedures.}
+
+@item The @code{RANK} intrinsic is supported.
+
+@item GNU Fortran's implementation for variables with @code{ASYNCHRONOUS}
+attribute is compatible with TS 29113.
+
+@item Assumed types (@code{TYPE(*)}.
+
+@item Assumed-rank (@code{DIMENSION(..)}). However, the array descriptor
+of the TS is not yet supported.
+@end itemize
+
+
+
+@c ---------------------------------------------------------------------
+@c Compiler Characteristics
+@c ---------------------------------------------------------------------
+
+@node Compiler Characteristics
+@chapter Compiler Characteristics
+
+This chapter describes certain characteristics of the GNU Fortran
+compiler, that are not specified by the Fortran standard, but which
+might in some way or another become visible to the programmer.
+
+@menu
+* KIND Type Parameters::
+* Internal representation of LOGICAL variables::
+* Thread-safety of the runtime library::
+* Data consistency and durability::
+@end menu
+
+
+@node KIND Type Parameters
+@section KIND Type Parameters
+@cindex kind
+
+The @code{KIND} type parameters supported by GNU Fortran for the primitive
+data types are:
+
+@table @code
+
+@item INTEGER
+1, 2, 4, 8*, 16*, default: 4**
+
+@item LOGICAL
+1, 2, 4, 8*, 16*, default: 4**
+
+@item REAL
+4, 8, 10*, 16*, default: 4***
+
+@item COMPLEX
+4, 8, 10*, 16*, default: 4***
+
+@item DOUBLE PRECISION
+4, 8, 10*, 16*, default: 8***
+
+@item CHARACTER
+1, 4, default: 1
+
+@end table
+
+@noindent
+* not available on all systems @*
+** unless @option{-fdefault-integer-8} is used @*
+*** unless @option{-fdefault-real-8} is used (see @ref{Fortran Dialect Options})
+
+@noindent
+The @code{KIND} value matches the storage size in bytes, except for
+@code{COMPLEX} where the storage size is twice as much (or both real and
+imaginary part are a real value of the given size).  It is recommended to use
+the @ref{SELECTED_CHAR_KIND}, @ref{SELECTED_INT_KIND} and
+@ref{SELECTED_REAL_KIND} intrinsics or the @code{INT8}, @code{INT16},
+@code{INT32}, @code{INT64}, @code{REAL32}, @code{REAL64}, and @code{REAL128}
+parameters of the @code{ISO_FORTRAN_ENV} module instead of the concrete values.
+The available kind parameters can be found in the constant arrays
+@code{CHARACTER_KINDS}, @code{INTEGER_KINDS}, @code{LOGICAL_KINDS} and
+@code{REAL_KINDS} in the @ref{ISO_FORTRAN_ENV} module.  For C interoperability,
+the kind parameters of the @ref{ISO_C_BINDING} module should be used.
+
+
+@node Internal representation of LOGICAL variables
+@section Internal representation of LOGICAL variables
+@cindex logical, variable representation
+
+The Fortran standard does not specify how variables of @code{LOGICAL}
+type are represented, beyond requiring that @code{LOGICAL} variables
+of default kind have the same storage size as default @code{INTEGER}
+and @code{REAL} variables.  The GNU Fortran internal representation is
+as follows.
+
+A @code{LOGICAL(KIND=N)} variable is represented as an
+@code{INTEGER(KIND=N)} variable, however, with only two permissible
+values: @code{1} for @code{.TRUE.} and @code{0} for
+@code{.FALSE.}.  Any other integer value results in undefined behavior.
+
+See also @ref{Argument passing conventions} and @ref{Interoperability with C}.
+
+
+@node Thread-safety of the runtime library
+@section Thread-safety of the runtime library
+@cindex thread-safety, threads
+
+GNU Fortran can be used in programs with multiple threads, e.g.@: by
+using OpenMP, by calling OS thread handling functions via the
+@code{ISO_C_BINDING} facility, or by GNU Fortran compiled library code
+being called from a multi-threaded program.
+
+The GNU Fortran runtime library, (@code{libgfortran}), supports being
+called concurrently from multiple threads with the following
+exceptions. 
+
+During library initialization, the C @code{getenv} function is used,
+which need not be thread-safe.  Similarly, the @code{getenv}
+function is used to implement the @code{GET_ENVIRONMENT_VARIABLE} and
+@code{GETENV} intrinsics.  It is the responsibility of the user to
+ensure that the environment is not being updated concurrently when any
+of these actions are taking place.
+
+The @code{EXECUTE_COMMAND_LINE} and @code{SYSTEM} intrinsics are
+implemented with the @code{system} function, which need not be
+thread-safe.  It is the responsibility of the user to ensure that
+@code{system} is not called concurrently.
+
+Finally, for platforms not supporting thread-safe POSIX functions,
+further functionality might not be thread-safe.  For details, please
+consult the documentation for your operating system.
+
+
+@node Data consistency and durability
+@section Data consistency and durability
+@cindex consistency, durability
+
+This section contains a brief overview of data and metadata
+consistency and durability issues when doing I/O.
+
+With respect to durability, GNU Fortran makes no effort to ensure that
+data is committed to stable storage. If this is required, the GNU
+Fortran programmer can use the intrinsic @code{FNUM} to retrieve the
+low level file descriptor corresponding to an open Fortran unit. Then,
+using e.g. the @code{ISO_C_BINDING} feature, one can call the
+underlying system call to flush dirty data to stable storage, such as
+@code{fsync} on POSIX, @code{_commit} on MingW, or @code{fcntl(fd,
+F_FULLSYNC, 0)} on Mac OS X. The following example shows how to call
+fsync:
+
+@smallexample
+  ! Declare the interface for POSIX fsync function
+  interface
+    function fsync (fd) bind(c,name="fsync")
+    use iso_c_binding, only: c_int
+      integer(c_int), value :: fd
+      integer(c_int) :: fsync
+    end function fsync
+  end interface
+
+  ! Variable declaration
+  integer :: ret
+
+  ! Opening unit 10
+  open (10,file="foo")
+
+  ! ...
+  ! Perform I/O on unit 10
+  ! ...
+
+  ! Flush and sync
+  flush(10)
+  ret = fsync(fnum(10))
+
+  ! Handle possible error
+  if (ret /= 0) stop "Error calling FSYNC"
+@end smallexample
+
+With respect to consistency, for regular files GNU Fortran uses
+buffered I/O in order to improve performance. This buffer is flushed
+automatically when full and in some other situations, e.g. when
+closing a unit. It can also be explicitly flushed with the
+@code{FLUSH} statement. Also, the buffering can be turned off with the
+@code{GFORTRAN_UNBUFFERED_ALL} and
+@code{GFORTRAN_UNBUFFERED_PRECONNECTED} environment variables. Special
+files, such as terminals and pipes, are always unbuffered. Sometimes,
+however, further things may need to be done in order to allow other
+processes to see data that GNU Fortran has written, as follows.
+
+The Windows platform supports a relaxed metadata consistency model,
+where file metadata is written to the directory lazily. This means
+that, for instance, the @code{dir} command can show a stale size for a
+file. One can force a directory metadata update by closing the unit,
+or by calling @code{_commit} on the file descriptor. Note, though,
+that @code{_commit} will force all dirty data to stable storage, which
+is often a very slow operation.
+
+The Network File System (NFS) implements a relaxed consistency model
+called open-to-close consistency. Closing a file forces dirty data and
+metadata to be flushed to the server, and opening a file forces the
+client to contact the server in order to revalidate cached
+data. @code{fsync} will also force a flush of dirty data and metadata
+to the server. Similar to @code{open} and @code{close}, acquiring and
+releasing @code{fcntl} file locks, if the server supports them, will
+also force cache validation and flushing dirty data and metadata.
+
+
+@c ---------------------------------------------------------------------
+@c Extensions
+@c ---------------------------------------------------------------------
+
+@c Maybe this chapter should be merged with the 'Standards' section,
+@c whenever that is written :-)
+
+@node Extensions
+@chapter Extensions
+@cindex extensions
+
+The two sections below detail the extensions to standard Fortran that are
+implemented in GNU Fortran, as well as some of the popular or
+historically important extensions that are not (or not yet) implemented.
+For the latter case, we explain the alternatives available to GNU Fortran
+users, including replacement by standard-conforming code or GNU
+extensions.
+
+@menu
+* Extensions implemented in GNU Fortran::
+* Extensions not implemented in GNU Fortran::
+@end menu
+
+
+@node Extensions implemented in GNU Fortran
+@section Extensions implemented in GNU Fortran
+@cindex extensions, implemented
+
+GNU Fortran implements a number of extensions over standard
+Fortran.  This chapter contains information on their syntax and
+meaning.  There are currently two categories of GNU Fortran
+extensions, those that provide functionality beyond that provided
+by any standard, and those that are supported by GNU Fortran
+purely for backward compatibility with legacy compilers.  By default,
+@option{-std=gnu} allows the compiler to accept both types of
+extensions, but to warn about the use of the latter.  Specifying
+either @option{-std=f95}, @option{-std=f2003} or @option{-std=f2008}
+disables both types of extensions, and @option{-std=legacy} allows both
+without warning.
+
+@menu
+* Old-style kind specifications::
+* Old-style variable initialization::
+* Extensions to namelist::
+* X format descriptor without count field::
+* Commas in FORMAT specifications::
+* Missing period in FORMAT specifications::
+* I/O item lists::
+* @code{Q} exponent-letter::
+* BOZ literal constants::
+* Real array indices::
+* Unary operators::
+* Implicitly convert LOGICAL and INTEGER values::
+* Hollerith constants support::
+* Cray pointers::
+* CONVERT specifier::
+* OpenMP::
+* Argument list functions::
+@end menu
+
+@node Old-style kind specifications
+@subsection Old-style kind specifications
+@cindex kind, old-style
+
+GNU Fortran allows old-style kind specifications in declarations.  These
+look like:
+@smallexample
+      TYPESPEC*size x,y,z
+@end smallexample
+@noindent
+where @code{TYPESPEC} is a basic type (@code{INTEGER}, @code{REAL},
+etc.), and where @code{size} is a byte count corresponding to the
+storage size of a valid kind for that type.  (For @code{COMPLEX}
+variables, @code{size} is the total size of the real and imaginary
+parts.)  The statement then declares @code{x}, @code{y} and @code{z} to
+be of type @code{TYPESPEC} with the appropriate kind.  This is
+equivalent to the standard-conforming declaration
+@smallexample
+      TYPESPEC(k) x,y,z
+@end smallexample
+@noindent
+where @code{k} is the kind parameter suitable for the intended precision.  As
+kind parameters are implementation-dependent, use the @code{KIND},
+@code{SELECTED_INT_KIND} and @code{SELECTED_REAL_KIND} intrinsics to retrieve
+the correct value, for instance @code{REAL*8 x} can be replaced by:
+@smallexample
+INTEGER, PARAMETER :: dbl = KIND(1.0d0)
+REAL(KIND=dbl) :: x
+@end smallexample
+
+@node Old-style variable initialization
+@subsection Old-style variable initialization
+
+GNU Fortran allows old-style initialization of variables of the
+form:
+@smallexample
+      INTEGER i/1/,j/2/
+      REAL x(2,2) /3*0.,1./
+@end smallexample
+The syntax for the initializers is as for the @code{DATA} statement, but
+unlike in a @code{DATA} statement, an initializer only applies to the
+variable immediately preceding the initialization.  In other words,
+something like @code{INTEGER I,J/2,3/} is not valid.  This style of
+initialization is only allowed in declarations without double colons
+(@code{::}); the double colons were introduced in Fortran 90, which also
+introduced a standard syntax for initializing variables in type
+declarations.
+
+Examples of standard-conforming code equivalent to the above example
+are:
+@smallexample
+! Fortran 90
+      INTEGER :: i = 1, j = 2
+      REAL :: x(2,2) = RESHAPE((/0.,0.,0.,1./),SHAPE(x))
+! Fortran 77
+      INTEGER i, j
+      REAL x(2,2)
+      DATA i/1/, j/2/, x/3*0.,1./
+@end smallexample
+
+Note that variables which are explicitly initialized in declarations
+or in @code{DATA} statements automatically acquire the @code{SAVE}
+attribute.
+
+@node Extensions to namelist
+@subsection Extensions to namelist
+@cindex Namelist
+
+GNU Fortran fully supports the Fortran 95 standard for namelist I/O
+including array qualifiers, substrings and fully qualified derived types.
+The output from a namelist write is compatible with namelist read.  The
+output has all names in upper case and indentation to column 1 after the
+namelist name.  Two extensions are permitted:
+
+Old-style use of @samp{$} instead of @samp{&}
+@smallexample
+$MYNML
+ X(:)%Y(2) = 1.0 2.0 3.0
+ CH(1:4) = "abcd"
+$END
+@end smallexample
+
+It should be noted that the default terminator is @samp{/} rather than
+@samp{&END}.
+
+Querying of the namelist when inputting from stdin.  After at least
+one space, entering @samp{?} sends to stdout the namelist name and the names of
+the variables in the namelist:
+@smallexample
+ ?
+
+&mynml
+ x
+ x%y
+ ch
+&end
+@end smallexample
+
+Entering @samp{=?} outputs the namelist to stdout, as if
+@code{WRITE(*,NML = mynml)} had been called:
+@smallexample
+=?
+
+&MYNML
+ X(1)%Y=  0.000000    ,  1.000000    ,  0.000000    ,
+ X(2)%Y=  0.000000    ,  2.000000    ,  0.000000    ,
+ X(3)%Y=  0.000000    ,  3.000000    ,  0.000000    ,
+ CH=abcd,  /
+@end smallexample
+
+To aid this dialog, when input is from stdin, errors send their
+messages to stderr and execution continues, even if @code{IOSTAT} is set.
+
+@code{PRINT} namelist is permitted.  This causes an error if
+@option{-std=f95} is used.
+@smallexample
+PROGRAM test_print
+  REAL, dimension (4)  ::  x = (/1.0, 2.0, 3.0, 4.0/)
+  NAMELIST /mynml/ x
+  PRINT mynml
+END PROGRAM test_print
+@end smallexample
+
+Expanded namelist reads are permitted.  This causes an error if 
+@option{-std=f95} is used.  In the following example, the first element
+of the array will be given the value 0.00 and the two succeeding
+elements will be given the values 1.00 and 2.00.
+@smallexample
+&MYNML
+  X(1,1) = 0.00 , 1.00 , 2.00
+/
+@end smallexample
+
+When writing a namelist, if no @code{DELIM=} is specified, by default a
+double quote is used to delimit character strings. If -std=F95, F2003,
+or F2008, etc, the delim status is set to 'none'.  Defaulting to
+quotes ensures that namelists with character strings can be subsequently
+read back in accurately.
+
+@node X format descriptor without count field
+@subsection @code{X} format descriptor without count field
+
+To support legacy codes, GNU Fortran permits the count field of the
+@code{X} edit descriptor in @code{FORMAT} statements to be omitted.
+When omitted, the count is implicitly assumed to be one.
+
+@smallexample
+       PRINT 10, 2, 3
+10     FORMAT (I1, X, I1)
+@end smallexample
+
+@node Commas in FORMAT specifications
+@subsection Commas in @code{FORMAT} specifications
+
+To support legacy codes, GNU Fortran allows the comma separator
+to be omitted immediately before and after character string edit
+descriptors in @code{FORMAT} statements.
+
+@smallexample
+       PRINT 10, 2, 3
+10     FORMAT ('FOO='I1' BAR='I2)
+@end smallexample
+
+
+@node Missing period in FORMAT specifications
+@subsection Missing period in @code{FORMAT} specifications
+
+To support legacy codes, GNU Fortran allows missing periods in format
+specifications if and only if @option{-std=legacy} is given on the
+command line.  This is considered non-conforming code and is
+discouraged.
+
+@smallexample
+       REAL :: value
+       READ(*,10) value
+10     FORMAT ('F4')
+@end smallexample
+
+@node I/O item lists
+@subsection I/O item lists
+@cindex I/O item lists
+
+To support legacy codes, GNU Fortran allows the input item list
+of the @code{READ} statement, and the output item lists of the
+@code{WRITE} and @code{PRINT} statements, to start with a comma.
+
+@node @code{Q} exponent-letter
+@subsection @code{Q} exponent-letter
+@cindex @code{Q} exponent-letter
+
+GNU Fortran accepts real literal constants with an exponent-letter
+of @code{Q}, for example, @code{1.23Q45}.  The constant is interpreted
+as a @code{REAL(16)} entity on targets that support this type.  If
+the target does not support @code{REAL(16)} but has a @code{REAL(10)}
+type, then the real-literal-constant will be interpreted as a
+@code{REAL(10)} entity.  In the absence of @code{REAL(16)} and
+@code{REAL(10)}, an error will occur.
+
+@node BOZ literal constants
+@subsection BOZ literal constants
+@cindex BOZ literal constants
+
+Besides decimal constants, Fortran also supports binary (@code{b}),
+octal (@code{o}) and hexadecimal (@code{z}) integer constants.  The
+syntax is: @samp{prefix quote digits quote}, were the prefix is
+either @code{b}, @code{o} or @code{z}, quote is either @code{'} or
+@code{"} and the digits are for binary @code{0} or @code{1}, for
+octal between @code{0} and @code{7}, and for hexadecimal between
+@code{0} and @code{F}.  (Example: @code{b'01011101'}.)
+
+Up to Fortran 95, BOZ literals were only allowed to initialize
+integer variables in DATA statements.  Since Fortran 2003 BOZ literals
+are also allowed as argument of @code{REAL}, @code{DBLE}, @code{INT}
+and @code{CMPLX}; the result is the same as if the integer BOZ
+literal had been converted by @code{TRANSFER} to, respectively,
+@code{real}, @code{double precision}, @code{integer} or @code{complex}.
+As GNU Fortran extension the intrinsic procedures @code{FLOAT},
+@code{DFLOAT}, @code{COMPLEX} and @code{DCMPLX} are treated alike.
+
+As an extension, GNU Fortran allows hexadecimal BOZ literal constants to
+be specified using the @code{X} prefix, in addition to the standard
+@code{Z} prefix.  The BOZ literal can also be specified by adding a
+suffix to the string, for example, @code{Z'ABC'} and @code{'ABC'Z} are
+equivalent.
+
+Furthermore, GNU Fortran allows using BOZ literal constants outside
+DATA statements and the four intrinsic functions allowed by Fortran 2003.
+In DATA statements, in direct assignments, where the right-hand side
+only contains a BOZ literal constant, and for old-style initializers of
+the form @code{integer i /o'0173'/}, the constant is transferred
+as if @code{TRANSFER} had been used; for @code{COMPLEX} numbers, only
+the real part is initialized unless @code{CMPLX} is used.  In all other
+cases, the BOZ literal constant is converted to an @code{INTEGER} value with
+the largest decimal representation.  This value is then converted
+numerically to the type and kind of the variable in question.
+(For instance, @code{real :: r = b'0000001' + 1} initializes @code{r}
+with @code{2.0}.) As different compilers implement the extension
+differently, one should be careful when doing bitwise initialization
+of non-integer variables.
+
+Note that initializing an @code{INTEGER} variable with a statement such
+as @code{DATA i/Z'FFFFFFFF'/} will give an integer overflow error rather
+than the desired result of @math{-1} when @code{i} is a 32-bit integer
+on a system that supports 64-bit integers.  The @samp{-fno-range-check}
+option can be used as a workaround for legacy code that initializes
+integers in this manner.
+
+@node Real array indices
+@subsection Real array indices
+@cindex array, indices of type real
+
+As an extension, GNU Fortran allows the use of @code{REAL} expressions
+or variables as array indices.
+
+@node Unary operators
+@subsection Unary operators
+@cindex operators, unary
+
+As an extension, GNU Fortran allows unary plus and unary minus operators
+to appear as the second operand of binary arithmetic operators without
+the need for parenthesis.
+
+@smallexample
+       X = Y * -Z
+@end smallexample
+
+@node Implicitly convert LOGICAL and INTEGER values
+@subsection Implicitly convert @code{LOGICAL} and @code{INTEGER} values
+@cindex conversion, to integer
+@cindex conversion, to logical
+
+As an extension for backwards compatibility with other compilers, GNU
+Fortran allows the implicit conversion of @code{LOGICAL} values to
+@code{INTEGER} values and vice versa.  When converting from a
+@code{LOGICAL} to an @code{INTEGER}, @code{.FALSE.} is interpreted as
+zero, and @code{.TRUE.} is interpreted as one.  When converting from
+@code{INTEGER} to @code{LOGICAL}, the value zero is interpreted as
+@code{.FALSE.} and any nonzero value is interpreted as @code{.TRUE.}.
+
+@smallexample
+        LOGICAL :: l
+        l = 1
+@end smallexample
+@smallexample
+        INTEGER :: i
+        i = .TRUE.
+@end smallexample
+
+However, there is no implicit conversion of @code{INTEGER} values in
+@code{if}-statements, nor of @code{LOGICAL} or @code{INTEGER} values
+in I/O operations.
+
+@node Hollerith constants support
+@subsection Hollerith constants support
+@cindex Hollerith constants
+
+GNU Fortran supports Hollerith constants in assignments, function
+arguments, and @code{DATA} and @code{ASSIGN} statements.  A Hollerith
+constant is written as a string of characters preceded by an integer
+constant indicating the character count, and the letter @code{H} or
+@code{h}, and stored in bytewise fashion in a numeric (@code{INTEGER},
+@code{REAL}, or @code{complex}) or @code{LOGICAL} variable.  The
+constant will be padded or truncated to fit the size of the variable in
+which it is stored.
+
+Examples of valid uses of Hollerith constants:
+@smallexample
+      complex*16 x(2)
+      data x /16Habcdefghijklmnop, 16Hqrstuvwxyz012345/
+      x(1) = 16HABCDEFGHIJKLMNOP
+      call foo (4h abc)
+@end smallexample
+
+Invalid Hollerith constants examples:
+@smallexample
+      integer*4 a
+      a = 8H12345678 ! Valid, but the Hollerith constant will be truncated.
+      a = 0H         ! At least one character is needed.
+@end smallexample
+
+In general, Hollerith constants were used to provide a rudimentary
+facility for handling character strings in early Fortran compilers,
+prior to the introduction of @code{CHARACTER} variables in Fortran 77;
+in those cases, the standard-compliant equivalent is to convert the
+program to use proper character strings.  On occasion, there may be a
+case where the intent is specifically to initialize a numeric variable
+with a given byte sequence.  In these cases, the same result can be
+obtained by using the @code{TRANSFER} statement, as in this example.
+@smallexample
+      INTEGER(KIND=4) :: a
+      a = TRANSFER ("abcd", a)     ! equivalent to: a = 4Habcd
+@end smallexample
+
+
+@node Cray pointers
+@subsection Cray pointers
+@cindex pointer, Cray
+
+Cray pointers are part of a non-standard extension that provides a
+C-like pointer in Fortran.  This is accomplished through a pair of
+variables: an integer "pointer" that holds a memory address, and a
+"pointee" that is used to dereference the pointer.
+
+Pointer/pointee pairs are declared in statements of the form:
+@smallexample
+        pointer ( <pointer> , <pointee> )
+@end smallexample
+or,
+@smallexample
+        pointer ( <pointer1> , <pointee1> ), ( <pointer2> , <pointee2> ), ...
+@end smallexample
+The pointer is an integer that is intended to hold a memory address.
+The pointee may be an array or scalar.  A pointee can be an assumed
+size array---that is, the last dimension may be left unspecified by
+using a @code{*} in place of a value---but a pointee cannot be an
+assumed shape array.  No space is allocated for the pointee.
+
+The pointee may have its type declared before or after the pointer
+statement, and its array specification (if any) may be declared
+before, during, or after the pointer statement.  The pointer may be
+declared as an integer prior to the pointer statement.  However, some
+machines have default integer sizes that are different than the size
+of a pointer, and so the following code is not portable:
+@smallexample
+        integer ipt
+        pointer (ipt, iarr)
+@end smallexample
+If a pointer is declared with a kind that is too small, the compiler
+will issue a warning; the resulting binary will probably not work
+correctly, because the memory addresses stored in the pointers may be
+truncated.  It is safer to omit the first line of the above example;
+if explicit declaration of ipt's type is omitted, then the compiler
+will ensure that ipt is an integer variable large enough to hold a
+pointer.
+
+Pointer arithmetic is valid with Cray pointers, but it is not the same
+as C pointer arithmetic.  Cray pointers are just ordinary integers, so
+the user is responsible for determining how many bytes to add to a
+pointer in order to increment it.  Consider the following example:
+@smallexample
+        real target(10)
+        real pointee(10)
+        pointer (ipt, pointee)
+        ipt = loc (target)
+        ipt = ipt + 1       
+@end smallexample
+The last statement does not set @code{ipt} to the address of
+@code{target(1)}, as it would in C pointer arithmetic.  Adding @code{1}
+to @code{ipt} just adds one byte to the address stored in @code{ipt}.
+
+Any expression involving the pointee will be translated to use the
+value stored in the pointer as the base address.
+
+To get the address of elements, this extension provides an intrinsic
+function @code{LOC()}.  The @code{LOC()} function is equivalent to the
+@code{&} operator in C, except the address is cast to an integer type:
+@smallexample
+        real ar(10)
+        pointer(ipt, arpte(10))
+        real arpte
+        ipt = loc(ar)  ! Makes arpte is an alias for ar
+        arpte(1) = 1.0 ! Sets ar(1) to 1.0
+@end smallexample
+The pointer can also be set by a call to the @code{MALLOC} intrinsic
+(see @ref{MALLOC}).
+
+Cray pointees often are used to alias an existing variable.  For
+example:
+@smallexample
+        integer target(10)
+        integer iarr(10)
+        pointer (ipt, iarr)
+        ipt = loc(target)
+@end smallexample
+As long as @code{ipt} remains unchanged, @code{iarr} is now an alias for
+@code{target}.  The optimizer, however, will not detect this aliasing, so
+it is unsafe to use @code{iarr} and @code{target} simultaneously.  Using
+a pointee in any way that violates the Fortran aliasing rules or
+assumptions is illegal.  It is the user's responsibility to avoid doing
+this; the compiler works under the assumption that no such aliasing
+occurs.
+
+Cray pointers will work correctly when there is no aliasing (i.e., when
+they are used to access a dynamically allocated block of memory), and
+also in any routine where a pointee is used, but any variable with which
+it shares storage is not used.  Code that violates these rules may not
+run as the user intends.  This is not a bug in the optimizer; any code
+that violates the aliasing rules is illegal.  (Note that this is not
+unique to GNU Fortran; any Fortran compiler that supports Cray pointers
+will ``incorrectly'' optimize code with illegal aliasing.)
+
+There are a number of restrictions on the attributes that can be applied
+to Cray pointers and pointees.  Pointees may not have the
+@code{ALLOCATABLE}, @code{INTENT}, @code{OPTIONAL}, @code{DUMMY},
+@code{TARGET}, @code{INTRINSIC}, or @code{POINTER} attributes.  Pointers
+may not have the @code{DIMENSION}, @code{POINTER}, @code{TARGET},
+@code{ALLOCATABLE}, @code{EXTERNAL}, or @code{INTRINSIC} attributes, nor
+may they be function results.  Pointees may not occur in more than one
+pointer statement.  A pointee cannot be a pointer.  Pointees cannot occur
+in equivalence, common, or data statements.
+
+A Cray pointer may also point to a function or a subroutine.  For
+example, the following excerpt is valid:
+@smallexample
+  implicit none
+  external sub
+  pointer (subptr,subpte)
+  external subpte
+  subptr = loc(sub)
+  call subpte()
+  [...]
+  subroutine sub
+  [...]
+  end subroutine sub
+@end smallexample
+
+A pointer may be modified during the course of a program, and this
+will change the location to which the pointee refers.  However, when
+pointees are passed as arguments, they are treated as ordinary
+variables in the invoked function.  Subsequent changes to the pointer
+will not change the base address of the array that was passed.
+
+@node CONVERT specifier
+@subsection @code{CONVERT} specifier
+@cindex @code{CONVERT} specifier
+
+GNU Fortran allows the conversion of unformatted data between little-
+and big-endian representation to facilitate moving of data
+between different systems.  The conversion can be indicated with
+the @code{CONVERT} specifier on the @code{OPEN} statement.
+@xref{GFORTRAN_CONVERT_UNIT}, for an alternative way of specifying
+the data format via an environment variable.
+
+Valid values for @code{CONVERT} are:
+@itemize @w{}
+@item @code{CONVERT='NATIVE'} Use the native format.  This is the default.
+@item @code{CONVERT='SWAP'} Swap between little- and big-endian.
+@item @code{CONVERT='LITTLE_ENDIAN'} Use the little-endian representation
+for unformatted files.
+@item @code{CONVERT='BIG_ENDIAN'} Use the big-endian representation for
+unformatted files.
+@end itemize
+
+Using the option could look like this:
+@smallexample
+  open(file='big.dat',form='unformatted',access='sequential', &
+       convert='big_endian')
+@end smallexample
+
+The value of the conversion can be queried by using
+@code{INQUIRE(CONVERT=ch)}.  The values returned are
+@code{'BIG_ENDIAN'} and @code{'LITTLE_ENDIAN'}.
+
+@code{CONVERT} works between big- and little-endian for
+@code{INTEGER} values of all supported kinds and for @code{REAL}
+on IEEE systems of kinds 4 and 8.  Conversion between different
+``extended double'' types on different architectures such as
+m68k and x86_64, which GNU Fortran
+supports as @code{REAL(KIND=10)} and @code{REAL(KIND=16)}, will
+probably not work.
+
+@emph{Note that the values specified via the GFORTRAN_CONVERT_UNIT
+environment variable will override the CONVERT specifier in the
+open statement}.  This is to give control over data formats to
+users who do not have the source code of their program available.
+
+Using anything but the native representation for unformatted data
+carries a significant speed overhead.  If speed in this area matters
+to you, it is best if you use this only for data that needs to be
+portable.
+
+@node OpenMP
+@subsection OpenMP
+@cindex OpenMP
+
+OpenMP (Open Multi-Processing) is an application programming
+interface (API) that supports multi-platform shared memory 
+multiprocessing programming in C/C++ and Fortran on many 
+architectures, including Unix and Microsoft Windows platforms.
+It consists of a set of compiler directives, library routines,
+and environment variables that influence run-time behavior.
+
+GNU Fortran strives to be compatible to the 
+@uref{http://www.openmp.org/mp-documents/spec31.pdf,
+OpenMP Application Program Interface v3.1}.
+
+To enable the processing of the OpenMP directive @code{!$omp} in
+free-form source code; the @code{c$omp}, @code{*$omp} and @code{!$omp}
+directives in fixed form; the @code{!$} conditional compilation sentinels
+in free form; and the @code{c$}, @code{*$} and @code{!$} sentinels
+in fixed form, @command{gfortran} needs to be invoked with the
+@option{-fopenmp}.  This also arranges for automatic linking of the
+GNU OpenMP runtime library @ref{Top,,libgomp,libgomp,GNU OpenMP
+runtime library}.
+
+The OpenMP Fortran runtime library routines are provided both in a
+form of a Fortran 90 module named @code{omp_lib} and in a form of
+a Fortran @code{include} file named @file{omp_lib.h}.
+
+An example of a parallelized loop taken from Appendix A.1 of
+the OpenMP Application Program Interface v2.5:
+@smallexample
+SUBROUTINE A1(N, A, B)
+  INTEGER I, N
+  REAL B(N), A(N)
+!$OMP PARALLEL DO !I is private by default
+  DO I=2,N
+    B(I) = (A(I) + A(I-1)) / 2.0
+  ENDDO
+!$OMP END PARALLEL DO
+END SUBROUTINE A1
+@end smallexample
+
+Please note:
+@itemize
+@item
+@option{-fopenmp} implies @option{-frecursive}, i.e., all local arrays
+will be allocated on the stack.  When porting existing code to OpenMP,
+this may lead to surprising results, especially to segmentation faults
+if the stacksize is limited.
+
+@item
+On glibc-based systems, OpenMP enabled applications cannot be statically
+linked due to limitations of the underlying pthreads-implementation.  It
+might be possible to get a working solution if 
+@command{-Wl,--whole-archive -lpthread -Wl,--no-whole-archive} is added
+to the command line.  However, this is not supported by @command{gcc} and
+thus not recommended.
+@end itemize
+
+@node Argument list functions
+@subsection Argument list functions @code{%VAL}, @code{%REF} and @code{%LOC}
+@cindex argument list functions
+@cindex @code{%VAL}
+@cindex @code{%REF}
+@cindex @code{%LOC}
+
+GNU Fortran supports argument list functions @code{%VAL}, @code{%REF} 
+and @code{%LOC} statements, for backward compatibility with g77. 
+It is recommended that these should be used only for code that is 
+accessing facilities outside of GNU Fortran, such as operating system 
+or windowing facilities.  It is best to constrain such uses to isolated 
+portions of a program--portions that deal specifically and exclusively 
+with low-level, system-dependent facilities.  Such portions might well 
+provide a portable interface for use by the program as a whole, but are 
+themselves not portable, and should be thoroughly tested each time they 
+are rebuilt using a new compiler or version of a compiler.
+
+@code{%VAL} passes a scalar argument by value, @code{%REF} passes it by 
+reference and @code{%LOC} passes its memory location.  Since gfortran 
+already passes scalar arguments by reference, @code{%REF} is in effect 
+a do-nothing.  @code{%LOC} has the same effect as a Fortran pointer.
+
+An example of passing an argument by value to a C subroutine foo.:
+@smallexample
+C
+C prototype      void foo_ (float x);
+C
+      external foo
+      real*4 x
+      x = 3.14159
+      call foo (%VAL (x))
+      end
+@end smallexample
+
+For details refer to the g77 manual
+@uref{http://gcc.gnu.org/@/onlinedocs/@/gcc-3.4.6/@/g77/@/index.html#Top}.
+
+Also, @code{c_by_val.f} and its partner @code{c_by_val.c} of the
+GNU Fortran testsuite are worth a look.
+
+
+@node Extensions not implemented in GNU Fortran
+@section Extensions not implemented in GNU Fortran
+@cindex extensions, not implemented
+
+The long history of the Fortran language, its wide use and broad
+userbase, the large number of different compiler vendors and the lack of
+some features crucial to users in the first standards have lead to the
+existence of a number of important extensions to the language.  While
+some of the most useful or popular extensions are supported by the GNU
+Fortran compiler, not all existing extensions are supported.  This section
+aims at listing these extensions and offering advice on how best make
+code that uses them running with the GNU Fortran compiler.
+
+@c More can be found here:
+@c   -- http://gcc.gnu.org/onlinedocs/gcc-3.4.6/g77/Missing-Features.html
+@c   -- the list of Fortran and libgfortran bugs closed as WONTFIX:
+@c      http://tinyurl.com/2u4h5y
+
+@menu
+* STRUCTURE and RECORD::
+@c * UNION and MAP::
+* ENCODE and DECODE statements::
+* Variable FORMAT expressions::
+@c * Q edit descriptor::
+@c * AUTOMATIC statement::
+@c * TYPE and ACCEPT I/O Statements::
+@c * .XOR. operator::
+@c * CARRIAGECONTROL, DEFAULTFILE, DISPOSE and RECORDTYPE I/O specifiers::
+@c * Omitted arguments in procedure call::
+* Alternate complex function syntax::
+@end menu
+
+
+@node STRUCTURE and RECORD
+@subsection @code{STRUCTURE} and @code{RECORD}
+@cindex @code{STRUCTURE}
+@cindex @code{RECORD}
+
+Record structures are a pre-Fortran-90 vendor extension to create
+user-defined aggregate data types.  GNU Fortran does not support
+record structures, only Fortran 90's ``derived types'', which have
+a different syntax.
+
+In many cases, record structures can easily be converted to derived types.
+To convert, replace @code{STRUCTURE /}@var{structure-name}@code{/}
+by @code{TYPE} @var{type-name}.  Additionally, replace
+@code{RECORD /}@var{structure-name}@code{/} by
+@code{TYPE(}@var{type-name}@code{)}. Finally, in the component access,
+replace the period (@code{.}) by the percent sign (@code{%}).
+
+Here is an example of code using the non portable record structure syntax:
+
+@example
+! Declaring a structure named ``item'' and containing three fields:
+! an integer ID, an description string and a floating-point price.
+STRUCTURE /item/
+  INTEGER id
+  CHARACTER(LEN=200) description
+  REAL price
+END STRUCTURE
+
+! Define two variables, an single record of type ``item''
+! named ``pear'', and an array of items named ``store_catalog''
+RECORD /item/ pear, store_catalog(100)
+
+! We can directly access the fields of both variables
+pear.id = 92316
+pear.description = "juicy D'Anjou pear"
+pear.price = 0.15
+store_catalog(7).id = 7831
+store_catalog(7).description = "milk bottle"
+store_catalog(7).price = 1.2
+
+! We can also manipulate the whole structure
+store_catalog(12) = pear
+print *, store_catalog(12)
+@end example
+
+@noindent
+This code can easily be rewritten in the Fortran 90 syntax as following:
+
+@example
+! ``STRUCTURE /name/ ... END STRUCTURE'' becomes
+! ``TYPE name ... END TYPE''
+TYPE item
+  INTEGER id
+  CHARACTER(LEN=200) description
+  REAL price
+END TYPE
+
+! ``RECORD /name/ variable'' becomes ``TYPE(name) variable''
+TYPE(item) pear, store_catalog(100)
+
+! Instead of using a dot (.) to access fields of a record, the
+! standard syntax uses a percent sign (%)
+pear%id = 92316
+pear%description = "juicy D'Anjou pear"
+pear%price = 0.15
+store_catalog(7)%id = 7831
+store_catalog(7)%description = "milk bottle"
+store_catalog(7)%price = 1.2
+
+! Assignments of a whole variable do not change
+store_catalog(12) = pear
+print *, store_catalog(12)
+@end example
+
+
+@c @node UNION and MAP
+@c @subsection @code{UNION} and @code{MAP}
+@c @cindex @code{UNION}
+@c @cindex @code{MAP}
+@c
+@c For help writing this one, see
+@c http://www.eng.umd.edu/~nsw/ench250/fortran1.htm#UNION and
+@c http://www.tacc.utexas.edu/services/userguides/pgi/pgiws_ug/pgi32u06.htm
+
+
+@node ENCODE and DECODE statements
+@subsection @code{ENCODE} and @code{DECODE} statements
+@cindex @code{ENCODE}
+@cindex @code{DECODE}
+
+GNU Fortran does not support the @code{ENCODE} and @code{DECODE}
+statements.  These statements are best replaced by @code{READ} and
+@code{WRITE} statements involving internal files (@code{CHARACTER}
+variables and arrays), which have been part of the Fortran standard since
+Fortran 77.  For example, replace a code fragment like
+
+@smallexample
+      INTEGER*1 LINE(80)
+      REAL A, B, C
+c     ... Code that sets LINE
+      DECODE (80, 9000, LINE) A, B, C
+ 9000 FORMAT (1X, 3(F10.5))
+@end smallexample
+
+@noindent
+with the following:
+
+@smallexample
+      CHARACTER(LEN=80) LINE
+      REAL A, B, C
+c     ... Code that sets LINE
+      READ (UNIT=LINE, FMT=9000) A, B, C
+ 9000 FORMAT (1X, 3(F10.5))
+@end smallexample
+
+Similarly, replace a code fragment like
+
+@smallexample
+      INTEGER*1 LINE(80)
+      REAL A, B, C
+c     ... Code that sets A, B and C
+      ENCODE (80, 9000, LINE) A, B, C
+ 9000 FORMAT (1X, 'OUTPUT IS ', 3(F10.5))
+@end smallexample
+
+@noindent
+with the following:
+
+@smallexample
+      CHARACTER(LEN=80) LINE
+      REAL A, B, C
+c     ... Code that sets A, B and C
+      WRITE (UNIT=LINE, FMT=9000) A, B, C
+ 9000 FORMAT (1X, 'OUTPUT IS ', 3(F10.5))
+@end smallexample
+
+
+@node Variable FORMAT expressions
+@subsection Variable @code{FORMAT} expressions
+@cindex @code{FORMAT}
+
+A variable @code{FORMAT} expression is format statement which includes
+angle brackets enclosing a Fortran expression: @code{FORMAT(I<N>)}.  GNU
+Fortran does not support this legacy extension.  The effect of variable
+format expressions can be reproduced by using the more powerful (and
+standard) combination of internal output and string formats.  For example,
+replace a code fragment like this:
+
+@smallexample
+      WRITE(6,20) INT1
+ 20   FORMAT(I<N+1>)
+@end smallexample
+
+@noindent
+with the following:
+
+@smallexample
+c     Variable declaration
+      CHARACTER(LEN=20) FMT
+c     
+c     Other code here...
+c
+      WRITE(FMT,'("(I", I0, ")")') N+1
+      WRITE(6,FMT) INT1
+@end smallexample
+
+@noindent
+or with:
+
+@smallexample
+c     Variable declaration
+      CHARACTER(LEN=20) FMT
+c     
+c     Other code here...
+c
+      WRITE(FMT,*) N+1
+      WRITE(6,"(I" // ADJUSTL(FMT) // ")") INT1
+@end smallexample
+
+
+@node Alternate complex function syntax
+@subsection Alternate complex function syntax
+@cindex Complex function
+
+Some Fortran compilers, including @command{g77}, let the user declare
+complex functions with the syntax @code{COMPLEX FUNCTION name*16()}, as
+well as @code{COMPLEX*16 FUNCTION name()}.  Both are non-standard, legacy
+extensions.  @command{gfortran} accepts the latter form, which is more
+common, but not the former.
+
+
+
+@c ---------------------------------------------------------------------
+@c Mixed-Language Programming
+@c ---------------------------------------------------------------------
+
+@node Mixed-Language Programming
+@chapter Mixed-Language Programming
+@cindex Interoperability
+@cindex Mixed-language programming
+
+@menu
+* Interoperability with C::
+* GNU Fortran Compiler Directives::
+* Non-Fortran Main Program::
+* Naming and argument-passing conventions::
+@end menu
+
+This chapter is about mixed-language interoperability, but also applies
+if one links Fortran code compiled by different compilers.  In most cases,
+use of the C Binding features of the Fortran 2003 standard is sufficient,
+and their use is highly recommended.
+
+
+@node Interoperability with C
+@section Interoperability with C
+
+@menu
+* Intrinsic Types::
+* Derived Types and struct::
+* Interoperable Global Variables::
+* Interoperable Subroutines and Functions::
+* Working with Pointers::
+* Further Interoperability of Fortran with C::
+@end menu
+
+Since Fortran 2003 (ISO/IEC 1539-1:2004(E)) there is a
+standardized way to generate procedure and derived-type
+declarations and global variables which are interoperable with C
+(ISO/IEC 9899:1999).  The @code{bind(C)} attribute has been added
+to inform the compiler that a symbol shall be interoperable with C;
+also, some constraints are added.  Note, however, that not
+all C features have a Fortran equivalent or vice versa.  For instance,
+neither C's unsigned integers nor C's functions with variable number
+of arguments have an equivalent in Fortran.
+
+Note that array dimensions are reversely ordered in C and that arrays in
+C always start with index 0 while in Fortran they start by default with
+1.  Thus, an array declaration @code{A(n,m)} in Fortran matches
+@code{A[m][n]} in C and accessing the element @code{A(i,j)} matches
+@code{A[j-1][i-1]}.  The element following @code{A(i,j)} (C: @code{A[j-1][i-1]};
+assuming @math{i < n}) in memory is @code{A(i+1,j)} (C: @code{A[j-1][i]}).
+
+@node Intrinsic Types
+@subsection Intrinsic Types
+
+In order to ensure that exactly the same variable type and kind is used
+in C and Fortran, the named constants shall be used which are defined in the
+@code{ISO_C_BINDING} intrinsic module.  That module contains named constants
+for kind parameters and character named constants for the escape sequences
+in C.  For a list of the constants, see @ref{ISO_C_BINDING}.
+
+For logical types, please note that the Fortran standard only guarantees
+interoperability between C99's @code{_Bool} and Fortran's @code{C_Bool}-kind
+logicals and C99 defines that @code{true} has the value 1 and @code{false}
+the value 0.  Using any other integer value with GNU Fortran's @code{LOGICAL}
+(with any kind parameter) gives an undefined result.  (Passing other integer
+values than 0 and 1 to GCC's @code{_Bool} is also undefined, unless the
+integer is explicitly or implicitly casted to @code{_Bool}.)
+
+
+
+@node Derived Types and struct
+@subsection Derived Types and struct
+
+For compatibility of derived types with @code{struct}, one needs to use
+the @code{BIND(C)} attribute in the type declaration.  For instance, the
+following type declaration
+
+@smallexample
+ USE ISO_C_BINDING
+ TYPE, BIND(C) :: myType
+   INTEGER(C_INT) :: i1, i2
+   INTEGER(C_SIGNED_CHAR) :: i3
+   REAL(C_DOUBLE) :: d1
+   COMPLEX(C_FLOAT_COMPLEX) :: c1
+   CHARACTER(KIND=C_CHAR) :: str(5)
+ END TYPE
+@end smallexample
+
+matches the following @code{struct} declaration in C
+
+@smallexample
+ struct @{
+   int i1, i2;
+   /* Note: "char" might be signed or unsigned.  */
+   signed char i3;
+   double d1;
+   float _Complex c1;
+   char str[5];
+ @} myType;
+@end smallexample
+
+Derived types with the C binding attribute shall not have the @code{sequence}
+attribute, type parameters, the @code{extends} attribute, nor type-bound
+procedures.  Every component must be of interoperable type and kind and may not
+have the @code{pointer} or @code{allocatable} attribute.  The names of the
+components are irrelevant for interoperability.
+
+As there exist no direct Fortran equivalents, neither unions nor structs
+with bit field or variable-length array members are interoperable.
+
+@node Interoperable Global Variables
+@subsection Interoperable Global Variables
+
+Variables can be made accessible from C using the C binding attribute,
+optionally together with specifying a binding name.  Those variables
+have to be declared in the declaration part of a @code{MODULE},
+be of interoperable type, and have neither the @code{pointer} nor
+the @code{allocatable} attribute.
+
+@smallexample
+  MODULE m
+    USE myType_module
+    USE ISO_C_BINDING
+    integer(C_INT), bind(C, name="_MyProject_flags") :: global_flag
+    type(myType), bind(C) :: tp
+  END MODULE
+@end smallexample
+
+Here, @code{_MyProject_flags} is the case-sensitive name of the variable
+as seen from C programs while @code{global_flag} is the case-insensitive
+name as seen from Fortran.  If no binding name is specified, as for
+@var{tp}, the C binding name is the (lowercase) Fortran binding name.
+If a binding name is specified, only a single variable may be after the
+double colon.  Note of warning: You cannot use a global variable to
+access @var{errno} of the C library as the C standard allows it to be
+a macro.  Use the @code{IERRNO} intrinsic (GNU extension) instead.
+
+@node Interoperable Subroutines and Functions
+@subsection Interoperable Subroutines and Functions
+
+Subroutines and functions have to have the @code{BIND(C)} attribute to
+be compatible with C.  The dummy argument declaration is relatively
+straightforward.  However, one needs to be careful because C uses
+call-by-value by default while Fortran behaves usually similar to
+call-by-reference.  Furthermore, strings and pointers are handled
+differently.  Note that in Fortran 2003 and 2008 only explicit size
+and assumed-size arrays are supported but not assumed-shape or
+deferred-shape (i.e. allocatable or pointer) arrays.  However, those
+are allowed since the Technical Specification 29113, see
+@ref{Further Interoperability of Fortran with C}
+
+To pass a variable by value, use the @code{VALUE} attribute.
+Thus, the following C prototype
+
+@smallexample
+@code{int func(int i, int *j)}
+@end smallexample
+
+matches the Fortran declaration
+
+@smallexample
+  integer(c_int) function func(i,j)
+    use iso_c_binding, only: c_int
+    integer(c_int), VALUE :: i
+    integer(c_int) :: j
+@end smallexample
+
+Note that pointer arguments also frequently need the @code{VALUE} attribute,
+see @ref{Working with Pointers}.
+
+Strings are handled quite differently in C and Fortran.  In C a string
+is a @code{NUL}-terminated array of characters while in Fortran each string
+has a length associated with it and is thus not terminated (by e.g.
+@code{NUL}).  For example, if one wants to use the following C function,
+
+@smallexample
+  #include <stdio.h>
+  void print_C(char *string) /* equivalent: char string[]  */
+  @{
+     printf("%s\n", string);
+  @}
+@end smallexample
+
+to print ``Hello World'' from Fortran, one can call it using
+
+@smallexample
+  use iso_c_binding, only: C_CHAR, C_NULL_CHAR
+  interface
+    subroutine print_c(string) bind(C, name="print_C")
+      use iso_c_binding, only: c_char
+      character(kind=c_char) :: string(*)
+    end subroutine print_c
+  end interface
+  call print_c(C_CHAR_"Hello World"//C_NULL_CHAR)
+@end smallexample
+
+As the example shows, one needs to ensure that the
+string is @code{NUL} terminated.  Additionally, the dummy argument
+@var{string} of @code{print_C} is a length-one assumed-size
+array; using @code{character(len=*)} is not allowed.  The example
+above uses @code{c_char_"Hello World"} to ensure the string
+literal has the right type; typically the default character
+kind and @code{c_char} are the same and thus @code{"Hello World"}
+is equivalent.  However, the standard does not guarantee this.
+
+The use of strings is now further illustrated using the C library
+function @code{strncpy}, whose prototype is
+
+@smallexample
+  char *strncpy(char *restrict s1, const char *restrict s2, size_t n);
+@end smallexample
+
+The function @code{strncpy} copies at most @var{n} characters from
+string @var{s2} to @var{s1} and returns @var{s1}.  In the following
+example, we ignore the return value:
+
+@smallexample
+  use iso_c_binding
+  implicit none
+  character(len=30) :: str,str2
+  interface
+    ! Ignore the return value of strncpy -> subroutine
+    ! "restrict" is always assumed if we do not pass a pointer
+    subroutine strncpy(dest, src, n) bind(C)
+      import
+      character(kind=c_char),  intent(out) :: dest(*)
+      character(kind=c_char),  intent(in)  :: src(*)
+      integer(c_size_t), value, intent(in) :: n
+    end subroutine strncpy
+  end interface
+  str = repeat('X',30) ! Initialize whole string with 'X'
+  call strncpy(str, c_char_"Hello World"//C_NULL_CHAR, &
+               len(c_char_"Hello World",kind=c_size_t))
+  print '(a)', str ! prints: "Hello WorldXXXXXXXXXXXXXXXXXXX"
+  end
+@end smallexample
+
+The intrinsic procedures are described in @ref{Intrinsic Procedures}.
+
+@node Working with Pointers
+@subsection Working with Pointers
+
+C pointers are represented in Fortran via the special opaque derived type
+@code{type(c_ptr)} (with private components).  Thus one needs to
+use intrinsic conversion procedures to convert from or to C pointers.
+
+For some applications, using an assumed type (@code{TYPE(*)}) can be an
+alternative to a C pointer; see
+@ref{Further Interoperability of Fortran with C}.
+
+For example,
+
+@smallexample
+  use iso_c_binding
+  type(c_ptr) :: cptr1, cptr2
+  integer, target :: array(7), scalar
+  integer, pointer :: pa(:), ps
+  cptr1 = c_loc(array(1)) ! The programmer needs to ensure that the
+                          ! array is contiguous if required by the C
+                          ! procedure
+  cptr2 = c_loc(scalar)
+  call c_f_pointer(cptr2, ps)
+  call c_f_pointer(cptr2, pa, shape=[7])
+@end smallexample
+
+When converting C to Fortran arrays, the one-dimensional @code{SHAPE} argument
+has to be passed.
+
+If a pointer is a dummy-argument of an interoperable procedure, it usually
+has to be declared using the @code{VALUE} attribute.  @code{void*}
+matches @code{TYPE(C_PTR), VALUE}, while @code{TYPE(C_PTR)} alone
+matches @code{void**}.
+
+Procedure pointers are handled analogously to pointers; the C type is
+@code{TYPE(C_FUNPTR)} and the intrinsic conversion procedures are
+@code{C_F_PROCPOINTER} and @code{C_FUNLOC}.
+
+Let us consider two examples of actually passing a procedure pointer from
+C to Fortran and vice versa.  Note that these examples are also very
+similar to passing ordinary pointers between both languages. First,
+consider this code in C:
+
+@smallexample
+/* Procedure implemented in Fortran.  */
+void get_values (void (*)(double));
+
+/* Call-back routine we want called from Fortran.  */
+void
+print_it (double x)
+@{
+  printf ("Number is %f.\n", x);
+@}
+
+/* Call Fortran routine and pass call-back to it.  */
+void
+foobar ()
+@{
+  get_values (&print_it);
+@}
+@end smallexample
+
+A matching implementation for @code{get_values} in Fortran, that correctly
+receives the procedure pointer from C and is able to call it, is given
+in the following @code{MODULE}:
+
+@smallexample
+MODULE m
+  IMPLICIT NONE
+
+  ! Define interface of call-back routine.
+  ABSTRACT INTERFACE
+    SUBROUTINE callback (x)
+      USE, INTRINSIC :: ISO_C_BINDING
+      REAL(KIND=C_DOUBLE), INTENT(IN), VALUE :: x
+    END SUBROUTINE callback
+  END INTERFACE
+
+CONTAINS
+
+  ! Define C-bound procedure.
+  SUBROUTINE get_values (cproc) BIND(C)
+    USE, INTRINSIC :: ISO_C_BINDING
+    TYPE(C_FUNPTR), INTENT(IN), VALUE :: cproc
+
+    PROCEDURE(callback), POINTER :: proc
+
+    ! Convert C to Fortran procedure pointer.
+    CALL C_F_PROCPOINTER (cproc, proc)
+
+    ! Call it.
+    CALL proc (1.0_C_DOUBLE)
+    CALL proc (-42.0_C_DOUBLE)
+    CALL proc (18.12_C_DOUBLE)
+  END SUBROUTINE get_values
+
+END MODULE m
+@end smallexample
+
+Next, we want to call a C routine that expects a procedure pointer argument
+and pass it a Fortran procedure (which clearly must be interoperable!).
+Again, the C function may be:
+
+@smallexample
+int
+call_it (int (*func)(int), int arg)
+@{
+  return func (arg);
+@}
+@end smallexample
+
+It can be used as in the following Fortran code:
+
+@smallexample
+MODULE m
+  USE, INTRINSIC :: ISO_C_BINDING
+  IMPLICIT NONE
+
+  ! Define interface of C function.
+  INTERFACE
+    INTEGER(KIND=C_INT) FUNCTION call_it (func, arg) BIND(C)
+      USE, INTRINSIC :: ISO_C_BINDING
+      TYPE(C_FUNPTR), INTENT(IN), VALUE :: func
+      INTEGER(KIND=C_INT), INTENT(IN), VALUE :: arg
+    END FUNCTION call_it
+  END INTERFACE
+
+CONTAINS
+
+  ! Define procedure passed to C function.
+  ! It must be interoperable!
+  INTEGER(KIND=C_INT) FUNCTION double_it (arg) BIND(C)
+    INTEGER(KIND=C_INT), INTENT(IN), VALUE :: arg
+    double_it = arg + arg
+  END FUNCTION double_it
+
+  ! Call C function.
+  SUBROUTINE foobar ()
+    TYPE(C_FUNPTR) :: cproc
+    INTEGER(KIND=C_INT) :: i
+
+    ! Get C procedure pointer.
+    cproc = C_FUNLOC (double_it)
+
+    ! Use it.
+    DO i = 1_C_INT, 10_C_INT
+      PRINT *, call_it (cproc, i)
+    END DO
+  END SUBROUTINE foobar
+
+END MODULE m
+@end smallexample
+
+@node Further Interoperability of Fortran with C
+@subsection Further Interoperability of Fortran with C
+
+The Technical Specification ISO/IEC TS 29113:2012 on further
+interoperability of Fortran with C extends the interoperability support
+of Fortran 2003 and Fortran 2008. Besides removing some restrictions
+and constraints, it adds assumed-type (@code{TYPE(*)}) and assumed-rank
+(@code{dimension}) variables and allows for interoperability of
+assumed-shape, assumed-rank and deferred-shape arrays, including
+allocatables and pointers.
+
+Note: Currently, GNU Fortran does not support the array descriptor
+(dope vector) as specified in the Technical Specification, but uses
+an array descriptor with different fields. The Chasm Language
+Interoperability Tools, @url{http://chasm-interop.sourceforge.net/},
+provide an interface to GNU Fortran's array descriptor.
+
+The Technical Specification adds the following new features, which
+are supported by GNU Fortran:
+
+@itemize @bullet
+
+@item The @code{ASYNCHRONOUS} attribute has been clarified and
+extended to allow its use with asynchronous communication in
+user-provided libraries such as in implementations of the
+Message Passing Interface specification.
+
+@item Many constraints have been relaxed, in particular for
+the @code{C_LOC} and @code{C_F_POINTER} intrinsics.
+
+@item The @code{OPTIONAL} attribute is now allowed for dummy
+arguments; an absent argument matches a @code{NULL} pointer.
+
+@item Assumed types (@code{TYPE(*)}) have been added, which may
+only be used for dummy arguments.  They are unlimited polymorphic
+but contrary to @code{CLASS(*)} they do not contain any type
+information, similar to C's @code{void *} pointers.  Expressions
+of any type and kind can be passed; thus, it can be used as
+replacement for @code{TYPE(C_PTR)}, avoiding the use of
+@code{C_LOC} in the caller.
+
+Note, however, that @code{TYPE(*)} only accepts scalar arguments,
+unless the @code{DIMENSION} is explicitly specified.  As
+@code{DIMENSION(*)} only supports array (including array elements) but
+no scalars, it is not a full replacement for @code{C_LOC}.  On the
+other hand, assumed-type assumed-rank dummy arguments
+(@code{TYPE(*), DIMENSION(..)}) allow for both scalars and arrays, but
+require special code on the callee side to handle the array descriptor.
+
+@item Assumed-rank arrays (@code{DIMENSION(..)}) as dummy argument
+allow that scalars and arrays of any rank can be passed as actual
+argument. As the Technical Specification does not provide for direct
+means to operate with them, they have to be used either from the C side
+or be converted using @code{C_LOC} and @code{C_F_POINTER} to scalars
+or arrays of a specific rank. The rank can be determined using the
+@code{RANK} intrinisic.
+@end itemize
+
+
+Currently unimplemented:
+
+@itemize @bullet
+
+@item GNU Fortran always uses an array descriptor, which does not
+match the one of the Technical Specification. The
+@code{ISO_Fortran_binding.h} header file and the C functions it
+specifies are not available.
+
+@item Using assumed-shape, assumed-rank and deferred-shape arrays in
+@code{BIND(C)} procedures is not fully supported. In particular,
+C interoperable strings of other length than one are not supported
+as this requires the new array descriptor.
+@end itemize
+
+
+@node GNU Fortran Compiler Directives
+@section GNU Fortran Compiler Directives
+
+The Fortran standard describes how a conforming program shall
+behave; however, the exact implementation is not standardized.  In order
+to allow the user to choose specific implementation details, compiler
+directives can be used to set attributes of variables and procedures
+which are not part of the standard.  Whether a given attribute is
+supported and its exact effects depend on both the operating system and
+on the processor; see
+@ref{Top,,C Extensions,gcc,Using the GNU Compiler Collection (GCC)}
+for details.
+
+For procedures and procedure pointers, the following attributes can
+be used to change the calling convention:
+
+@itemize
+@item @code{CDECL} -- standard C calling convention
+@item @code{STDCALL} -- convention where the called procedure pops the stack
+@item @code{FASTCALL} -- part of the arguments are passed via registers
+instead using the stack
+@end itemize
+
+Besides changing the calling convention, the attributes also influence
+the decoration of the symbol name, e.g., by a leading underscore or by
+a trailing at-sign followed by the number of bytes on the stack.  When
+assigning a procedure to a procedure pointer, both should use the same
+calling convention.
+
+On some systems, procedures and global variables (module variables and
+@code{COMMON} blocks) need special handling to be accessible when they
+are in a shared library.  The following attributes are available:
+
+@itemize
+@item @code{DLLEXPORT} -- provide a global pointer to a pointer in the DLL
+@item @code{DLLIMPORT} -- reference the function or variable using a global pointer 
+@end itemize
+
+For dummy arguments, the @code{NO_ARG_CHECK} attribute can be used; in
+other compilers, it is also known as @code{IGNORE_TKR}.  For dummy arguments
+with this attribute actual arguments of any type and kind (similar to
+@code{TYPE(*)}), scalars and arrays of any rank (no equivalent
+in Fortran standard) are accepted.  As with @code{TYPE(*)}, the argument
+is unlimited polymorphic and no type information is available.
+Additionally, the argument may only be passed to dummy arguments
+with the @code{NO_ARG_CHECK} attribute and as argument to the
+@code{PRESENT} intrinsic function and to @code{C_LOC} of the
+@code{ISO_C_BINDING} module.
+
+Variables with @code{NO_ARG_CHECK} attribute shall be of assumed-type
+(@code{TYPE(*)}; recommended) or of type @code{INTEGER}, @code{LOGICAL},
+@code{REAL} or @code{COMPLEX}. They shall not have the @code{ALLOCATE},
+@code{CODIMENSION}, @code{INTENT(OUT)}, @code{POINTER} or @code{VALUE}
+attribute; furthermore, they shall be either scalar or of assumed-size
+(@code{dimension(*)}). As @code{TYPE(*)}, the @code{NO_ARG_CHECK} attribute
+requires an explicit interface.
+
+@itemize
+@item @code{NO_ARG_CHECK} -- disable the type, kind and rank checking
+@end itemize
+
+
+The attributes are specified using the syntax
+
+@code{!GCC$ ATTRIBUTES} @var{attribute-list} @code{::} @var{variable-list}
+
+where in free-form source code only whitespace is allowed before @code{!GCC$}
+and in fixed-form source code @code{!GCC$}, @code{cGCC$} or @code{*GCC$} shall
+start in the first column.
+
+For procedures, the compiler directives shall be placed into the body
+of the procedure; for variables and procedure pointers, they shall be in
+the same declaration part as the variable or procedure pointer.
+
+
+
+@node Non-Fortran Main Program
+@section Non-Fortran Main Program
+
+@menu
+* _gfortran_set_args:: Save command-line arguments
+* _gfortran_set_options:: Set library option flags
+* _gfortran_set_convert:: Set endian conversion
+* _gfortran_set_record_marker:: Set length of record markers
+* _gfortran_set_fpe:: Set when a Floating Point Exception should be raised
+* _gfortran_set_max_subrecord_length:: Set subrecord length
+@end menu
+
+Even if you are doing mixed-language programming, it is very
+likely that you do not need to know or use the information in this
+section.  Since it is about the internal structure of GNU Fortran,
+it may also change in GCC minor releases.
+
+When you compile a @code{PROGRAM} with GNU Fortran, a function
+with the name @code{main} (in the symbol table of the object file)
+is generated, which initializes the libgfortran library and then
+calls the actual program which uses the name @code{MAIN__}, for
+historic reasons.  If you link GNU Fortran compiled procedures
+to, e.g., a C or C++ program or to a Fortran program compiled by
+a different compiler, the libgfortran library is not initialized
+and thus a few intrinsic procedures do not work properly, e.g.
+those for obtaining the command-line arguments.
+
+Therefore, if your @code{PROGRAM} is not compiled with
+GNU Fortran and the GNU Fortran compiled procedures require
+intrinsics relying on the library initialization, you need to
+initialize the library yourself.  Using the default options,
+gfortran calls @code{_gfortran_set_args} and
+@code{_gfortran_set_options}.  The initialization of the former
+is needed if the called procedures access the command line
+(and for backtracing); the latter sets some flags based on the
+standard chosen or to enable backtracing.  In typical programs,
+it is not necessary to call any initialization function.
+
+If your @code{PROGRAM} is compiled with GNU Fortran, you shall
+not call any of the following functions.  The libgfortran
+initialization functions are shown in C syntax but using C
+bindings they are also accessible from Fortran.
+
+
+@node _gfortran_set_args
+@subsection @code{_gfortran_set_args} --- Save command-line arguments
+@fnindex _gfortran_set_args
+@cindex libgfortran initialization, set_args
+
+@table @asis
+@item @emph{Description}:
+@code{_gfortran_set_args} saves the command-line arguments; this
+initialization is required if any of the command-line intrinsics
+is called.  Additionally, it shall be called if backtracing is
+enabled (see @code{_gfortran_set_options}).
+
+@item @emph{Syntax}:
+@code{void _gfortran_set_args (int argc, char *argv[])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{argc} @tab number of command line argument strings
+@item @var{argv} @tab the command-line argument strings; argv[0]
+is the pathname of the executable itself.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+int main (int argc, char *argv[])
+@{
+  /* Initialize libgfortran.  */
+  _gfortran_set_args (argc, argv);
+  return 0;
+@}
+@end smallexample
+@end table
+
+
+@node _gfortran_set_options
+@subsection @code{_gfortran_set_options} --- Set library option flags
+@fnindex _gfortran_set_options
+@cindex libgfortran initialization, set_options
+
+@table @asis
+@item @emph{Description}:
+@code{_gfortran_set_options} sets several flags related to the Fortran
+standard to be used, whether backtracing should be enabled
+and whether range checks should be performed.  The syntax allows for
+upward compatibility since the number of passed flags is specified; for
+non-passed flags, the default value is used.  See also
+@pxref{Code Gen Options}.  Please note that not all flags are actually
+used.
+
+@item @emph{Syntax}:
+@code{void _gfortran_set_options (int num, int options[])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{num} @tab number of options passed
+@item @var{argv} @tab The list of flag values
+@end multitable
+
+@item @emph{option flag list}:
+@multitable @columnfractions .15 .70
+@item @var{option}[0] @tab Allowed standard; can give run-time errors
+if e.g. an input-output edit descriptor is invalid in a given standard.
+Possible values are (bitwise or-ed) @code{GFC_STD_F77} (1),
+@code{GFC_STD_F95_OBS} (2), @code{GFC_STD_F95_DEL} (4), @code{GFC_STD_F95}
+(8), @code{GFC_STD_F2003} (16), @code{GFC_STD_GNU} (32),
+@code{GFC_STD_LEGACY} (64), @code{GFC_STD_F2008} (128), 
+@code{GFC_STD_F2008_OBS} (256) and GFC_STD_F2008_TS (512). Default:
+@code{GFC_STD_F95_OBS | GFC_STD_F95_DEL | GFC_STD_F95 | GFC_STD_F2003
+| GFC_STD_F2008 | GFC_STD_F2008_TS | GFC_STD_F2008_OBS | GFC_STD_F77
+| GFC_STD_GNU | GFC_STD_LEGACY}.
+@item @var{option}[1] @tab Standard-warning flag; prints a warning to
+standard error.  Default: @code{GFC_STD_F95_DEL | GFC_STD_LEGACY}.
+@item @var{option}[2] @tab If non zero, enable pedantic checking.
+Default: off.
+@item @var{option}[3] @tab Unused.
+@item @var{option}[4] @tab If non zero, enable backtracing on run-time
+errors.  Default: off. (Default in the compiler: on.)
+Note: Installs a signal handler and requires command-line
+initialization using @code{_gfortran_set_args}.
+@item @var{option}[5] @tab If non zero, supports signed zeros.
+Default: enabled.
+@item @var{option}[6] @tab Enables run-time checking.  Possible values
+are (bitwise or-ed): GFC_RTCHECK_BOUNDS (1), GFC_RTCHECK_ARRAY_TEMPS (2),
+GFC_RTCHECK_RECURSION (4), GFC_RTCHECK_DO (16), GFC_RTCHECK_POINTER (32).
+Default: disabled.
+@item @var{option}[7] @tab Unused.
+@item @var{option}[8] @tab Show a warning when invoking @code{STOP} and
+@code{ERROR STOP} if a floating-point exception occurred. Possible values
+are (bitwise or-ed) @code{GFC_FPE_INVALID} (1), @code{GFC_FPE_DENORMAL} (2),
+@code{GFC_FPE_ZERO} (4), @code{GFC_FPE_OVERFLOW} (8),
+@code{GFC_FPE_UNDERFLOW} (16), @code{GFC_FPE_INEXACT} (32). Default: None (0).
+(Default in the compiler: @code{GFC_FPE_INVALID | GFC_FPE_DENORMAL |
+GFC_FPE_ZERO | GFC_FPE_OVERFLOW | GFC_FPE_UNDERFLOW}.)
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+  /* Use gfortran 4.9 default options.  */
+  static int options[] = @{68, 511, 0, 0, 1, 1, 0, 0, 31@};
+  _gfortran_set_options (9, &options);
+@end smallexample
+@end table
+
+
+@node _gfortran_set_convert
+@subsection @code{_gfortran_set_convert} --- Set endian conversion
+@fnindex _gfortran_set_convert
+@cindex libgfortran initialization, set_convert
+
+@table @asis
+@item @emph{Description}:
+@code{_gfortran_set_convert} set the representation of data for
+unformatted files.
+
+@item @emph{Syntax}:
+@code{void _gfortran_set_convert (int conv)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{conv} @tab Endian conversion, possible values:
+GFC_CONVERT_NATIVE (0, default), GFC_CONVERT_SWAP (1),
+GFC_CONVERT_BIG (2), GFC_CONVERT_LITTLE (3).
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+int main (int argc, char *argv[])
+@{
+  /* Initialize libgfortran.  */
+  _gfortran_set_args (argc, argv);
+  _gfortran_set_convert (1);
+  return 0;
+@}
+@end smallexample
+@end table
+
+
+@node _gfortran_set_record_marker
+@subsection @code{_gfortran_set_record_marker} --- Set length of record markers
+@fnindex _gfortran_set_record_marker
+@cindex libgfortran initialization, set_record_marker
+
+@table @asis
+@item @emph{Description}:
+@code{_gfortran_set_record_marker} sets the length of record markers
+for unformatted files.
+
+@item @emph{Syntax}:
+@code{void _gfortran_set_record_marker (int val)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{val} @tab Length of the record marker; valid values
+are 4 and 8.  Default is 4.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+int main (int argc, char *argv[])
+@{
+  /* Initialize libgfortran.  */
+  _gfortran_set_args (argc, argv);
+  _gfortran_set_record_marker (8);
+  return 0;
+@}
+@end smallexample
+@end table
+
+
+@node _gfortran_set_fpe
+@subsection @code{_gfortran_set_fpe} --- Enable floating point exception traps
+@fnindex _gfortran_set_fpe
+@cindex libgfortran initialization, set_fpe
+
+@table @asis
+@item @emph{Description}:
+@code{_gfortran_set_fpe} enables floating point exception traps for
+the specified exceptions.  On most systems, this will result in a
+SIGFPE signal being sent and the program being aborted.
+
+@item @emph{Syntax}:
+@code{void _gfortran_set_fpe (int val)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{option}[0] @tab IEEE exceptions.  Possible values are
+(bitwise or-ed) zero (0, default) no trapping,
+@code{GFC_FPE_INVALID} (1), @code{GFC_FPE_DENORMAL} (2),
+@code{GFC_FPE_ZERO} (4), @code{GFC_FPE_OVERFLOW} (8),
+@code{GFC_FPE_UNDERFLOW} (16), and @code{GFC_FPE_INEXACT} (32).
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+int main (int argc, char *argv[])
+@{
+  /* Initialize libgfortran.  */
+  _gfortran_set_args (argc, argv);
+  /* FPE for invalid operations such as SQRT(-1.0).  */
+  _gfortran_set_fpe (1);
+  return 0;
+@}
+@end smallexample
+@end table
+
+
+@node _gfortran_set_max_subrecord_length
+@subsection @code{_gfortran_set_max_subrecord_length} --- Set subrecord length
+@fnindex _gfortran_set_max_subrecord_length
+@cindex libgfortran initialization, set_max_subrecord_length
+
+@table @asis
+@item @emph{Description}:
+@code{_gfortran_set_max_subrecord_length} set the maximum length
+for a subrecord.  This option only makes sense for testing and
+debugging of unformatted I/O.
+
+@item @emph{Syntax}:
+@code{void _gfortran_set_max_subrecord_length (int val)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{val} @tab the maximum length for a subrecord;
+the maximum permitted value is 2147483639, which is also
+the default.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+int main (int argc, char *argv[])
+@{
+  /* Initialize libgfortran.  */
+  _gfortran_set_args (argc, argv);
+  _gfortran_set_max_subrecord_length (8);
+  return 0;
+@}
+@end smallexample
+@end table
+
+
+@node Naming and argument-passing conventions
+@section Naming and argument-passing conventions
+
+This section gives an overview about the naming convention of procedures
+and global variables and about the argument passing conventions used by
+GNU Fortran.  If a C binding has been specified, the naming convention
+and some of the argument-passing conventions change.  If possible,
+mixed-language and mixed-compiler projects should use the better defined
+C binding for interoperability.  See @pxref{Interoperability with C}.
+
+@menu
+* Naming conventions::
+* Argument passing conventions::
+@end menu
+
+
+@node Naming conventions
+@subsection Naming conventions
+
+According the Fortran standard, valid Fortran names consist of a letter
+between @code{A} to @code{Z}, @code{a} to @code{z}, digits @code{0},
+@code{1} to @code{9} and underscores (@code{_}) with the restriction
+that names may only start with a letter.  As vendor extension, the
+dollar sign (@code{$}) is additionally permitted with the option
+@option{-fdollar-ok}, but not as first character and only if the
+target system supports it.
+
+By default, the procedure name is the lower-cased Fortran name with an
+appended underscore (@code{_}); using @option{-fno-underscoring} no
+underscore is appended while @code{-fsecond-underscore} appends two
+underscores.  Depending on the target system and the calling convention,
+the procedure might be additionally dressed; for instance, on 32bit
+Windows with @code{stdcall}, an at-sign @code{@@} followed by an integer
+number is appended.  For the changing the calling convention, see
+@pxref{GNU Fortran Compiler Directives}.
+
+For common blocks, the same convention is used, i.e. by default an
+underscore is appended to the lower-cased Fortran name.  Blank commons
+have the name @code{__BLNK__}.
+
+For procedures and variables declared in the specification space of a
+module, the name is formed by @code{__}, followed by the lower-cased
+module name, @code{_MOD_}, and the lower-cased Fortran name.  Note that
+no underscore is appended.
+
+
+@node Argument passing conventions
+@subsection Argument passing conventions
+
+Subroutines do not return a value (matching C99's @code{void}) while
+functions either return a value as specified in the platform ABI or
+the result variable is passed as hidden argument to the function and
+no result is returned.  A hidden result variable is used when the
+result variable is an array or of type @code{CHARACTER}.
+
+Arguments are passed according to the platform ABI. In particular,
+complex arguments might not be compatible to a struct with two real
+components for the real and imaginary part. The argument passing
+matches the one of C99's @code{_Complex}.  Functions with scalar
+complex result variables return their value and do not use a
+by-reference argument.  Note that with the @option{-ff2c} option,
+the argument passing is modified and no longer completely matches
+the platform ABI.  Some other Fortran compilers use @code{f2c}
+semantic by default; this might cause problems with
+interoperablility. 
+
+GNU Fortran passes most arguments by reference, i.e. by passing a
+pointer to the data.  Note that the compiler might use a temporary
+variable into which the actual argument has been copied, if required
+semantically (copy-in/copy-out).
+
+For arguments with @code{ALLOCATABLE} and @code{POINTER}
+attribute (including procedure pointers), a pointer to the pointer
+is passed such that the pointer address can be modified in the
+procedure.
+
+For dummy arguments with the @code{VALUE} attribute: Scalar arguments
+of the type @code{INTEGER}, @code{LOGICAL}, @code{REAL} and
+@code{COMPLEX} are passed by value according to the platform ABI.
+(As vendor extension and not recommended, using @code{%VAL()} in the
+call to a procedure has the same effect.) For @code{TYPE(C_PTR)} and
+procedure pointers, the pointer itself is passed such that it can be
+modified without affecting the caller.
+@c FIXME: Document how VALUE is handled for CHARACTER, TYPE,
+@c CLASS and arrays, i.e. whether the copy-in is done in the caller
+@c or in the callee.
+
+For Boolean (@code{LOGICAL}) arguments, please note that GCC expects
+only the integer value 0 and 1.  If a GNU Fortran @code{LOGICAL}
+variable contains another integer value, the result is undefined.
+As some other Fortran compilers use @math{-1} for @code{.TRUE.},
+extra care has to be taken -- such as passing the value as
+@code{INTEGER}.  (The same value restriction also applies to other
+front ends of GCC, e.g. to GCC's C99 compiler for @code{_Bool}
+or GCC's Ada compiler for @code{Boolean}.)
+
+For arguments of @code{CHARACTER} type, the character length is passed
+as hidden argument.  For deferred-length strings, the value is passed
+by reference, otherwise by value.  The character length has the type
+@code{INTEGER(kind=4)}.  Note with C binding, @code{CHARACTER(len=1)}
+result variables are returned according to the platform ABI and no
+hidden length argument is used for dummy arguments; with @code{VALUE},
+those variables are passed by value.
+
+For @code{OPTIONAL} dummy arguments, an absent argument is denoted
+by a NULL pointer, except for scalar dummy arguments of type
+@code{INTEGER}, @code{LOGICAL}, @code{REAL} and @code{COMPLEX}
+which have the @code{VALUE} attribute.  For those, a hidden Boolean
+argument (@code{logical(kind=C_bool),value}) is used to indicate
+whether the argument is present.
+
+Arguments which are assumed-shape, assumed-rank or deferred-rank
+arrays or, with @option{-fcoarray=lib}, allocatable scalar coarrays use
+an array descriptor.  All other arrays pass the address of the
+first element of the array.  With @option{-fcoarray=lib}, the token
+and the offset belonging to nonallocatable coarrays dummy arguments
+are passed as hidden argument along the character length hidden
+arguments.  The token is an oparque pointer identifying the coarray
+and the offset is a passed-by-value integer of kind @code{C_PTRDIFF_T},
+denoting the byte offset between the base address of the coarray and
+the passed scalar or first element of the passed array.
+
+The arguments are passed in the following order
+@itemize @bullet
+@item Result variable, when the function result is passed by reference
+@item Character length of the function result, if it is a of type
+@code{CHARACTER} and no C binding is used
+@item The arguments in the order in which they appear in the Fortran
+declaration
+@item The the present status for optional arguments with value attribute,
+which are internally passed by value
+@item The character length and/or coarray token and offset for the first
+argument which is a @code{CHARACTER} or a nonallocatable coarray dummy
+argument, followed by the hidden arguments of the next dummy argument
+of such a type
+@end itemize
+
+
+
+@c Intrinsic Procedures
+@c ---------------------------------------------------------------------
+
+@include intrinsic.texi
+
+
+@tex
+\blankpart
+@end tex
+
+@c ---------------------------------------------------------------------
+@c Contributing
+@c ---------------------------------------------------------------------
+
+@node Contributing
+@unnumbered Contributing
+@cindex Contributing
+
+Free software is only possible if people contribute to efforts
+to create it.
+We're always in need of more people helping out with ideas
+and comments, writing documentation and contributing code.
+
+If you want to contribute to GNU Fortran,
+have a look at the long lists of projects you can take on.
+Some of these projects are small,
+some of them are large;
+some are completely orthogonal to the rest of what is
+happening on GNU Fortran,
+but others are ``mainstream'' projects in need of enthusiastic hackers.
+All of these projects are important!
+We will eventually get around to the things here,
+but they are also things doable by someone who is willing and able.
+
+@menu
+* Contributors::
+* Projects::
+* Proposed Extensions::
+@end menu
+
+
+@node Contributors
+@section Contributors to GNU Fortran
+@cindex Contributors
+@cindex Credits
+@cindex Authors
+
+Most of the parser was hand-crafted by @emph{Andy Vaught}, who is
+also the initiator of the whole project.  Thanks Andy!
+Most of the interface with GCC was written by @emph{Paul Brook}.
+
+The following individuals have contributed code and/or
+ideas and significant help to the GNU Fortran project
+(in alphabetical order):
+
+@itemize @minus
+@item Janne Blomqvist
+@item Steven Bosscher
+@item Paul Brook
+@item Tobias Burnus
+@item Fran@,{c}ois-Xavier Coudert
+@item Bud Davis
+@item Jerry DeLisle
+@item Erik Edelmann
+@item Bernhard Fischer
+@item Daniel Franke
+@item Richard Guenther
+@item Richard Henderson
+@item Katherine Holcomb
+@item Jakub Jelinek
+@item Niels Kristian Bech Jensen
+@item Steven Johnson
+@item Steven G. Kargl
+@item Thomas Koenig
+@item Asher Langton
+@item H. J. Lu
+@item Toon Moene
+@item Brooks Moses
+@item Andrew Pinski
+@item Tim Prince
+@item Christopher D. Rickett
+@item Richard Sandiford
+@item Tobias Schl@"uter
+@item Roger Sayle
+@item Paul Thomas
+@item Andy Vaught
+@item Feng Wang
+@item Janus Weil
+@item Daniel Kraft
+@end itemize
+
+The following people have contributed bug reports,
+smaller or larger patches,
+and much needed feedback and encouragement for the
+GNU Fortran project: 
+
+@itemize @minus
+@item Bill Clodius
+@item Dominique d'Humi@`eres
+@item Kate Hedstrom
+@item Erik Schnetter
+@item Joost VandeVondele
+@end itemize
+
+Many other individuals have helped debug,
+test and improve the GNU Fortran compiler over the past few years,
+and we welcome you to do the same!
+If you already have done so,
+and you would like to see your name listed in the
+list above, please contact us.
+
+
+@node Projects
+@section Projects
+
+@table @emph
+
+@item Help build the test suite
+Solicit more code for donation to the test suite: the more extensive the
+testsuite, the smaller the risk of breaking things in the future! We can
+keep code private on request.
+
+@item Bug hunting/squishing
+Find bugs and write more test cases! Test cases are especially very
+welcome, because it allows us to concentrate on fixing bugs instead of
+isolating them.  Going through the bugzilla database at
+@url{http://gcc.gnu.org/@/bugzilla/} to reduce testcases posted there and
+add more information (for example, for which version does the testcase
+work, for which versions does it fail?) is also very helpful.
+
+@end table
+
+
+@node Proposed Extensions
+@section Proposed Extensions
+
+Here's a list of proposed extensions for the GNU Fortran compiler, in no particular
+order.  Most of these are necessary to be fully compatible with
+existing Fortran compilers, but they are not part of the official
+J3 Fortran 95 standard.
+
+@subsection Compiler extensions: 
+@itemize @bullet
+@item
+User-specified alignment rules for structures.
+
+@item
+Automatically extend single precision constants to double.
+
+@item
+Compile code that conserves memory by dynamically allocating common and
+module storage either on stack or heap.
+
+@item
+Compile flag to generate code for array conformance checking (suggest -CC).
+
+@item
+User control of symbol names (underscores, etc).
+
+@item
+Compile setting for maximum size of stack frame size before spilling
+parts to static or heap.
+
+@item
+Flag to force local variables into static space.
+
+@item
+Flag to force local variables onto stack.
+@end itemize
+
+
+@subsection Environment Options
+@itemize @bullet
+@item
+Pluggable library modules for random numbers, linear algebra.
+LA should use BLAS calling conventions.
+
+@item
+Environment variables controlling actions on arithmetic exceptions like
+overflow, underflow, precision loss---Generate NaN, abort, default.
+action.
+
+@item
+Set precision for fp units that support it (i387).
+
+@item
+Variable for setting fp rounding mode.
+
+@item
+Variable to fill uninitialized variables with a user-defined bit
+pattern.
+
+@item
+Environment variable controlling filename that is opened for that unit
+number.
+
+@item
+Environment variable to clear/trash memory being freed.
+
+@item
+Environment variable to control tracing of allocations and frees.
+
+@item
+Environment variable to display allocated memory at normal program end.
+
+@item
+Environment variable for filename for * IO-unit.
+
+@item
+Environment variable for temporary file directory.
+
+@item
+Environment variable forcing standard output to be line buffered (Unix).
+
+@end itemize
+
+
+@c ---------------------------------------------------------------------
+@c GNU General Public License
+@c ---------------------------------------------------------------------
+
+@include gpl_v3.texi
+
+
+
+@c ---------------------------------------------------------------------
+@c GNU Free Documentation License
+@c ---------------------------------------------------------------------
+
+@include fdl.texi
+
+
+
+@c ---------------------------------------------------------------------
+@c Funding Free Software
+@c ---------------------------------------------------------------------
+
+@include funding.texi
+
+@c ---------------------------------------------------------------------
+@c Indices
+@c ---------------------------------------------------------------------
+
+@node Option Index
+@unnumbered Option Index
+@command{gfortran}'s command line options are indexed here without any
+initial @samp{-} or @samp{--}.  Where an option has both positive and
+negative forms (such as -foption and -fno-option), relevant entries in
+the manual are indexed under the most appropriate form; it may sometimes
+be useful to look up both forms.
+@printindex op
+
+@node Keyword Index
+@unnumbered Keyword Index
+@printindex cp
+
+@bye
diff --git a/gcc-4.9/gcc/fortran/gfortranspec.c b/gcc-4.9/gcc/fortran/gfortranspec.c
new file mode 100644
index 000000000..a6296efbf
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/gfortranspec.c
@@ -0,0 +1,484 @@
+/* Specific flags and argument handling of the Fortran front-end.
+   Copyright (C) 1997-2014 Free Software Foundation, Inc.
+
+This file is part of GCC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+/* This file is copied more or less verbatim from g77.  */
+/* This file contains a filter for the main `gcc' driver, which is
+   replicated for the `gfortran' driver by adding this filter.  The purpose
+   of this filter is to be basically identical to gcc (in that
+   it faithfully passes all of the original arguments to gcc) but,
+   unless explicitly overridden by the user in certain ways, ensure
+   that the needs of the language supported by this wrapper are met.
+
+   For GNU Fortran 95(gfortran), we do the following to the argument list
+   before passing it to `gcc':
+
+   1.  Make sure `-lgfortran -lm' is at the end of the list.
+
+   2.  Make sure each time `-lgfortran' or `-lm' is seen, it forms
+       part of the series `-lgfortran -lm'.
+
+   #1 and #2 are not done if `-nostdlib' or any option that disables
+   the linking phase is present, or if `-xfoo' is in effect.  Note that
+   a lack of source files or -l options disables linking.
+
+   This program was originally made out of gcc/cp/g++spec.c, but the
+   way it builds the new argument list was rewritten so it is much
+   easier to maintain, improve the way it decides to add or not add
+   extra arguments, etc.  And several improvements were made in the
+   handling of arguments, primarily to make it more consistent with
+   `gcc' itself.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "gcc.h"
+#include "opts.h"
+
+#include "tm.h"
+#include "intl.h"
+
+#ifndef MATH_LIBRARY
+#define MATH_LIBRARY "m"
+#endif
+
+#ifndef FORTRAN_LIBRARY
+#define FORTRAN_LIBRARY "gfortran"
+#endif
+
+/* Name of the spec file.  */
+#define SPEC_FILE "libgfortran.spec"
+
+/* The original argument list and related info is copied here.  */
+static unsigned int g77_xargc;
+static const struct cl_decoded_option *g77_x_decoded_options;
+static void append_arg (const struct cl_decoded_option *);
+
+/* The new argument list will be built here.  */
+static unsigned int g77_newargc;
+static struct cl_decoded_option *g77_new_decoded_options;
+
+/* The path to the spec file.  */
+static char *spec_file = NULL;
+
+/* This will be NULL if we encounter a situation where we should not
+   link in the fortran libraries.  */
+static const char *library = NULL;
+
+
+/* Return full path name of spec file if it is in DIR, or NULL if
+   not.  */
+static char *
+find_spec_file (const char *dir)
+{
+  const char dirsep_string[] = { DIR_SEPARATOR, '\0' };
+  char *spec;
+  struct stat sb;
+
+  spec = XNEWVEC (char, strlen (dir) + sizeof (SPEC_FILE) + 4);
+  strcpy (spec, dir);
+  strcat (spec, dirsep_string);
+  strcat (spec, SPEC_FILE);
+  if (!stat (spec, &sb))
+    return spec;
+  free (spec);
+  return NULL;
+}
+
+
+/* Return whether strings S1 and S2 are both NULL or both the same
+   string.  */
+
+static bool
+strings_same (const char *s1, const char *s2)
+{
+  return s1 == s2 || (s1 != NULL && s2 != NULL && strcmp (s1, s2) == 0);
+}
+
+/* Return whether decoded option structures OPT1 and OPT2 are the
+   same.  */
+
+static bool
+options_same (const struct cl_decoded_option *opt1,
+	      const struct cl_decoded_option *opt2)
+{
+  return (opt1->opt_index == opt2->opt_index
+	  && strings_same (opt1->arg, opt2->arg)
+	  && strings_same (opt1->orig_option_with_args_text,
+			   opt2->orig_option_with_args_text)
+	  && strings_same (opt1->canonical_option[0],
+			   opt2->canonical_option[0])
+	  && strings_same (opt1->canonical_option[1],
+			   opt2->canonical_option[1])
+	  && strings_same (opt1->canonical_option[2],
+			   opt2->canonical_option[2])
+	  && strings_same (opt1->canonical_option[3],
+			   opt2->canonical_option[3])
+	  && (opt1->canonical_option_num_elements
+	      == opt2->canonical_option_num_elements)
+	  && opt1->value == opt2->value
+	  && opt1->errors == opt2->errors);
+}
+
+/* Append another argument to the list being built.  As long as it is
+   identical to the corresponding arg in the original list, just increment
+   the new arg count.  Otherwise allocate a new list, etc.  */
+
+static void
+append_arg (const struct cl_decoded_option *arg)
+{
+  static unsigned int newargsize;
+
+  if (g77_new_decoded_options == g77_x_decoded_options
+      && g77_newargc < g77_xargc
+      && options_same (arg, &g77_x_decoded_options[g77_newargc]))
+    {
+      ++g77_newargc;
+      return;			/* Nothing new here.  */
+    }
+
+  if (g77_new_decoded_options == g77_x_decoded_options)
+    {				/* Make new arglist.  */
+      unsigned int i;
+
+      newargsize = (g77_xargc << 2) + 20;	/* This should handle all.  */
+      g77_new_decoded_options = XNEWVEC (struct cl_decoded_option, newargsize);
+
+      /* Copy what has been done so far.  */
+      for (i = 0; i < g77_newargc; ++i)
+	g77_new_decoded_options[i] = g77_x_decoded_options[i];
+    }
+
+  if (g77_newargc == newargsize)
+    fatal_error ("overflowed output arg list for %qs",
+		 arg->orig_option_with_args_text);
+
+  g77_new_decoded_options[g77_newargc++] = *arg;
+}
+
+/* Append an option described by OPT_INDEX, ARG and VALUE to the list
+   being built.  */
+static void
+append_option (size_t opt_index, const char *arg, int value)
+{
+  struct cl_decoded_option decoded;
+
+  generate_option (opt_index, arg, value, CL_DRIVER, &decoded);
+  append_arg (&decoded);
+}
+
+/* Append a libgfortran argument to the list being built.  If
+   FORCE_STATIC, ensure the library is linked statically.  */
+
+static void
+add_arg_libgfortran (bool force_static ATTRIBUTE_UNUSED)
+{
+#ifdef HAVE_LD_STATIC_DYNAMIC
+  if (force_static)
+    append_option (OPT_Wl_, LD_STATIC_OPTION, 1);
+#endif
+  append_option (OPT_l, FORTRAN_LIBRARY, 1);
+#ifdef HAVE_LD_STATIC_DYNAMIC
+  if (force_static)
+    append_option (OPT_Wl_, LD_DYNAMIC_OPTION, 1);
+#endif
+}
+
+void
+lang_specific_driver (struct cl_decoded_option **in_decoded_options,
+		      unsigned int *in_decoded_options_count,
+		      int *in_added_libraries ATTRIBUTE_UNUSED)
+{
+  unsigned int argc = *in_decoded_options_count;
+  struct cl_decoded_option *decoded_options = *in_decoded_options;
+  unsigned int i;
+  int verbose = 0;
+
+  /* 0 => -xnone in effect.
+     1 => -xfoo in effect.  */
+  int saw_speclang = 0;
+
+  /* 0 => initial/reset state
+     1 => last arg was -l<library>
+     2 => last two args were -l<library> -lm.  */
+  int saw_library = 0;
+
+  /* By default, we throw on the math library if we have one.  */
+  int need_math = (MATH_LIBRARY[0] != '\0');
+
+  /* Whether we should link a static libgfortran. */
+  int static_lib = 0; 
+
+  /* Whether we need to link statically.  */
+  int static_linking = 0;
+
+  /* The number of input and output files in the incoming arg list.  */
+  int n_infiles = 0;
+  int n_outfiles = 0;
+
+  library = FORTRAN_LIBRARY;
+
+#if 0
+  fprintf (stderr, "Incoming:");
+  for (i = 0; i < argc; i++)
+    fprintf (stderr, " %s", decoded_options[i].orig_option_with_args_text);
+  fprintf (stderr, "\n");
+#endif
+
+  g77_xargc = argc;
+  g77_x_decoded_options = decoded_options;
+  g77_newargc = 0;
+  g77_new_decoded_options = decoded_options;
+
+  /* First pass through arglist.
+
+     If -nostdlib or a "turn-off-linking" option is anywhere in the
+     command line, don't do any library-option processing (except
+     relating to -x).  */
+
+  for (i = 1; i < argc; ++i)
+    {
+      if (decoded_options[i].errors & CL_ERR_MISSING_ARG)
+	continue;
+
+      switch (decoded_options[i].opt_index)
+	{
+	case OPT_SPECIAL_input_file:
+	  ++n_infiles;
+	  continue;
+
+	case OPT_nostdlib:
+	case OPT_nodefaultlibs:
+	case OPT_c:
+	case OPT_S:
+	case OPT_fsyntax_only:
+	case OPT_E:
+	  /* These options disable linking entirely or linking of the
+	     standard libraries.  */
+	  library = 0;
+	  break;
+
+	case OPT_static_libgfortran:
+#ifdef HAVE_LD_STATIC_DYNAMIC
+	  static_lib = 1;
+#endif
+	  break;
+
+	case OPT_static:
+#ifdef HAVE_LD_STATIC_DYNAMIC
+	  static_linking = 1;
+#endif
+	  break;
+
+	case OPT_l:
+	  ++n_infiles;
+	  break;
+
+	case OPT_o:
+	  ++n_outfiles;
+	  break;
+
+	case OPT_v:
+	  verbose = 1;
+	  break;
+
+	case OPT__version:
+	  printf ("GNU Fortran %s%s\n", pkgversion_string, version_string);
+	  printf ("Copyright %s 2014 Free Software Foundation, Inc.\n\n",
+		  _("(C)"));
+	  printf (_("GNU Fortran comes with NO WARRANTY, to the extent permitted by law.\n\
+You may redistribute copies of GNU Fortran\n\
+under the terms of the GNU General Public License.\n\
+For more information about these matters, see the file named COPYING\n\n"));
+	  exit (0);
+	  break;
+
+	case OPT__help:
+	  /* Let gcc.c handle this, as it has a really
+	     cool facility for handling --help and --verbose --help.  */
+	  return;
+
+	case OPT_L:
+	  if (!spec_file)
+	    spec_file = find_spec_file (decoded_options[i].arg);
+	  break;
+
+
+	default:
+	  break;
+	}
+    }
+
+  if ((n_outfiles != 0) && (n_infiles == 0))
+    fatal_error ("no input files; unwilling to write output files");
+
+  /* If there are no input files, no need for the library.  */
+  if (n_infiles == 0)
+    library = 0;
+
+  /* Second pass through arglist, transforming arguments as appropriate.  */
+
+  append_arg (&decoded_options[0]); /* Start with command name, of course.  */
+
+  for (i = 1; i < argc; ++i)
+    {
+      if (decoded_options[i].errors & CL_ERR_MISSING_ARG)
+	{
+	  append_arg (&decoded_options[i]);
+	  continue;
+	}
+
+      if (decoded_options[i].opt_index == OPT_SPECIAL_input_file
+	  && decoded_options[i].arg[0] == '\0')
+	{
+	  /* Interesting.  Just append as is.  */
+	  append_arg (&decoded_options[i]);
+	  continue;
+	}
+
+      if (decoded_options[i].opt_index != OPT_l
+	  && (decoded_options[i].opt_index != OPT_SPECIAL_input_file
+	      || strcmp (decoded_options[i].arg, "-") == 0))
+	{
+	  /* Not a filename or library.  */
+
+	  if (saw_library == 1 && need_math)	/* -l<library>.  */
+	    append_option (OPT_l, MATH_LIBRARY, 1);
+
+	  saw_library = 0;
+
+	  if (decoded_options[i].opt_index == OPT_SPECIAL_input_file)
+	    {
+	      append_arg (&decoded_options[i]);	/* "-" == Standard input.  */
+	      continue;
+	    }
+
+	  if (decoded_options[i].opt_index == OPT_x)
+	    {
+	      /* Track input language.  */
+	      const char *lang = decoded_options[i].arg;
+
+	      saw_speclang = (strcmp (lang, "none") != 0);
+	    }
+
+	  append_arg (&decoded_options[i]);
+
+	  continue;
+	}
+
+      /* A filename/library, not an option.  */
+
+      if (saw_speclang)
+	saw_library = 0;	/* -xfoo currently active.  */
+      else
+	{			/* -lfoo or filename.  */
+	  if (decoded_options[i].opt_index == OPT_l
+	      && strcmp (decoded_options[i].arg, MATH_LIBRARY) == 0)
+	    {
+	      if (saw_library == 1)
+		saw_library = 2;	/* -l<library> -lm.  */
+	      else
+		add_arg_libgfortran (static_lib && !static_linking);
+	    }
+	  else if (decoded_options[i].opt_index == OPT_l
+	      && strcmp (decoded_options[i].arg, FORTRAN_LIBRARY) == 0)
+	    {
+	      saw_library = 1;	/* -l<library>.  */
+	      add_arg_libgfortran (static_lib && !static_linking);
+	      continue;
+	    }
+	  else
+	    {			/* Other library, or filename.  */
+	      if (saw_library == 1 && need_math)
+		append_option (OPT_l, MATH_LIBRARY, 1);
+	      saw_library = 0;
+	    }
+	}
+      append_arg (&decoded_options[i]);
+    }
+
+  /* Append `-lgfortran -lm' as necessary.  */
+
+  if (library)
+    {				/* Doing a link and no -nostdlib.  */
+      if (saw_speclang)
+	append_option (OPT_x, "none", 1);
+
+      switch (saw_library)
+	{
+	case 0:
+	  add_arg_libgfortran (static_lib && !static_linking);
+	  /* Fall through.  */
+
+	case 1:
+	  if (need_math)
+	    append_option (OPT_l, MATH_LIBRARY, 1);
+	default:
+	  break;
+	}
+    }
+
+#ifdef ENABLE_SHARED_LIBGCC
+  if (library)
+    {
+      unsigned int i;
+
+      for (i = 1; i < g77_newargc; i++)
+	if (g77_new_decoded_options[i].opt_index == OPT_static_libgcc
+	    || g77_new_decoded_options[i].opt_index == OPT_static)
+	  break;
+
+      if (i == g77_newargc)
+	append_option (OPT_shared_libgcc, NULL, 1);
+    }
+
+#endif
+
+  /* Read the specs file corresponding to libgfortran.
+     If we didn't find the spec file on the -L path, we load it
+     via lang_specific_pre_link.  */
+  if (spec_file)
+    append_option (OPT_specs_, spec_file, 1);
+
+  if (verbose && g77_new_decoded_options != g77_x_decoded_options)
+    {
+      fprintf (stderr, _("Driving:"));
+      for (i = 0; i < g77_newargc; i++)
+	fprintf (stderr, " %s",
+		 g77_new_decoded_options[i].orig_option_with_args_text);
+      fprintf (stderr, "\n");
+    }
+
+  *in_decoded_options_count = g77_newargc;
+  *in_decoded_options = g77_new_decoded_options;
+}
+
+
+/* Called before linking.  Returns 0 on success and -1 on failure.  */
+int
+lang_specific_pre_link (void)
+{
+  free (spec_file);
+  if (spec_file == NULL && library)
+    do_spec ("%:include(libgfortran.spec)");
+
+  return 0;
+}
+
+/* Number of extra output files that lang_specific_pre_link may generate.  */
+int lang_specific_extra_outfiles = 0;	/* Not used for F77.  */
diff --git a/gcc-4.9/gcc/fortran/interface.c b/gcc-4.9/gcc/fortran/interface.c
new file mode 100644
index 000000000..67548c062
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/interface.c
@@ -0,0 +1,4280 @@
+/* Deal with interfaces.
+   Copyright (C) 2000-2014 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+
+/* Deal with interfaces.  An explicit interface is represented as a
+   singly linked list of formal argument structures attached to the
+   relevant symbols.  For an implicit interface, the arguments don't
+   point to symbols.  Explicit interfaces point to namespaces that
+   contain the symbols within that interface.
+
+   Implicit interfaces are linked together in a singly linked list
+   along the next_if member of symbol nodes.  Since a particular
+   symbol can only have a single explicit interface, the symbol cannot
+   be part of multiple lists and a single next-member suffices.
+
+   This is not the case for general classes, though.  An operator
+   definition is independent of just about all other uses and has it's
+   own head pointer.
+
+   Nameless interfaces:
+     Nameless interfaces create symbols with explicit interfaces within
+     the current namespace.  They are otherwise unlinked.
+
+   Generic interfaces:
+     The generic name points to a linked list of symbols.  Each symbol
+     has an explicit interface.  Each explicit interface has its own
+     namespace containing the arguments.  Module procedures are symbols in
+     which the interface is added later when the module procedure is parsed.
+
+   User operators:
+     User-defined operators are stored in a their own set of symtrees
+     separate from regular symbols.  The symtrees point to gfc_user_op
+     structures which in turn head up a list of relevant interfaces.
+
+   Extended intrinsics and assignment:
+     The head of these interface lists are stored in the containing namespace.
+
+   Implicit interfaces:
+     An implicit interface is represented as a singly linked list of
+     formal argument list structures that don't point to any symbol
+     nodes -- they just contain types.
+
+
+   When a subprogram is defined, the program unit's name points to an
+   interface as usual, but the link to the namespace is NULL and the
+   formal argument list points to symbols within the same namespace as
+   the program unit name.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "gfortran.h"
+#include "match.h"
+#include "arith.h"
+
+/* The current_interface structure holds information about the
+   interface currently being parsed.  This structure is saved and
+   restored during recursive interfaces.  */
+
+gfc_interface_info current_interface;
+
+
+/* Free a singly linked list of gfc_interface structures.  */
+
+void
+gfc_free_interface (gfc_interface *intr)
+{
+  gfc_interface *next;
+
+  for (; intr; intr = next)
+    {
+      next = intr->next;
+      free (intr);
+    }
+}
+
+
+/* Change the operators unary plus and minus into binary plus and
+   minus respectively, leaving the rest unchanged.  */
+
+static gfc_intrinsic_op
+fold_unary_intrinsic (gfc_intrinsic_op op)
+{
+  switch (op)
+    {
+    case INTRINSIC_UPLUS:
+      op = INTRINSIC_PLUS;
+      break;
+    case INTRINSIC_UMINUS:
+      op = INTRINSIC_MINUS;
+      break;
+    default:
+      break;
+    }
+
+  return op;
+}
+
+
+/* Match a generic specification.  Depending on which type of
+   interface is found, the 'name' or 'op' pointers may be set.
+   This subroutine doesn't return MATCH_NO.  */
+
+match
+gfc_match_generic_spec (interface_type *type,
+			char *name,
+			gfc_intrinsic_op *op)
+{
+  char buffer[GFC_MAX_SYMBOL_LEN + 1];
+  match m;
+  gfc_intrinsic_op i;
+
+  if (gfc_match (" assignment ( = )") == MATCH_YES)
+    {
+      *type = INTERFACE_INTRINSIC_OP;
+      *op = INTRINSIC_ASSIGN;
+      return MATCH_YES;
+    }
+
+  if (gfc_match (" operator ( %o )", &i) == MATCH_YES)
+    {				/* Operator i/f */
+      *type = INTERFACE_INTRINSIC_OP;
+      *op = fold_unary_intrinsic (i);
+      return MATCH_YES;
+    }
+
+  *op = INTRINSIC_NONE;
+  if (gfc_match (" operator ( ") == MATCH_YES)
+    {
+      m = gfc_match_defined_op_name (buffer, 1);
+      if (m == MATCH_NO)
+	goto syntax;
+      if (m != MATCH_YES)
+	return MATCH_ERROR;
+
+      m = gfc_match_char (')');
+      if (m == MATCH_NO)
+	goto syntax;
+      if (m != MATCH_YES)
+	return MATCH_ERROR;
+
+      strcpy (name, buffer);
+      *type = INTERFACE_USER_OP;
+      return MATCH_YES;
+    }
+
+  if (gfc_match_name (buffer) == MATCH_YES)
+    {
+      strcpy (name, buffer);
+      *type = INTERFACE_GENERIC;
+      return MATCH_YES;
+    }
+
+  *type = INTERFACE_NAMELESS;
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in generic specification at %C");
+  return MATCH_ERROR;
+}
+
+
+/* Match one of the five F95 forms of an interface statement.  The
+   matcher for the abstract interface follows.  */
+
+match
+gfc_match_interface (void)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  interface_type type;
+  gfc_symbol *sym;
+  gfc_intrinsic_op op;
+  match m;
+
+  m = gfc_match_space ();
+
+  if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR)
+    return MATCH_ERROR;
+
+  /* If we're not looking at the end of the statement now, or if this
+     is not a nameless interface but we did not see a space, punt.  */
+  if (gfc_match_eos () != MATCH_YES
+      || (type != INTERFACE_NAMELESS && m != MATCH_YES))
+    {
+      gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
+		 "at %C");
+      return MATCH_ERROR;
+    }
+
+  current_interface.type = type;
+
+  switch (type)
+    {
+    case INTERFACE_GENERIC:
+      if (gfc_get_symbol (name, NULL, &sym))
+	return MATCH_ERROR;
+
+      if (!sym->attr.generic
+	  && !gfc_add_generic (&sym->attr, sym->name, NULL))
+	return MATCH_ERROR;
+
+      if (sym->attr.dummy)
+	{
+	  gfc_error ("Dummy procedure '%s' at %C cannot have a "
+		     "generic interface", sym->name);
+	  return MATCH_ERROR;
+	}
+
+      current_interface.sym = gfc_new_block = sym;
+      break;
+
+    case INTERFACE_USER_OP:
+      current_interface.uop = gfc_get_uop (name);
+      break;
+
+    case INTERFACE_INTRINSIC_OP:
+      current_interface.op = op;
+      break;
+
+    case INTERFACE_NAMELESS:
+    case INTERFACE_ABSTRACT:
+      break;
+    }
+
+  return MATCH_YES;
+}
+
+
+
+/* Match a F2003 abstract interface.  */
+
+match
+gfc_match_abstract_interface (void)
+{
+  match m;
+
+  if (!gfc_notify_std (GFC_STD_F2003, "ABSTRACT INTERFACE at %C"))
+    return MATCH_ERROR;
+
+  m = gfc_match_eos ();
+
+  if (m != MATCH_YES)
+    {
+      gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C");
+      return MATCH_ERROR;
+    }
+
+  current_interface.type = INTERFACE_ABSTRACT;
+
+  return m;
+}
+
+
+/* Match the different sort of generic-specs that can be present after
+   the END INTERFACE itself.  */
+
+match
+gfc_match_end_interface (void)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  interface_type type;
+  gfc_intrinsic_op op;
+  match m;
+
+  m = gfc_match_space ();
+
+  if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR)
+    return MATCH_ERROR;
+
+  /* If we're not looking at the end of the statement now, or if this
+     is not a nameless interface but we did not see a space, punt.  */
+  if (gfc_match_eos () != MATCH_YES
+      || (type != INTERFACE_NAMELESS && m != MATCH_YES))
+    {
+      gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
+		 "statement at %C");
+      return MATCH_ERROR;
+    }
+
+  m = MATCH_YES;
+
+  switch (current_interface.type)
+    {
+    case INTERFACE_NAMELESS:
+    case INTERFACE_ABSTRACT:
+      if (type != INTERFACE_NAMELESS)
+	{
+	  gfc_error ("Expected a nameless interface at %C");
+	  m = MATCH_ERROR;
+	}
+
+      break;
+
+    case INTERFACE_INTRINSIC_OP:
+      if (type != current_interface.type || op != current_interface.op)
+	{
+
+	  if (current_interface.op == INTRINSIC_ASSIGN)
+	    {
+	      m = MATCH_ERROR;
+	      gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
+	    }
+	  else
+	    {
+	      const char *s1, *s2;
+	      s1 = gfc_op2string (current_interface.op);
+	      s2 = gfc_op2string (op);
+
+	      /* The following if-statements are used to enforce C1202
+		 from F2003.  */
+	      if ((strcmp(s1, "==") == 0 && strcmp (s2, ".eq.") == 0)
+		  || (strcmp(s1, ".eq.") == 0 && strcmp (s2, "==") == 0))
+		break;
+	      if ((strcmp(s1, "/=") == 0 && strcmp (s2, ".ne.") == 0)
+		  || (strcmp(s1, ".ne.") == 0 && strcmp (s2, "/=") == 0))
+		break;
+	      if ((strcmp(s1, "<=") == 0 && strcmp (s2, ".le.") == 0)
+		  || (strcmp(s1, ".le.") == 0 && strcmp (s2, "<=") == 0))
+		break;
+	      if ((strcmp(s1, "<") == 0 && strcmp (s2, ".lt.") == 0)
+		  || (strcmp(s1, ".lt.") == 0 && strcmp (s2, "<") == 0))
+		break;
+	      if ((strcmp(s1, ">=") == 0 && strcmp (s2, ".ge.") == 0)
+		  || (strcmp(s1, ".ge.") == 0 && strcmp (s2, ">=") == 0))
+		break;
+	      if ((strcmp(s1, ">") == 0 && strcmp (s2, ".gt.") == 0)
+		  || (strcmp(s1, ".gt.") == 0 && strcmp (s2, ">") == 0))
+		break;
+
+	      m = MATCH_ERROR;
+	      gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C, "
+			 "but got %s", s1, s2);
+	    }
+
+	}
+
+      break;
+
+    case INTERFACE_USER_OP:
+      /* Comparing the symbol node names is OK because only use-associated
+	 symbols can be renamed.  */
+      if (type != current_interface.type
+	  || strcmp (current_interface.uop->name, name) != 0)
+	{
+	  gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
+		     current_interface.uop->name);
+	  m = MATCH_ERROR;
+	}
+
+      break;
+
+    case INTERFACE_GENERIC:
+      if (type != current_interface.type
+	  || strcmp (current_interface.sym->name, name) != 0)
+	{
+	  gfc_error ("Expecting 'END INTERFACE %s' at %C",
+		     current_interface.sym->name);
+	  m = MATCH_ERROR;
+	}
+
+      break;
+    }
+
+  return m;
+}
+
+
+/* Compare two derived types using the criteria in 4.4.2 of the standard,
+   recursing through gfc_compare_types for the components.  */
+
+int
+gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)
+{
+  gfc_component *dt1, *dt2;
+
+  if (derived1 == derived2)
+    return 1;
+
+  gcc_assert (derived1 && derived2);
+
+  /* Special case for comparing derived types across namespaces.  If the
+     true names and module names are the same and the module name is
+     nonnull, then they are equal.  */
+  if (strcmp (derived1->name, derived2->name) == 0
+      && derived1->module != NULL && derived2->module != NULL
+      && strcmp (derived1->module, derived2->module) == 0)
+    return 1;
+
+  /* Compare type via the rules of the standard.  Both types must have
+     the SEQUENCE or BIND(C) attribute to be equal.  */
+
+  if (strcmp (derived1->name, derived2->name))
+    return 0;
+
+  if (derived1->component_access == ACCESS_PRIVATE
+      || derived2->component_access == ACCESS_PRIVATE)
+    return 0;
+
+  if (!(derived1->attr.sequence && derived2->attr.sequence)
+      && !(derived1->attr.is_bind_c && derived2->attr.is_bind_c))
+    return 0;
+
+  dt1 = derived1->components;
+  dt2 = derived2->components;
+
+  /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
+     simple test can speed things up.  Otherwise, lots of things have to
+     match.  */
+  for (;;)
+    {
+      if (strcmp (dt1->name, dt2->name) != 0)
+	return 0;
+
+      if (dt1->attr.access != dt2->attr.access)
+	return 0;
+
+      if (dt1->attr.pointer != dt2->attr.pointer)
+	return 0;
+
+      if (dt1->attr.dimension != dt2->attr.dimension)
+	return 0;
+
+     if (dt1->attr.allocatable != dt2->attr.allocatable)
+	return 0;
+
+      if (dt1->attr.dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
+	return 0;
+
+      /* Make sure that link lists do not put this function into an
+	 endless recursive loop!  */
+      if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
+	    && !(dt2->ts.type == BT_DERIVED && derived2 == dt2->ts.u.derived)
+	    && gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
+	return 0;
+
+      else if ((dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
+		&& !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived))
+	return 0;
+
+      else if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
+		&& (dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived))
+	return 0;
+
+      dt1 = dt1->next;
+      dt2 = dt2->next;
+
+      if (dt1 == NULL && dt2 == NULL)
+	break;
+      if (dt1 == NULL || dt2 == NULL)
+	return 0;
+    }
+
+  return 1;
+}
+
+
+/* Compare two typespecs, recursively if necessary.  */
+
+int
+gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
+{
+  /* See if one of the typespecs is a BT_VOID, which is what is being used
+     to allow the funcs like c_f_pointer to accept any pointer type.
+     TODO: Possibly should narrow this to just the one typespec coming in
+     that is for the formal arg, but oh well.  */
+  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)
+    return 1;
+
+  /* F2003: C717  */
+  if (ts2->type == BT_CLASS && ts1->type == BT_DERIVED
+      && ts2->u.derived->components->ts.u.derived->attr.unlimited_polymorphic
+      && (ts1->u.derived->attr.sequence || ts1->u.derived->attr.is_bind_c))
+    return 1;
+
+  if (ts1->type != ts2->type
+      && ((ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
+	  || (ts2->type != BT_DERIVED && ts2->type != BT_CLASS)))
+    return 0;
+  if (ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
+    return (ts1->kind == ts2->kind);
+
+  /* Compare derived types.  */
+  if (gfc_type_compatible (ts1, ts2))
+    return 1;
+
+  return gfc_compare_derived_types (ts1->u.derived ,ts2->u.derived);
+}
+
+
+static int
+compare_type (gfc_symbol *s1, gfc_symbol *s2)
+{
+  if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
+    return 1;
+
+  /* TYPE and CLASS of the same declared type are type compatible,
+     but have different characteristics.  */
+  if ((s1->ts.type == BT_CLASS && s2->ts.type == BT_DERIVED)
+      || (s1->ts.type == BT_DERIVED && s2->ts.type == BT_CLASS))
+    return 0;
+
+  return gfc_compare_types (&s1->ts, &s2->ts) || s2->ts.type == BT_ASSUMED;
+}
+
+
+static int
+compare_rank (gfc_symbol *s1, gfc_symbol *s2)
+{
+  gfc_array_spec *as1, *as2;
+  int r1, r2;
+
+  if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
+    return 1;
+
+  as1 = (s1->ts.type == BT_CLASS) ? CLASS_DATA (s1)->as : s1->as;
+  as2 = (s2->ts.type == BT_CLASS) ? CLASS_DATA (s2)->as : s2->as;
+
+  r1 = as1 ? as1->rank : 0;
+  r2 = as2 ? as2->rank : 0;
+
+  if (r1 != r2 && (!as2 || as2->type != AS_ASSUMED_RANK))
+    return 0;			/* Ranks differ.  */
+
+  return 1;
+}
+
+
+/* Given two symbols that are formal arguments, compare their ranks
+   and types.  Returns nonzero if they have the same rank and type,
+   zero otherwise.  */
+
+static int
+compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
+{
+  return compare_type (s1, s2) && compare_rank (s1, s2);
+}
+
+
+/* Given two symbols that are formal arguments, compare their types
+   and rank and their formal interfaces if they are both dummy
+   procedures.  Returns nonzero if the same, zero if different.  */
+
+static int
+compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2)
+{
+  if (s1 == NULL || s2 == NULL)
+    return s1 == s2 ? 1 : 0;
+
+  if (s1 == s2)
+    return 1;
+
+  if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
+    return compare_type_rank (s1, s2);
+
+  if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
+    return 0;
+
+  /* At this point, both symbols are procedures.  It can happen that
+     external procedures are compared, where one is identified by usage
+     to be a function or subroutine but the other is not.  Check TKR
+     nonetheless for these cases.  */
+  if (s1->attr.function == 0 && s1->attr.subroutine == 0)
+    return s1->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
+
+  if (s2->attr.function == 0 && s2->attr.subroutine == 0)
+    return s2->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
+
+  /* Now the type of procedure has been identified.  */
+  if (s1->attr.function != s2->attr.function
+      || s1->attr.subroutine != s2->attr.subroutine)
+    return 0;
+
+  if (s1->attr.function && compare_type_rank (s1, s2) == 0)
+    return 0;
+
+  /* Originally, gfortran recursed here to check the interfaces of passed
+     procedures.  This is explicitly not required by the standard.  */
+  return 1;
+}
+
+
+/* Given a formal argument list and a keyword name, search the list
+   for that keyword.  Returns the correct symbol node if found, NULL
+   if not found.  */
+
+static gfc_symbol *
+find_keyword_arg (const char *name, gfc_formal_arglist *f)
+{
+  for (; f; f = f->next)
+    if (strcmp (f->sym->name, name) == 0)
+      return f->sym;
+
+  return NULL;
+}
+
+
+/******** Interface checking subroutines **********/
+
+
+/* Given an operator interface and the operator, make sure that all
+   interfaces for that operator are legal.  */
+
+bool
+gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op,
+			      locus opwhere)
+{
+  gfc_formal_arglist *formal;
+  sym_intent i1, i2;
+  bt t1, t2;
+  int args, r1, r2, k1, k2;
+
+  gcc_assert (sym);
+
+  args = 0;
+  t1 = t2 = BT_UNKNOWN;
+  i1 = i2 = INTENT_UNKNOWN;
+  r1 = r2 = -1;
+  k1 = k2 = -1;
+
+  for (formal = gfc_sym_get_dummy_args (sym); formal; formal = formal->next)
+    {
+      gfc_symbol *fsym = formal->sym;
+      if (fsym == NULL)
+	{
+	  gfc_error ("Alternate return cannot appear in operator "
+		     "interface at %L", &sym->declared_at);
+	  return false;
+	}
+      if (args == 0)
+	{
+	  t1 = fsym->ts.type;
+	  i1 = fsym->attr.intent;
+	  r1 = (fsym->as != NULL) ? fsym->as->rank : 0;
+	  k1 = fsym->ts.kind;
+	}
+      if (args == 1)
+	{
+	  t2 = fsym->ts.type;
+	  i2 = fsym->attr.intent;
+	  r2 = (fsym->as != NULL) ? fsym->as->rank : 0;
+	  k2 = fsym->ts.kind;
+	}
+      args++;
+    }
+
+  /* Only +, - and .not. can be unary operators.
+     .not. cannot be a binary operator.  */
+  if (args == 0 || args > 2 || (args == 1 && op != INTRINSIC_PLUS
+				&& op != INTRINSIC_MINUS
+				&& op != INTRINSIC_NOT)
+      || (args == 2 && op == INTRINSIC_NOT))
+    {
+      if (op == INTRINSIC_ASSIGN)
+	gfc_error ("Assignment operator interface at %L must have "
+		   "two arguments", &sym->declared_at);
+      else
+	gfc_error ("Operator interface at %L has the wrong number of arguments",
+		   &sym->declared_at);
+      return false;
+    }
+
+  /* Check that intrinsics are mapped to functions, except
+     INTRINSIC_ASSIGN which should map to a subroutine.  */
+  if (op == INTRINSIC_ASSIGN)
+    {
+      gfc_formal_arglist *dummy_args;
+
+      if (!sym->attr.subroutine)
+	{
+	  gfc_error ("Assignment operator interface at %L must be "
+		     "a SUBROUTINE", &sym->declared_at);
+	  return false;
+	}
+
+      /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
+	 - First argument an array with different rank than second,
+	 - First argument is a scalar and second an array,
+	 - Types and kinds do not conform, or
+	 - First argument is of derived type.  */
+      dummy_args = gfc_sym_get_dummy_args (sym);
+      if (dummy_args->sym->ts.type != BT_DERIVED
+	  && dummy_args->sym->ts.type != BT_CLASS
+	  && (r2 == 0 || r1 == r2)
+	  && (dummy_args->sym->ts.type == dummy_args->next->sym->ts.type
+	      || (gfc_numeric_ts (&dummy_args->sym->ts)
+		  && gfc_numeric_ts (&dummy_args->next->sym->ts))))
+	{
+	  gfc_error ("Assignment operator interface at %L must not redefine "
+		     "an INTRINSIC type assignment", &sym->declared_at);
+	  return false;
+	}
+    }
+  else
+    {
+      if (!sym->attr.function)
+	{
+	  gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
+		     &sym->declared_at);
+	  return false;
+	}
+    }
+
+  /* Check intents on operator interfaces.  */
+  if (op == INTRINSIC_ASSIGN)
+    {
+      if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
+	{
+	  gfc_error ("First argument of defined assignment at %L must be "
+		     "INTENT(OUT) or INTENT(INOUT)", &sym->declared_at);
+	  return false;
+	}
+
+      if (i2 != INTENT_IN)
+	{
+	  gfc_error ("Second argument of defined assignment at %L must be "
+		     "INTENT(IN)", &sym->declared_at);
+	  return false;
+	}
+    }
+  else
+    {
+      if (i1 != INTENT_IN)
+	{
+	  gfc_error ("First argument of operator interface at %L must be "
+		     "INTENT(IN)", &sym->declared_at);
+	  return false;
+	}
+
+      if (args == 2 && i2 != INTENT_IN)
+	{
+	  gfc_error ("Second argument of operator interface at %L must be "
+		     "INTENT(IN)", &sym->declared_at);
+	  return false;
+	}
+    }
+
+  /* From now on, all we have to do is check that the operator definition
+     doesn't conflict with an intrinsic operator. The rules for this
+     game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
+     as well as 12.3.2.1.1 of Fortran 2003:
+
+     "If the operator is an intrinsic-operator (R310), the number of
+     function arguments shall be consistent with the intrinsic uses of
+     that operator, and the types, kind type parameters, or ranks of the
+     dummy arguments shall differ from those required for the intrinsic
+     operation (7.1.2)."  */
+
+#define IS_NUMERIC_TYPE(t) \
+  ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
+
+  /* Unary ops are easy, do them first.  */
+  if (op == INTRINSIC_NOT)
+    {
+      if (t1 == BT_LOGICAL)
+	goto bad_repl;
+      else
+	return true;
+    }
+
+  if (args == 1 && (op == INTRINSIC_PLUS || op == INTRINSIC_MINUS))
+    {
+      if (IS_NUMERIC_TYPE (t1))
+	goto bad_repl;
+      else
+	return true;
+    }
+
+  /* Character intrinsic operators have same character kind, thus
+     operator definitions with operands of different character kinds
+     are always safe.  */
+  if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2)
+    return true;
+
+  /* Intrinsic operators always perform on arguments of same rank,
+     so different ranks is also always safe.  (rank == 0) is an exception
+     to that, because all intrinsic operators are elemental.  */
+  if (r1 != r2 && r1 != 0 && r2 != 0)
+    return true;
+
+  switch (op)
+  {
+    case INTRINSIC_EQ:
+    case INTRINSIC_EQ_OS:
+    case INTRINSIC_NE:
+    case INTRINSIC_NE_OS:
+      if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
+	goto bad_repl;
+      /* Fall through.  */
+
+    case INTRINSIC_PLUS:
+    case INTRINSIC_MINUS:
+    case INTRINSIC_TIMES:
+    case INTRINSIC_DIVIDE:
+    case INTRINSIC_POWER:
+      if (IS_NUMERIC_TYPE (t1) && IS_NUMERIC_TYPE (t2))
+	goto bad_repl;
+      break;
+
+    case INTRINSIC_GT:
+    case INTRINSIC_GT_OS:
+    case INTRINSIC_GE:
+    case INTRINSIC_GE_OS:
+    case INTRINSIC_LT:
+    case INTRINSIC_LT_OS:
+    case INTRINSIC_LE:
+    case INTRINSIC_LE_OS:
+      if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
+	goto bad_repl;
+      if ((t1 == BT_INTEGER || t1 == BT_REAL)
+	  && (t2 == BT_INTEGER || t2 == BT_REAL))
+	goto bad_repl;
+      break;
+
+    case INTRINSIC_CONCAT:
+      if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
+	goto bad_repl;
+      break;
+
+    case INTRINSIC_AND:
+    case INTRINSIC_OR:
+    case INTRINSIC_EQV:
+    case INTRINSIC_NEQV:
+      if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
+	goto bad_repl;
+      break;
+
+    default:
+      break;
+  }
+
+  return true;
+
+#undef IS_NUMERIC_TYPE
+
+bad_repl:
+  gfc_error ("Operator interface at %L conflicts with intrinsic interface",
+	     &opwhere);
+  return false;
+}
+
+
+/* Given a pair of formal argument lists, we see if the two lists can
+   be distinguished by counting the number of nonoptional arguments of
+   a given type/rank in f1 and seeing if there are less then that
+   number of those arguments in f2 (including optional arguments).
+   Since this test is asymmetric, it has to be called twice to make it
+   symmetric. Returns nonzero if the argument lists are incompatible
+   by this test. This subroutine implements rule 1 of section F03:16.2.3.
+   'p1' and 'p2' are the PASS arguments of both procedures (if applicable).  */
+
+static int
+count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
+		  const char *p1, const char *p2)
+{
+  int rc, ac1, ac2, i, j, k, n1;
+  gfc_formal_arglist *f;
+
+  typedef struct
+  {
+    int flag;
+    gfc_symbol *sym;
+  }
+  arginfo;
+
+  arginfo *arg;
+
+  n1 = 0;
+
+  for (f = f1; f; f = f->next)
+    n1++;
+
+  /* Build an array of integers that gives the same integer to
+     arguments of the same type/rank.  */
+  arg = XCNEWVEC (arginfo, n1);
+
+  f = f1;
+  for (i = 0; i < n1; i++, f = f->next)
+    {
+      arg[i].flag = -1;
+      arg[i].sym = f->sym;
+    }
+
+  k = 0;
+
+  for (i = 0; i < n1; i++)
+    {
+      if (arg[i].flag != -1)
+	continue;
+
+      if (arg[i].sym && (arg[i].sym->attr.optional
+			 || (p1 && strcmp (arg[i].sym->name, p1) == 0)))
+	continue;		/* Skip OPTIONAL and PASS arguments.  */
+
+      arg[i].flag = k;
+
+      /* Find other non-optional, non-pass arguments of the same type/rank.  */
+      for (j = i + 1; j < n1; j++)
+	if ((arg[j].sym == NULL
+	     || !(arg[j].sym->attr.optional
+		  || (p1 && strcmp (arg[j].sym->name, p1) == 0)))
+	    && (compare_type_rank_if (arg[i].sym, arg[j].sym)
+	        || compare_type_rank_if (arg[j].sym, arg[i].sym)))
+	  arg[j].flag = k;
+
+      k++;
+    }
+
+  /* Now loop over each distinct type found in f1.  */
+  k = 0;
+  rc = 0;
+
+  for (i = 0; i < n1; i++)
+    {
+      if (arg[i].flag != k)
+	continue;
+
+      ac1 = 1;
+      for (j = i + 1; j < n1; j++)
+	if (arg[j].flag == k)
+	  ac1++;
+
+      /* Count the number of non-pass arguments in f2 with that type,
+	 including those that are optional.  */
+      ac2 = 0;
+
+      for (f = f2; f; f = f->next)
+	if ((!p2 || strcmp (f->sym->name, p2) != 0)
+	    && (compare_type_rank_if (arg[i].sym, f->sym)
+		|| compare_type_rank_if (f->sym, arg[i].sym)))
+	  ac2++;
+
+      if (ac1 > ac2)
+	{
+	  rc = 1;
+	  break;
+	}
+
+      k++;
+    }
+
+  free (arg);
+
+  return rc;
+}
+
+
+/* Perform the correspondence test in rule (3) of F08:C1215.
+   Returns zero if no argument is found that satisfies this rule,
+   nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
+   (if applicable).
+
+   This test is also not symmetric in f1 and f2 and must be called
+   twice.  This test finds problems caused by sorting the actual
+   argument list with keywords.  For example:
+
+   INTERFACE FOO
+     SUBROUTINE F1(A, B)
+       INTEGER :: A ; REAL :: B
+     END SUBROUTINE F1
+
+     SUBROUTINE F2(B, A)
+       INTEGER :: A ; REAL :: B
+     END SUBROUTINE F1
+   END INTERFACE FOO
+
+   At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous.  */
+
+static int
+generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
+			const char *p1, const char *p2)
+{
+  gfc_formal_arglist *f2_save, *g;
+  gfc_symbol *sym;
+
+  f2_save = f2;
+
+  while (f1)
+    {
+      if (f1->sym->attr.optional)
+	goto next;
+
+      if (p1 && strcmp (f1->sym->name, p1) == 0)
+	f1 = f1->next;
+      if (f2 && p2 && strcmp (f2->sym->name, p2) == 0)
+	f2 = f2->next;
+
+      if (f2 != NULL && (compare_type_rank (f1->sym, f2->sym)
+			 || compare_type_rank (f2->sym, f1->sym))
+	  && !((gfc_option.allow_std & GFC_STD_F2008)
+	       && ((f1->sym->attr.allocatable && f2->sym->attr.pointer)
+		   || (f2->sym->attr.allocatable && f1->sym->attr.pointer))))
+	goto next;
+
+      /* Now search for a disambiguating keyword argument starting at
+	 the current non-match.  */
+      for (g = f1; g; g = g->next)
+	{
+	  if (g->sym->attr.optional || (p1 && strcmp (g->sym->name, p1) == 0))
+	    continue;
+
+	  sym = find_keyword_arg (g->sym->name, f2_save);
+	  if (sym == NULL || !compare_type_rank (g->sym, sym)
+	      || ((gfc_option.allow_std & GFC_STD_F2008)
+		  && ((sym->attr.allocatable && g->sym->attr.pointer)
+		      || (sym->attr.pointer && g->sym->attr.allocatable))))
+	    return 1;
+	}
+
+    next:
+      if (f1 != NULL)
+	f1 = f1->next;
+      if (f2 != NULL)
+	f2 = f2->next;
+    }
+
+  return 0;
+}
+
+
+static int
+symbol_rank (gfc_symbol *sym)
+{
+  gfc_array_spec *as;
+  as = (sym->ts.type == BT_CLASS) ? CLASS_DATA (sym)->as : sym->as;
+  return as ? as->rank : 0;
+}
+
+
+/* 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)
+{
+  if (s1 == NULL || s2 == NULL)
+    return s1 == s2 ? true : false;
+
+  /* Check type and rank.  */
+  if (type_must_agree)
+    {
+      if (!compare_type (s1, s2) || !compare_type (s2, s1))
+	{
+	  snprintf (errmsg, err_len, "Type mismatch in argument '%s' (%s/%s)",
+		    s1->name, gfc_typename (&s1->ts), gfc_typename (&s2->ts));
+	  return false;
+	}
+      if (!compare_rank (s1, s2))
+	{
+	  snprintf (errmsg, err_len, "Rank mismatch in argument '%s' (%i/%i)",
+		    s1->name, symbol_rank (s1), symbol_rank (s2));
+	  return false;
+	}
+    }
+
+  /* Check INTENT.  */
+  if (s1->attr.intent != s2->attr.intent)
+    {
+      snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'",
+		s1->name);
+      return false;
+    }
+
+  /* Check OPTIONAL attribute.  */
+  if (s1->attr.optional != s2->attr.optional)
+    {
+      snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
+		s1->name);
+      return false;
+    }
+
+  /* Check ALLOCATABLE attribute.  */
+  if (s1->attr.allocatable != s2->attr.allocatable)
+    {
+      snprintf (errmsg, err_len, "ALLOCATABLE mismatch in argument '%s'",
+		s1->name);
+      return false;
+    }
+
+  /* Check POINTER attribute.  */
+  if (s1->attr.pointer != s2->attr.pointer)
+    {
+      snprintf (errmsg, err_len, "POINTER mismatch in argument '%s'",
+		s1->name);
+      return false;
+    }
+
+  /* Check TARGET attribute.  */
+  if (s1->attr.target != s2->attr.target)
+    {
+      snprintf (errmsg, err_len, "TARGET mismatch in argument '%s'",
+		s1->name);
+      return false;
+    }
+
+  /* Check ASYNCHRONOUS attribute.  */
+  if (s1->attr.asynchronous != s2->attr.asynchronous)
+    {
+      snprintf (errmsg, err_len, "ASYNCHRONOUS mismatch in argument '%s'",
+		s1->name);
+      return false;
+    }
+
+  /* Check CONTIGUOUS attribute.  */
+  if (s1->attr.contiguous != s2->attr.contiguous)
+    {
+      snprintf (errmsg, err_len, "CONTIGUOUS mismatch in argument '%s'",
+		s1->name);
+      return false;
+    }
+
+  /* Check VALUE attribute.  */
+  if (s1->attr.value != s2->attr.value)
+    {
+      snprintf (errmsg, err_len, "VALUE mismatch in argument '%s'",
+		s1->name);
+      return false;
+    }
+
+  /* Check VOLATILE attribute.  */
+  if (s1->attr.volatile_ != s2->attr.volatile_)
+    {
+      snprintf (errmsg, err_len, "VOLATILE mismatch in argument '%s'",
+		s1->name);
+      return false;
+    }
+
+  /* Check interface of dummy procedures.  */
+  if (s1->attr.flavor == FL_PROCEDURE)
+    {
+      char err[200];
+      if (!gfc_compare_interfaces (s1, s2, s2->name, 0, 1, err, sizeof(err),
+				   NULL, NULL))
+	{
+	  snprintf (errmsg, err_len, "Interface mismatch in dummy procedure "
+		    "'%s': %s", s1->name, err);
+	  return false;
+	}
+    }
+
+  /* Check string length.  */
+  if (s1->ts.type == BT_CHARACTER
+      && s1->ts.u.cl && s1->ts.u.cl->length
+      && s2->ts.u.cl && s2->ts.u.cl->length)
+    {
+      int compval = gfc_dep_compare_expr (s1->ts.u.cl->length,
+					  s2->ts.u.cl->length);
+      switch (compval)
+      {
+	case -1:
+	case  1:
+	case -3:
+	  snprintf (errmsg, err_len, "Character length mismatch "
+		    "in argument '%s'", s1->name);
+	  return false;
+
+	case -2:
+	  /* FIXME: Implement a warning for this case.
+	  gfc_warning ("Possible character length mismatch in argument '%s'",
+		       s1->name);*/
+	  break;
+
+	case 0:
+	  break;
+
+	default:
+	  gfc_internal_error ("check_dummy_characteristics: Unexpected result "
+			      "%i of gfc_dep_compare_expr", compval);
+	  break;
+      }
+    }
+
+  /* Check array shape.  */
+  if (s1->as && s2->as)
+    {
+      int i, compval;
+      gfc_expr *shape1, *shape2;
+
+      if (s1->as->type != s2->as->type)
+	{
+	  snprintf (errmsg, err_len, "Shape mismatch in argument '%s'",
+		    s1->name);
+	  return false;
+	}
+
+      if (s1->as->type == AS_EXPLICIT)
+	for (i = 0; i < s1->as->rank + s1->as->corank; i++)
+	  {
+	    shape1 = gfc_subtract (gfc_copy_expr (s1->as->upper[i]),
+				  gfc_copy_expr (s1->as->lower[i]));
+	    shape2 = gfc_subtract (gfc_copy_expr (s2->as->upper[i]),
+				  gfc_copy_expr (s2->as->lower[i]));
+	    compval = gfc_dep_compare_expr (shape1, shape2);
+	    gfc_free_expr (shape1);
+	    gfc_free_expr (shape2);
+	    switch (compval)
+	    {
+	      case -1:
+	      case  1:
+	      case -3:
+		snprintf (errmsg, err_len, "Shape mismatch in dimension %i of "
+			  "argument '%s'", i + 1, s1->name);
+		return false;
+
+	      case -2:
+		/* FIXME: Implement a warning for this case.
+		gfc_warning ("Possible shape mismatch in argument '%s'",
+			    s1->name);*/
+		break;
+
+	      case 0:
+		break;
+
+	      default:
+		gfc_internal_error ("check_dummy_characteristics: Unexpected "
+				    "result %i of gfc_dep_compare_expr",
+				    compval);
+		break;
+	    }
+	  }
+    }
+
+  return true;
+}
+
+
+/* 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,
+			      char *errmsg, int err_len)
+{
+  gfc_symbol *r1, *r2;
+
+  if (s1->ts.interface && s1->ts.interface->result)
+    r1 = s1->ts.interface->result;
+  else
+    r1 = s1->result ? s1->result : s1;
+
+  if (s2->ts.interface && s2->ts.interface->result)
+    r2 = s2->ts.interface->result;
+  else
+    r2 = s2->result ? s2->result : s2;
+
+  if (r1->ts.type == BT_UNKNOWN)
+    return true;
+
+  /* Check type and rank.  */
+  if (!compare_type (r1, r2))
+    {
+      snprintf (errmsg, err_len, "Type mismatch in function result (%s/%s)",
+		gfc_typename (&r1->ts), gfc_typename (&r2->ts));
+      return false;
+    }
+  if (!compare_rank (r1, r2))
+    {
+      snprintf (errmsg, err_len, "Rank mismatch in function result (%i/%i)",
+		symbol_rank (r1), symbol_rank (r2));
+      return false;
+    }
+
+  /* Check ALLOCATABLE attribute.  */
+  if (r1->attr.allocatable != r2->attr.allocatable)
+    {
+      snprintf (errmsg, err_len, "ALLOCATABLE attribute mismatch in "
+		"function result");
+      return false;
+    }
+
+  /* Check POINTER attribute.  */
+  if (r1->attr.pointer != r2->attr.pointer)
+    {
+      snprintf (errmsg, err_len, "POINTER attribute mismatch in "
+		"function result");
+      return false;
+    }
+
+  /* Check CONTIGUOUS attribute.  */
+  if (r1->attr.contiguous != r2->attr.contiguous)
+    {
+      snprintf (errmsg, err_len, "CONTIGUOUS attribute mismatch in "
+		"function result");
+      return false;
+    }
+
+  /* Check PROCEDURE POINTER attribute.  */
+  if (r1 != s1 && r1->attr.proc_pointer != r2->attr.proc_pointer)
+    {
+      snprintf (errmsg, err_len, "PROCEDURE POINTER mismatch in "
+		"function result");
+      return false;
+    }
+
+  /* Check string length.  */
+  if (r1->ts.type == BT_CHARACTER && r1->ts.u.cl && r2->ts.u.cl)
+    {
+      if (r1->ts.deferred != r2->ts.deferred)
+	{
+	  snprintf (errmsg, err_len, "Character length mismatch "
+		    "in function result");
+	  return false;
+	}
+
+      if (r1->ts.u.cl->length && r2->ts.u.cl->length)
+	{
+	  int compval = gfc_dep_compare_expr (r1->ts.u.cl->length,
+					      r2->ts.u.cl->length);
+	  switch (compval)
+	  {
+	    case -1:
+	    case  1:
+	    case -3:
+	      snprintf (errmsg, err_len, "Character length mismatch "
+			"in function result");
+	      return false;
+
+	    case -2:
+	      /* FIXME: Implement a warning for this case.
+	      snprintf (errmsg, err_len, "Possible character length mismatch "
+			"in function result");*/
+	      break;
+
+	    case 0:
+	      break;
+
+	    default:
+	      gfc_internal_error ("check_result_characteristics (1): Unexpected "
+				  "result %i of gfc_dep_compare_expr", compval);
+	      break;
+	  }
+	}
+    }
+
+  /* Check array shape.  */
+  if (!r1->attr.allocatable && !r1->attr.pointer && r1->as && r2->as)
+    {
+      int i, compval;
+      gfc_expr *shape1, *shape2;
+
+      if (r1->as->type != r2->as->type)
+	{
+	  snprintf (errmsg, err_len, "Shape mismatch in function result");
+	  return false;
+	}
+
+      if (r1->as->type == AS_EXPLICIT)
+	for (i = 0; i < r1->as->rank + r1->as->corank; i++)
+	  {
+	    shape1 = gfc_subtract (gfc_copy_expr (r1->as->upper[i]),
+				   gfc_copy_expr (r1->as->lower[i]));
+	    shape2 = gfc_subtract (gfc_copy_expr (r2->as->upper[i]),
+				   gfc_copy_expr (r2->as->lower[i]));
+	    compval = gfc_dep_compare_expr (shape1, shape2);
+	    gfc_free_expr (shape1);
+	    gfc_free_expr (shape2);
+	    switch (compval)
+	    {
+	      case -1:
+	      case  1:
+	      case -3:
+		snprintf (errmsg, err_len, "Shape mismatch in dimension %i of "
+			  "function result", i + 1);
+		return false;
+
+	      case -2:
+		/* FIXME: Implement a warning for this case.
+		gfc_warning ("Possible shape mismatch in return value");*/
+		break;
+
+	      case 0:
+		break;
+
+	      default:
+		gfc_internal_error ("check_result_characteristics (2): "
+				    "Unexpected result %i of "
+				    "gfc_dep_compare_expr", compval);
+		break;
+	    }
+	  }
+    }
+
+  return true;
+}
+
+
+/* 'Compare' two formal interfaces associated with a pair of symbols.
+   We return nonzero if there exists an actual argument list that
+   would be ambiguous between the two interfaces, zero otherwise.
+   'strict_flag' specifies whether all the characteristics are
+   required to match, which is not the case for ambiguity checks.
+   'p1' and 'p2' are the PASS arguments of both procedures (if applicable).  */
+
+int
+gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
+			int generic_flag, int strict_flag,
+			char *errmsg, int err_len,
+			const char *p1, const char *p2)
+{
+  gfc_formal_arglist *f1, *f2;
+
+  gcc_assert (name2 != NULL);
+
+  if (s1->attr.function && (s2->attr.subroutine
+      || (!s2->attr.function && s2->ts.type == BT_UNKNOWN
+	  && gfc_get_default_type (name2, s2->ns)->type == BT_UNKNOWN)))
+    {
+      if (errmsg != NULL)
+	snprintf (errmsg, err_len, "'%s' is not a function", name2);
+      return 0;
+    }
+
+  if (s1->attr.subroutine && s2->attr.function)
+    {
+      if (errmsg != NULL)
+	snprintf (errmsg, err_len, "'%s' is not a subroutine", name2);
+      return 0;
+    }
+
+  /* Do strict checks on all characteristics
+     (for dummy procedures and procedure pointer assignments).  */
+  if (!generic_flag && strict_flag)
+    {
+      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))
+	    return 0;
+	}
+
+      if (s1->attr.pure && !s2->attr.pure)
+	{
+	  snprintf (errmsg, err_len, "Mismatch in PURE attribute");
+	  return 0;
+	}
+      if (s1->attr.elemental && !s2->attr.elemental)
+	{
+	  snprintf (errmsg, err_len, "Mismatch in ELEMENTAL attribute");
+	  return 0;
+	}
+    }
+
+  if (s1->attr.if_source == IFSRC_UNKNOWN
+      || s2->attr.if_source == IFSRC_UNKNOWN)
+    return 1;
+
+  f1 = gfc_sym_get_dummy_args (s1);
+  f2 = gfc_sym_get_dummy_args (s2);
+
+  if (f1 == NULL && f2 == NULL)
+    return 1;			/* Special case: No arguments.  */
+
+  if (generic_flag)
+    {
+      if (count_types_test (f1, f2, p1, p2)
+	  || count_types_test (f2, f1, p2, p1))
+	return 0;
+      if (generic_correspondence (f1, f2, p1, p2)
+	  || generic_correspondence (f2, f1, p2, p1))
+	return 0;
+    }
+  else
+    /* Perform the abbreviated correspondence test for operators (the
+       arguments cannot be optional and are always ordered correctly).
+       This is also done when comparing interfaces for dummy procedures and in
+       procedure pointer assignments.  */
+
+    for (;;)
+      {
+	/* Check existence.  */
+	if (f1 == NULL && f2 == NULL)
+	  break;
+	if (f1 == NULL || f2 == NULL)
+	  {
+	    if (errmsg != NULL)
+	      snprintf (errmsg, err_len, "'%s' has the wrong number of "
+			"arguments", name2);
+	    return 0;
+	  }
+
+	if (UNLIMITED_POLY (f1->sym))
+	  goto next;
+
+	if (strict_flag)
+	  {
+	    /* Check all characteristics.  */
+	    if (!check_dummy_characteristics (f1->sym, f2->sym, true, 
+					      errmsg, err_len))
+	      return 0;
+	  }
+	else
+	  {
+	    /* Only check type and rank.  */
+	    if (!compare_type (f2->sym, f1->sym))
+	      {
+		if (errmsg != NULL)
+		  snprintf (errmsg, err_len, "Type mismatch in argument '%s' "
+			    "(%s/%s)", f1->sym->name,
+			    gfc_typename (&f1->sym->ts),
+			    gfc_typename (&f2->sym->ts));
+		return 0;
+	      }
+	    if (!compare_rank (f2->sym, f1->sym))
+	      {
+		if (errmsg != NULL)
+		  snprintf (errmsg, err_len, "Rank mismatch in argument '%s' "
+			    "(%i/%i)", f1->sym->name, symbol_rank (f1->sym),
+			    symbol_rank (f2->sym));
+		return 0;
+	      }
+	  }
+next:
+	f1 = f1->next;
+	f2 = f2->next;
+      }
+
+  return 1;
+}
+
+
+/* Given a pointer to an interface pointer, remove duplicate
+   interfaces and make sure that all symbols are either functions
+   or subroutines, and all of the same kind.  Returns nonzero if
+   something goes wrong.  */
+
+static int
+check_interface0 (gfc_interface *p, const char *interface_name)
+{
+  gfc_interface *psave, *q, *qlast;
+
+  psave = p;
+  for (; p; p = p->next)
+    {
+      /* Make sure all symbols in the interface have been defined as
+	 functions or subroutines.  */
+      if (((!p->sym->attr.function && !p->sym->attr.subroutine)
+	   || !p->sym->attr.if_source)
+	  && p->sym->attr.flavor != FL_DERIVED)
+	{
+	  if (p->sym->attr.external)
+	    gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
+		       p->sym->name, interface_name, &p->sym->declared_at);
+	  else
+	    gfc_error ("Procedure '%s' in %s at %L is neither function nor "
+		       "subroutine", p->sym->name, interface_name,
+		      &p->sym->declared_at);
+	  return 1;
+	}
+
+      /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs.  */
+      if ((psave->sym->attr.function && !p->sym->attr.function
+	   && p->sym->attr.flavor != FL_DERIVED)
+	  || (psave->sym->attr.subroutine && !p->sym->attr.subroutine))
+	{
+	  if (p->sym->attr.flavor != FL_DERIVED)
+	    gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
+		       " or all FUNCTIONs", interface_name,
+		       &p->sym->declared_at);
+	  else
+	    gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
+		       "generic name is also the name of a derived type",
+		       interface_name, &p->sym->declared_at);
+	  return 1;
+	}
+
+      /* F2003, C1207. F2008, C1207.  */
+      if (p->sym->attr.proc == PROC_INTERNAL
+	  && !gfc_notify_std (GFC_STD_F2008, "Internal procedure "
+			      "'%s' in %s at %L", p->sym->name, 
+			      interface_name, &p->sym->declared_at))
+	return 1;
+    }
+  p = psave;
+
+  /* Remove duplicate interfaces in this interface list.  */
+  for (; p; p = p->next)
+    {
+      qlast = p;
+
+      for (q = p->next; q;)
+	{
+	  if (p->sym != q->sym)
+	    {
+	      qlast = q;
+	      q = q->next;
+	    }
+	  else
+	    {
+	      /* Duplicate interface.  */
+	      qlast->next = q->next;
+	      free (q);
+	      q = qlast->next;
+	    }
+	}
+    }
+
+  return 0;
+}
+
+
+/* Check lists of interfaces to make sure that no two interfaces are
+   ambiguous.  Duplicate interfaces (from the same symbol) are OK here.  */
+
+static int
+check_interface1 (gfc_interface *p, gfc_interface *q0,
+		  int generic_flag, const char *interface_name,
+		  bool referenced)
+{
+  gfc_interface *q;
+  for (; p; p = p->next)
+    for (q = q0; q; q = q->next)
+      {
+	if (p->sym == q->sym)
+	  continue;		/* Duplicates OK here.  */
+
+	if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
+	  continue;
+
+	if (p->sym->attr.flavor != FL_DERIVED
+	    && q->sym->attr.flavor != FL_DERIVED
+	    && gfc_compare_interfaces (p->sym, q->sym, q->sym->name,
+				       generic_flag, 0, NULL, 0, NULL, NULL))
+	  {
+	    if (referenced)
+	      gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
+			 p->sym->name, q->sym->name, interface_name,
+			 &p->where);
+	    else if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
+	      gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
+			   p->sym->name, q->sym->name, interface_name,
+			   &p->where);
+	    else
+	      gfc_warning ("Although not referenced, '%s' has ambiguous "
+			   "interfaces at %L", interface_name, &p->where);
+	    return 1;
+	  }
+      }
+  return 0;
+}
+
+
+/* Check the generic and operator interfaces of symbols to make sure
+   that none of the interfaces conflict.  The check has to be done
+   after all of the symbols are actually loaded.  */
+
+static void
+check_sym_interfaces (gfc_symbol *sym)
+{
+  char interface_name[100];
+  gfc_interface *p;
+
+  if (sym->ns != gfc_current_ns)
+    return;
+
+  if (sym->generic != NULL)
+    {
+      sprintf (interface_name, "generic interface '%s'", sym->name);
+      if (check_interface0 (sym->generic, interface_name))
+	return;
+
+      for (p = sym->generic; p; p = p->next)
+	{
+	  if (p->sym->attr.mod_proc
+	      && (p->sym->attr.if_source != IFSRC_DECL
+		  || p->sym->attr.procedure))
+	    {
+	      gfc_error ("'%s' at %L is not a module procedure",
+			 p->sym->name, &p->where);
+	      return;
+	    }
+	}
+
+      /* Originally, this test was applied to host interfaces too;
+	 this is incorrect since host associated symbols, from any
+	 source, cannot be ambiguous with local symbols.  */
+      check_interface1 (sym->generic, sym->generic, 1, interface_name,
+			sym->attr.referenced || !sym->attr.use_assoc);
+    }
+}
+
+
+static void
+check_uop_interfaces (gfc_user_op *uop)
+{
+  char interface_name[100];
+  gfc_user_op *uop2;
+  gfc_namespace *ns;
+
+  sprintf (interface_name, "operator interface '%s'", uop->name);
+  if (check_interface0 (uop->op, interface_name))
+    return;
+
+  for (ns = gfc_current_ns; ns; ns = ns->parent)
+    {
+      uop2 = gfc_find_uop (uop->name, ns);
+      if (uop2 == NULL)
+	continue;
+
+      check_interface1 (uop->op, uop2->op, 0,
+			interface_name, true);
+    }
+}
+
+/* Given an intrinsic op, return an equivalent op if one exists,
+   or INTRINSIC_NONE otherwise.  */
+
+gfc_intrinsic_op
+gfc_equivalent_op (gfc_intrinsic_op op)
+{
+  switch(op)
+    {
+    case INTRINSIC_EQ:
+      return INTRINSIC_EQ_OS;
+
+    case INTRINSIC_EQ_OS:
+      return INTRINSIC_EQ;
+
+    case INTRINSIC_NE:
+      return INTRINSIC_NE_OS;
+
+    case INTRINSIC_NE_OS:
+      return INTRINSIC_NE;
+
+    case INTRINSIC_GT:
+      return INTRINSIC_GT_OS;
+
+    case INTRINSIC_GT_OS:
+      return INTRINSIC_GT;
+
+    case INTRINSIC_GE:
+      return INTRINSIC_GE_OS;
+
+    case INTRINSIC_GE_OS:
+      return INTRINSIC_GE;
+
+    case INTRINSIC_LT:
+      return INTRINSIC_LT_OS;
+
+    case INTRINSIC_LT_OS:
+      return INTRINSIC_LT;
+
+    case INTRINSIC_LE:
+      return INTRINSIC_LE_OS;
+
+    case INTRINSIC_LE_OS:
+      return INTRINSIC_LE;
+
+    default:
+      return INTRINSIC_NONE;
+    }
+}
+
+/* For the namespace, check generic, user operator and intrinsic
+   operator interfaces for consistency and to remove duplicate
+   interfaces.  We traverse the whole namespace, counting on the fact
+   that most symbols will not have generic or operator interfaces.  */
+
+void
+gfc_check_interfaces (gfc_namespace *ns)
+{
+  gfc_namespace *old_ns, *ns2;
+  char interface_name[100];
+  int i;
+
+  old_ns = gfc_current_ns;
+  gfc_current_ns = ns;
+
+  gfc_traverse_ns (ns, check_sym_interfaces);
+
+  gfc_traverse_user_op (ns, check_uop_interfaces);
+
+  for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
+    {
+      if (i == INTRINSIC_USER)
+	continue;
+
+      if (i == INTRINSIC_ASSIGN)
+	strcpy (interface_name, "intrinsic assignment operator");
+      else
+	sprintf (interface_name, "intrinsic '%s' operator",
+		 gfc_op2string ((gfc_intrinsic_op) i));
+
+      if (check_interface0 (ns->op[i], interface_name))
+	continue;
+
+      if (ns->op[i])
+	gfc_check_operator_interface (ns->op[i]->sym, (gfc_intrinsic_op) i,
+				      ns->op[i]->where);
+
+      for (ns2 = ns; ns2; ns2 = ns2->parent)
+	{
+	  gfc_intrinsic_op other_op;
+
+	  if (check_interface1 (ns->op[i], ns2->op[i], 0,
+				interface_name, true))
+	    goto done;
+
+	  /* i should be gfc_intrinsic_op, but has to be int with this cast
+	     here for stupid C++ compatibility rules.  */
+	  other_op = gfc_equivalent_op ((gfc_intrinsic_op) i);
+	  if (other_op != INTRINSIC_NONE
+	    &&  check_interface1 (ns->op[i], ns2->op[other_op],
+				  0, interface_name, true))
+	    goto done;
+	}
+    }
+
+done:
+  gfc_current_ns = old_ns;
+}
+
+
+/* Given a symbol of a formal argument list and an expression, if the
+   formal argument is allocatable, check that the actual argument is
+   allocatable. Returns nonzero if compatible, zero if not compatible.  */
+
+static int
+compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
+{
+  symbol_attribute attr;
+
+  if (formal->attr.allocatable
+      || (formal->ts.type == BT_CLASS && CLASS_DATA (formal)->attr.allocatable))
+    {
+      attr = gfc_expr_attr (actual);
+      if (!attr.allocatable)
+	return 0;
+    }
+
+  return 1;
+}
+
+
+/* Given a symbol of a formal argument list and an expression, if the
+   formal argument is a pointer, see if the actual argument is a
+   pointer. Returns nonzero if compatible, zero if not compatible.  */
+
+static int
+compare_pointer (gfc_symbol *formal, gfc_expr *actual)
+{
+  symbol_attribute attr;
+
+  if (formal->attr.pointer
+      || (formal->ts.type == BT_CLASS && CLASS_DATA (formal)
+	  && CLASS_DATA (formal)->attr.class_pointer))
+    {
+      attr = gfc_expr_attr (actual);
+
+      /* Fortran 2008 allows non-pointer actual arguments.  */
+      if (!attr.pointer && attr.target && formal->attr.intent == INTENT_IN)
+	return 2;
+
+      if (!attr.pointer)
+	return 0;
+    }
+
+  return 1;
+}
+
+
+/* Emit clear error messages for rank mismatch.  */
+
+static void
+argument_rank_mismatch (const char *name, locus *where,
+			int rank1, int rank2)
+{
+
+  /* TS 29113, C407b.  */
+  if (rank2 == -1)
+    {
+      gfc_error ("The assumed-rank array at %L requires that the dummy argument"
+		 " '%s' has assumed-rank", where, name);
+    }
+  else if (rank1 == 0)
+    {
+      gfc_error ("Rank mismatch in argument '%s' at %L "
+		 "(scalar and rank-%d)", name, where, rank2);
+    }
+  else if (rank2 == 0)
+    {
+      gfc_error ("Rank mismatch in argument '%s' at %L "
+		 "(rank-%d and scalar)", name, where, rank1);
+    }
+  else
+    {
+      gfc_error ("Rank mismatch in argument '%s' at %L "
+		 "(rank-%d and rank-%d)", name, where, rank1, rank2);
+    }
+}
+
+
+/* Given a symbol of a formal argument list and an expression, see if
+   the two are compatible as arguments.  Returns nonzero if
+   compatible, zero if not compatible.  */
+
+static int
+compare_parameter (gfc_symbol *formal, gfc_expr *actual,
+		   int ranks_must_agree, int is_elemental, locus *where)
+{
+  gfc_ref *ref;
+  bool rank_check, is_pointer;
+
+  /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
+     procs c_f_pointer or c_f_procpointer, and we need to accept most
+     pointers the user could give us.  This should allow that.  */
+  if (formal->ts.type == BT_VOID)
+    return 1;
+
+  if (formal->ts.type == BT_DERIVED
+      && formal->ts.u.derived && formal->ts.u.derived->ts.is_iso_c
+      && actual->ts.type == BT_DERIVED
+      && actual->ts.u.derived && actual->ts.u.derived->ts.is_iso_c)
+    return 1;
+
+  if (formal->ts.type == BT_CLASS && actual->ts.type == BT_DERIVED)
+    /* Make sure the vtab symbol is present when
+       the module variables are generated.  */
+    gfc_find_derived_vtab (actual->ts.u.derived);
+
+  if (actual->ts.type == BT_PROCEDURE)
+    {
+      char err[200];
+      gfc_symbol *act_sym = actual->symtree->n.sym;
+
+      if (formal->attr.flavor != FL_PROCEDURE)
+	{
+	  if (where)
+	    gfc_error ("Invalid procedure argument at %L", &actual->where);
+	  return 0;
+	}
+
+      if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err,
+				   sizeof(err), NULL, NULL))
+	{
+	  if (where)
+	    gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
+		       formal->name, &actual->where, err);
+	  return 0;
+	}
+
+      if (formal->attr.function && !act_sym->attr.function)
+	{
+	  gfc_add_function (&act_sym->attr, act_sym->name,
+	  &act_sym->declared_at);
+	  if (act_sym->ts.type == BT_UNKNOWN
+	      && !gfc_set_default_type (act_sym, 1, act_sym->ns))
+	    return 0;
+	}
+      else if (formal->attr.subroutine && !act_sym->attr.subroutine)
+	gfc_add_subroutine (&act_sym->attr, act_sym->name,
+			    &act_sym->declared_at);
+
+      return 1;
+    }
+
+  /* F2008, C1241.  */
+  if (formal->attr.pointer && formal->attr.contiguous
+      && !gfc_is_simply_contiguous (actual, true))
+    {
+      if (where)
+	gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L "
+		   "must be simply contiguous", formal->name, &actual->where);
+      return 0;
+    }
+
+  if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
+      && actual->ts.type != BT_HOLLERITH
+      && formal->ts.type != BT_ASSUMED
+      && !(formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
+      && !gfc_compare_types (&formal->ts, &actual->ts)
+      && !(formal->ts.type == BT_DERIVED && actual->ts.type == BT_CLASS
+	   && gfc_compare_derived_types (formal->ts.u.derived,
+					 CLASS_DATA (actual)->ts.u.derived)))
+    {
+      if (where)
+	gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
+		   formal->name, &actual->where, gfc_typename (&actual->ts),
+		   gfc_typename (&formal->ts));
+      return 0;
+    }
+
+  if (actual->ts.type == BT_ASSUMED && formal->ts.type != BT_ASSUMED)
+    {
+      if (where)
+	gfc_error ("Assumed-type actual argument at %L requires that dummy "
+		   "argument '%s' is of assumed type", &actual->where,
+		   formal->name);
+      return 0;
+    }
+
+  /* F2008, 12.5.2.5; IR F08/0073.  */
+  if (formal->ts.type == BT_CLASS && formal->attr.class_ok
+      && actual->expr_type != EXPR_NULL
+      && ((CLASS_DATA (formal)->attr.class_pointer
+	   && !formal->attr.intent == INTENT_IN)
+          || CLASS_DATA (formal)->attr.allocatable))
+    {
+      if (actual->ts.type != BT_CLASS)
+	{
+	  if (where)
+	    gfc_error ("Actual argument to '%s' at %L must be polymorphic",
+			formal->name, &actual->where);
+	  return 0;
+	}
+
+      if (!gfc_expr_attr (actual).class_ok)
+	return 0;
+
+      if ((!UNLIMITED_POLY (formal) || !UNLIMITED_POLY(actual))
+	  && !gfc_compare_derived_types (CLASS_DATA (actual)->ts.u.derived,
+					 CLASS_DATA (formal)->ts.u.derived))
+	{
+	  if (where)
+	    gfc_error ("Actual argument to '%s' at %L must have the same "
+		       "declared type", formal->name, &actual->where);
+	  return 0;
+	}
+    }
+
+  /* F08: 12.5.2.5 Allocatable and pointer dummy variables.  However, this
+     is necessary also for F03, so retain error for both.
+     NOTE: Other type/kind errors pre-empt this error.  Since they are F03
+     compatible, no attempt has been made to channel to this one.  */
+  if (UNLIMITED_POLY (formal) && !UNLIMITED_POLY (actual)
+      && (CLASS_DATA (formal)->attr.allocatable
+	  ||CLASS_DATA (formal)->attr.class_pointer))
+    {
+      if (where)
+	gfc_error ("Actual argument to '%s' at %L must be unlimited "
+		   "polymorphic since the formal argument is a "
+		   "pointer or allocatable unlimited polymorphic "
+		   "entity [F2008: 12.5.2.5]", formal->name,
+		   &actual->where);
+      return 0;
+    }
+
+  if (formal->attr.codimension && !gfc_is_coarray (actual))
+    {
+      if (where)
+	gfc_error ("Actual argument to '%s' at %L must be a coarray",
+		       formal->name, &actual->where);
+      return 0;
+    }
+
+  if (formal->attr.codimension && formal->attr.allocatable)
+    {
+      gfc_ref *last = NULL;
+
+      for (ref = actual->ref; ref; ref = ref->next)
+	if (ref->type == REF_COMPONENT)
+	  last = ref;
+
+      /* F2008, 12.5.2.6.  */
+      if ((last && last->u.c.component->as->corank != formal->as->corank)
+	  || (!last
+	      && actual->symtree->n.sym->as->corank != formal->as->corank))
+	{
+	  if (where)
+	    gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
+		   formal->name, &actual->where, formal->as->corank,
+		   last ? last->u.c.component->as->corank
+			: actual->symtree->n.sym->as->corank);
+	  return 0;
+	}
+    }
+
+  if (formal->attr.codimension)
+    {
+      /* F2008, 12.5.2.8.  */
+      if (formal->attr.dimension
+	  && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE)
+	  && gfc_expr_attr (actual).dimension
+	  && !gfc_is_simply_contiguous (actual, true))
+	{
+	  if (where)
+	    gfc_error ("Actual argument to '%s' at %L must be simply "
+		       "contiguous", formal->name, &actual->where);
+	  return 0;
+	}
+
+      /* F2008, C1303 and C1304.  */
+      if (formal->attr.intent != INTENT_INOUT
+	  && (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS)
+	       && formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+	       && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
+	      || formal->attr.lock_comp))
+
+    	{
+	  if (where)
+	    gfc_error ("Actual argument to non-INTENT(INOUT) dummy '%s' at %L, "
+		       "which is LOCK_TYPE or has a LOCK_TYPE component",
+		       formal->name, &actual->where);
+	  return 0;
+	}
+    }
+
+  /* F2008, C1239/C1240.  */
+  if (actual->expr_type == EXPR_VARIABLE
+      && (actual->symtree->n.sym->attr.asynchronous
+         || actual->symtree->n.sym->attr.volatile_)
+      &&  (formal->attr.asynchronous || formal->attr.volatile_)
+      && actual->rank && formal->as && !gfc_is_simply_contiguous (actual, true)
+      && ((formal->as->type != AS_ASSUMED_SHAPE
+	   && formal->as->type != AS_ASSUMED_RANK && !formal->attr.pointer)
+	  || formal->attr.contiguous))
+    {
+      if (where)
+	gfc_error ("Dummy argument '%s' has to be a pointer, assumed-shape or "
+		   "assumed-rank array without CONTIGUOUS attribute - as actual"
+		   " argument at %L is not simply contiguous and both are "
+		   "ASYNCHRONOUS or VOLATILE", formal->name, &actual->where);
+      return 0;
+    }
+
+  if (formal->attr.allocatable && !formal->attr.codimension
+      && gfc_expr_attr (actual).codimension)
+    {
+      if (formal->attr.intent == INTENT_OUT)
+	{
+	  if (where)
+	    gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
+		       "INTENT(OUT) dummy argument '%s'", &actual->where,
+		       formal->name);
+	    return 0;
+	}
+      else if (gfc_option.warn_surprising && where
+	       && formal->attr.intent != INTENT_IN)
+	gfc_warning ("Passing coarray at %L to allocatable, noncoarray dummy "
+		     "argument '%s', which is invalid if the allocation status"
+		     " is modified",  &actual->where, formal->name);
+    }
+
+  /* If the rank is the same or the formal argument has assumed-rank.  */
+  if (symbol_rank (formal) == actual->rank || symbol_rank (formal) == -1)
+    return 1;
+
+  if (actual->ts.type == BT_CLASS && CLASS_DATA (actual)->as
+	&& CLASS_DATA (actual)->as->rank == symbol_rank (formal))
+    return 1;
+
+  rank_check = where != NULL && !is_elemental && formal->as
+	       && (formal->as->type == AS_ASSUMED_SHAPE
+		   || formal->as->type == AS_DEFERRED)
+	       && actual->expr_type != EXPR_NULL;
+
+  /* Skip rank checks for NO_ARG_CHECK.  */
+  if (formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
+    return 1;
+
+  /* Scalar & coindexed, see: F2008, Section 12.5.2.4.  */
+  if (rank_check || ranks_must_agree
+      || (formal->attr.pointer && actual->expr_type != EXPR_NULL)
+      || (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
+      || (actual->rank == 0
+	  && ((formal->ts.type == BT_CLASS
+	       && CLASS_DATA (formal)->as->type == AS_ASSUMED_SHAPE)
+	      || (formal->ts.type != BT_CLASS
+		   && formal->as->type == AS_ASSUMED_SHAPE))
+	  && actual->expr_type != EXPR_NULL)
+      || (actual->rank == 0 && formal->attr.dimension
+	  && gfc_is_coindexed (actual)))
+    {
+      if (where)
+	argument_rank_mismatch (formal->name, &actual->where,
+				symbol_rank (formal), actual->rank);
+      return 0;
+    }
+  else if (actual->rank != 0 && (is_elemental || formal->attr.dimension))
+    return 1;
+
+  /* At this point, we are considering a scalar passed to an array.   This
+     is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
+     - if the actual argument is (a substring of) an element of a
+       non-assumed-shape/non-pointer/non-polymorphic array; or
+     - (F2003) if the actual argument is of type character of default/c_char
+       kind.  */
+
+  is_pointer = actual->expr_type == EXPR_VARIABLE
+	       ? actual->symtree->n.sym->attr.pointer : false;
+
+  for (ref = actual->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_COMPONENT)
+	is_pointer = ref->u.c.component->attr.pointer;
+      else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
+	       && ref->u.ar.dimen > 0
+	       && (!ref->next
+		   || (ref->next->type == REF_SUBSTRING && !ref->next->next)))
+        break;
+    }
+
+  if (actual->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL)
+    {
+      if (where)
+	gfc_error ("Polymorphic scalar passed to array dummy argument '%s' "
+		   "at %L", formal->name, &actual->where);
+      return 0;
+    }
+
+  if (actual->expr_type != EXPR_NULL && ref && actual->ts.type != BT_CHARACTER
+      && (is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
+    {
+      if (where)
+	gfc_error ("Element of assumed-shaped or pointer "
+		   "array passed to array dummy argument '%s' at %L",
+		   formal->name, &actual->where);
+      return 0;
+    }
+
+  if (actual->ts.type == BT_CHARACTER && actual->expr_type != EXPR_NULL
+      && (!ref || is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
+    {
+      if (formal->ts.kind != 1 && (gfc_option.allow_std & GFC_STD_GNU) == 0)
+	{
+	  if (where)
+	    gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
+		       "CHARACTER actual argument with array dummy argument "
+		       "'%s' at %L", formal->name, &actual->where);
+	  return 0;
+	}
+
+      if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
+	{
+	  gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
+		     "array dummy argument '%s' at %L",
+		     formal->name, &actual->where);
+	  return 0;
+	}
+      else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
+	return 0;
+      else
+	return 1;
+    }
+
+  if (ref == NULL && actual->expr_type != EXPR_NULL)
+    {
+      if (where)
+	argument_rank_mismatch (formal->name, &actual->where,
+				symbol_rank (formal), actual->rank);
+      return 0;
+    }
+
+  return 1;
+}
+
+
+/* Returns the storage size of a symbol (formal argument) or
+   zero if it cannot be determined.  */
+
+static unsigned long
+get_sym_storage_size (gfc_symbol *sym)
+{
+  int i;
+  unsigned long strlen, elements;
+
+  if (sym->ts.type == BT_CHARACTER)
+    {
+      if (sym->ts.u.cl && sym->ts.u.cl->length
+          && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+	strlen = mpz_get_ui (sym->ts.u.cl->length->value.integer);
+      else
+	return 0;
+    }
+  else
+    strlen = 1;
+
+  if (symbol_rank (sym) == 0)
+    return strlen;
+
+  elements = 1;
+  if (sym->as->type != AS_EXPLICIT)
+    return 0;
+  for (i = 0; i < sym->as->rank; i++)
+    {
+      if (sym->as->upper[i]->expr_type != EXPR_CONSTANT
+	  || sym->as->lower[i]->expr_type != EXPR_CONSTANT)
+	return 0;
+
+      elements *= mpz_get_si (sym->as->upper[i]->value.integer)
+		  - mpz_get_si (sym->as->lower[i]->value.integer) + 1L;
+    }
+
+  return strlen*elements;
+}
+
+
+/* Returns the storage size of an expression (actual argument) or
+   zero if it cannot be determined. For an array element, it returns
+   the remaining size as the element sequence consists of all storage
+   units of the actual argument up to the end of the array.  */
+
+static unsigned long
+get_expr_storage_size (gfc_expr *e)
+{
+  int i;
+  long int strlen, elements;
+  long int substrlen = 0;
+  bool is_str_storage = false;
+  gfc_ref *ref;
+
+  if (e == NULL)
+    return 0;
+
+  if (e->ts.type == BT_CHARACTER)
+    {
+      if (e->ts.u.cl && e->ts.u.cl->length
+          && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+	strlen = mpz_get_si (e->ts.u.cl->length->value.integer);
+      else if (e->expr_type == EXPR_CONSTANT
+	       && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
+	strlen = e->value.character.length;
+      else
+	return 0;
+    }
+  else
+    strlen = 1; /* Length per element.  */
+
+  if (e->rank == 0 && !e->ref)
+    return strlen;
+
+  elements = 1;
+  if (!e->ref)
+    {
+      if (!e->shape)
+	return 0;
+      for (i = 0; i < e->rank; i++)
+	elements *= mpz_get_si (e->shape[i]);
+      return elements*strlen;
+    }
+
+  for (ref = e->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_SUBSTRING && ref->u.ss.start
+	  && ref->u.ss.start->expr_type == EXPR_CONSTANT)
+	{
+	  if (is_str_storage)
+	    {
+	      /* The string length is the substring length.
+		 Set now to full string length.  */
+	      if (!ref->u.ss.length || !ref->u.ss.length->length
+		  || ref->u.ss.length->length->expr_type != EXPR_CONSTANT)
+		return 0;
+
+	      strlen = mpz_get_ui (ref->u.ss.length->length->value.integer);
+	    }
+	  substrlen = strlen - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
+	  continue;
+	}
+
+      if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
+	for (i = 0; i < ref->u.ar.dimen; i++)
+	  {
+	    long int start, end, stride;
+	    stride = 1;
+
+	    if (ref->u.ar.stride[i])
+	      {
+		if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT)
+		  stride = mpz_get_si (ref->u.ar.stride[i]->value.integer);
+		else
+		  return 0;
+	      }
+
+	    if (ref->u.ar.start[i])
+	      {
+		if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT)
+		  start = mpz_get_si (ref->u.ar.start[i]->value.integer);
+		else
+		  return 0;
+	      }
+	    else if (ref->u.ar.as->lower[i]
+		     && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT)
+	      start = mpz_get_si (ref->u.ar.as->lower[i]->value.integer);
+	    else
+	      return 0;
+
+	    if (ref->u.ar.end[i])
+	      {
+		if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT)
+		  end = mpz_get_si (ref->u.ar.end[i]->value.integer);
+		else
+		  return 0;
+	      }
+	    else if (ref->u.ar.as->upper[i]
+		     && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
+	      end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer);
+	    else
+	      return 0;
+
+	    elements *= (end - start)/stride + 1L;
+	  }
+      else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL)
+	for (i = 0; i < ref->u.ar.as->rank; i++)
+	  {
+	    if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i]
+		&& ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT
+		&& ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
+	      elements *= mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
+			  - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
+			  + 1L;
+	    else
+	      return 0;
+	  }
+      else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
+	       && e->expr_type == EXPR_VARIABLE)
+	{
+	  if (ref->u.ar.as->type == AS_ASSUMED_SHAPE
+	      || e->symtree->n.sym->attr.pointer)
+	    {
+	      elements = 1;
+	      continue;
+	    }
+
+	  /* Determine the number of remaining elements in the element
+	     sequence for array element designators.  */
+	  is_str_storage = true;
+	  for (i = ref->u.ar.dimen - 1; i >= 0; i--)
+	    {
+	      if (ref->u.ar.start[i] == NULL
+		  || ref->u.ar.start[i]->expr_type != EXPR_CONSTANT
+		  || ref->u.ar.as->upper[i] == NULL
+		  || ref->u.ar.as->lower[i] == NULL
+		  || ref->u.ar.as->upper[i]->expr_type != EXPR_CONSTANT
+		  || ref->u.ar.as->lower[i]->expr_type != EXPR_CONSTANT)
+		return 0;
+
+	      elements
+		   = elements
+		     * (mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
+			- mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
+			+ 1L)
+		     - (mpz_get_si (ref->u.ar.start[i]->value.integer)
+			- mpz_get_si (ref->u.ar.as->lower[i]->value.integer));
+	    }
+        }
+      else if (ref->type == REF_COMPONENT && ref->u.c.component->attr.function
+	       && ref->u.c.component->attr.proc_pointer
+	       && ref->u.c.component->attr.dimension)
+	{
+	  /* Array-valued procedure-pointer components.  */
+	  gfc_array_spec *as = ref->u.c.component->as;
+	  for (i = 0; i < as->rank; i++)
+	    {
+	      if (!as->upper[i] || !as->lower[i]
+		  || as->upper[i]->expr_type != EXPR_CONSTANT
+		  || as->lower[i]->expr_type != EXPR_CONSTANT)
+		return 0;
+
+	      elements = elements
+			 * (mpz_get_si (as->upper[i]->value.integer)
+			    - mpz_get_si (as->lower[i]->value.integer) + 1L);
+	    }
+	}
+    }
+
+  if (substrlen)
+    return (is_str_storage) ? substrlen + (elements-1)*strlen
+			    : elements*strlen;
+  else
+    return elements*strlen;
+}
+
+
+/* Given an expression, check whether it is an array section
+   which has a vector subscript. If it has, one is returned,
+   otherwise zero.  */
+
+int
+gfc_has_vector_subscript (gfc_expr *e)
+{
+  int i;
+  gfc_ref *ref;
+
+  if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE)
+    return 0;
+
+  for (ref = e->ref; ref; ref = ref->next)
+    if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
+      for (i = 0; i < ref->u.ar.dimen; i++)
+	if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
+	  return 1;
+
+  return 0;
+}
+
+
+/* Given formal and actual argument lists, see if they are compatible.
+   If they are compatible, the actual argument list is sorted to
+   correspond with the formal list, and elements for missing optional
+   arguments are inserted. If WHERE pointer is nonnull, then we issue
+   errors when things don't match instead of just returning the status
+   code.  */
+
+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_formal_arglist *f;
+  int i, n, na;
+  unsigned long actual_size, formal_size;
+  bool full_array = false;
+
+  actual = *ap;
+
+  if (actual == NULL && formal == NULL)
+    return 1;
+
+  n = 0;
+  for (f = formal; f; f = f->next)
+    n++;
+
+  new_arg = XALLOCAVEC (gfc_actual_arglist *, n);
+
+  for (i = 0; i < n; i++)
+    new_arg[i] = NULL;
+
+  na = 0;
+  f = formal;
+  i = 0;
+
+  for (a = actual; a; a = a->next, f = f->next)
+    {
+      /* Look for keywords but ignore g77 extensions like %VAL.  */
+      if (a->name != NULL && a->name[0] != '%')
+	{
+	  i = 0;
+	  for (f = formal; f; f = f->next, i++)
+	    {
+	      if (f->sym == NULL)
+		continue;
+	      if (strcmp (f->sym->name, a->name) == 0)
+		break;
+	    }
+
+	  if (f == NULL)
+	    {
+	      if (where)
+		gfc_error ("Keyword argument '%s' at %L is not in "
+			   "the procedure", a->name, &a->expr->where);
+	      return 0;
+	    }
+
+	  if (new_arg[i] != NULL)
+	    {
+	      if (where)
+		gfc_error ("Keyword argument '%s' at %L is already associated "
+			   "with another actual argument", a->name,
+			   &a->expr->where);
+	      return 0;
+	    }
+	}
+
+      if (f == NULL)
+	{
+	  if (where)
+	    gfc_error ("More actual than formal arguments in procedure "
+		       "call at %L", where);
+
+	  return 0;
+	}
+
+      if (f->sym == NULL && a->expr == NULL)
+	goto match;
+
+      if (f->sym == NULL)
+	{
+	  if (where)
+	    gfc_error ("Missing alternate return spec in subroutine call "
+		       "at %L", where);
+	  return 0;
+	}
+
+      if (a->expr == NULL)
+	{
+	  if (where)
+	    gfc_error ("Unexpected alternate return spec in subroutine "
+		       "call at %L", where);
+	  return 0;
+	}
+
+      /* Make sure that intrinsic vtables exist for calls to unlimited
+	 polymorphic formal arguments.  */
+      if (UNLIMITED_POLY (f->sym)
+	  && a->expr->ts.type != BT_DERIVED
+	  && a->expr->ts.type != BT_CLASS)
+	gfc_find_vtab (&a->expr->ts);
+
+      if (a->expr->expr_type == EXPR_NULL
+	  && ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer
+	       && (f->sym->attr.allocatable || !f->sym->attr.optional
+		   || (gfc_option.allow_std & GFC_STD_F2008) == 0))
+	      || (f->sym->ts.type == BT_CLASS
+		  && !CLASS_DATA (f->sym)->attr.class_pointer
+		  && (CLASS_DATA (f->sym)->attr.allocatable
+		      || !f->sym->attr.optional
+		      || (gfc_option.allow_std & GFC_STD_F2008) == 0))))
+	{
+	  if (where
+	      && (!f->sym->attr.optional
+		  || (f->sym->ts.type != BT_CLASS && f->sym->attr.allocatable)
+		  || (f->sym->ts.type == BT_CLASS
+			 && CLASS_DATA (f->sym)->attr.allocatable)))
+	    gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
+		       where, f->sym->name);
+	  else if (where)
+	    gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
+		       "dummy '%s'", where, f->sym->name);
+
+	  return 0;
+	}
+
+      if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
+			      is_elemental, where))
+	return 0;
+
+      /* TS 29113, 6.3p2.  */
+      if (f->sym->ts.type == BT_ASSUMED
+	  && (a->expr->ts.type == BT_DERIVED
+	      || (a->expr->ts.type == BT_CLASS && CLASS_DATA (a->expr))))
+	{
+	  gfc_namespace *f2k_derived;
+
+	  f2k_derived = a->expr->ts.type == BT_DERIVED
+			? a->expr->ts.u.derived->f2k_derived
+			: CLASS_DATA (a->expr)->ts.u.derived->f2k_derived;
+
+	  if (f2k_derived
+	      && (f2k_derived->finalizers || f2k_derived->tb_sym_root))
+	    {
+	      gfc_error ("Actual argument at %L to assumed-type dummy is of "
+			 "derived type with type-bound or FINAL procedures",
+			 &a->expr->where);
+	      return false;
+	    }
+	}
+
+      /* Special case for character arguments.  For allocatable, pointer
+	 and assumed-shape dummies, the string length needs to match
+	 exactly.  */
+      if (a->expr->ts.type == BT_CHARACTER
+	   && a->expr->ts.u.cl && a->expr->ts.u.cl->length
+	   && a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
+	   && f->sym->ts.u.cl && f->sym->ts.u.cl && f->sym->ts.u.cl->length
+	   && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
+	   && (f->sym->attr.pointer || f->sym->attr.allocatable
+	       || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
+	   && (mpz_cmp (a->expr->ts.u.cl->length->value.integer,
+			f->sym->ts.u.cl->length->value.integer) != 0))
+	 {
+	   if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
+	     gfc_warning ("Character length mismatch (%ld/%ld) between actual "
+			  "argument and pointer or allocatable dummy argument "
+			  "'%s' at %L",
+			  mpz_get_si (a->expr->ts.u.cl->length->value.integer),
+			  mpz_get_si (f->sym->ts.u.cl->length->value.integer),
+			  f->sym->name, &a->expr->where);
+	   else if (where)
+	     gfc_warning ("Character length mismatch (%ld/%ld) between actual "
+			  "argument and assumed-shape dummy argument '%s' "
+			  "at %L",
+			  mpz_get_si (a->expr->ts.u.cl->length->value.integer),
+			  mpz_get_si (f->sym->ts.u.cl->length->value.integer),
+			  f->sym->name, &a->expr->where);
+	   return 0;
+	 }
+
+      if ((f->sym->attr.pointer || f->sym->attr.allocatable)
+	    && f->sym->ts.deferred != a->expr->ts.deferred
+	    && a->expr->ts.type == BT_CHARACTER)
+	{
+	  if (where)
+	    gfc_error ("Actual argument at %L to allocatable or "
+		       "pointer dummy argument '%s' must have a deferred "
+		       "length type parameter if and only if the dummy has one",
+		       &a->expr->where, f->sym->name);
+	  return 0;
+	}
+
+      if (f->sym->ts.type == BT_CLASS)
+	goto skip_size_check;
+
+      actual_size = get_expr_storage_size (a->expr);
+      formal_size = get_sym_storage_size (f->sym);
+      if (actual_size != 0 && actual_size < formal_size
+	  && a->expr->ts.type != BT_PROCEDURE
+	  && f->sym->attr.flavor != FL_PROCEDURE)
+	{
+	  if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
+	    gfc_warning ("Character length of actual argument shorter "
+			 "than of dummy argument '%s' (%lu/%lu) at %L",
+			 f->sym->name, actual_size, formal_size,
+			 &a->expr->where);
+          else if (where)
+	    gfc_warning ("Actual argument contains too few "
+			 "elements for dummy argument '%s' (%lu/%lu) at %L",
+			 f->sym->name, actual_size, formal_size,
+			 &a->expr->where);
+	  return  0;
+	}
+
+     skip_size_check:
+
+      /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
+         argument is provided for a procedure pointer formal argument.  */
+      if (f->sym->attr.proc_pointer
+	  && !((a->expr->expr_type == EXPR_VARIABLE
+		&& a->expr->symtree->n.sym->attr.proc_pointer)
+	       || (a->expr->expr_type == EXPR_FUNCTION
+		   && a->expr->symtree->n.sym->result->attr.proc_pointer)
+	       || gfc_is_proc_ptr_comp (a->expr)))
+	{
+	  if (where)
+	    gfc_error ("Expected a procedure pointer for argument '%s' at %L",
+		       f->sym->name, &a->expr->where);
+	  return 0;
+	}
+
+      /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
+	 provided for a procedure formal argument.  */
+      if (f->sym->attr.flavor == FL_PROCEDURE
+	  && gfc_expr_attr (a->expr).flavor != FL_PROCEDURE)
+	{
+	  if (where)
+	    gfc_error ("Expected a procedure for argument '%s' at %L",
+		       f->sym->name, &a->expr->where);
+	  return 0;
+	}
+
+      if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE
+	  && a->expr->expr_type == EXPR_VARIABLE
+	  && a->expr->symtree->n.sym->as
+	  && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
+	  && (a->expr->ref == NULL
+	      || (a->expr->ref->type == REF_ARRAY
+		  && a->expr->ref->u.ar.type == AR_FULL)))
+	{
+	  if (where)
+	    gfc_error ("Actual argument for '%s' cannot be an assumed-size"
+		       " array at %L", f->sym->name, where);
+	  return 0;
+	}
+
+      if (a->expr->expr_type != EXPR_NULL
+	  && compare_pointer (f->sym, a->expr) == 0)
+	{
+	  if (where)
+	    gfc_error ("Actual argument for '%s' must be a pointer at %L",
+		       f->sym->name, &a->expr->where);
+	  return 0;
+	}
+
+      if (a->expr->expr_type != EXPR_NULL
+	  && (gfc_option.allow_std & GFC_STD_F2008) == 0
+	  && compare_pointer (f->sym, a->expr) == 2)
+	{
+	  if (where)
+	    gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
+		       "pointer dummy '%s'", &a->expr->where,f->sym->name);
+	  return 0;
+	}
+
+
+      /* Fortran 2008, C1242.  */
+      if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
+	{
+	  if (where)
+	    gfc_error ("Coindexed actual argument at %L to pointer "
+		       "dummy '%s'",
+		       &a->expr->where, f->sym->name);
+	  return 0;
+	}
+
+      /* Fortran 2008, 12.5.2.5 (no constraint).  */
+      if (a->expr->expr_type == EXPR_VARIABLE
+	  && f->sym->attr.intent != INTENT_IN
+	  && f->sym->attr.allocatable
+	  && gfc_is_coindexed (a->expr))
+	{
+	  if (where)
+	    gfc_error ("Coindexed actual argument at %L to allocatable "
+		       "dummy '%s' requires INTENT(IN)",
+		       &a->expr->where, f->sym->name);
+	  return 0;
+	}
+
+      /* Fortran 2008, C1237.  */
+      if (a->expr->expr_type == EXPR_VARIABLE
+	  && (f->sym->attr.asynchronous || f->sym->attr.volatile_)
+	  && gfc_is_coindexed (a->expr)
+	  && (a->expr->symtree->n.sym->attr.volatile_
+	      || a->expr->symtree->n.sym->attr.asynchronous))
+	{
+	  if (where)
+	    gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
+		       "%L requires that dummy '%s' has neither "
+		       "ASYNCHRONOUS nor VOLATILE", &a->expr->where,
+		       f->sym->name);
+	  return 0;
+	}
+
+      /* Fortran 2008, 12.5.2.4 (no constraint).  */
+      if (a->expr->expr_type == EXPR_VARIABLE
+	  && f->sym->attr.intent != INTENT_IN && !f->sym->attr.value
+	  && gfc_is_coindexed (a->expr)
+	  && gfc_has_ultimate_allocatable (a->expr))
+	{
+	  if (where)
+	    gfc_error ("Coindexed actual argument at %L with allocatable "
+		       "ultimate component to dummy '%s' requires either VALUE "
+		       "or INTENT(IN)", &a->expr->where, f->sym->name);
+	  return 0;
+	}
+
+     if (f->sym->ts.type == BT_CLASS
+	   && CLASS_DATA (f->sym)->attr.allocatable
+	   && gfc_is_class_array_ref (a->expr, &full_array)
+	   && !full_array)
+	{
+	  if (where)
+	    gfc_error ("Actual CLASS array argument for '%s' must be a full "
+		       "array at %L", f->sym->name, &a->expr->where);
+	  return 0;
+	}
+
+
+      if (a->expr->expr_type != EXPR_NULL
+	  && compare_allocatable (f->sym, a->expr) == 0)
+	{
+	  if (where)
+	    gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
+		       f->sym->name, &a->expr->where);
+	  return 0;
+	}
+
+      /* Check intent = OUT/INOUT for definable actual argument.  */
+      if ((f->sym->attr.intent == INTENT_OUT
+	  || f->sym->attr.intent == INTENT_INOUT))
+	{
+	  const char* context = (where
+				 ? _("actual argument to INTENT = OUT/INOUT")
+				 : NULL);
+
+	  if (((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
+		&& CLASS_DATA (f->sym)->attr.class_pointer)
+	       || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
+	      && !gfc_check_vardef_context (a->expr, true, false, false, context))
+	    return 0;
+	  if (!gfc_check_vardef_context (a->expr, false, false, false, context))
+	    return 0;
+	}
+
+      if ((f->sym->attr.intent == INTENT_OUT
+	   || f->sym->attr.intent == INTENT_INOUT
+	   || f->sym->attr.volatile_
+	   || f->sym->attr.asynchronous)
+	  && gfc_has_vector_subscript (a->expr))
+	{
+	  if (where)
+	    gfc_error ("Array-section actual argument with vector "
+		       "subscripts at %L is incompatible with INTENT(OUT), "
+		       "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
+		       "of the dummy argument '%s'",
+		       &a->expr->where, f->sym->name);
+	  return 0;
+	}
+
+      /* C1232 (R1221) For an actual argument which is an array section or
+	 an assumed-shape array, the dummy argument shall be an assumed-
+	 shape array, if the dummy argument has the VOLATILE attribute.  */
+
+      if (f->sym->attr.volatile_
+	  && a->expr->symtree->n.sym->as
+	  && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
+	  && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
+	{
+	  if (where)
+	    gfc_error ("Assumed-shape actual argument at %L is "
+		       "incompatible with the non-assumed-shape "
+		       "dummy argument '%s' due to VOLATILE attribute",
+		       &a->expr->where,f->sym->name);
+	  return 0;
+	}
+
+      if (f->sym->attr.volatile_
+	  && a->expr->ref && a->expr->ref->u.ar.type == AR_SECTION
+	  && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
+	{
+	  if (where)
+	    gfc_error ("Array-section actual argument at %L is "
+		       "incompatible with the non-assumed-shape "
+		       "dummy argument '%s' due to VOLATILE attribute",
+		       &a->expr->where,f->sym->name);
+	  return 0;
+	}
+
+      /* C1233 (R1221) For an actual argument which is a pointer array, the
+	 dummy argument shall be an assumed-shape or pointer array, if the
+	 dummy argument has the VOLATILE attribute.  */
+
+      if (f->sym->attr.volatile_
+	  && a->expr->symtree->n.sym->attr.pointer
+	  && a->expr->symtree->n.sym->as
+	  && !(f->sym->as
+	       && (f->sym->as->type == AS_ASSUMED_SHAPE
+		   || f->sym->attr.pointer)))
+	{
+	  if (where)
+	    gfc_error ("Pointer-array actual argument at %L requires "
+		       "an assumed-shape or pointer-array dummy "
+		       "argument '%s' due to VOLATILE attribute",
+		       &a->expr->where,f->sym->name);
+	  return 0;
+	}
+
+    match:
+      if (a == actual)
+	na = i;
+
+      new_arg[i++] = a;
+    }
+
+  /* Make sure missing actual arguments are optional.  */
+  i = 0;
+  for (f = formal; f; f = f->next, i++)
+    {
+      if (new_arg[i] != NULL)
+	continue;
+      if (f->sym == NULL)
+	{
+	  if (where)
+	    gfc_error ("Missing alternate return spec in subroutine call "
+		       "at %L", where);
+	  return 0;
+	}
+      if (!f->sym->attr.optional)
+	{
+	  if (where)
+	    gfc_error ("Missing actual argument for argument '%s' at %L",
+		       f->sym->name, where);
+	  return 0;
+	}
+    }
+
+  /* The argument lists are compatible.  We now relink a new actual
+     argument list with null arguments in the right places.  The head
+     of the list remains the head.  */
+  for (i = 0; i < n; i++)
+    if (new_arg[i] == NULL)
+      new_arg[i] = gfc_get_actual_arglist ();
+
+  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;
+    }
+
+  for (i = 0; i < n - 1; i++)
+    new_arg[i]->next = new_arg[i + 1];
+
+  new_arg[i]->next = NULL;
+
+  if (*ap == NULL && n > 0)
+    *ap = new_arg[0];
+
+  /* Note the types of omitted optional arguments.  */
+  for (a = *ap, f = formal; a; a = a->next, f = f->next)
+    if (a->expr == NULL && a->label == NULL)
+      a->missing_arg_type = f->sym->ts.type;
+
+  return 1;
+}
+
+
+typedef struct
+{
+  gfc_formal_arglist *f;
+  gfc_actual_arglist *a;
+}
+argpair;
+
+/* qsort comparison function for argument pairs, with the following
+   order:
+    - p->a->expr == NULL
+    - p->a->expr->expr_type != EXPR_VARIABLE
+    - growing p->a->expr->symbol.  */
+
+static int
+pair_cmp (const void *p1, const void *p2)
+{
+  const gfc_actual_arglist *a1, *a2;
+
+  /* *p1 and *p2 are elements of the to-be-sorted array.  */
+  a1 = ((const argpair *) p1)->a;
+  a2 = ((const argpair *) p2)->a;
+  if (!a1->expr)
+    {
+      if (!a2->expr)
+	return 0;
+      return -1;
+    }
+  if (!a2->expr)
+    return 1;
+  if (a1->expr->expr_type != EXPR_VARIABLE)
+    {
+      if (a2->expr->expr_type != EXPR_VARIABLE)
+	return 0;
+      return -1;
+    }
+  if (a2->expr->expr_type != EXPR_VARIABLE)
+    return 1;
+  return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
+}
+
+
+/* Given two expressions from some actual arguments, test whether they
+   refer to the same expression. The analysis is conservative.
+   Returning false will produce no warning.  */
+
+static bool
+compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
+{
+  const gfc_ref *r1, *r2;
+
+  if (!e1 || !e2
+      || e1->expr_type != EXPR_VARIABLE
+      || e2->expr_type != EXPR_VARIABLE
+      || e1->symtree->n.sym != e2->symtree->n.sym)
+    return false;
+
+  /* TODO: improve comparison, see expr.c:show_ref().  */
+  for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
+    {
+      if (r1->type != r2->type)
+	return false;
+      switch (r1->type)
+	{
+	case REF_ARRAY:
+	  if (r1->u.ar.type != r2->u.ar.type)
+	    return false;
+	  /* TODO: At the moment, consider only full arrays;
+	     we could do better.  */
+	  if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
+	    return false;
+	  break;
+
+	case REF_COMPONENT:
+	  if (r1->u.c.component != r2->u.c.component)
+	    return false;
+	  break;
+
+	case REF_SUBSTRING:
+	  return false;
+
+	default:
+	  gfc_internal_error ("compare_actual_expr(): Bad component code");
+	}
+    }
+  if (!r1 && !r2)
+    return true;
+  return false;
+}
+
+
+/* Given formal and actual argument lists that correspond to one
+   another, check that identical actual arguments aren't not
+   associated with some incompatible INTENTs.  */
+
+static bool
+check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
+{
+  sym_intent f1_intent, f2_intent;
+  gfc_formal_arglist *f1;
+  gfc_actual_arglist *a1;
+  size_t n, i, j;
+  argpair *p;
+  bool t = true;
+
+  n = 0;
+  for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
+    {
+      if (f1 == NULL && a1 == NULL)
+	break;
+      if (f1 == NULL || a1 == NULL)
+	gfc_internal_error ("check_some_aliasing(): List mismatch");
+      n++;
+    }
+  if (n == 0)
+    return t;
+  p = XALLOCAVEC (argpair, n);
+
+  for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
+    {
+      p[i].f = f1;
+      p[i].a = a1;
+    }
+
+  qsort (p, n, sizeof (argpair), pair_cmp);
+
+  for (i = 0; i < n; i++)
+    {
+      if (!p[i].a->expr
+	  || p[i].a->expr->expr_type != EXPR_VARIABLE
+	  || p[i].a->expr->ts.type == BT_PROCEDURE)
+	continue;
+      f1_intent = p[i].f->sym->attr.intent;
+      for (j = i + 1; j < n; j++)
+	{
+	  /* Expected order after the sort.  */
+	  if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
+	    gfc_internal_error ("check_some_aliasing(): corrupted data");
+
+	  /* Are the expression the same?  */
+	  if (!compare_actual_expr (p[i].a->expr, p[j].a->expr))
+	    break;
+	  f2_intent = p[j].f->sym->attr.intent;
+	  if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
+	      || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN)
+	      || (f1_intent == INTENT_OUT && f2_intent == INTENT_OUT))
+	    {
+	      gfc_warning ("Same actual argument associated with INTENT(%s) "
+			   "argument '%s' and INTENT(%s) argument '%s' at %L",
+			   gfc_intent_string (f1_intent), p[i].f->sym->name,
+			   gfc_intent_string (f2_intent), p[j].f->sym->name,
+			   &p[i].a->expr->where);
+	      t = false;
+	    }
+	}
+    }
+
+  return t;
+}
+
+
+/* Given formal and actual argument lists that correspond to one
+   another, check that they are compatible in the sense that intents
+   are not mismatched.  */
+
+static bool
+check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
+{
+  sym_intent f_intent;
+
+  for (;; f = f->next, a = a->next)
+    {
+      if (f == NULL && a == NULL)
+	break;
+      if (f == NULL || a == NULL)
+	gfc_internal_error ("check_intents(): List mismatch");
+
+      if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
+	continue;
+
+      f_intent = f->sym->attr.intent;
+
+      if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
+	{
+	  if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
+	       && CLASS_DATA (f->sym)->attr.class_pointer)
+	      || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
+	    {
+	      gfc_error ("Procedure argument at %L is local to a PURE "
+			 "procedure and has the POINTER attribute",
+			 &a->expr->where);
+	      return false;
+	    }
+	}
+
+       /* Fortran 2008, C1283.  */
+       if (gfc_pure (NULL) && gfc_is_coindexed (a->expr))
+	{
+	  if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
+	    {
+	      gfc_error ("Coindexed actual argument at %L in PURE procedure "
+			 "is passed to an INTENT(%s) argument",
+			 &a->expr->where, gfc_intent_string (f_intent));
+	      return false;
+	    }
+
+	  if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
+               && CLASS_DATA (f->sym)->attr.class_pointer)
+              || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
+	    {
+	      gfc_error ("Coindexed actual argument at %L in PURE procedure "
+			 "is passed to a POINTER dummy argument",
+			 &a->expr->where);
+	      return false;
+	    }
+	}
+
+       /* F2008, Section 12.5.2.4.  */
+       if (a->expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS
+	   && gfc_is_coindexed (a->expr))
+	 {
+	   gfc_error ("Coindexed polymorphic actual argument at %L is passed "
+		      "polymorphic dummy argument '%s'",
+			 &a->expr->where, f->sym->name);
+	   return false;
+	 }
+    }
+
+  return true;
+}
+
+
+/* Check how a procedure is used against its interface.  If all goes
+   well, the actual argument list will also end up being properly
+   sorted.  */
+
+bool
+gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
+{
+  gfc_formal_arglist *dummy_args;
+
+  /* Warn about calls with an implicit interface.  Special case
+     for calling a ISO_C_BINDING because c_loc and c_funloc
+     are pseudo-unknown.  Additionally, warn about procedures not
+     explicitly declared at all if requested.  */
+  if (sym->attr.if_source == IFSRC_UNKNOWN && ! sym->attr.is_iso_c)
+    {
+      if (gfc_option.warn_implicit_interface)
+	gfc_warning ("Procedure '%s' called with an implicit interface at %L",
+		     sym->name, where);
+      else if (gfc_option.warn_implicit_procedure
+	       && sym->attr.proc == PROC_UNKNOWN)
+	gfc_warning ("Procedure '%s' called at %L is not explicitly declared",
+		     sym->name, where);
+    }
+
+  if (sym->attr.if_source == IFSRC_UNKNOWN)
+    {
+      gfc_actual_arglist *a;
+
+      if (sym->attr.pointer)
+	{
+	  gfc_error("The pointer object '%s' at %L must have an explicit "
+		    "function interface or be declared as array",
+		    sym->name, where);
+	  return false;
+	}
+
+      if (sym->attr.allocatable && !sym->attr.external)
+	{
+	  gfc_error("The allocatable object '%s' at %L must have an explicit "
+		    "function interface or be declared as array",
+		    sym->name, where);
+	  return false;
+	}
+
+      if (sym->attr.allocatable)
+	{
+	  gfc_error("Allocatable function '%s' at %L must have an explicit "
+		    "function interface", sym->name, where);
+	  return false;
+	}
+
+      for (a = *ap; a; a = a->next)
+	{
+	  /* Skip g77 keyword extensions like %VAL, %REF, %LOC.  */
+	  if (a->name != NULL && a->name[0] != '%')
+	    {
+	      gfc_error("Keyword argument requires explicit interface "
+			"for procedure '%s' at %L", sym->name, &a->expr->where);
+	      break;
+	    }
+
+	  /* TS 29113, 6.2.  */
+	  if (a->expr && a->expr->ts.type == BT_ASSUMED
+	      && sym->intmod_sym_id != ISOCBINDING_LOC)
+	    {
+	      gfc_error ("Assumed-type argument %s at %L requires an explicit "
+			 "interface", a->expr->symtree->n.sym->name,
+			 &a->expr->where);
+	      break;
+	    }
+
+	  /* F2008, C1303 and C1304.  */
+	  if (a->expr
+	      && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS)
+	      && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+		   && a->expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
+		  || gfc_expr_attr (a->expr).lock_comp))
+	    {
+	      gfc_error("Actual argument of LOCK_TYPE or with LOCK_TYPE "
+			"component at %L requires an explicit interface for "
+			"procedure '%s'", &a->expr->where, sym->name);
+	      break;
+	    }
+
+	  if (a->expr && a->expr->expr_type == EXPR_NULL
+	      && a->expr->ts.type == BT_UNKNOWN)
+	    {
+	      gfc_error ("MOLD argument to NULL required at %L", &a->expr->where);
+	      return false;
+	    }
+
+	  /* TS 29113, C407b.  */
+	  if (a->expr && a->expr->expr_type == EXPR_VARIABLE
+	      && symbol_rank (a->expr->symtree->n.sym) == -1)
+	    {
+	      gfc_error ("Assumed-rank argument requires an explicit interface "
+			 "at %L", &a->expr->where);
+	      return false;
+	    }
+	}
+
+      return true;
+    }
+
+  dummy_args = gfc_sym_get_dummy_args (sym);
+
+  if (!compare_actual_formal (ap, dummy_args, 0, sym->attr.elemental, where))
+    return false;
+
+  if (!check_intents (dummy_args, *ap))
+    return false;
+
+  if (gfc_option.warn_aliasing)
+    check_some_aliasing (dummy_args, *ap);
+
+  return true;
+}
+
+
+/* Check how a procedure pointer component is used against its interface.
+   If all goes well, the actual argument list will also end up being properly
+   sorted. Completely analogous to gfc_procedure_use.  */
+
+void
+gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where)
+{
+  /* Warn about calls with an implicit interface.  Special case
+     for calling a ISO_C_BINDING because c_loc and c_funloc
+     are pseudo-unknown.  */
+  if (gfc_option.warn_implicit_interface
+      && comp->attr.if_source == IFSRC_UNKNOWN
+      && !comp->attr.is_iso_c)
+    gfc_warning ("Procedure pointer component '%s' called with an implicit "
+		 "interface at %L", comp->name, where);
+
+  if (comp->attr.if_source == IFSRC_UNKNOWN)
+    {
+      gfc_actual_arglist *a;
+      for (a = *ap; a; a = a->next)
+	{
+	  /* Skip g77 keyword extensions like %VAL, %REF, %LOC.  */
+	  if (a->name != NULL && a->name[0] != '%')
+	    {
+	      gfc_error("Keyword argument requires explicit interface "
+			"for procedure pointer component '%s' at %L",
+			comp->name, &a->expr->where);
+	      break;
+	    }
+	}
+
+      return;
+    }
+
+  if (!compare_actual_formal (ap, comp->ts.interface->formal, 0,
+			      comp->attr.elemental, where))
+    return;
+
+  check_intents (comp->ts.interface->formal, *ap);
+  if (gfc_option.warn_aliasing)
+    check_some_aliasing (comp->ts.interface->formal, *ap);
+}
+
+
+/* Try if an actual argument list matches the formal list of a symbol,
+   respecting the symbol's attributes like ELEMENTAL.  This is used for
+   GENERIC resolution.  */
+
+bool
+gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym)
+{
+  gfc_formal_arglist *dummy_args;
+  bool r;
+
+  gcc_assert (sym->attr.flavor == FL_PROCEDURE);
+
+  dummy_args = gfc_sym_get_dummy_args (sym);
+
+  r = !sym->attr.elemental;
+  if (compare_actual_formal (args, dummy_args, r, !r, NULL))
+    {
+      check_intents (dummy_args, *args);
+      if (gfc_option.warn_aliasing)
+	check_some_aliasing (dummy_args, *args);
+      return true;
+    }
+
+  return false;
+}
+
+
+/* Given an interface pointer and an actual argument list, search for
+   a formal argument list that matches the actual.  If found, returns
+   a pointer to the symbol of the correct interface.  Returns NULL if
+   not found.  */
+
+gfc_symbol *
+gfc_search_interface (gfc_interface *intr, int sub_flag,
+		      gfc_actual_arglist **ap)
+{
+  gfc_symbol *elem_sym = NULL;
+  gfc_symbol *null_sym = NULL;
+  locus null_expr_loc;
+  gfc_actual_arglist *a;
+  bool has_null_arg = false;
+
+  for (a = *ap; a; a = a->next)
+    if (a->expr && a->expr->expr_type == EXPR_NULL
+	&& a->expr->ts.type == BT_UNKNOWN)
+      {
+	has_null_arg = true;
+	null_expr_loc = a->expr->where;
+	break;
+      }
+
+  for (; intr; intr = intr->next)
+    {
+      if (intr->sym->attr.flavor == FL_DERIVED)
+	continue;
+      if (sub_flag && intr->sym->attr.function)
+	continue;
+      if (!sub_flag && intr->sym->attr.subroutine)
+	continue;
+
+      if (gfc_arglist_matches_symbol (ap, intr->sym))
+	{
+	  if (has_null_arg && null_sym)
+	    {
+	      gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
+			 "between specific functions %s and %s",
+			 &null_expr_loc, null_sym->name, intr->sym->name);
+	      return NULL;
+	    }
+	  else if (has_null_arg)
+	    {
+	      null_sym = intr->sym;
+	      continue;
+	    }
+
+	  /* Satisfy 12.4.4.1 such that an elemental match has lower
+	     weight than a non-elemental match.  */
+	  if (intr->sym->attr.elemental)
+	    {
+	      elem_sym = intr->sym;
+	      continue;
+	    }
+	  return intr->sym;
+	}
+    }
+
+  if (null_sym)
+    return null_sym;
+
+  return elem_sym ? elem_sym : NULL;
+}
+
+
+/* Do a brute force recursive search for a symbol.  */
+
+static gfc_symtree *
+find_symtree0 (gfc_symtree *root, gfc_symbol *sym)
+{
+  gfc_symtree * st;
+
+  if (root->n.sym == sym)
+    return root;
+
+  st = NULL;
+  if (root->left)
+    st = find_symtree0 (root->left, sym);
+  if (root->right && ! st)
+    st = find_symtree0 (root->right, sym);
+  return st;
+}
+
+
+/* Find a symtree for a symbol.  */
+
+gfc_symtree *
+gfc_find_sym_in_symtree (gfc_symbol *sym)
+{
+  gfc_symtree *st;
+  gfc_namespace *ns;
+
+  /* First try to find it by name.  */
+  gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
+  if (st && st->n.sym == sym)
+    return st;
+
+  /* If it's been renamed, resort to a brute-force search.  */
+  /* TODO: avoid having to do this search.  If the symbol doesn't exist
+     in the symtree for the current namespace, it should probably be added.  */
+  for (ns = gfc_current_ns; ns; ns = ns->parent)
+    {
+      st = find_symtree0 (ns->sym_root, sym);
+      if (st)
+	return st;
+    }
+  gfc_internal_error ("Unable to find symbol %s", sym->name);
+  /* Not reached.  */
+}
+
+
+/* See if the arglist to an operator-call contains a derived-type argument
+   with a matching type-bound operator.  If so, return the matching specific
+   procedure defined as operator-target as well as the base-object to use
+   (which is the found derived-type argument with operator).  The generic
+   name, if any, is transmitted to the final expression via 'gname'.  */
+
+static gfc_typebound_proc*
+matching_typebound_op (gfc_expr** tb_base,
+		       gfc_actual_arglist* args,
+		       gfc_intrinsic_op op, const char* uop,
+		       const char ** gname)
+{
+  gfc_actual_arglist* base;
+
+  for (base = args; base; base = base->next)
+    if (base->expr->ts.type == BT_DERIVED || base->expr->ts.type == BT_CLASS)
+      {
+	gfc_typebound_proc* tb;
+	gfc_symbol* derived;
+	bool result;
+
+	while (base->expr->expr_type == EXPR_OP
+	       && base->expr->value.op.op == INTRINSIC_PARENTHESES)
+	  base->expr = base->expr->value.op.op1;
+
+	if (base->expr->ts.type == BT_CLASS)
+	  {
+	    if (CLASS_DATA (base->expr) == NULL
+		|| !gfc_expr_attr (base->expr).class_ok)
+	      continue;
+	    derived = CLASS_DATA (base->expr)->ts.u.derived;
+	  }
+	else
+	  derived = base->expr->ts.u.derived;
+
+	if (op == INTRINSIC_USER)
+	  {
+	    gfc_symtree* tb_uop;
+
+	    gcc_assert (uop);
+	    tb_uop = gfc_find_typebound_user_op (derived, &result, uop,
+						 false, NULL);
+
+	    if (tb_uop)
+	      tb = tb_uop->n.tb;
+	    else
+	      tb = NULL;
+	  }
+	else
+	  tb = gfc_find_typebound_intrinsic_op (derived, &result, op,
+						false, NULL);
+
+	/* This means we hit a PRIVATE operator which is use-associated and
+	   should thus not be seen.  */
+	if (!result)
+	  tb = NULL;
+
+	/* Look through the super-type hierarchy for a matching specific
+	   binding.  */
+	for (; tb; tb = tb->overridden)
+	  {
+	    gfc_tbp_generic* g;
+
+	    gcc_assert (tb->is_generic);
+	    for (g = tb->u.generic; g; g = g->next)
+	      {
+		gfc_symbol* target;
+		gfc_actual_arglist* argcopy;
+		bool matches;
+
+		gcc_assert (g->specific);
+		if (g->specific->error)
+		  continue;
+
+		target = g->specific->u.specific->n.sym;
+
+		/* Check if this arglist matches the formal.  */
+		argcopy = gfc_copy_actual_arglist (args);
+		matches = gfc_arglist_matches_symbol (&argcopy, target);
+		gfc_free_actual_arglist (argcopy);
+
+		/* Return if we found a match.  */
+		if (matches)
+		  {
+		    *tb_base = base->expr;
+		    *gname = g->specific_st->name;
+		    return g->specific;
+		  }
+	      }
+	  }
+      }
+
+  return NULL;
+}
+
+
+/* For the 'actual arglist' of an operator call and a specific typebound
+   procedure that has been found the target of a type-bound operator, build the
+   appropriate EXPR_COMPCALL and resolve it.  We take this indirection over
+   type-bound procedures rather than resolving type-bound operators 'directly'
+   so that we can reuse the existing logic.  */
+
+static void
+build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
+			     gfc_expr* base, gfc_typebound_proc* target,
+			     const char *gname)
+{
+  e->expr_type = EXPR_COMPCALL;
+  e->value.compcall.tbp = target;
+  e->value.compcall.name = gname ? gname : "$op";
+  e->value.compcall.actual = actual;
+  e->value.compcall.base_object = base;
+  e->value.compcall.ignore_pass = 1;
+  e->value.compcall.assign = 0;
+  if (e->ts.type == BT_UNKNOWN
+	&& target->function)
+    {
+      if (target->is_generic)
+	e->ts = target->u.generic->specific->u.specific->n.sym->ts;
+      else
+	e->ts = target->u.specific->n.sym->ts;
+    }
+}
+
+
+/* This subroutine is called when an expression is being resolved.
+   The expression node in question is either a user defined operator
+   or an intrinsic operator with arguments that aren't compatible
+   with the operator.  This subroutine builds an actual argument list
+   corresponding to the operands, then searches for a compatible
+   interface.  If one is found, the expression node is replaced with
+   the appropriate function call. We use the 'match' enum to specify
+   whether a replacement has been made or not, or if an error occurred.  */
+
+match
+gfc_extend_expr (gfc_expr *e)
+{
+  gfc_actual_arglist *actual;
+  gfc_symbol *sym;
+  gfc_namespace *ns;
+  gfc_user_op *uop;
+  gfc_intrinsic_op i;
+  const char *gname;
+
+  sym = NULL;
+
+  actual = gfc_get_actual_arglist ();
+  actual->expr = e->value.op.op1;
+
+  gname = NULL;
+
+  if (e->value.op.op2 != NULL)
+    {
+      actual->next = gfc_get_actual_arglist ();
+      actual->next->expr = e->value.op.op2;
+    }
+
+  i = fold_unary_intrinsic (e->value.op.op);
+
+  if (i == INTRINSIC_USER)
+    {
+      for (ns = gfc_current_ns; ns; ns = ns->parent)
+	{
+	  uop = gfc_find_uop (e->value.op.uop->name, ns);
+	  if (uop == NULL)
+	    continue;
+
+	  sym = gfc_search_interface (uop->op, 0, &actual);
+	  if (sym != NULL)
+	    break;
+	}
+    }
+  else
+    {
+      for (ns = gfc_current_ns; ns; ns = ns->parent)
+	{
+	  /* Due to the distinction between '==' and '.eq.' and friends, one has
+	     to check if either is defined.  */
+	  switch (i)
+	    {
+#define CHECK_OS_COMPARISON(comp) \
+  case INTRINSIC_##comp: \
+  case INTRINSIC_##comp##_OS: \
+    sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
+    if (!sym) \
+      sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
+    break;
+	      CHECK_OS_COMPARISON(EQ)
+	      CHECK_OS_COMPARISON(NE)
+	      CHECK_OS_COMPARISON(GT)
+	      CHECK_OS_COMPARISON(GE)
+	      CHECK_OS_COMPARISON(LT)
+	      CHECK_OS_COMPARISON(LE)
+#undef CHECK_OS_COMPARISON
+
+	      default:
+		sym = gfc_search_interface (ns->op[i], 0, &actual);
+	    }
+
+	  if (sym != NULL)
+	    break;
+	}
+    }
+
+  /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
+     found rather than just taking the first one and not checking further.  */
+
+  if (sym == NULL)
+    {
+      gfc_typebound_proc* tbo;
+      gfc_expr* tb_base;
+
+      /* See if we find a matching type-bound operator.  */
+      if (i == INTRINSIC_USER)
+	tbo = matching_typebound_op (&tb_base, actual,
+				     i, e->value.op.uop->name, &gname);
+      else
+	switch (i)
+	  {
+#define CHECK_OS_COMPARISON(comp) \
+  case INTRINSIC_##comp: \
+  case INTRINSIC_##comp##_OS: \
+    tbo = matching_typebound_op (&tb_base, actual, \
+				 INTRINSIC_##comp, NULL, &gname); \
+    if (!tbo) \
+      tbo = matching_typebound_op (&tb_base, actual, \
+				   INTRINSIC_##comp##_OS, NULL, &gname); \
+    break;
+	    CHECK_OS_COMPARISON(EQ)
+	    CHECK_OS_COMPARISON(NE)
+	    CHECK_OS_COMPARISON(GT)
+	    CHECK_OS_COMPARISON(GE)
+	    CHECK_OS_COMPARISON(LT)
+	    CHECK_OS_COMPARISON(LE)
+#undef CHECK_OS_COMPARISON
+
+	    default:
+	      tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname);
+	      break;
+	  }
+
+      /* If there is a matching typebound-operator, replace the expression with
+	 a call to it and succeed.  */
+      if (tbo)
+	{
+	  bool result;
+
+	  gcc_assert (tb_base);
+	  build_compcall_for_operator (e, actual, tb_base, tbo, gname);
+
+	  result = gfc_resolve_expr (e);
+	  if (!result)
+	    return MATCH_ERROR;
+
+	  return MATCH_YES;
+	}
+
+      /* Don't use gfc_free_actual_arglist().  */
+      free (actual->next);
+      free (actual);
+
+      return MATCH_NO;
+    }
+
+  /* Change the expression node to a function call.  */
+  e->expr_type = EXPR_FUNCTION;
+  e->symtree = gfc_find_sym_in_symtree (sym);
+  e->value.function.actual = actual;
+  e->value.function.esym = NULL;
+  e->value.function.isym = NULL;
+  e->value.function.name = NULL;
+  e->user_operator = 1;
+
+  if (!gfc_resolve_expr (e))
+    return MATCH_ERROR;
+
+  return MATCH_YES;
+}
+
+
+/* Tries to replace an assignment code node with a subroutine call to the
+   subroutine associated with the assignment operator. Return true if the node
+   was replaced. On false, no error is generated.  */
+
+bool
+gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
+{
+  gfc_actual_arglist *actual;
+  gfc_expr *lhs, *rhs, *tb_base;
+  gfc_symbol *sym = NULL;
+  const char *gname = NULL;
+  gfc_typebound_proc* tbo;
+
+  lhs = c->expr1;
+  rhs = c->expr2;
+
+  /* Don't allow an intrinsic assignment to be replaced.  */
+  if (lhs->ts.type != BT_DERIVED && lhs->ts.type != BT_CLASS
+      && (rhs->rank == 0 || rhs->rank == lhs->rank)
+      && (lhs->ts.type == rhs->ts.type
+	  || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
+    return false;
+
+  actual = gfc_get_actual_arglist ();
+  actual->expr = lhs;
+
+  actual->next = gfc_get_actual_arglist ();
+  actual->next->expr = rhs;
+
+  /* TODO: Ambiguity-check, see above for gfc_extend_expr.  */
+
+  /* See if we find a matching type-bound assignment.  */
+  tbo = matching_typebound_op (&tb_base, actual, INTRINSIC_ASSIGN,
+			       NULL, &gname);
+
+  if (tbo)
+    {
+      /* Success: Replace the expression with a type-bound call.  */
+      gcc_assert (tb_base);
+      c->expr1 = gfc_get_expr ();
+      build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname);
+      c->expr1->value.compcall.assign = 1;
+      c->expr1->where = c->loc;
+      c->expr2 = NULL;
+      c->op = EXEC_COMPCALL;
+      return true;
+    }
+
+  /* See if we find an 'ordinary' (non-typebound) assignment procedure.  */
+  for (; ns; ns = ns->parent)
+    {
+      sym = gfc_search_interface (ns->op[INTRINSIC_ASSIGN], 1, &actual);
+      if (sym != NULL)
+	break;
+    }
+
+  if (sym)
+    {
+      /* Success: Replace the assignment with the call.  */
+      c->op = EXEC_ASSIGN_CALL;
+      c->symtree = gfc_find_sym_in_symtree (sym);
+      c->expr1 = NULL;
+      c->expr2 = NULL;
+      c->ext.actual = actual;
+      return true;
+    }
+
+  /* Failure: No assignment procedure found.  */
+  free (actual->next);
+  free (actual);
+  return false;
+}
+
+
+/* Make sure that the interface just parsed is not already present in
+   the given interface list.  Ambiguity isn't checked yet since module
+   procedures can be present without interfaces.  */
+
+bool
+gfc_check_new_interface (gfc_interface *base, gfc_symbol *new_sym, locus loc)
+{
+  gfc_interface *ip;
+
+  for (ip = base; ip; ip = ip->next)
+    {
+      if (ip->sym == new_sym)
+	{
+	  gfc_error ("Entity '%s' at %L is already present in the interface",
+		     new_sym->name, &loc);
+	  return false;
+	}
+    }
+
+  return true;
+}
+
+
+/* Add a symbol to the current interface.  */
+
+bool
+gfc_add_interface (gfc_symbol *new_sym)
+{
+  gfc_interface **head, *intr;
+  gfc_namespace *ns;
+  gfc_symbol *sym;
+
+  switch (current_interface.type)
+    {
+    case INTERFACE_NAMELESS:
+    case INTERFACE_ABSTRACT:
+      return true;
+
+    case INTERFACE_INTRINSIC_OP:
+      for (ns = current_interface.ns; ns; ns = ns->parent)
+	switch (current_interface.op)
+	  {
+	    case INTRINSIC_EQ:
+	    case INTRINSIC_EQ_OS:
+	      if (!gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym, 
+					    gfc_current_locus)
+	          || !gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS], 
+					       new_sym, gfc_current_locus))
+		return false;
+	      break;
+
+	    case INTRINSIC_NE:
+	    case INTRINSIC_NE_OS:
+	      if (!gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym, 
+					    gfc_current_locus)
+	          || !gfc_check_new_interface (ns->op[INTRINSIC_NE_OS], 
+					       new_sym, gfc_current_locus))
+		return false;
+	      break;
+
+	    case INTRINSIC_GT:
+	    case INTRINSIC_GT_OS:
+	      if (!gfc_check_new_interface (ns->op[INTRINSIC_GT], 
+					    new_sym, gfc_current_locus)
+	          || !gfc_check_new_interface (ns->op[INTRINSIC_GT_OS], 
+					       new_sym, gfc_current_locus))
+		return false;
+	      break;
+
+	    case INTRINSIC_GE:
+	    case INTRINSIC_GE_OS:
+	      if (!gfc_check_new_interface (ns->op[INTRINSIC_GE], 
+					    new_sym, gfc_current_locus)
+	          || !gfc_check_new_interface (ns->op[INTRINSIC_GE_OS], 
+					       new_sym, gfc_current_locus))
+		return false;
+	      break;
+
+	    case INTRINSIC_LT:
+	    case INTRINSIC_LT_OS:
+	      if (!gfc_check_new_interface (ns->op[INTRINSIC_LT], 
+					    new_sym, gfc_current_locus)
+	          || !gfc_check_new_interface (ns->op[INTRINSIC_LT_OS], 
+					       new_sym, gfc_current_locus))
+		return false;
+	      break;
+
+	    case INTRINSIC_LE:
+	    case INTRINSIC_LE_OS:
+	      if (!gfc_check_new_interface (ns->op[INTRINSIC_LE], 
+					    new_sym, gfc_current_locus)
+	          || !gfc_check_new_interface (ns->op[INTRINSIC_LE_OS], 
+					       new_sym, gfc_current_locus))
+		return false;
+	      break;
+
+	    default:
+	      if (!gfc_check_new_interface (ns->op[current_interface.op], 
+					    new_sym, gfc_current_locus))
+		return false;
+	  }
+
+      head = &current_interface.ns->op[current_interface.op];
+      break;
+
+    case INTERFACE_GENERIC:
+      for (ns = current_interface.ns; ns; ns = ns->parent)
+	{
+	  gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
+	  if (sym == NULL)
+	    continue;
+
+	  if (!gfc_check_new_interface (sym->generic, 
+					new_sym, gfc_current_locus))
+	    return false;
+	}
+
+      head = &current_interface.sym->generic;
+      break;
+
+    case INTERFACE_USER_OP:
+      if (!gfc_check_new_interface (current_interface.uop->op, 
+				    new_sym, gfc_current_locus))
+	return false;
+
+      head = &current_interface.uop->op;
+      break;
+
+    default:
+      gfc_internal_error ("gfc_add_interface(): Bad interface type");
+    }
+
+  intr = gfc_get_interface ();
+  intr->sym = new_sym;
+  intr->where = gfc_current_locus;
+
+  intr->next = *head;
+  *head = intr;
+
+  return true;
+}
+
+
+gfc_interface *
+gfc_current_interface_head (void)
+{
+  switch (current_interface.type)
+    {
+      case INTERFACE_INTRINSIC_OP:
+	return current_interface.ns->op[current_interface.op];
+	break;
+
+      case INTERFACE_GENERIC:
+	return current_interface.sym->generic;
+	break;
+
+      case INTERFACE_USER_OP:
+	return current_interface.uop->op;
+	break;
+
+      default:
+	gcc_unreachable ();
+    }
+}
+
+
+void
+gfc_set_current_interface_head (gfc_interface *i)
+{
+  switch (current_interface.type)
+    {
+      case INTERFACE_INTRINSIC_OP:
+	current_interface.ns->op[current_interface.op] = i;
+	break;
+
+      case INTERFACE_GENERIC:
+	current_interface.sym->generic = i;
+	break;
+
+      case INTERFACE_USER_OP:
+	current_interface.uop->op = i;
+	break;
+
+      default:
+	gcc_unreachable ();
+    }
+}
+
+
+/* Gets rid of a formal argument list.  We do not free symbols.
+   Symbols are freed when a namespace is freed.  */
+
+void
+gfc_free_formal_arglist (gfc_formal_arglist *p)
+{
+  gfc_formal_arglist *q;
+
+  for (; p; p = q)
+    {
+      q = p->next;
+      free (p);
+    }
+}
+
+
+/* Check that it is ok for the type-bound procedure 'proc' to override the
+   procedure 'old', cf. F08:4.5.7.3.  */
+
+bool
+gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
+{
+  locus where;
+  gfc_symbol *proc_target, *old_target;
+  unsigned proc_pass_arg, old_pass_arg, argpos;
+  gfc_formal_arglist *proc_formal, *old_formal;
+  bool check_type;
+  char err[200];
+
+  /* This procedure should only be called for non-GENERIC proc.  */
+  gcc_assert (!proc->n.tb->is_generic);
+
+  /* If the overwritten procedure is GENERIC, this is an error.  */
+  if (old->n.tb->is_generic)
+    {
+      gfc_error ("Can't overwrite GENERIC '%s' at %L",
+		 old->name, &proc->n.tb->where);
+      return false;
+    }
+
+  where = proc->n.tb->where;
+  proc_target = proc->n.tb->u.specific->n.sym;
+  old_target = old->n.tb->u.specific->n.sym;
+
+  /* Check that overridden binding is not NON_OVERRIDABLE.  */
+  if (old->n.tb->non_overridable)
+    {
+      gfc_error ("'%s' at %L overrides a procedure binding declared"
+		 " NON_OVERRIDABLE", proc->name, &where);
+      return false;
+    }
+
+  /* It's an error to override a non-DEFERRED procedure with a DEFERRED one.  */
+  if (!old->n.tb->deferred && proc->n.tb->deferred)
+    {
+      gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
+		 " non-DEFERRED binding", proc->name, &where);
+      return false;
+    }
+
+  /* If the overridden binding is PURE, the overriding must be, too.  */
+  if (old_target->attr.pure && !proc_target->attr.pure)
+    {
+      gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
+		 proc->name, &where);
+      return false;
+    }
+
+  /* If the overridden binding is ELEMENTAL, the overriding must be, too.  If it
+     is not, the overriding must not be either.  */
+  if (old_target->attr.elemental && !proc_target->attr.elemental)
+    {
+      gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
+		 " ELEMENTAL", proc->name, &where);
+      return false;
+    }
+  if (!old_target->attr.elemental && proc_target->attr.elemental)
+    {
+      gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
+		 " be ELEMENTAL, either", proc->name, &where);
+      return false;
+    }
+
+  /* If the overridden binding is a SUBROUTINE, the overriding must also be a
+     SUBROUTINE.  */
+  if (old_target->attr.subroutine && !proc_target->attr.subroutine)
+    {
+      gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
+		 " SUBROUTINE", proc->name, &where);
+      return false;
+    }
+
+  /* If the overridden binding is a FUNCTION, the overriding must also be a
+     FUNCTION and have the same characteristics.  */
+  if (old_target->attr.function)
+    {
+      if (!proc_target->attr.function)
+	{
+	  gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
+		     " FUNCTION", proc->name, &where);
+	  return false;
+	}
+
+      if (!check_result_characteristics (proc_target, old_target, err, 
+					 sizeof(err)))
+	{
+	  gfc_error ("Result mismatch for the overriding procedure "
+		     "'%s' at %L: %s", proc->name, &where, err);
+	  return false;
+	}
+    }
+
+  /* If the overridden binding is PUBLIC, the overriding one must not be
+     PRIVATE.  */
+  if (old->n.tb->access == ACCESS_PUBLIC
+      && proc->n.tb->access == ACCESS_PRIVATE)
+    {
+      gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
+		 " PRIVATE", proc->name, &where);
+      return false;
+    }
+
+  /* Compare the formal argument lists of both procedures.  This is also abused
+     to find the position of the passed-object dummy arguments of both
+     bindings as at least the overridden one might not yet be resolved and we
+     need those positions in the check below.  */
+  proc_pass_arg = old_pass_arg = 0;
+  if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
+    proc_pass_arg = 1;
+  if (!old->n.tb->nopass && !old->n.tb->pass_arg)
+    old_pass_arg = 1;
+  argpos = 1;
+  proc_formal = gfc_sym_get_dummy_args (proc_target);
+  old_formal = gfc_sym_get_dummy_args (old_target);
+  for ( ; proc_formal && old_formal;
+       proc_formal = proc_formal->next, old_formal = old_formal->next)
+    {
+      if (proc->n.tb->pass_arg
+	  && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
+	proc_pass_arg = argpos;
+      if (old->n.tb->pass_arg
+	  && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
+	old_pass_arg = argpos;
+
+      /* Check that the names correspond.  */
+      if (strcmp (proc_formal->sym->name, old_formal->sym->name))
+	{
+	  gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
+		     " to match the corresponding argument of the overridden"
+		     " procedure", proc_formal->sym->name, proc->name, &where,
+		     old_formal->sym->name);
+	  return false;
+	}
+
+      check_type = proc_pass_arg != argpos && old_pass_arg != argpos;
+      if (!check_dummy_characteristics (proc_formal->sym, old_formal->sym, 
+					check_type, err, sizeof(err)))
+	{
+	  gfc_error ("Argument mismatch for the overriding procedure "
+		     "'%s' at %L: %s", proc->name, &where, err);
+	  return false;
+	}
+
+      ++argpos;
+    }
+  if (proc_formal || old_formal)
+    {
+      gfc_error ("'%s' at %L must have the same number of formal arguments as"
+		 " the overridden procedure", proc->name, &where);
+      return false;
+    }
+
+  /* If the overridden binding is NOPASS, the overriding one must also be
+     NOPASS.  */
+  if (old->n.tb->nopass && !proc->n.tb->nopass)
+    {
+      gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
+		 " NOPASS", proc->name, &where);
+      return false;
+    }
+
+  /* If the overridden binding is PASS(x), the overriding one must also be
+     PASS and the passed-object dummy arguments must correspond.  */
+  if (!old->n.tb->nopass)
+    {
+      if (proc->n.tb->nopass)
+	{
+	  gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
+		     " PASS", proc->name, &where);
+	  return false;
+	}
+
+      if (proc_pass_arg != old_pass_arg)
+	{
+	  gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
+		     " the same position as the passed-object dummy argument of"
+		     " the overridden procedure", proc->name, &where);
+	  return false;
+	}
+    }
+
+  return true;
+}
diff --git a/gcc-4.9/gcc/fortran/intrinsic.c b/gcc-4.9/gcc/fortran/intrinsic.c
new file mode 100644
index 000000000..19d46202e
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/intrinsic.c
@@ -0,0 +1,4701 @@
+/* Build up a list of intrinsic subroutines and functions for the
+   name-resolution stage.
+   Copyright (C) 2000-2014 Free Software Foundation, Inc.
+   Contributed by Andy Vaught & Katherine Holcomb
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "flags.h"
+#include "gfortran.h"
+#include "intrinsic.h"
+
+/* Namespace to hold the resolved symbols for intrinsic subroutines.  */
+static gfc_namespace *gfc_intrinsic_namespace;
+
+bool gfc_init_expr_flag = false;
+
+/* Pointers to an intrinsic function and its argument names that are being
+   checked.  */
+
+const char *gfc_current_intrinsic;
+gfc_intrinsic_arg *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS];
+locus *gfc_current_intrinsic_where;
+
+static gfc_intrinsic_sym *functions, *subroutines, *conversion, *next_sym;
+static gfc_intrinsic_sym *char_conversions;
+static gfc_intrinsic_arg *next_arg;
+
+static int nfunc, nsub, nargs, nconv, ncharconv;
+
+static enum
+{ SZ_NOTHING = 0, SZ_SUBS, SZ_FUNCS, SZ_CONVS }
+sizing;
+
+enum klass
+{ CLASS_IMPURE = 0, CLASS_PURE, CLASS_ELEMENTAL,
+  CLASS_INQUIRY, CLASS_TRANSFORMATIONAL, CLASS_ATOMIC };
+
+#define ACTUAL_NO	0
+#define ACTUAL_YES	1
+
+#define REQUIRED	0
+#define OPTIONAL	1
+
+
+/* Return a letter based on the passed type.  Used to construct the
+   name of a type-dependent subroutine.  */
+
+char
+gfc_type_letter (bt type)
+{
+  char c;
+
+  switch (type)
+    {
+    case BT_LOGICAL:
+      c = 'l';
+      break;
+    case BT_CHARACTER:
+      c = 's';
+      break;
+    case BT_INTEGER:
+      c = 'i';
+      break;
+    case BT_REAL:
+      c = 'r';
+      break;
+    case BT_COMPLEX:
+      c = 'c';
+      break;
+
+    case BT_HOLLERITH:
+      c = 'h';
+      break;
+
+    default:
+      c = 'u';
+      break;
+    }
+
+  return c;
+}
+
+
+/* Get a symbol for a resolved name. Note, if needed be, the elemental
+   attribute has be added afterwards.  */
+
+gfc_symbol *
+gfc_get_intrinsic_sub_symbol (const char *name)
+{
+  gfc_symbol *sym;
+
+  gfc_get_symbol (name, gfc_intrinsic_namespace, &sym);
+  sym->attr.always_explicit = 1;
+  sym->attr.subroutine = 1;
+  sym->attr.flavor = FL_PROCEDURE;
+  sym->attr.proc = PROC_INTRINSIC;
+
+  gfc_commit_symbol (sym);
+
+  return sym;
+}
+
+
+/* Return a pointer to the name of a conversion function given two
+   typespecs.  */
+
+static const char *
+conv_name (gfc_typespec *from, gfc_typespec *to)
+{
+  return gfc_get_string ("__convert_%c%d_%c%d",
+			 gfc_type_letter (from->type), from->kind,
+			 gfc_type_letter (to->type), to->kind);
+}
+
+
+/* Given a pair of typespecs, find the gfc_intrinsic_sym node that
+   corresponds to the conversion.  Returns NULL if the conversion
+   isn't found.  */
+
+static gfc_intrinsic_sym *
+find_conv (gfc_typespec *from, gfc_typespec *to)
+{
+  gfc_intrinsic_sym *sym;
+  const char *target;
+  int i;
+
+  target = conv_name (from, to);
+  sym = conversion;
+
+  for (i = 0; i < nconv; i++, sym++)
+    if (target == sym->name)
+      return sym;
+
+  return NULL;
+}
+
+
+/* Given a pair of CHARACTER typespecs, find the gfc_intrinsic_sym node
+   that corresponds to the conversion.  Returns NULL if the conversion
+   isn't found.  */
+
+static gfc_intrinsic_sym *
+find_char_conv (gfc_typespec *from, gfc_typespec *to)
+{
+  gfc_intrinsic_sym *sym;
+  const char *target;
+  int i;
+
+  target = conv_name (from, to);
+  sym = char_conversions;
+
+  for (i = 0; i < ncharconv; i++, sym++)
+    if (target == sym->name)
+      return sym;
+
+  return NULL;
+}
+
+
+/* Check TS29113, C407b for assumed type and C535b for assumed-rank,
+   and a likewise check for NO_ARG_CHECK.  */
+
+static bool
+do_ts29113_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg)
+{
+  gfc_actual_arglist *a;
+
+  for (a = arg; a; a = a->next)
+    {
+      if (!a->expr)
+	continue;
+
+      if (a->expr->expr_type == EXPR_VARIABLE
+	  && (a->expr->symtree->n.sym->attr.ext_attr
+	      & (1 << EXT_ATTR_NO_ARG_CHECK))
+	  && specific->id != GFC_ISYM_C_LOC
+	  && specific->id != GFC_ISYM_PRESENT)
+	{
+	  gfc_error ("Variable with NO_ARG_CHECK attribute at %L is only "
+		     "permitted as argument to the intrinsic functions "
+		     "C_LOC and PRESENT", &a->expr->where);
+	  return false;
+	}
+      else if (a->expr->ts.type == BT_ASSUMED
+	       && specific->id != GFC_ISYM_LBOUND
+	       && specific->id != GFC_ISYM_PRESENT
+	       && specific->id != GFC_ISYM_RANK
+	       && specific->id != GFC_ISYM_SHAPE
+	       && specific->id != GFC_ISYM_SIZE
+	       && specific->id != GFC_ISYM_UBOUND
+	       && specific->id != GFC_ISYM_C_LOC)
+	{
+	  gfc_error ("Assumed-type argument at %L is not permitted as actual"
+		     " argument to the intrinsic %s", &a->expr->where,
+		     gfc_current_intrinsic);
+	  return false;
+	}
+      else if (a->expr->ts.type == BT_ASSUMED && a != arg)
+	{
+	  gfc_error ("Assumed-type argument at %L is only permitted as "
+		     "first actual argument to the intrinsic %s",
+		     &a->expr->where, gfc_current_intrinsic);
+	  return false;
+	}
+      if (a->expr->rank == -1 && !specific->inquiry)
+	{
+	  gfc_error ("Assumed-rank argument at %L is only permitted as actual "
+		     "argument to intrinsic inquiry functions",
+		     &a->expr->where);
+	  return false;
+	}
+      if (a->expr->rank == -1 && arg != a)
+	{
+	  gfc_error ("Assumed-rank argument at %L is only permitted as first "
+		     "actual argument to the intrinsic inquiry function %s",
+		     &a->expr->where, gfc_current_intrinsic);
+	  return false;
+	}
+    }
+
+  return true;
+}
+
+
+/* Interface to the check functions.  We break apart an argument list
+   and call the proper check function rather than forcing each
+   function to manipulate the argument list.  */
+
+static bool
+do_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg)
+{
+  gfc_expr *a1, *a2, *a3, *a4, *a5;
+
+  if (arg == NULL)
+    return (*specific->check.f0) ();
+
+  a1 = arg->expr;
+  arg = arg->next;
+  if (arg == NULL)
+    return (*specific->check.f1) (a1);
+
+  a2 = arg->expr;
+  arg = arg->next;
+  if (arg == NULL)
+    return (*specific->check.f2) (a1, a2);
+
+  a3 = arg->expr;
+  arg = arg->next;
+  if (arg == NULL)
+    return (*specific->check.f3) (a1, a2, a3);
+
+  a4 = arg->expr;
+  arg = arg->next;
+  if (arg == NULL)
+    return (*specific->check.f4) (a1, a2, a3, a4);
+
+  a5 = arg->expr;
+  arg = arg->next;
+  if (arg == NULL)
+    return (*specific->check.f5) (a1, a2, a3, a4, a5);
+
+  gfc_internal_error ("do_check(): too many args");
+}
+
+
+/*********** Subroutines to build the intrinsic list ****************/
+
+/* Add a single intrinsic symbol to the current list.
+
+   Argument list:
+      char *     name of function
+      int	whether function is elemental
+      int	If the function can be used as an actual argument [1]
+      bt	 return type of function
+      int	kind of return type of function
+      int	Fortran standard version
+      check      pointer to check function
+      simplify   pointer to simplification function
+      resolve    pointer to resolution function
+
+   Optional arguments come in multiples of five:
+      char *      name of argument
+      bt          type of argument
+      int         kind of argument
+      int         arg optional flag (1=optional, 0=required)
+      sym_intent  intent of argument
+
+   The sequence is terminated by a NULL name.
+
+
+ [1] Whether a function can or cannot be used as an actual argument is
+     determined by its presence on the 13.6 list in Fortran 2003.  The
+     following intrinsics, which are GNU extensions, are considered allowed
+     as actual arguments: ACOSH ATANH DACOSH DASINH DATANH DCONJG DIMAG
+     ZABS ZCOS ZEXP ZLOG ZSIN ZSQRT.  */
+
+static void
+add_sym (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, int kind,
+	 int standard, gfc_check_f check, gfc_simplify_f simplify,
+	 gfc_resolve_f resolve, ...)
+{
+  char buf[GFC_MAX_SYMBOL_LEN + 11]; /* 10 for '_gfortran_', 1 for '\0'  */
+  int optional, first_flag;
+  sym_intent intent;
+  va_list argp;
+
+  switch (sizing)
+    {
+    case SZ_SUBS:
+      nsub++;
+      break;
+
+    case SZ_FUNCS:
+      nfunc++;
+      break;
+
+    case SZ_NOTHING:
+      next_sym->name = gfc_get_string (name);
+
+      strcpy (buf, "_gfortran_");
+      strcat (buf, name);
+      next_sym->lib_name = gfc_get_string (buf);
+
+      next_sym->pure = (cl != CLASS_IMPURE);
+      next_sym->elemental = (cl == CLASS_ELEMENTAL);
+      next_sym->inquiry = (cl == CLASS_INQUIRY);
+      next_sym->transformational = (cl == CLASS_TRANSFORMATIONAL);
+      next_sym->actual_ok = actual_ok;
+      next_sym->ts.type = type;
+      next_sym->ts.kind = kind;
+      next_sym->standard = standard;
+      next_sym->simplify = simplify;
+      next_sym->check = check;
+      next_sym->resolve = resolve;
+      next_sym->specific = 0;
+      next_sym->generic = 0;
+      next_sym->conversion = 0;
+      next_sym->id = id;
+      break;
+
+    default:
+      gfc_internal_error ("add_sym(): Bad sizing mode");
+    }
+
+  va_start (argp, resolve);
+
+  first_flag = 1;
+
+  for (;;)
+    {
+      name = va_arg (argp, char *);
+      if (name == NULL)
+	break;
+
+      type = (bt) va_arg (argp, int);
+      kind = va_arg (argp, int);
+      optional = va_arg (argp, int);
+      intent = (sym_intent) va_arg (argp, int);
+
+      if (sizing != SZ_NOTHING)
+	nargs++;
+      else
+	{
+	  next_arg++;
+
+	  if (first_flag)
+	    next_sym->formal = next_arg;
+	  else
+	    (next_arg - 1)->next = next_arg;
+
+	  first_flag = 0;
+
+	  strcpy (next_arg->name, name);
+	  next_arg->ts.type = type;
+	  next_arg->ts.kind = kind;
+	  next_arg->optional = optional;
+	  next_arg->value = 0;
+	  next_arg->intent = intent;
+	}
+    }
+
+  va_end (argp);
+
+  next_sym++;
+}
+
+
+/* Add a symbol to the function list where the function takes
+   0 arguments.  */
+
+static void
+add_sym_0 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
+	   int kind, int standard,
+	   bool (*check) (void),
+	   gfc_expr *(*simplify) (void),
+	   void (*resolve) (gfc_expr *))
+{
+  gfc_simplify_f sf;
+  gfc_check_f cf;
+  gfc_resolve_f rf;
+
+  cf.f0 = check;
+  sf.f0 = simplify;
+  rf.f0 = resolve;
+
+  add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
+	   (void *) 0);
+}
+
+
+/* Add a symbol to the subroutine list where the subroutine takes
+   0 arguments.  */
+
+static void
+add_sym_0s (const char *name, gfc_isym_id id, int standard,
+	    void (*resolve) (gfc_code *))
+{
+  gfc_check_f cf;
+  gfc_simplify_f sf;
+  gfc_resolve_f rf;
+
+  cf.f1 = NULL;
+  sf.f1 = NULL;
+  rf.s1 = resolve;
+
+  add_sym (name, id, CLASS_IMPURE, ACTUAL_NO, BT_UNKNOWN, 0, standard, cf, sf,
+	   rf, (void *) 0);
+}
+
+
+/* Add a symbol to the function list where the function takes
+   1 arguments.  */
+
+static void
+add_sym_1 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
+	   int kind, int standard,
+	   bool (*check) (gfc_expr *),
+	   gfc_expr *(*simplify) (gfc_expr *),
+	   void (*resolve) (gfc_expr *, gfc_expr *),
+	   const char *a1, bt type1, int kind1, int optional1)
+{
+  gfc_check_f cf;
+  gfc_simplify_f sf;
+  gfc_resolve_f rf;
+
+  cf.f1 = check;
+  sf.f1 = simplify;
+  rf.f1 = resolve;
+
+  add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
+	   a1, type1, kind1, optional1, INTENT_IN,
+	   (void *) 0);
+}
+
+
+/* Add a symbol to the function list where the function takes
+   1 arguments, specifying the intent of the argument.  */
+
+static void
+add_sym_1_intent (const char *name, gfc_isym_id id, enum klass cl,
+		  int actual_ok, bt type, int kind, int standard,
+		  bool (*check) (gfc_expr *),
+		  gfc_expr *(*simplify) (gfc_expr *),
+		  void (*resolve) (gfc_expr *, gfc_expr *),
+		  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.f1 = check;
+  sf.f1 = simplify;
+  rf.f1 = resolve;
+
+  add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
+	   a1, type1, kind1, optional1, intent1,
+	   (void *) 0);
+}
+
+
+/* Add a symbol to the subroutine list where the subroutine takes
+   1 arguments, specifying the intent of the argument.  */
+
+static void
+add_sym_1s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind,
+	    int standard, bool (*check) (gfc_expr *),
+	    gfc_expr *(*simplify) (gfc_expr *), void (*resolve) (gfc_code *),
+	    const char *a1, bt type1, int kind1, int optional1,
+	    sym_intent intent1)
+{
+  gfc_check_f cf;
+  gfc_simplify_f sf;
+  gfc_resolve_f rf;
+
+  cf.f1 = check;
+  sf.f1 = simplify;
+  rf.s1 = resolve;
+
+  add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
+	   a1, type1, kind1, optional1, 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.  */
+
+static void
+add_sym_1m (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
+	    int kind, int standard,
+	    bool (*check) (gfc_actual_arglist *),
+	    gfc_expr *(*simplify) (gfc_expr *),
+	    void (*resolve) (gfc_expr *, gfc_actual_arglist *),
+	    const char *a1, bt type1, int kind1, int optional1,
+	    const char *a2, bt type2, int kind2, int optional2)
+{
+  gfc_check_f cf;
+  gfc_simplify_f sf;
+  gfc_resolve_f rf;
+
+  cf.f1m = check;
+  sf.f1 = simplify;
+  rf.f1m = resolve;
+
+  add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
+	   a1, type1, kind1, optional1, INTENT_IN,
+	   a2, type2, kind2, optional2, INTENT_IN,
+	   (void *) 0);
+}
+
+
+/* Add a symbol to the function list where the function takes
+   2 arguments.  */
+
+static void
+add_sym_2 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
+	   int kind, int standard,
+	   bool (*check) (gfc_expr *, gfc_expr *),
+	   gfc_expr *(*simplify) (gfc_expr *, gfc_expr *),
+	   void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *),
+	   const char *a1, bt type1, int kind1, int optional1,
+	   const char *a2, bt type2, int kind2, int optional2)
+{
+  gfc_check_f cf;
+  gfc_simplify_f sf;
+  gfc_resolve_f rf;
+
+  cf.f2 = check;
+  sf.f2 = simplify;
+  rf.f2 = resolve;
+
+  add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
+	   a1, type1, kind1, optional1, INTENT_IN,
+	   a2, type2, kind2, optional2, INTENT_IN,
+	   (void *) 0);
+}
+
+
+/* Add a symbol to the function list where the function takes
+   2 arguments; same as add_sym_2 - but allows to specify the intent.  */
+
+static void
+add_sym_2_intent (const char *name, gfc_isym_id id, enum klass cl,
+		  int actual_ok, bt type, int kind, int standard,
+		  bool (*check) (gfc_expr *, gfc_expr *),
+		  gfc_expr *(*simplify) (gfc_expr *, gfc_expr *),
+		  void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *),
+		  const char *a1, bt type1, int kind1, int optional1,
+		  sym_intent intent1, const char *a2, bt type2, int kind2,
+		  int optional2, sym_intent intent2)
+{
+  gfc_check_f cf;
+  gfc_simplify_f sf;
+  gfc_resolve_f rf;
+
+  cf.f2 = check;
+  sf.f2 = simplify;
+  rf.f2 = resolve;
+
+  add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
+	   a1, type1, kind1, optional1, intent1,
+	   a2, type2, kind2, optional2, intent2,
+	   (void *) 0);
+}
+
+
+/* Add a symbol to the subroutine list where the subroutine takes
+   2 arguments, specifying the intent of the arguments.  */
+
+static void
+add_sym_2s (const char *name, gfc_isym_id id, enum klass cl, bt type,
+	    int kind, int standard,
+	    bool (*check) (gfc_expr *, gfc_expr *),
+	    gfc_expr *(*simplify) (gfc_expr *, gfc_expr *),
+	    void (*resolve) (gfc_code *),
+	    const char *a1, bt type1, int kind1, int optional1,
+	    sym_intent intent1, const char *a2, bt type2, int kind2,
+	    int optional2, sym_intent intent2)
+{
+  gfc_check_f cf;
+  gfc_simplify_f sf;
+  gfc_resolve_f rf;
+
+  cf.f2 = check;
+  sf.f2 = simplify;
+  rf.s1 = resolve;
+
+  add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
+	   a1, type1, kind1, optional1, intent1,
+	   a2, type2, kind2, optional2, intent2,
+	   (void *) 0);
+}
+
+
+/* Add a symbol to the function list where the function takes
+   3 arguments.  */
+
+static void
+add_sym_3 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
+	   int kind, int standard,
+	   bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *),
+	   gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *),
+	   void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
+	   const char *a1, bt type1, int kind1, int optional1,
+	   const char *a2, bt type2, int kind2, int optional2,
+	   const char *a3, bt type3, int kind3, int optional3)
+{
+  gfc_check_f cf;
+  gfc_simplify_f sf;
+  gfc_resolve_f rf;
+
+  cf.f3 = check;
+  sf.f3 = simplify;
+  rf.f3 = resolve;
+
+  add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
+	   a1, type1, kind1, optional1, INTENT_IN,
+	   a2, type2, kind2, optional2, INTENT_IN,
+	   a3, type3, kind3, optional3, INTENT_IN,
+	   (void *) 0);
+}
+
+
+/* MINLOC and MAXLOC get special treatment because their argument
+   might have to be reordered.  */
+
+static void
+add_sym_3ml (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
+	     int kind, int standard,
+	     bool (*check) (gfc_actual_arglist *),
+	     gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *),
+	     void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
+	     const char *a1, bt type1, int kind1, int optional1,
+	     const char *a2, bt type2, int kind2, int optional2,
+	     const char *a3, bt type3, int kind3, int optional3)
+{
+  gfc_check_f cf;
+  gfc_simplify_f sf;
+  gfc_resolve_f rf;
+
+  cf.f3ml = check;
+  sf.f3 = simplify;
+  rf.f3 = resolve;
+
+  add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
+	   a1, type1, kind1, optional1, INTENT_IN,
+	   a2, type2, kind2, optional2, INTENT_IN,
+	   a3, type3, kind3, optional3, INTENT_IN,
+	   (void *) 0);
+}
+
+
+/* MINVAL, MAXVAL, PRODUCT, and SUM also get special treatment because
+   their argument also might have to be reordered.  */
+
+static void
+add_sym_3red (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
+	      int kind, int standard,
+	      bool (*check) (gfc_actual_arglist *),
+	      gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *),
+	      void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
+	      const char *a1, bt type1, int kind1, int optional1,
+	      const char *a2, bt type2, int kind2, int optional2,
+	      const char *a3, bt type3, int kind3, int optional3)
+{
+  gfc_check_f cf;
+  gfc_simplify_f sf;
+  gfc_resolve_f rf;
+
+  cf.f3red = check;
+  sf.f3 = simplify;
+  rf.f3 = resolve;
+
+  add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
+	   a1, type1, kind1, optional1, INTENT_IN,
+	   a2, type2, kind2, optional2, INTENT_IN,
+	   a3, type3, kind3, optional3, INTENT_IN,
+	   (void *) 0);
+}
+
+
+/* Add a symbol to the subroutine list where the subroutine takes
+   3 arguments, specifying the intent of the arguments.  */
+
+static void
+add_sym_3s (const char *name, gfc_isym_id id, enum klass cl, bt type,
+	    int kind, int standard,
+	    bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *),
+	    gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *),
+	    void (*resolve) (gfc_code *),
+	    const char *a1, bt type1, int kind1, int optional1,
+	    sym_intent intent1, const char *a2, bt type2, int kind2,
+	    int optional2, sym_intent intent2, const char *a3, bt type3,
+	    int kind3, int optional3, sym_intent intent3)
+{
+  gfc_check_f cf;
+  gfc_simplify_f sf;
+  gfc_resolve_f rf;
+
+  cf.f3 = check;
+  sf.f3 = simplify;
+  rf.s1 = resolve;
+
+  add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
+	   a1, type1, kind1, optional1, intent1,
+	   a2, type2, kind2, optional2, intent2,
+	   a3, type3, kind3, optional3, intent3,
+	   (void *) 0);
+}
+
+
+/* Add a symbol to the function list where the function takes
+   4 arguments.  */
+
+static void
+add_sym_4 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
+	   int kind, int standard,
+	   bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
+	   gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *,
+				  gfc_expr *),
+	   void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
+			    gfc_expr *),
+	   const char *a1, bt type1, int kind1, int optional1,
+	   const char *a2, bt type2, int kind2, int optional2,
+	   const char *a3, bt type3, int kind3, int optional3,
+	   const char *a4, bt type4, int kind4, int optional4 )
+{
+  gfc_check_f cf;
+  gfc_simplify_f sf;
+  gfc_resolve_f rf;
+
+  cf.f4 = check;
+  sf.f4 = simplify;
+  rf.f4 = resolve;
+
+  add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
+	   a1, type1, kind1, optional1, INTENT_IN,
+	   a2, type2, kind2, optional2, INTENT_IN,
+	   a3, type3, kind3, optional3, INTENT_IN,
+	   a4, type4, kind4, optional4, INTENT_IN,
+	   (void *) 0);
+}
+
+
+/* Add a symbol to the subroutine list where the subroutine takes
+   4 arguments.  */
+
+static void
+add_sym_4s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind,
+	    int standard,
+	    bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
+	    gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *,
+				   gfc_expr *),
+	    void (*resolve) (gfc_code *),
+	    const char *a1, bt type1, int kind1, int optional1,
+	    sym_intent intent1, const char *a2, bt type2, int kind2,
+	    int optional2, sym_intent intent2, const char *a3, bt type3,
+	    int kind3, int optional3, sym_intent intent3, const char *a4,
+	    bt type4, int kind4, int optional4, sym_intent intent4)
+{
+  gfc_check_f cf;
+  gfc_simplify_f sf;
+  gfc_resolve_f rf;
+
+  cf.f4 = check;
+  sf.f4 = simplify;
+  rf.s1 = resolve;
+
+  add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
+	   a1, type1, kind1, optional1, intent1,
+	   a2, type2, kind2, optional2, intent2,
+	   a3, type3, kind3, optional3, intent3,
+	   a4, type4, kind4, optional4, intent4,
+	   (void *) 0);
+}
+
+
+/* Add a symbol to the subroutine list where the subroutine takes
+   5 arguments.  */
+
+static void
+add_sym_5s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind,
+	    int standard,
+	    bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
+			  gfc_expr *),
+	    gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *,
+				   gfc_expr *, gfc_expr *),
+	    void (*resolve) (gfc_code *),
+	    const char *a1, bt type1, int kind1, int optional1,
+	    sym_intent intent1, const char *a2, bt type2, int kind2,
+	    int optional2, sym_intent intent2, const char *a3, bt type3,
+	    int kind3, int optional3, sym_intent intent3, const char *a4,
+	    bt type4, int kind4, int optional4, sym_intent intent4,
+	    const char *a5, bt type5, int kind5, int optional5,
+	    sym_intent intent5) 
+{
+  gfc_check_f cf;
+  gfc_simplify_f sf;
+  gfc_resolve_f rf;
+
+  cf.f5 = check;
+  sf.f5 = simplify;
+  rf.s1 = resolve;
+
+  add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
+	   a1, type1, kind1, optional1, intent1,
+	   a2, type2, kind2, optional2, intent2,
+	   a3, type3, kind3, optional3, intent3,
+	   a4, type4, kind4, optional4, intent4,
+	   a5, type5, kind5, optional5, intent5,
+	   (void *) 0);
+}
+
+
+/* Locate an intrinsic symbol given a base pointer, number of elements
+   in the table and a pointer to a name.  Returns the NULL pointer if
+   a name is not found.  */
+
+static gfc_intrinsic_sym *
+find_sym (gfc_intrinsic_sym *start, int n, const char *name)
+{
+  /* name may be a user-supplied string, so we must first make sure
+     that we're comparing against a pointer into the global string
+     table.  */
+  const char *p = gfc_get_string (name);
+
+  while (n > 0)
+    {
+      if (p == start->name)
+	return start;
+
+      start++;
+      n--;
+    }
+
+  return NULL;
+}
+
+
+gfc_isym_id
+gfc_isym_id_by_intmod (intmod_id from_intmod, int intmod_sym_id)
+{
+  if (from_intmod == INTMOD_NONE)
+    return (gfc_isym_id) intmod_sym_id;
+  else if (from_intmod == INTMOD_ISO_C_BINDING)
+    return (gfc_isym_id) c_interop_kinds_table[intmod_sym_id].value;
+  else if (from_intmod == INTMOD_ISO_FORTRAN_ENV)
+    switch (intmod_sym_id)
+      {
+#define NAMED_SUBROUTINE(a,b,c,d) \
+      case a: \
+	return (gfc_isym_id) c;
+#define NAMED_FUNCTION(a,b,c,d) \
+      case a: \
+	return (gfc_isym_id) c;
+#include "iso-fortran-env.def"
+      default:
+	gcc_unreachable ();
+      }
+  else
+    gcc_unreachable ();
+  return (gfc_isym_id) 0;
+}
+
+
+gfc_isym_id
+gfc_isym_id_by_intmod_sym (gfc_symbol *sym)
+{
+  return gfc_isym_id_by_intmod (sym->from_intmod, sym->intmod_sym_id);
+}
+
+
+gfc_intrinsic_sym *
+gfc_intrinsic_subroutine_by_id (gfc_isym_id id)
+{
+  gfc_intrinsic_sym *start = subroutines;
+  int n = nsub;
+
+  while (true)
+    {
+      gcc_assert (n > 0);
+      if (id == start->id)
+	return start;
+
+      start++;
+      n--;
+    }
+}
+
+
+gfc_intrinsic_sym *
+gfc_intrinsic_function_by_id (gfc_isym_id id)
+{
+  gfc_intrinsic_sym *start = functions;
+  int n = nfunc;
+
+  while (true)
+    {
+      gcc_assert (n > 0);
+      if (id == start->id)
+	return start;
+
+      start++;
+      n--;
+    }
+}
+
+
+/* Given a name, find a function in the intrinsic function table.
+   Returns NULL if not found.  */
+
+gfc_intrinsic_sym *
+gfc_find_function (const char *name)
+{
+  gfc_intrinsic_sym *sym;
+
+  sym = find_sym (functions, nfunc, name);
+  if (!sym || sym->from_module)
+    sym = find_sym (conversion, nconv, name);
+
+  return (!sym || sym->from_module) ? NULL : sym;
+}
+
+
+/* Given a name, find a function in the intrinsic subroutine table.
+   Returns NULL if not found.  */
+
+gfc_intrinsic_sym *
+gfc_find_subroutine (const char *name)
+{
+  gfc_intrinsic_sym *sym;
+  sym = find_sym (subroutines, nsub, name);
+  return (!sym || sym->from_module) ? NULL : sym;
+}
+
+
+/* Given a string, figure out if it is the name of a generic intrinsic
+   function or not.  */
+
+int
+gfc_generic_intrinsic (const char *name)
+{
+  gfc_intrinsic_sym *sym;
+
+  sym = gfc_find_function (name);
+  return (!sym || sym->from_module) ? 0 : sym->generic;
+}
+
+
+/* Given a string, figure out if it is the name of a specific
+   intrinsic function or not.  */
+
+int
+gfc_specific_intrinsic (const char *name)
+{
+  gfc_intrinsic_sym *sym;
+
+  sym = gfc_find_function (name);
+  return (!sym || sym->from_module) ? 0 : sym->specific;
+}
+
+
+/* Given a string, figure out if it is the name of an intrinsic function
+   or subroutine allowed as an actual argument or not.  */
+int
+gfc_intrinsic_actual_ok (const char *name, const bool subroutine_flag)
+{
+  gfc_intrinsic_sym *sym;
+
+  /* Intrinsic subroutines are not allowed as actual arguments.  */
+  if (subroutine_flag)
+    return 0;
+  else
+    {
+      sym = gfc_find_function (name);
+      return (sym == NULL) ? 0 : sym->actual_ok;
+    }
+}
+
+
+/* Given a symbol, find out if it is (and is to be treated as) an intrinsic.
+   If its name refers to an intrinsic, but this intrinsic is not included in
+   the selected standard, this returns FALSE and sets the symbol's external
+   attribute.  */
+
+bool
+gfc_is_intrinsic (gfc_symbol* sym, int subroutine_flag, locus loc)
+{
+  gfc_intrinsic_sym* isym;
+  const char* symstd;
+
+  /* If INTRINSIC attribute is already known, return.  */
+  if (sym->attr.intrinsic)
+    return true;
+
+  /* Check for attributes which prevent the symbol from being INTRINSIC.  */
+  if (sym->attr.external || sym->attr.contained
+      || sym->attr.if_source == IFSRC_IFBODY)
+    return false;
+
+  if (subroutine_flag)
+    isym = gfc_find_subroutine (sym->name);
+  else
+    isym = gfc_find_function (sym->name);
+
+  /* No such intrinsic available at all?  */
+  if (!isym)
+    return false;
+
+  /* See if this intrinsic is allowed in the current standard.  */
+  if (!gfc_check_intrinsic_standard (isym, &symstd, false, loc)
+      && !sym->attr.artificial)
+    {
+      if (sym->attr.proc == PROC_UNKNOWN
+	  && gfc_option.warn_intrinsics_std)
+	gfc_warning_now ("The intrinsic '%s' at %L is not included in the"
+			 " selected standard but %s and '%s' will be"
+			 " treated as if declared EXTERNAL.  Use an"
+			 " appropriate -std=* option or define"
+			 " -fall-intrinsics to allow this intrinsic.",
+			 sym->name, &loc, symstd, sym->name);
+
+      return false;
+    }
+
+  return true;
+}
+
+
+/* Collect a set of intrinsic functions into a generic collection.
+   The first argument is the name of the generic function, which is
+   also the name of a specific function.  The rest of the specifics
+   currently in the table are placed into the list of specific
+   functions associated with that generic.
+
+   PR fortran/32778
+   FIXME: Remove the argument STANDARD if no regressions are
+          encountered. Change all callers (approx. 360).
+*/
+
+static void
+make_generic (const char *name, gfc_isym_id id, int standard ATTRIBUTE_UNUSED)
+{
+  gfc_intrinsic_sym *g;
+
+  if (sizing != SZ_NOTHING)
+    return;
+
+  g = gfc_find_function (name);
+  if (g == NULL)
+    gfc_internal_error ("make_generic(): Can't find generic symbol '%s'",
+			name);
+
+  gcc_assert (g->id == id);
+
+  g->generic = 1;
+  g->specific = 1;
+  if ((g + 1)->name != NULL)
+    g->specific_head = g + 1;
+  g++;
+
+  while (g->name != NULL)
+    {
+      g->next = g + 1;
+      g->specific = 1;
+      g++;
+    }
+
+  g--;
+  g->next = NULL;
+}
+
+
+/* Create a duplicate intrinsic function entry for the current
+   function, the only differences being the alternate name and
+   a different standard if necessary. Note that we use argument
+   lists more than once, but all argument lists are freed as a
+   single block.  */
+
+static void
+make_alias (const char *name, int standard)
+{
+  switch (sizing)
+    {
+    case SZ_FUNCS:
+      nfunc++;
+      break;
+
+    case SZ_SUBS:
+      nsub++;
+      break;
+
+    case SZ_NOTHING:
+      next_sym[0] = next_sym[-1];
+      next_sym->name = gfc_get_string (name);
+      next_sym->standard = standard;
+      next_sym++;
+      break;
+
+    default:
+      break;
+    }
+}
+
+
+/* Make the current subroutine noreturn.  */
+
+static void
+make_noreturn (void)
+{
+  if (sizing == SZ_NOTHING)
+    next_sym[-1].noreturn = 1;
+}
+
+
+/* Mark current intrinsic as module intrinsic.  */
+static void
+make_from_module (void)
+{
+  if (sizing == SZ_NOTHING)
+    next_sym[-1].from_module = 1;
+}
+
+/* Set the attr.value of the current procedure.  */
+
+static void
+set_attr_value (int n, ...)
+{
+  gfc_intrinsic_arg *arg;
+  va_list argp;
+  int i;
+
+  if (sizing != SZ_NOTHING)
+    return;
+
+  va_start (argp, n);
+  arg = next_sym[-1].formal;
+
+  for (i = 0; i < n; i++)
+    {
+      gcc_assert (arg != NULL);
+      arg->value = va_arg (argp, int);
+      arg = arg->next;
+    }
+  va_end (argp);
+}
+
+
+/* Add intrinsic functions.  */
+
+static void
+add_functions (void)
+{
+  /* Argument names as in the standard (to be used as argument keywords).  */
+  const char
+    *a = "a", *f = "field", *pt = "pointer", *tg = "target",
+    *b = "b", *m = "matrix", *ma = "matrix_a", *mb = "matrix_b",
+    *c = "c", *n = "n", *ncopies= "ncopies", *pos = "pos", *bck = "back",
+    *i = "i", *v = "vector", *va = "vector_a", *vb = "vector_b",
+    *j = "j", *a1 = "a1", *fs = "fsource", *ts = "tsource",
+    *l = "l", *a2 = "a2", *mo = "mold", *ord = "order",
+    *p = "p", *ar = "array", *shp = "shape", *src = "source",
+    *r = "r", *bd = "boundary", *pad = "pad", *set = "set",
+    *s = "s", *dm = "dim", *kind = "kind", *msk = "mask",
+    *x = "x", *sh = "shift", *stg = "string", *ssg = "substring",
+    *y = "y", *sz = "size", *sta = "string_a", *stb = "string_b",
+    *z = "z", *ln = "len", *ut = "unit", *han = "handler",
+    *num = "number", *tm = "time", *nm = "name", *md = "mode",
+    *vl = "values", *p1 = "path1", *p2 = "path2", *com = "command",
+    *ca = "coarray", *sub = "sub";
+
+  int di, dr, dd, dl, dc, dz, ii;
+
+  di = gfc_default_integer_kind;
+  dr = gfc_default_real_kind;
+  dd = gfc_default_double_kind;
+  dl = gfc_default_logical_kind;
+  dc = gfc_default_character_kind;
+  dz = gfc_default_complex_kind;
+  ii = gfc_index_integer_kind;
+
+  add_sym_1 ("abs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
+	     gfc_check_abs, gfc_simplify_abs, gfc_resolve_abs,
+	     a, BT_REAL, dr, REQUIRED);
+
+  add_sym_1 ("iabs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
+	     NULL, gfc_simplify_abs, gfc_resolve_abs,
+	     a, BT_INTEGER, di, REQUIRED);
+
+  add_sym_1 ("dabs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
+	     gfc_check_fn_d, gfc_simplify_abs, gfc_resolve_abs,
+	     a, BT_REAL, dd, REQUIRED);
+
+  add_sym_1 ("cabs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
+	     NULL, gfc_simplify_abs, gfc_resolve_abs,
+	     a, BT_COMPLEX, dz, REQUIRED);
+
+  add_sym_1 ("zabs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, 
+	     NULL, gfc_simplify_abs, gfc_resolve_abs, 
+	     a, BT_COMPLEX, dd, REQUIRED);
+
+  make_alias ("cdabs", GFC_STD_GNU);
+
+  make_generic ("abs", GFC_ISYM_ABS, GFC_STD_F77);
+
+  /* The checking function for ACCESS is called gfc_check_access_func
+     because the name gfc_check_access is already used in module.c.  */
+  add_sym_2 ("access", GFC_ISYM_ACCESS, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
+	     di, GFC_STD_GNU, gfc_check_access_func, NULL, gfc_resolve_access,
+	     nm, BT_CHARACTER, dc, REQUIRED, md, BT_CHARACTER, dc, REQUIRED);
+
+  make_generic ("access", GFC_ISYM_ACCESS, GFC_STD_GNU);
+
+  add_sym_2 ("achar", GFC_ISYM_ACHAR, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_CHARACTER, dc, GFC_STD_F95,
+	     gfc_check_achar, gfc_simplify_achar, gfc_resolve_achar,
+	     i, BT_INTEGER, di, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
+
+  make_generic ("achar", GFC_ISYM_ACHAR, GFC_STD_F95);
+
+  add_sym_1 ("acos", GFC_ISYM_ACOS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
+	     gfc_check_fn_rc2008, gfc_simplify_acos, gfc_resolve_acos,
+	     x, BT_REAL, dr, REQUIRED);
+
+  add_sym_1 ("dacos", GFC_ISYM_ACOS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
+	     gfc_check_fn_d, gfc_simplify_acos, gfc_resolve_acos,
+	     x, BT_REAL, dd, REQUIRED);
+
+  make_generic ("acos", GFC_ISYM_ACOS, GFC_STD_F77);
+
+  add_sym_1 ("acosh", GFC_ISYM_ACOSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr,
+	     GFC_STD_F2008, gfc_check_fn_rc2008, gfc_simplify_acosh,
+	     gfc_resolve_acosh, x, BT_REAL, dr, REQUIRED);
+
+  add_sym_1 ("dacosh", GFC_ISYM_ACOSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU,
+	     gfc_check_fn_d, gfc_simplify_acosh, gfc_resolve_acosh,
+	     x, BT_REAL, dd, REQUIRED);
+
+  make_generic ("acosh", GFC_ISYM_ACOSH, GFC_STD_F2008);
+
+  add_sym_1 ("adjustl", GFC_ISYM_ADJUSTL, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_CHARACTER, dc, GFC_STD_F95, NULL, gfc_simplify_adjustl,
+	     gfc_resolve_adjustl, stg, BT_CHARACTER, 0, REQUIRED);
+
+  make_generic ("adjustl", GFC_ISYM_ADJUSTL, GFC_STD_F95);
+
+  add_sym_1 ("adjustr", GFC_ISYM_ADJUSTR, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_CHARACTER, dc, GFC_STD_F95, NULL, gfc_simplify_adjustr,
+	     gfc_resolve_adjustr, stg, BT_CHARACTER, 0, REQUIRED);
+
+  make_generic ("adjustr", GFC_ISYM_ADJUSTR, GFC_STD_F95);
+
+  add_sym_1 ("aimag", GFC_ISYM_AIMAG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
+	     gfc_check_fn_c, gfc_simplify_aimag, gfc_resolve_aimag,
+	     z, BT_COMPLEX, dz, REQUIRED);
+
+  make_alias ("imag", GFC_STD_GNU);
+  make_alias ("imagpart", GFC_STD_GNU);
+
+  add_sym_1 ("dimag", GFC_ISYM_AIMAG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, 
+	     NULL, gfc_simplify_aimag, gfc_resolve_aimag, 
+	     z, BT_COMPLEX, dd, REQUIRED);
+
+  make_generic ("aimag", GFC_ISYM_AIMAG, GFC_STD_F77);
+
+  add_sym_2 ("aint", GFC_ISYM_AINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
+	     gfc_check_a_xkind, gfc_simplify_aint, gfc_resolve_aint,
+	     a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
+
+  add_sym_1 ("dint", GFC_ISYM_AINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
+	     NULL, gfc_simplify_dint, gfc_resolve_dint,
+	     a, BT_REAL, dd, REQUIRED);
+
+  make_generic ("aint", GFC_ISYM_AINT, GFC_STD_F77);
+
+  add_sym_2 ("all", GFC_ISYM_ALL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
+	     gfc_check_all_any, gfc_simplify_all, gfc_resolve_all,
+	     msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
+
+  make_generic ("all", GFC_ISYM_ALL, GFC_STD_F95);
+
+  add_sym_1 ("allocated", GFC_ISYM_ALLOCATED, CLASS_INQUIRY, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
+	     gfc_check_allocated, NULL, NULL,
+	     ar, BT_UNKNOWN, 0, REQUIRED);
+
+  make_generic ("allocated", GFC_ISYM_ALLOCATED, GFC_STD_F95);
+
+  add_sym_2 ("anint", GFC_ISYM_ANINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
+	     gfc_check_a_xkind, gfc_simplify_anint, gfc_resolve_anint,
+	     a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
+
+  add_sym_1 ("dnint", GFC_ISYM_ANINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
+	     NULL, gfc_simplify_dnint, gfc_resolve_dnint,
+	     a, BT_REAL, dd, REQUIRED);
+
+  make_generic ("anint", GFC_ISYM_ANINT, GFC_STD_F77);
+
+  add_sym_2 ("any", GFC_ISYM_ANY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
+	     gfc_check_all_any, gfc_simplify_any, gfc_resolve_any,
+	     msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
+
+  make_generic ("any", GFC_ISYM_ANY, GFC_STD_F95);
+
+  add_sym_1 ("asin", GFC_ISYM_ASIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
+	     gfc_check_fn_rc2008, gfc_simplify_asin, gfc_resolve_asin,
+	     x, BT_REAL, dr, REQUIRED);
+
+  add_sym_1 ("dasin", GFC_ISYM_ASIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
+	     gfc_check_fn_d, gfc_simplify_asin, gfc_resolve_asin,
+	     x, BT_REAL, dd, REQUIRED);
+
+  make_generic ("asin", GFC_ISYM_ASIN, GFC_STD_F77);
+  
+  add_sym_1 ("asinh", GFC_ISYM_ASINH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr,
+	     GFC_STD_F2008, gfc_check_fn_rc2008, gfc_simplify_asinh,
+	     gfc_resolve_asinh, x, BT_REAL, dr, REQUIRED);
+
+  add_sym_1 ("dasinh", GFC_ISYM_ASINH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU,
+	     gfc_check_fn_d, gfc_simplify_asinh, gfc_resolve_asinh,
+	     x, BT_REAL, dd, REQUIRED);
+
+  make_generic ("asinh", GFC_ISYM_ASINH, GFC_STD_F2008);
+
+  add_sym_2 ("associated", GFC_ISYM_ASSOCIATED, CLASS_INQUIRY, ACTUAL_NO, BT_LOGICAL, dl,
+	     GFC_STD_F95, gfc_check_associated, NULL, NULL,
+	     pt, BT_UNKNOWN, 0, REQUIRED, tg, BT_UNKNOWN, 0, OPTIONAL);
+
+  make_generic ("associated", GFC_ISYM_ASSOCIATED, GFC_STD_F95);
+
+  add_sym_1 ("atan", GFC_ISYM_ATAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
+	     gfc_check_fn_rc2008, gfc_simplify_atan, gfc_resolve_atan,
+	     x, BT_REAL, dr, REQUIRED);
+
+  add_sym_1 ("datan", GFC_ISYM_ATAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
+	     gfc_check_fn_d, gfc_simplify_atan, gfc_resolve_atan,
+	     x, BT_REAL, dd, REQUIRED);
+
+  /* Two-argument version of atan, equivalent to atan2.  */
+  add_sym_2 ("atan", GFC_ISYM_ATAN2, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F2008,
+	     gfc_check_atan_2, gfc_simplify_atan2, gfc_resolve_atan2,
+	     y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, REQUIRED);
+
+  make_generic ("atan", GFC_ISYM_ATAN, GFC_STD_F77);
+  
+  add_sym_1 ("atanh", GFC_ISYM_ATANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr,
+	     GFC_STD_F2008, gfc_check_fn_rc2008, gfc_simplify_atanh,
+	     gfc_resolve_atanh, x, BT_REAL, dr, REQUIRED);
+
+  add_sym_1 ("datanh", GFC_ISYM_ATANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU,
+	     gfc_check_fn_d, gfc_simplify_atanh, gfc_resolve_atanh,
+	     x, BT_REAL, dd, REQUIRED);
+
+  make_generic ("atanh", GFC_ISYM_ATANH, GFC_STD_F2008);
+
+  add_sym_2 ("atan2", GFC_ISYM_ATAN2, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
+	     gfc_check_atan2, gfc_simplify_atan2, gfc_resolve_atan2,
+	     y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, REQUIRED);
+
+  add_sym_2 ("datan2", GFC_ISYM_ATAN2, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
+	     gfc_check_datan2, gfc_simplify_atan2, gfc_resolve_atan2,
+	     y, BT_REAL, dd, REQUIRED, x, BT_REAL, dd, REQUIRED);
+
+  make_generic ("atan2", GFC_ISYM_ATAN2, GFC_STD_F77);
+  
+  /* Bessel and Neumann functions for G77 compatibility.  */
+  add_sym_1 ("besj0", GFC_ISYM_J0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
+	     gfc_check_fn_r, gfc_simplify_bessel_j0, gfc_resolve_g77_math1,
+	     x, BT_REAL, dr, REQUIRED);
+
+  make_alias ("bessel_j0", GFC_STD_F2008);
+
+  add_sym_1 ("dbesj0", GFC_ISYM_J0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
+	     gfc_check_fn_d, gfc_simplify_bessel_j0, gfc_resolve_g77_math1,
+	     x, BT_REAL, dd, REQUIRED);
+
+  make_generic ("bessel_j0", GFC_ISYM_J0, GFC_STD_F2008);
+
+  add_sym_1 ("besj1", GFC_ISYM_J1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
+	     gfc_check_fn_r, gfc_simplify_bessel_j1, gfc_resolve_g77_math1,
+	     x, BT_REAL, dr, REQUIRED);
+
+  make_alias ("bessel_j1", GFC_STD_F2008);
+
+  add_sym_1 ("dbesj1", GFC_ISYM_J1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
+	     gfc_check_fn_d, gfc_simplify_bessel_j1, gfc_resolve_g77_math1,
+	     x, BT_REAL, dd, REQUIRED);
+
+  make_generic ("bessel_j1", GFC_ISYM_J1, GFC_STD_F2008);
+
+  add_sym_2 ("besjn", GFC_ISYM_JN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
+	     gfc_check_besn, gfc_simplify_bessel_jn, gfc_resolve_besn,
+	     n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dr, REQUIRED);
+
+  make_alias ("bessel_jn", GFC_STD_F2008);
+
+  add_sym_2 ("dbesjn", GFC_ISYM_JN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
+	     gfc_check_besn, gfc_simplify_bessel_jn, gfc_resolve_besn,
+	     n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dd, REQUIRED);
+
+  add_sym_3 ("bessel_jn", GFC_ISYM_JN2, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008,
+	     gfc_check_bessel_n2, gfc_simplify_bessel_jn2, gfc_resolve_bessel_n2,
+	     "n1", BT_INTEGER, di, REQUIRED,"n2", BT_INTEGER, di, REQUIRED,
+	     x, BT_REAL, dr, REQUIRED);
+  set_attr_value (3, true, true, true);
+
+  make_generic ("bessel_jn", GFC_ISYM_JN, GFC_STD_F2008);
+
+  add_sym_1 ("besy0", GFC_ISYM_Y0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
+	     gfc_check_fn_r, gfc_simplify_bessel_y0, gfc_resolve_g77_math1,
+	     x, BT_REAL, dr, REQUIRED);
+
+  make_alias ("bessel_y0", GFC_STD_F2008);
+
+  add_sym_1 ("dbesy0", GFC_ISYM_Y0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
+	     gfc_check_fn_d, gfc_simplify_bessel_y0, gfc_resolve_g77_math1,
+	     x, BT_REAL, dd, REQUIRED);
+
+  make_generic ("bessel_y0", GFC_ISYM_Y0, GFC_STD_F2008);
+
+  add_sym_1 ("besy1", GFC_ISYM_Y1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
+	     gfc_check_fn_r, gfc_simplify_bessel_y1, gfc_resolve_g77_math1,
+	     x, BT_REAL, dr, REQUIRED);
+
+  make_alias ("bessel_y1", GFC_STD_F2008);
+
+  add_sym_1 ("dbesy1", GFC_ISYM_Y1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
+	     gfc_check_fn_d, gfc_simplify_bessel_y1, gfc_resolve_g77_math1,
+	     x, BT_REAL, dd, REQUIRED);
+
+  make_generic ("bessel_y1", GFC_ISYM_Y1, GFC_STD_F2008);
+
+  add_sym_2 ("besyn", GFC_ISYM_YN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
+	     gfc_check_besn, gfc_simplify_bessel_yn, gfc_resolve_besn,
+	     n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dr, REQUIRED);
+
+  make_alias ("bessel_yn", GFC_STD_F2008);
+
+  add_sym_2 ("dbesyn", GFC_ISYM_YN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
+	     gfc_check_besn, gfc_simplify_bessel_yn, gfc_resolve_besn,
+	     n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dd, REQUIRED);
+
+  add_sym_3 ("bessel_yn", GFC_ISYM_YN2, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008,
+	     gfc_check_bessel_n2, gfc_simplify_bessel_yn2, gfc_resolve_bessel_n2,
+	     "n1", BT_INTEGER, di, REQUIRED,"n2", BT_INTEGER, di, REQUIRED,
+	      x, BT_REAL, dr, REQUIRED);
+  set_attr_value (3, true, true, true);
+
+  make_generic ("bessel_yn", GFC_ISYM_YN, GFC_STD_F2008);
+
+  add_sym_2 ("bge", GFC_ISYM_BGE, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_LOGICAL, dl, GFC_STD_F2008,
+	     gfc_check_bge_bgt_ble_blt, gfc_simplify_bge, NULL,
+	     i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("bge", GFC_ISYM_BGE, GFC_STD_F2008);
+
+  add_sym_2 ("bgt", GFC_ISYM_BGT, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_LOGICAL, dl, GFC_STD_F2008,
+	     gfc_check_bge_bgt_ble_blt, gfc_simplify_bgt, NULL,
+	     i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("bgt", GFC_ISYM_BGT, GFC_STD_F2008);
+
+  add_sym_1 ("bit_size", GFC_ISYM_BIT_SIZE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
+	     gfc_check_i, gfc_simplify_bit_size, NULL,
+	     i, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("bit_size", GFC_ISYM_BIT_SIZE, GFC_STD_F95);
+
+  add_sym_2 ("ble", GFC_ISYM_BLE, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_LOGICAL, dl, GFC_STD_F2008,
+	     gfc_check_bge_bgt_ble_blt, gfc_simplify_ble, NULL,
+	     i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("ble", GFC_ISYM_BLE, GFC_STD_F2008);
+
+  add_sym_2 ("blt", GFC_ISYM_BLT, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_LOGICAL, dl, GFC_STD_F2008,
+	     gfc_check_bge_bgt_ble_blt, gfc_simplify_blt, NULL,
+	     i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("blt", GFC_ISYM_BLT, GFC_STD_F2008);
+
+  add_sym_2 ("btest", GFC_ISYM_BTEST, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
+	     gfc_check_bitfcn, gfc_simplify_btest, gfc_resolve_btest,
+	     i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("btest", GFC_ISYM_BTEST, GFC_STD_F95);
+
+  add_sym_2 ("ceiling", GFC_ISYM_CEILING, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
+	     gfc_check_a_ikind, gfc_simplify_ceiling, gfc_resolve_ceiling,
+	     a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
+
+  make_generic ("ceiling", GFC_ISYM_CEILING, GFC_STD_F95);
+
+  add_sym_2 ("char", GFC_ISYM_CHAR, CLASS_ELEMENTAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F77,
+	     gfc_check_char, gfc_simplify_char, gfc_resolve_char,
+	     i, BT_INTEGER, di, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
+
+  make_generic ("char", GFC_ISYM_CHAR, GFC_STD_F77);
+
+  add_sym_1 ("chdir", GFC_ISYM_CHDIR, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di,
+	     GFC_STD_GNU, gfc_check_chdir, NULL, gfc_resolve_chdir,
+	     nm, BT_CHARACTER, dc, REQUIRED);
+
+  make_generic ("chdir", GFC_ISYM_CHDIR, GFC_STD_GNU);
+
+  add_sym_2 ("chmod", GFC_ISYM_CHMOD, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
+	     di, GFC_STD_GNU, gfc_check_chmod, NULL, gfc_resolve_chmod,
+	     nm, BT_CHARACTER, dc, REQUIRED, md, BT_CHARACTER, dc, REQUIRED);
+
+  make_generic ("chmod", GFC_ISYM_CHMOD, GFC_STD_GNU);
+
+  add_sym_3 ("cmplx", GFC_ISYM_CMPLX, CLASS_ELEMENTAL, ACTUAL_NO, BT_COMPLEX, dz, GFC_STD_F77,
+	     gfc_check_cmplx, gfc_simplify_cmplx, gfc_resolve_cmplx,
+	     x, BT_UNKNOWN, dr, REQUIRED, y, BT_UNKNOWN, dr, OPTIONAL,
+	     kind, BT_INTEGER, di, OPTIONAL);
+
+  make_generic ("cmplx", GFC_ISYM_CMPLX, GFC_STD_F77);
+
+  add_sym_0 ("command_argument_count", GFC_ISYM_COMMAND_ARGUMENT_COUNT, CLASS_INQUIRY, 
+	     ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2003, NULL, NULL, NULL);
+
+  make_generic ("command_argument_count", GFC_ISYM_COMMAND_ARGUMENT_COUNT,
+		GFC_STD_F2003);
+
+  add_sym_2 ("complex", GFC_ISYM_COMPLEX, CLASS_ELEMENTAL, ACTUAL_NO, BT_COMPLEX, dz, GFC_STD_GNU,
+	     gfc_check_complex, gfc_simplify_complex, gfc_resolve_complex,
+	     x, BT_UNKNOWN, dr, REQUIRED, y, BT_UNKNOWN, dr, REQUIRED);
+
+  make_generic ("complex", GFC_ISYM_COMPLEX, GFC_STD_GNU);
+
+  /* Making dcmplx a specific of cmplx causes cmplx to return a double
+     complex instead of the default complex.  */
+
+  add_sym_2 ("dcmplx", GFC_ISYM_CMPLX, CLASS_ELEMENTAL, ACTUAL_NO, BT_COMPLEX, dd, GFC_STD_GNU,
+	     gfc_check_dcmplx, gfc_simplify_dcmplx, gfc_resolve_dcmplx,
+	     x, BT_REAL, dd, REQUIRED, y, BT_REAL, dd, OPTIONAL);
+
+  make_generic ("dcmplx", GFC_ISYM_CMPLX, GFC_STD_GNU);
+
+  add_sym_1 ("conjg", GFC_ISYM_CONJG, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77,
+	     gfc_check_fn_c, gfc_simplify_conjg, gfc_resolve_conjg,
+	     z, BT_COMPLEX, dz, REQUIRED);
+
+  add_sym_1 ("dconjg", GFC_ISYM_CONJG, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU,
+	     NULL, gfc_simplify_conjg, gfc_resolve_conjg, 
+	     z, BT_COMPLEX, dd, REQUIRED);
+
+  make_generic ("conjg", GFC_ISYM_CONJG, GFC_STD_F77);
+
+  add_sym_1 ("cos", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
+	     gfc_check_fn_rc, gfc_simplify_cos, gfc_resolve_cos,
+	     x, BT_REAL, dr, REQUIRED);
+
+  add_sym_1 ("dcos", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
+	     gfc_check_fn_d, gfc_simplify_cos, gfc_resolve_cos,
+	     x, BT_REAL, dd, REQUIRED);
+
+  add_sym_1 ("ccos", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77,
+	     NULL, gfc_simplify_cos, gfc_resolve_cos,
+	     x, BT_COMPLEX, dz, REQUIRED);
+
+  add_sym_1 ("zcos", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU,
+	     NULL, gfc_simplify_cos, gfc_resolve_cos, 
+	     x, BT_COMPLEX, dd, REQUIRED);
+
+  make_alias ("cdcos", GFC_STD_GNU);
+
+  make_generic ("cos", GFC_ISYM_COS, GFC_STD_F77);
+
+  add_sym_1 ("cosh", GFC_ISYM_COSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
+	     gfc_check_fn_rc2008, gfc_simplify_cosh, gfc_resolve_cosh,
+	     x, BT_REAL, dr, REQUIRED);
+
+  add_sym_1 ("dcosh", GFC_ISYM_COSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
+	     gfc_check_fn_d, gfc_simplify_cosh, gfc_resolve_cosh,
+	     x, BT_REAL, dd, REQUIRED);
+
+  make_generic ("cosh", GFC_ISYM_COSH, GFC_STD_F77);
+
+  add_sym_3 ("count", GFC_ISYM_COUNT, CLASS_TRANSFORMATIONAL, ACTUAL_NO,
+	     BT_INTEGER, di, GFC_STD_F95,
+	     gfc_check_count, gfc_simplify_count, gfc_resolve_count,
+	     msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
+	     kind, BT_INTEGER, di, OPTIONAL);
+
+  make_generic ("count", GFC_ISYM_COUNT, GFC_STD_F95);
+
+  add_sym_3 ("cshift", GFC_ISYM_CSHIFT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
+	     gfc_check_cshift, NULL, gfc_resolve_cshift,
+	     ar, BT_REAL, dr, REQUIRED, sh, BT_INTEGER, di, REQUIRED,
+	     dm, BT_INTEGER, ii, OPTIONAL);
+
+  make_generic ("cshift", GFC_ISYM_CSHIFT, GFC_STD_F95);
+
+  add_sym_1 ("ctime", GFC_ISYM_CTIME, CLASS_IMPURE, ACTUAL_NO, BT_CHARACTER,
+	     0, GFC_STD_GNU, gfc_check_ctime, NULL, gfc_resolve_ctime,
+	     tm, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("ctime", GFC_ISYM_CTIME, GFC_STD_GNU);
+
+  add_sym_1 ("dble", GFC_ISYM_DBLE, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_F77,
+	     gfc_check_dble, gfc_simplify_dble, gfc_resolve_dble,
+	     a, BT_REAL, dr, REQUIRED);
+
+  make_generic ("dble", GFC_ISYM_DBLE, GFC_STD_F77);
+
+  add_sym_1 ("digits", GFC_ISYM_DIGITS, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
+	     gfc_check_digits, gfc_simplify_digits, NULL,
+	     x, BT_UNKNOWN, dr, REQUIRED);
+
+  make_generic ("digits", GFC_ISYM_DIGITS, GFC_STD_F95);
+
+  add_sym_2 ("dim", GFC_ISYM_DIM, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
+	     gfc_check_a_p, gfc_simplify_dim, gfc_resolve_dim,
+	     x, BT_REAL, dr, REQUIRED, y, BT_REAL, dr, REQUIRED);
+
+  add_sym_2 ("idim", GFC_ISYM_DIM, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
+	     NULL, gfc_simplify_dim, gfc_resolve_dim,
+	     x, BT_INTEGER, di, REQUIRED, y, BT_INTEGER, di, REQUIRED);
+
+  add_sym_2 ("ddim", GFC_ISYM_DIM, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
+	     gfc_check_x_yd, gfc_simplify_dim, gfc_resolve_dim,
+	     x, BT_REAL, dd, REQUIRED, y, BT_REAL, dd, REQUIRED);
+
+  make_generic ("dim", GFC_ISYM_DIM, GFC_STD_F77);
+
+  add_sym_2 ("dot_product", GFC_ISYM_DOT_PRODUCT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr,
+	     GFC_STD_F95, gfc_check_dot_product, gfc_simplify_dot_product, gfc_resolve_dot_product,
+	     va, BT_REAL, dr, REQUIRED, vb, BT_REAL, dr, REQUIRED);
+
+  make_generic ("dot_product", GFC_ISYM_DOT_PRODUCT, GFC_STD_F95);
+
+  add_sym_2 ("dprod", GFC_ISYM_DPROD,CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
+	     gfc_check_dprod, gfc_simplify_dprod, gfc_resolve_dprod,
+	     x, BT_REAL, dr, REQUIRED, y, BT_REAL, dr, REQUIRED);
+
+  make_generic ("dprod", GFC_ISYM_DPROD, GFC_STD_F77);
+
+  add_sym_1 ("dreal", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_REAL, dd, GFC_STD_GNU, NULL, gfc_simplify_dreal, NULL,
+	     a, BT_COMPLEX, dd, REQUIRED);
+
+  make_generic ("dreal", GFC_ISYM_REAL, GFC_STD_GNU);
+
+  add_sym_3 ("dshiftl", GFC_ISYM_DSHIFTL, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_INTEGER, di, GFC_STD_F2008,
+	     gfc_check_dshift, gfc_simplify_dshiftl, gfc_resolve_dshift,
+	     i, BT_INTEGER, di, REQUIRED,
+	     j, BT_INTEGER, di, REQUIRED,
+	     sh, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("dshiftl", GFC_ISYM_DSHIFTL, GFC_STD_F2008);
+
+  add_sym_3 ("dshiftr", GFC_ISYM_DSHIFTR, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_INTEGER, di, GFC_STD_F2008,
+	     gfc_check_dshift, gfc_simplify_dshiftr, gfc_resolve_dshift,
+	     i, BT_INTEGER, di, REQUIRED,
+	     j, BT_INTEGER, di, REQUIRED,
+	     sh, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("dshiftr", GFC_ISYM_DSHIFTR, GFC_STD_F2008);
+
+  add_sym_4 ("eoshift", GFC_ISYM_EOSHIFT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
+	     gfc_check_eoshift, NULL, gfc_resolve_eoshift,
+	     ar, BT_REAL, dr, REQUIRED, sh, BT_INTEGER, ii, REQUIRED,
+	     bd, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL);
+
+  make_generic ("eoshift", GFC_ISYM_EOSHIFT, GFC_STD_F95);
+
+  add_sym_1 ("epsilon", GFC_ISYM_EPSILON, CLASS_INQUIRY, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
+	     gfc_check_x, gfc_simplify_epsilon, NULL,
+	     x, BT_REAL, dr, REQUIRED);
+
+  make_generic ("epsilon", GFC_ISYM_EPSILON, GFC_STD_F95);
+
+  /* G77 compatibility for the ERF() and ERFC() functions.  */
+  add_sym_1 ("erf", GFC_ISYM_ERF, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr,
+	     GFC_STD_F2008, gfc_check_fn_r, gfc_simplify_erf,
+	     gfc_resolve_g77_math1, x, BT_REAL, dr, REQUIRED);
+
+  add_sym_1 ("derf", GFC_ISYM_ERF, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd,
+	     GFC_STD_GNU, gfc_check_fn_d, gfc_simplify_erf,
+	     gfc_resolve_g77_math1, x, BT_REAL, dd, REQUIRED);
+
+  make_generic ("erf", GFC_ISYM_ERF, GFC_STD_F2008);
+
+  add_sym_1 ("erfc", GFC_ISYM_ERFC, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr,
+	     GFC_STD_F2008, gfc_check_fn_r, gfc_simplify_erfc,
+	     gfc_resolve_g77_math1, x, BT_REAL, dr, REQUIRED);
+
+  add_sym_1 ("derfc", GFC_ISYM_ERFC, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd,
+	     GFC_STD_GNU, gfc_check_fn_d, gfc_simplify_erfc,
+	     gfc_resolve_g77_math1, x, BT_REAL, dd, REQUIRED);
+
+  make_generic ("erfc", GFC_ISYM_ERFC, GFC_STD_F2008);
+
+  add_sym_1 ("erfc_scaled", GFC_ISYM_ERFC_SCALED, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_REAL, dr, GFC_STD_F2008, gfc_check_fn_r,
+	     gfc_simplify_erfc_scaled, gfc_resolve_g77_math1, x, BT_REAL,
+	     dr, REQUIRED);
+
+  make_generic ("erfc_scaled", GFC_ISYM_ERFC_SCALED, GFC_STD_F2008);
+
+  /* G77 compatibility */
+  add_sym_1 ("dtime", GFC_ISYM_DTIME, CLASS_IMPURE, ACTUAL_NO, BT_REAL,
+	     4, GFC_STD_GNU, gfc_check_dtime_etime, NULL, NULL,
+	     x, BT_REAL, 4, REQUIRED);
+
+  make_generic ("dtime", GFC_ISYM_DTIME, GFC_STD_GNU);
+
+  add_sym_1 ("etime", GFC_ISYM_ETIME, CLASS_IMPURE, ACTUAL_NO, BT_REAL,
+	     4, GFC_STD_GNU, gfc_check_dtime_etime, NULL, NULL,
+	     x, BT_REAL, 4, REQUIRED);
+
+  make_generic ("etime", GFC_ISYM_ETIME, GFC_STD_GNU);
+
+  add_sym_1 ("exp", GFC_ISYM_EXP, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr,  GFC_STD_F77,
+	     gfc_check_fn_rc, gfc_simplify_exp, gfc_resolve_exp,
+	     x, BT_REAL, dr, REQUIRED);
+
+  add_sym_1 ("dexp", GFC_ISYM_EXP, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
+	     gfc_check_fn_d, gfc_simplify_exp, gfc_resolve_exp,
+	     x, BT_REAL, dd, REQUIRED);
+
+  add_sym_1 ("cexp", GFC_ISYM_EXP, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77,
+	     NULL, gfc_simplify_exp, gfc_resolve_exp,
+	     x, BT_COMPLEX, dz, REQUIRED);
+
+  add_sym_1 ("zexp", GFC_ISYM_EXP, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd,  GFC_STD_GNU,
+	     NULL, gfc_simplify_exp, gfc_resolve_exp, 
+	     x, BT_COMPLEX, dd, REQUIRED);
+
+  make_alias ("cdexp", GFC_STD_GNU);
+
+  make_generic ("exp", GFC_ISYM_EXP, GFC_STD_F77);
+
+  add_sym_1 ("exponent", GFC_ISYM_EXPONENT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
+	     gfc_check_x, gfc_simplify_exponent, gfc_resolve_exponent,
+	     x, BT_REAL, dr, REQUIRED);
+
+  make_generic ("exponent", GFC_ISYM_EXPONENT, GFC_STD_F95);
+
+  add_sym_2 ("extends_type_of", GFC_ISYM_EXTENDS_TYPE_OF, CLASS_INQUIRY,
+	     ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003,
+	     gfc_check_same_type_as, gfc_simplify_extends_type_of,
+	     gfc_resolve_extends_type_of,
+	     a, BT_UNKNOWN, 0, REQUIRED,
+	     mo, BT_UNKNOWN, 0, REQUIRED);
+
+  add_sym_0 ("fdate",  GFC_ISYM_FDATE, CLASS_IMPURE, ACTUAL_NO, BT_CHARACTER,
+	     dc, GFC_STD_GNU, NULL, NULL, gfc_resolve_fdate);
+
+  make_generic ("fdate", GFC_ISYM_FDATE, GFC_STD_GNU);
+
+  add_sym_2 ("floor", GFC_ISYM_FLOOR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
+	     gfc_check_a_ikind, gfc_simplify_floor, gfc_resolve_floor,
+	     a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
+
+  make_generic ("floor", GFC_ISYM_FLOOR, GFC_STD_F95);
+
+  /* G77 compatible fnum */
+  add_sym_1 ("fnum", GFC_ISYM_FNUM, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
+	     di, GFC_STD_GNU, gfc_check_fnum, NULL, gfc_resolve_fnum,
+	     ut, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("fnum", GFC_ISYM_FNUM, GFC_STD_GNU);
+
+  add_sym_1 ("fraction", GFC_ISYM_FRACTION, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
+	     gfc_check_x, gfc_simplify_fraction, gfc_resolve_fraction,
+	     x, BT_REAL, dr, REQUIRED);
+
+  make_generic ("fraction", GFC_ISYM_FRACTION, GFC_STD_F95);
+
+  add_sym_2_intent ("fstat", GFC_ISYM_FSTAT, CLASS_IMPURE, ACTUAL_NO,
+		    BT_INTEGER, di, GFC_STD_GNU,
+		    gfc_check_fstat, NULL, gfc_resolve_fstat,
+		    ut, BT_INTEGER, di, REQUIRED, INTENT_IN,
+		    vl, BT_INTEGER, di, REQUIRED, INTENT_OUT);
+
+  make_generic ("fstat", GFC_ISYM_FSTAT, GFC_STD_GNU);
+
+  add_sym_1 ("ftell", GFC_ISYM_FTELL, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
+	     ii, GFC_STD_GNU, gfc_check_ftell, NULL, gfc_resolve_ftell,
+	     ut, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("ftell", GFC_ISYM_FTELL, GFC_STD_GNU);
+
+  add_sym_2_intent ("fgetc", GFC_ISYM_FGETC, CLASS_IMPURE, ACTUAL_NO,
+		    BT_INTEGER, di, GFC_STD_GNU,
+		    gfc_check_fgetputc, NULL, gfc_resolve_fgetc,
+		    ut, BT_INTEGER, di, REQUIRED, INTENT_IN,
+		    c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT);
+
+  make_generic ("fgetc", GFC_ISYM_FGETC, GFC_STD_GNU);
+
+  add_sym_1_intent ("fget", GFC_ISYM_FGET, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
+	     di, GFC_STD_GNU, gfc_check_fgetput, NULL, gfc_resolve_fget,
+	     c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT);
+
+  make_generic ("fget", GFC_ISYM_FGET, GFC_STD_GNU);
+
+  add_sym_2 ("fputc", GFC_ISYM_FPUTC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
+	     di, GFC_STD_GNU, gfc_check_fgetputc, NULL, gfc_resolve_fputc,
+	     ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED);
+
+  make_generic ("fputc", GFC_ISYM_FPUTC, GFC_STD_GNU);
+
+  add_sym_1 ("fput", GFC_ISYM_FPUT, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
+	     di, GFC_STD_GNU, gfc_check_fgetput, NULL, gfc_resolve_fput,
+	     c, BT_CHARACTER, dc, REQUIRED);
+
+  make_generic ("fput", GFC_ISYM_FPUT, GFC_STD_GNU);
+
+  add_sym_1 ("gamma", GFC_ISYM_TGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr,
+	     GFC_STD_F2008, gfc_check_fn_r, gfc_simplify_gamma,
+	     gfc_resolve_gamma, x, BT_REAL, dr, REQUIRED);
+
+  add_sym_1 ("dgamma", GFC_ISYM_TGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
+	     gfc_check_fn_d, gfc_simplify_gamma, gfc_resolve_gamma,
+	     x, BT_REAL, dr, REQUIRED);
+
+  make_generic ("gamma", GFC_ISYM_TGAMMA, GFC_STD_F2008);
+
+  /* Unix IDs (g77 compatibility)  */
+  add_sym_1 ("getcwd", GFC_ISYM_GETCWD, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
+	     di,  GFC_STD_GNU, NULL, NULL, gfc_resolve_getcwd,
+	     c, BT_CHARACTER, dc, REQUIRED);
+
+  make_generic ("getcwd", GFC_ISYM_GETCWD, GFC_STD_GNU);
+
+  add_sym_0 ("getgid", GFC_ISYM_GETGID, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
+	     di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getgid);
+
+  make_generic ("getgid", GFC_ISYM_GETGID, GFC_STD_GNU);
+
+  add_sym_0 ("getpid", GFC_ISYM_GETPID, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
+	     di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getpid);
+
+  make_generic ("getpid", GFC_ISYM_GETPID, GFC_STD_GNU);
+
+  add_sym_0 ("getuid", GFC_ISYM_GETUID, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
+	     di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getuid);
+
+  make_generic ("getuid", GFC_ISYM_GETUID, GFC_STD_GNU);
+
+  add_sym_1_intent ("hostnm", GFC_ISYM_HOSTNM, CLASS_IMPURE, ACTUAL_NO,
+		    BT_INTEGER, di, GFC_STD_GNU,
+		    gfc_check_hostnm, NULL, gfc_resolve_hostnm,
+		    c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT);
+
+  make_generic ("hostnm", GFC_ISYM_HOSTNM, GFC_STD_GNU);
+
+  add_sym_1 ("huge", GFC_ISYM_HUGE, CLASS_INQUIRY, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
+	     gfc_check_huge, gfc_simplify_huge, NULL,
+	     x, BT_UNKNOWN, dr, REQUIRED);
+
+  make_generic ("huge", GFC_ISYM_HUGE, GFC_STD_F95);
+
+  add_sym_2 ("hypot", GFC_ISYM_HYPOT, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_REAL, dr, GFC_STD_F2008,
+	     gfc_check_hypot, gfc_simplify_hypot, gfc_resolve_hypot,
+	     x, BT_REAL, dr, REQUIRED, y, BT_REAL, dr, REQUIRED);
+
+  make_generic ("hypot", GFC_ISYM_HYPOT, GFC_STD_F2008);
+
+  add_sym_2 ("iachar", GFC_ISYM_IACHAR, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_INTEGER, di, GFC_STD_F95,
+	     gfc_check_ichar_iachar, gfc_simplify_iachar, gfc_resolve_iachar,
+	     c, BT_CHARACTER, dc, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
+
+  make_generic ("iachar", GFC_ISYM_IACHAR, GFC_STD_F95);
+
+  add_sym_2 ("iand", GFC_ISYM_IAND, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
+	     gfc_check_iand, gfc_simplify_iand, gfc_resolve_iand,
+	     i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("iand", GFC_ISYM_IAND, GFC_STD_F95);
+
+  add_sym_2 ("and", GFC_ISYM_AND, CLASS_IMPURE, ACTUAL_NO, BT_LOGICAL,
+	     dl, GFC_STD_GNU, gfc_check_and, gfc_simplify_and, gfc_resolve_and,
+	     i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED);
+
+  make_generic ("and", GFC_ISYM_AND, GFC_STD_GNU);
+
+  add_sym_3red ("iall", GFC_ISYM_IALL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008,
+		gfc_check_transf_bit_intrins, gfc_simplify_iall, gfc_resolve_iall,
+		ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
+		msk, BT_LOGICAL, dl, OPTIONAL);
+
+  make_generic ("iall", GFC_ISYM_IALL, GFC_STD_F2008);
+
+  add_sym_3red ("iany", GFC_ISYM_IANY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008,
+		gfc_check_transf_bit_intrins, gfc_simplify_iany, gfc_resolve_iany,
+		ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
+		msk, BT_LOGICAL, dl, OPTIONAL);
+
+  make_generic ("iany", GFC_ISYM_IANY, GFC_STD_F2008);
+
+  add_sym_0 ("iargc", GFC_ISYM_IARGC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
+	     di, GFC_STD_GNU, NULL, NULL, NULL);
+
+  make_generic ("iargc", GFC_ISYM_IARGC, GFC_STD_GNU);
+
+  add_sym_2 ("ibclr", GFC_ISYM_IBCLR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
+	     gfc_check_bitfcn, gfc_simplify_ibclr, gfc_resolve_ibclr,
+	     i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("ibclr", GFC_ISYM_IBCLR, GFC_STD_F95);
+
+  add_sym_3 ("ibits", GFC_ISYM_IBITS, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
+	     gfc_check_ibits, gfc_simplify_ibits, gfc_resolve_ibits,
+	     i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED,
+	     ln, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("ibits", GFC_ISYM_IBITS, GFC_STD_F95);
+
+  add_sym_2 ("ibset", GFC_ISYM_IBSET, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
+	     gfc_check_bitfcn, gfc_simplify_ibset, gfc_resolve_ibset,
+	     i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("ibset", GFC_ISYM_IBSET, GFC_STD_F95);
+
+  add_sym_2 ("ichar", GFC_ISYM_ICHAR, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_INTEGER, di, GFC_STD_F77,
+	     gfc_check_ichar_iachar, gfc_simplify_ichar, gfc_resolve_ichar,
+	     c, BT_CHARACTER, dc, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
+
+  make_generic ("ichar", GFC_ISYM_ICHAR, GFC_STD_F77);
+
+  add_sym_2 ("ieor", GFC_ISYM_IEOR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
+	     gfc_check_ieor, gfc_simplify_ieor, gfc_resolve_ieor,
+	     i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("ieor", GFC_ISYM_IEOR, GFC_STD_F95);
+
+  add_sym_2 ("xor", GFC_ISYM_XOR, CLASS_IMPURE, ACTUAL_NO, BT_LOGICAL,
+	     dl, GFC_STD_GNU, gfc_check_and, gfc_simplify_xor, gfc_resolve_xor,
+	     i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED);
+
+  make_generic ("xor", GFC_ISYM_XOR, GFC_STD_GNU);
+
+  add_sym_0 ("ierrno", GFC_ISYM_IERRNO, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
+	     di, GFC_STD_GNU, NULL, NULL, gfc_resolve_ierrno);
+
+  make_generic ("ierrno", GFC_ISYM_IERRNO, GFC_STD_GNU);
+
+  add_sym_2 ("image_index", GFC_ISYM_IMAGE_INDEX, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008,
+	     gfc_check_image_index, gfc_simplify_image_index, gfc_resolve_image_index,
+	     ca, BT_REAL, dr, REQUIRED, sub, BT_INTEGER, ii, REQUIRED);
+
+  /* The resolution function for INDEX is called gfc_resolve_index_func
+     because the name gfc_resolve_index is already used in resolve.c.  */
+  add_sym_4 ("index", GFC_ISYM_INDEX, CLASS_ELEMENTAL, ACTUAL_YES,
+	     BT_INTEGER, di, GFC_STD_F77,
+	     gfc_check_index, gfc_simplify_index, gfc_resolve_index_func,
+	     stg, BT_CHARACTER, dc, REQUIRED, ssg, BT_CHARACTER, dc, REQUIRED,
+	     bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL);
+
+  make_generic ("index", GFC_ISYM_INDEX, GFC_STD_F77);
+
+  add_sym_2 ("int", GFC_ISYM_INT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
+	     gfc_check_int, gfc_simplify_int, gfc_resolve_int,
+	     a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
+
+  add_sym_1 ("ifix", GFC_ISYM_INT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
+	     NULL, gfc_simplify_ifix, NULL,
+	     a, BT_REAL, dr, REQUIRED);
+
+  add_sym_1 ("idint", GFC_ISYM_INT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
+	     NULL, gfc_simplify_idint, NULL,
+	     a, BT_REAL, dd, REQUIRED);
+
+  make_generic ("int", GFC_ISYM_INT, GFC_STD_F77);
+
+  add_sym_1 ("int2", GFC_ISYM_INT2, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
+	     gfc_check_intconv, gfc_simplify_int2, gfc_resolve_int2,
+	     a, BT_REAL, dr, REQUIRED);
+
+  make_alias ("short", GFC_STD_GNU);
+
+  make_generic ("int2", GFC_ISYM_INT2, GFC_STD_GNU);
+
+  add_sym_1 ("int8", GFC_ISYM_INT8, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
+	     gfc_check_intconv, gfc_simplify_int8, gfc_resolve_int8,
+	     a, BT_REAL, dr, REQUIRED);
+
+  make_generic ("int8", GFC_ISYM_INT8, GFC_STD_GNU);
+
+  add_sym_1 ("long", GFC_ISYM_LONG, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
+	     gfc_check_intconv, gfc_simplify_long, gfc_resolve_long,
+	     a, BT_REAL, dr, REQUIRED);
+
+  make_generic ("long", GFC_ISYM_LONG, GFC_STD_GNU);
+
+  add_sym_2 ("ior", GFC_ISYM_IOR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
+	     gfc_check_ior, gfc_simplify_ior, gfc_resolve_ior,
+	     i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("ior", GFC_ISYM_IOR, GFC_STD_F95);
+
+  add_sym_2 ("or", GFC_ISYM_OR, CLASS_IMPURE, ACTUAL_NO, BT_LOGICAL,
+	     dl, GFC_STD_GNU, gfc_check_and, gfc_simplify_or, gfc_resolve_or,
+	     i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED);
+
+  make_generic ("or", GFC_ISYM_OR, GFC_STD_GNU);
+
+  add_sym_3red ("iparity", GFC_ISYM_IPARITY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008,
+		gfc_check_transf_bit_intrins, gfc_simplify_iparity, gfc_resolve_iparity,
+		ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
+		msk, BT_LOGICAL, dl, OPTIONAL);
+
+  make_generic ("iparity", GFC_ISYM_IPARITY, GFC_STD_F2008);
+
+  /* The following function is for G77 compatibility.  */
+  add_sym_1 ("irand", GFC_ISYM_IRAND, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
+	     4, GFC_STD_GNU, gfc_check_irand, NULL, NULL,
+	     i, BT_INTEGER, 4, OPTIONAL);
+
+  make_generic ("irand", GFC_ISYM_IRAND, GFC_STD_GNU);
+
+  add_sym_1 ("isatty", GFC_ISYM_ISATTY, CLASS_IMPURE, ACTUAL_NO, BT_LOGICAL,
+	     dl, GFC_STD_GNU, gfc_check_isatty, NULL, gfc_resolve_isatty,
+	     ut, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("isatty", GFC_ISYM_ISATTY, GFC_STD_GNU);
+
+  add_sym_1 ("is_iostat_end", GFC_ISYM_IS_IOSTAT_END,
+	     CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003,
+	     gfc_check_i, gfc_simplify_is_iostat_end, NULL,
+	     i, BT_INTEGER, 0, REQUIRED);
+
+  make_generic ("is_iostat_end", GFC_ISYM_IS_IOSTAT_END, GFC_STD_F2003);
+
+  add_sym_1 ("is_iostat_eor", GFC_ISYM_IS_IOSTAT_EOR,
+	     CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003,
+	     gfc_check_i, gfc_simplify_is_iostat_eor, NULL,
+	     i, BT_INTEGER, 0, REQUIRED);
+
+  make_generic ("is_iostat_eor", GFC_ISYM_IS_IOSTAT_EOR, GFC_STD_F2003);
+
+  add_sym_1 ("isnan", GFC_ISYM_ISNAN, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_LOGICAL, dl, GFC_STD_GNU,
+	     gfc_check_isnan, gfc_simplify_isnan, NULL,
+	     x, BT_REAL, 0, REQUIRED);
+
+  make_generic ("isnan", GFC_ISYM_ISNAN, GFC_STD_GNU);
+
+  add_sym_2 ("rshift", GFC_ISYM_RSHIFT, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_INTEGER, di, GFC_STD_GNU,
+	     gfc_check_ishft, gfc_simplify_rshift, gfc_resolve_rshift,
+	     i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("rshift", GFC_ISYM_RSHIFT, GFC_STD_GNU);
+
+  add_sym_2 ("lshift", GFC_ISYM_LSHIFT, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_INTEGER, di, GFC_STD_GNU,
+	     gfc_check_ishft, gfc_simplify_lshift, gfc_resolve_lshift,
+	     i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("lshift", GFC_ISYM_LSHIFT, GFC_STD_GNU);
+
+  add_sym_2 ("ishft", GFC_ISYM_ISHFT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
+	     gfc_check_ishft, gfc_simplify_ishft, gfc_resolve_ishft,
+	     i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("ishft", GFC_ISYM_ISHFT, GFC_STD_F95);
+
+  add_sym_3 ("ishftc", GFC_ISYM_ISHFTC, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
+	     gfc_check_ishftc, gfc_simplify_ishftc, gfc_resolve_ishftc,
+	     i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED,
+	     sz, BT_INTEGER, di, OPTIONAL);
+
+  make_generic ("ishftc", GFC_ISYM_ISHFTC, GFC_STD_F95);
+
+  add_sym_2 ("kill", GFC_ISYM_KILL, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
+	     di, GFC_STD_GNU, gfc_check_kill, NULL, gfc_resolve_kill,
+	     a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("kill", GFC_ISYM_KILL, GFC_STD_GNU);
+
+  add_sym_1 ("kind", GFC_ISYM_KIND, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
+	     gfc_check_kind, gfc_simplify_kind, NULL,
+	     x, BT_REAL, dr, REQUIRED);
+
+  make_generic ("kind", GFC_ISYM_KIND, GFC_STD_F95);
+
+  add_sym_3 ("lbound", GFC_ISYM_LBOUND, CLASS_INQUIRY, ACTUAL_NO,
+	     BT_INTEGER, di, GFC_STD_F95,
+	     gfc_check_lbound, gfc_simplify_lbound, gfc_resolve_lbound,
+	     ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, di, OPTIONAL,
+	     kind, BT_INTEGER, di, OPTIONAL);
+
+  make_generic ("lbound", GFC_ISYM_LBOUND, GFC_STD_F95);
+
+  add_sym_3 ("lcobound", GFC_ISYM_LCOBOUND, CLASS_INQUIRY, ACTUAL_NO,
+	     BT_INTEGER, di, GFC_STD_F2008,
+	     gfc_check_lcobound, gfc_simplify_lcobound, gfc_resolve_lcobound,
+	     ca, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
+	     kind, BT_INTEGER, di, OPTIONAL);
+
+  make_generic ("lcobound", GFC_ISYM_LCOBOUND, GFC_STD_F2008);
+
+  add_sym_1 ("leadz", GFC_ISYM_LEADZ, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_INTEGER, di, GFC_STD_F2008,
+	     gfc_check_i, gfc_simplify_leadz, NULL,
+	     i, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("leadz", GFC_ISYM_LEADZ, GFC_STD_F2008);
+
+  add_sym_2 ("len", GFC_ISYM_LEN, CLASS_INQUIRY, ACTUAL_YES,
+	     BT_INTEGER, di, GFC_STD_F77,
+	     gfc_check_len_lentrim, gfc_simplify_len, gfc_resolve_len,
+	     stg, BT_CHARACTER, dc, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
+
+  make_generic ("len", GFC_ISYM_LEN, GFC_STD_F77);
+
+  add_sym_2 ("len_trim", GFC_ISYM_LEN_TRIM, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_INTEGER, di, GFC_STD_F95,
+	     gfc_check_len_lentrim, gfc_simplify_len_trim, gfc_resolve_len_trim,
+	     stg, BT_CHARACTER, dc, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
+
+  make_alias ("lnblnk", GFC_STD_GNU);
+
+  make_generic ("len_trim", GFC_ISYM_LEN_TRIM, GFC_STD_F95);
+
+  add_sym_1 ("lgamma", GFC_ISYM_LGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL,
+	     dr, GFC_STD_GNU,
+	     gfc_check_fn_r, gfc_simplify_lgamma, gfc_resolve_lgamma,
+	     x, BT_REAL, dr, REQUIRED);
+
+  make_alias ("log_gamma", GFC_STD_F2008);
+
+  add_sym_1 ("algama", GFC_ISYM_LGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
+	     gfc_check_fn_r, gfc_simplify_lgamma, gfc_resolve_lgamma,
+	     x, BT_REAL, dr, REQUIRED);
+
+  add_sym_1 ("dlgama", GFC_ISYM_LGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
+	     gfc_check_fn_d, gfc_simplify_lgamma, gfc_resolve_lgamma,
+	     x, BT_REAL, dr, REQUIRED);
+
+  make_generic ("log_gamma", GFC_ISYM_LGAMMA, GFC_STD_F2008);
+
+
+  add_sym_2 ("lge", GFC_ISYM_LGE, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl,
+	     GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_lge, NULL,
+	     sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
+
+  make_generic ("lge", GFC_ISYM_LGE, GFC_STD_F77);
+
+  add_sym_2 ("lgt", GFC_ISYM_LGT, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl,
+	     GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_lgt, NULL,
+	     sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
+
+  make_generic ("lgt", GFC_ISYM_LGT, GFC_STD_F77);
+
+  add_sym_2 ("lle",GFC_ISYM_LLE,  CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl,
+	     GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_lle, NULL,
+	     sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
+
+  make_generic ("lle", GFC_ISYM_LLE, GFC_STD_F77);
+
+  add_sym_2 ("llt", GFC_ISYM_LLT, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl,
+	     GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_llt, NULL,
+	     sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
+
+  make_generic ("llt", GFC_ISYM_LLT, GFC_STD_F77);
+
+  add_sym_2 ("link", GFC_ISYM_LINK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di,
+	     GFC_STD_GNU, gfc_check_link, NULL, gfc_resolve_link,
+	     p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED);
+
+  make_generic ("link", GFC_ISYM_LINK, GFC_STD_GNU);
+  
+  add_sym_1 ("log", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
+	     gfc_check_fn_rc, gfc_simplify_log, gfc_resolve_log,
+	     x, BT_REAL, dr, REQUIRED);
+
+  add_sym_1 ("alog", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
+	     NULL, gfc_simplify_log, gfc_resolve_log,
+	     x, BT_REAL, dr, REQUIRED);
+
+  add_sym_1 ("dlog", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
+	     gfc_check_fn_d, gfc_simplify_log, gfc_resolve_log,
+	     x, BT_REAL, dd, REQUIRED);
+
+  add_sym_1 ("clog", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77,
+	     NULL, gfc_simplify_log, gfc_resolve_log,
+	     x, BT_COMPLEX, dz, REQUIRED);
+
+  add_sym_1 ("zlog", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd,  GFC_STD_GNU,
+	     NULL, gfc_simplify_log, gfc_resolve_log,
+	     x, BT_COMPLEX, dd, REQUIRED);
+
+  make_alias ("cdlog", GFC_STD_GNU);
+
+  make_generic ("log", GFC_ISYM_LOG, GFC_STD_F77);
+
+  add_sym_1 ("log10", GFC_ISYM_LOG10, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
+	     gfc_check_fn_r, gfc_simplify_log10, gfc_resolve_log10,
+	     x, BT_REAL, dr, REQUIRED);
+
+  add_sym_1 ("alog10", GFC_ISYM_LOG10, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
+	     NULL, gfc_simplify_log10, gfc_resolve_log10,
+	     x, BT_REAL, dr, REQUIRED);
+
+  add_sym_1 ("dlog10", GFC_ISYM_LOG10, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
+	     gfc_check_fn_d, gfc_simplify_log10, gfc_resolve_log10,
+	     x, BT_REAL, dd, REQUIRED);
+
+  make_generic ("log10", GFC_ISYM_LOG10, GFC_STD_F77);
+
+  add_sym_2 ("logical", GFC_ISYM_LOGICAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
+	     gfc_check_logical, gfc_simplify_logical, gfc_resolve_logical,
+	     l, BT_LOGICAL, dl, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
+
+  make_generic ("logical", GFC_ISYM_LOGICAL, GFC_STD_F95);
+
+  add_sym_2_intent ("lstat", GFC_ISYM_LSTAT, CLASS_IMPURE, ACTUAL_NO,
+		    BT_INTEGER, di, GFC_STD_GNU,
+		    gfc_check_stat, NULL, gfc_resolve_lstat,
+		    nm, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
+		    vl, BT_INTEGER, di, REQUIRED, INTENT_OUT);
+
+  make_generic ("lstat", GFC_ISYM_LSTAT, GFC_STD_GNU);
+
+  add_sym_1 ("malloc", GFC_ISYM_MALLOC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, ii,
+	     GFC_STD_GNU, gfc_check_malloc, NULL, gfc_resolve_malloc,
+	     sz, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("malloc", GFC_ISYM_MALLOC, GFC_STD_GNU);
+
+  add_sym_2 ("maskl", GFC_ISYM_MASKL, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_INTEGER, di, GFC_STD_F2008,
+	     gfc_check_mask, gfc_simplify_maskl, gfc_resolve_mask,
+	     i, BT_INTEGER, di, REQUIRED,
+	     kind, BT_INTEGER, di, OPTIONAL);
+
+  make_generic ("maskl", GFC_ISYM_MASKL, GFC_STD_F2008);
+
+  add_sym_2 ("maskr", GFC_ISYM_MASKR, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_INTEGER, di, GFC_STD_F2008,
+	     gfc_check_mask, gfc_simplify_maskr, gfc_resolve_mask,
+	     i, BT_INTEGER, di, REQUIRED,
+	     kind, BT_INTEGER, di, OPTIONAL);
+
+  make_generic ("maskr", GFC_ISYM_MASKR, GFC_STD_F2008);
+
+  add_sym_2 ("matmul", GFC_ISYM_MATMUL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
+	     gfc_check_matmul, gfc_simplify_matmul, gfc_resolve_matmul,
+	     ma, BT_REAL, dr, REQUIRED, mb, BT_REAL, dr, REQUIRED);
+
+  make_generic ("matmul", GFC_ISYM_MATMUL, GFC_STD_F95);
+
+  /* Note: amax0 is equivalent to real(max), max1 is equivalent to
+     int(max).  The max function must take at least two arguments.  */
+
+  add_sym_1m ("max", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_UNKNOWN, 0, GFC_STD_F77,
+	     gfc_check_min_max, gfc_simplify_max, gfc_resolve_max,
+	     a1, BT_UNKNOWN, dr, REQUIRED, a2, BT_UNKNOWN, dr, REQUIRED);
+
+  add_sym_1m ("max0", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
+	     gfc_check_min_max_integer, gfc_simplify_max, NULL,
+	     a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
+
+  add_sym_1m ("amax0", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
+	     gfc_check_min_max_integer, gfc_simplify_max, NULL,
+	     a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
+
+  add_sym_1m ("amax1", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
+	     gfc_check_min_max_real, gfc_simplify_max, NULL,
+	     a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
+
+  add_sym_1m ("max1", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
+	     gfc_check_min_max_real, gfc_simplify_max, NULL,
+	     a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
+
+  add_sym_1m ("dmax1", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_F77,
+	     gfc_check_min_max_double, gfc_simplify_max, NULL,
+	     a1, BT_REAL, dd, REQUIRED, a2, BT_REAL, dd, REQUIRED);
+
+  make_generic ("max", GFC_ISYM_MAX, GFC_STD_F77);
+
+  add_sym_1 ("maxexponent", GFC_ISYM_MAXEXPONENT, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di,
+	     GFC_STD_F95, gfc_check_x, gfc_simplify_maxexponent, NULL,
+	     x, BT_UNKNOWN, dr, REQUIRED);
+
+  make_generic ("maxexponent", GFC_ISYM_MAXEXPONENT, GFC_STD_F95);
+
+  add_sym_3ml ("maxloc", GFC_ISYM_MAXLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
+	       gfc_check_minloc_maxloc, NULL, gfc_resolve_maxloc,
+	       ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
+	       msk, BT_LOGICAL, dl, OPTIONAL);
+
+  make_generic ("maxloc", GFC_ISYM_MAXLOC, GFC_STD_F95);
+
+  add_sym_3red ("maxval", GFC_ISYM_MAXVAL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
+		gfc_check_minval_maxval, gfc_simplify_maxval, gfc_resolve_maxval,
+		ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
+		msk, BT_LOGICAL, dl, OPTIONAL);
+
+  make_generic ("maxval", GFC_ISYM_MAXVAL, GFC_STD_F95);
+
+  add_sym_0 ("mclock", GFC_ISYM_MCLOCK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di,
+	     GFC_STD_GNU, NULL, NULL, gfc_resolve_mclock);
+
+  make_generic ("mclock", GFC_ISYM_MCLOCK, GFC_STD_GNU);
+
+  add_sym_0 ("mclock8", GFC_ISYM_MCLOCK8, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
+	     di, GFC_STD_GNU, NULL, NULL, gfc_resolve_mclock8);
+
+  make_generic ("mclock8", GFC_ISYM_MCLOCK8, GFC_STD_GNU);
+
+  add_sym_3 ("merge", GFC_ISYM_MERGE, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
+	     gfc_check_merge, gfc_simplify_merge, gfc_resolve_merge,
+	     ts, BT_REAL, dr, REQUIRED, fs, BT_REAL, dr, REQUIRED,
+	     msk, BT_LOGICAL, dl, REQUIRED);
+
+  make_generic ("merge", GFC_ISYM_MERGE, GFC_STD_F95);
+
+  add_sym_3 ("merge_bits", GFC_ISYM_MERGE_BITS, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_INTEGER, di, GFC_STD_F2008,
+	     gfc_check_merge_bits, gfc_simplify_merge_bits,
+	     gfc_resolve_merge_bits,
+	     i, BT_INTEGER, di, REQUIRED,
+	     j, BT_INTEGER, di, REQUIRED,
+	     msk, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("merge_bits", GFC_ISYM_MERGE_BITS, GFC_STD_F2008);
+
+  /* Note: amin0 is equivalent to real(min), min1 is equivalent to
+     int(min).  */
+
+  add_sym_1m ("min", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_UNKNOWN, 0, GFC_STD_F77,
+	      gfc_check_min_max, gfc_simplify_min, gfc_resolve_min,
+	      a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
+
+  add_sym_1m ("min0", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
+	      gfc_check_min_max_integer, gfc_simplify_min, NULL,
+	      a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
+
+  add_sym_1m ("amin0", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
+	      gfc_check_min_max_integer, gfc_simplify_min, NULL,
+	      a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
+
+  add_sym_1m ("amin1", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
+	      gfc_check_min_max_real, gfc_simplify_min, NULL,
+	      a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
+
+  add_sym_1m ("min1", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
+	      gfc_check_min_max_real, gfc_simplify_min, NULL,
+	      a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
+
+  add_sym_1m ("dmin1", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_F77,
+	      gfc_check_min_max_double, gfc_simplify_min, NULL,
+	      a1, BT_REAL, dd, REQUIRED, a2, BT_REAL, dd, REQUIRED);
+
+  make_generic ("min", GFC_ISYM_MIN, GFC_STD_F77);
+
+  add_sym_1 ("minexponent", GFC_ISYM_MINEXPONENT, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di,
+	     GFC_STD_F95, gfc_check_x, gfc_simplify_minexponent, NULL,
+	     x, BT_UNKNOWN, dr, REQUIRED);
+
+  make_generic ("minexponent", GFC_ISYM_MINEXPONENT, GFC_STD_F95);
+
+  add_sym_3ml ("minloc", GFC_ISYM_MINLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
+	       gfc_check_minloc_maxloc, NULL, gfc_resolve_minloc,
+	       ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
+	       msk, BT_LOGICAL, dl, OPTIONAL);
+
+  make_generic ("minloc", GFC_ISYM_MINLOC, GFC_STD_F95);
+
+  add_sym_3red ("minval", GFC_ISYM_MINVAL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
+		gfc_check_minval_maxval, gfc_simplify_minval, gfc_resolve_minval,
+		ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
+		msk, BT_LOGICAL, dl, OPTIONAL);
+
+  make_generic ("minval", GFC_ISYM_MINVAL, GFC_STD_F95);
+
+  add_sym_2 ("mod", GFC_ISYM_MOD, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
+	     gfc_check_a_p, gfc_simplify_mod, gfc_resolve_mod,
+	     a, BT_INTEGER, di, REQUIRED, p, BT_INTEGER, di, REQUIRED);
+
+  add_sym_2 ("amod", GFC_ISYM_MOD, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
+	     NULL, gfc_simplify_mod, gfc_resolve_mod,
+	     a, BT_REAL, dr, REQUIRED, p, BT_REAL, dr, REQUIRED);
+
+  add_sym_2 ("dmod", GFC_ISYM_MOD, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
+	     gfc_check_x_yd, gfc_simplify_mod, gfc_resolve_mod,
+	     a, BT_REAL, dd, REQUIRED, p, BT_REAL, dd, REQUIRED);
+
+  make_generic ("mod", GFC_ISYM_MOD, GFC_STD_F77);
+
+  add_sym_2 ("modulo", GFC_ISYM_MODULO, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, di, GFC_STD_F95,
+	     gfc_check_a_p, gfc_simplify_modulo, gfc_resolve_modulo,
+	     a, BT_REAL, di, REQUIRED, p, BT_REAL, di, REQUIRED);
+
+  make_generic ("modulo", GFC_ISYM_MODULO, GFC_STD_F95);
+
+  add_sym_2 ("nearest", GFC_ISYM_NEAREST, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
+	     gfc_check_nearest, gfc_simplify_nearest, gfc_resolve_nearest,
+	     x, BT_REAL, dr, REQUIRED, s, BT_REAL, dr, REQUIRED);
+
+  make_generic ("nearest", GFC_ISYM_NEAREST, GFC_STD_F95);
+
+  add_sym_1 ("new_line", GFC_ISYM_NEW_LINE, CLASS_INQUIRY, ACTUAL_NO, BT_CHARACTER, dc,
+	     GFC_STD_F2003, gfc_check_new_line, gfc_simplify_new_line, NULL,
+	     a, BT_CHARACTER, dc, REQUIRED);
+
+  make_generic ("new_line", GFC_ISYM_NEW_LINE, GFC_STD_F2003);
+
+  add_sym_2 ("nint", GFC_ISYM_NINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
+	     gfc_check_a_ikind, gfc_simplify_nint, gfc_resolve_nint,
+	     a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
+
+  add_sym_1 ("idnint", GFC_ISYM_NINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
+	     gfc_check_idnint, gfc_simplify_idnint, gfc_resolve_idnint,
+	     a, BT_REAL, dd, REQUIRED);
+
+  make_generic ("nint", GFC_ISYM_NINT, GFC_STD_F77);
+
+  add_sym_1 ("not", GFC_ISYM_NOT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
+	     gfc_check_i, gfc_simplify_not, gfc_resolve_not,
+	     i, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("not", GFC_ISYM_NOT, GFC_STD_F95);
+
+  add_sym_2 ("norm2", GFC_ISYM_NORM2, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr,
+	     GFC_STD_F2008, gfc_check_norm2, gfc_simplify_norm2, gfc_resolve_norm2,
+	     x, BT_REAL, dr, REQUIRED,
+	     dm, BT_INTEGER, ii, OPTIONAL);
+
+  make_generic ("norm2", GFC_ISYM_NORM2, GFC_STD_F2008);
+
+  add_sym_1 ("null", GFC_ISYM_NULL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
+	     gfc_check_null, gfc_simplify_null, NULL,
+	     mo, BT_INTEGER, di, OPTIONAL);
+
+  make_generic ("null", GFC_ISYM_NULL, GFC_STD_F95);
+
+  add_sym_0 ("num_images", GFC_ISYM_NUM_IMAGES, CLASS_INQUIRY, ACTUAL_NO,
+	     BT_INTEGER, di, GFC_STD_F2008,
+	     NULL, gfc_simplify_num_images, NULL);
+
+  add_sym_3 ("pack", GFC_ISYM_PACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
+	     gfc_check_pack, gfc_simplify_pack, gfc_resolve_pack,
+	     ar, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED,
+	     v, BT_REAL, dr, OPTIONAL);
+
+  make_generic ("pack", GFC_ISYM_PACK, GFC_STD_F95);
+
+
+  add_sym_2 ("parity", GFC_ISYM_PARITY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_LOGICAL, dl,
+	     GFC_STD_F2008, gfc_check_parity, gfc_simplify_parity, gfc_resolve_parity,
+	     msk, BT_LOGICAL, dl, REQUIRED,
+	     dm, BT_INTEGER, ii, OPTIONAL);
+
+  make_generic ("parity", GFC_ISYM_PARITY, GFC_STD_F2008);
+
+  add_sym_1 ("popcnt", GFC_ISYM_POPCNT, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_INTEGER, di, GFC_STD_F2008,
+	     gfc_check_i, gfc_simplify_popcnt, NULL,
+	     i, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("popcnt", GFC_ISYM_POPCNT, GFC_STD_F2008);
+
+  add_sym_1 ("poppar", GFC_ISYM_POPPAR, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_INTEGER, di, GFC_STD_F2008,
+	     gfc_check_i, gfc_simplify_poppar, NULL,
+	     i, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("poppar", GFC_ISYM_POPPAR, GFC_STD_F2008);
+
+  add_sym_1 ("precision", GFC_ISYM_PRECISION, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
+	     gfc_check_precision, gfc_simplify_precision, NULL,
+	     x, BT_UNKNOWN, 0, REQUIRED);
+
+  make_generic ("precision", GFC_ISYM_PRECISION, GFC_STD_F95);
+
+  add_sym_1_intent ("present", GFC_ISYM_PRESENT, CLASS_INQUIRY, ACTUAL_NO,
+		    BT_LOGICAL, dl, GFC_STD_F95, gfc_check_present, NULL, NULL,
+		    a, BT_REAL, dr, REQUIRED, INTENT_UNKNOWN);
+
+  make_generic ("present", GFC_ISYM_PRESENT, GFC_STD_F95);
+
+  add_sym_3red ("product", GFC_ISYM_PRODUCT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
+		gfc_check_product_sum, gfc_simplify_product, gfc_resolve_product,
+		ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
+		msk, BT_LOGICAL, dl, OPTIONAL);
+
+  make_generic ("product", GFC_ISYM_PRODUCT, GFC_STD_F95);
+
+  add_sym_1 ("radix", GFC_ISYM_RADIX, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
+	     gfc_check_radix, gfc_simplify_radix, NULL,
+	     x, BT_UNKNOWN, 0, REQUIRED);
+
+  make_generic ("radix", GFC_ISYM_RADIX, GFC_STD_F95);
+
+  /* The following function is for G77 compatibility.  */
+  add_sym_1 ("rand", GFC_ISYM_RAND, CLASS_IMPURE, ACTUAL_NO, BT_REAL,
+	     4, GFC_STD_GNU, gfc_check_rand, NULL, NULL,
+	     i, BT_INTEGER, 4, OPTIONAL);
+
+  /* Compatibility with HP FORTRAN 77/iX Reference.  Note, rand() and ran()
+     use slightly different shoddy multiplicative congruential PRNG.  */
+  make_alias ("ran", GFC_STD_GNU);
+
+  make_generic ("rand", GFC_ISYM_RAND, GFC_STD_GNU);
+
+  add_sym_1 ("range", GFC_ISYM_RANGE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
+	     gfc_check_range, gfc_simplify_range, NULL,
+	     x, BT_REAL, dr, REQUIRED);
+
+  make_generic ("range", GFC_ISYM_RANGE, GFC_STD_F95);
+
+  add_sym_1 ("rank", GFC_ISYM_RANK, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di,
+	     GFC_STD_F2008_TS, gfc_check_rank, gfc_simplify_rank, gfc_resolve_rank,
+	     a, BT_REAL, dr, REQUIRED);
+  make_generic ("rank", GFC_ISYM_RANK, GFC_STD_F2008_TS);
+
+  add_sym_2 ("real", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
+	     gfc_check_real, gfc_simplify_real, gfc_resolve_real,
+	     a, BT_UNKNOWN, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
+
+  /* This provides compatibility with g77.  */
+  add_sym_1 ("realpart", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
+	     gfc_check_fn_c, gfc_simplify_realpart, gfc_resolve_realpart,
+	     a, BT_UNKNOWN, dr, REQUIRED);
+
+  add_sym_1 ("float", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
+	     gfc_check_float, gfc_simplify_float, NULL,
+	     a, BT_INTEGER, di, REQUIRED);
+
+  add_sym_1 ("dfloat", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
+	     gfc_check_float, gfc_simplify_dble, gfc_resolve_dble,
+	     a, BT_REAL, dr, REQUIRED);
+
+  add_sym_1 ("sngl", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
+	     gfc_check_sngl, gfc_simplify_sngl, NULL,
+	     a, BT_REAL, dd, REQUIRED);
+
+  make_generic ("real", GFC_ISYM_REAL, GFC_STD_F77);
+
+  add_sym_2 ("rename", GFC_ISYM_RENAME, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di,
+	     GFC_STD_GNU, gfc_check_rename, NULL, gfc_resolve_rename,
+	     p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED);
+
+  make_generic ("rename", GFC_ISYM_RENAME, GFC_STD_GNU);
+  
+  add_sym_2 ("repeat", GFC_ISYM_REPEAT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F95,
+	     gfc_check_repeat, gfc_simplify_repeat, gfc_resolve_repeat,
+	     stg, BT_CHARACTER, dc, REQUIRED, ncopies, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("repeat", GFC_ISYM_REPEAT, GFC_STD_F95);
+
+  add_sym_4 ("reshape", GFC_ISYM_RESHAPE, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
+	     gfc_check_reshape, gfc_simplify_reshape, gfc_resolve_reshape,
+	     src, BT_REAL, dr, REQUIRED, shp, BT_INTEGER, ii, REQUIRED,
+	     pad, BT_REAL, dr, OPTIONAL, ord, BT_INTEGER, ii, OPTIONAL);
+
+  make_generic ("reshape", GFC_ISYM_RESHAPE, GFC_STD_F95);
+
+  add_sym_1 ("rrspacing", GFC_ISYM_RRSPACING, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
+	     gfc_check_x, gfc_simplify_rrspacing, gfc_resolve_rrspacing,
+	     x, BT_REAL, dr, REQUIRED);
+
+  make_generic ("rrspacing", GFC_ISYM_RRSPACING, GFC_STD_F95);
+
+  add_sym_2 ("same_type_as", GFC_ISYM_SAME_TYPE_AS, CLASS_INQUIRY, ACTUAL_NO,
+	     BT_LOGICAL, dl, GFC_STD_F2003,
+	     gfc_check_same_type_as, gfc_simplify_same_type_as, NULL,
+	     a, BT_UNKNOWN, 0, REQUIRED,
+	     b, BT_UNKNOWN, 0, REQUIRED);
+
+  add_sym_2 ("scale", GFC_ISYM_SCALE, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
+	     gfc_check_scale, gfc_simplify_scale, gfc_resolve_scale,
+	     x, BT_REAL, dr, REQUIRED, i, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("scale", GFC_ISYM_SCALE, GFC_STD_F95);
+
+  add_sym_4 ("scan", GFC_ISYM_SCAN, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_INTEGER, di, GFC_STD_F95,
+	     gfc_check_scan, gfc_simplify_scan, gfc_resolve_scan,
+	     stg, BT_CHARACTER, dc, REQUIRED, set, BT_CHARACTER, dc, REQUIRED,
+	     bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL);
+
+  make_generic ("scan", GFC_ISYM_SCAN, GFC_STD_F95);
+
+  /* Added for G77 compatibility garbage.  */
+  add_sym_0 ("second", GFC_ISYM_SECOND, CLASS_IMPURE, ACTUAL_NO, BT_REAL,
+	     4, GFC_STD_GNU, NULL, NULL, NULL);
+
+  make_generic ("second", GFC_ISYM_SECOND, GFC_STD_GNU);
+
+  /* Added for G77 compatibility.  */
+  add_sym_1 ("secnds", GFC_ISYM_SECNDS, CLASS_IMPURE, ACTUAL_NO, BT_REAL,
+	     dr, GFC_STD_GNU, gfc_check_secnds, NULL, gfc_resolve_secnds,
+	     x, BT_REAL, dr, REQUIRED);
+
+  make_generic ("secnds", GFC_ISYM_SECNDS, GFC_STD_GNU);
+
+  add_sym_1 ("selected_char_kind", GFC_ISYM_SC_KIND, CLASS_TRANSFORMATIONAL,
+	     ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2003,
+	     gfc_check_selected_char_kind, gfc_simplify_selected_char_kind,
+	     NULL, nm, BT_CHARACTER, dc, REQUIRED);
+
+  make_generic ("selected_char_kind", GFC_ISYM_SC_KIND, GFC_STD_F2003);
+
+  add_sym_1 ("selected_int_kind", GFC_ISYM_SI_KIND, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di,
+	     GFC_STD_F95, gfc_check_selected_int_kind,
+	     gfc_simplify_selected_int_kind, NULL, r, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("selected_int_kind", GFC_ISYM_SI_KIND, GFC_STD_F95);
+
+  add_sym_3 ("selected_real_kind", GFC_ISYM_SR_KIND, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di,
+	     GFC_STD_F95, gfc_check_selected_real_kind,
+	     gfc_simplify_selected_real_kind, NULL,
+	     p, BT_INTEGER, di, OPTIONAL, r, BT_INTEGER, di, OPTIONAL,
+	     "radix", BT_INTEGER, di, OPTIONAL);
+
+  make_generic ("selected_real_kind", GFC_ISYM_SR_KIND, GFC_STD_F95);
+
+  add_sym_2 ("set_exponent", GFC_ISYM_SET_EXPONENT, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
+	     gfc_check_set_exponent, gfc_simplify_set_exponent,
+	     gfc_resolve_set_exponent,
+	     x, BT_REAL, dr, REQUIRED, i, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("set_exponent", GFC_ISYM_SET_EXPONENT, GFC_STD_F95);
+
+  add_sym_2 ("shape", GFC_ISYM_SHAPE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
+	     gfc_check_shape, gfc_simplify_shape, gfc_resolve_shape,
+	     src, BT_REAL, dr, REQUIRED,
+	     kind, BT_INTEGER, di, OPTIONAL);
+
+  make_generic ("shape", GFC_ISYM_SHAPE, GFC_STD_F95);
+
+  add_sym_2 ("shifta", GFC_ISYM_SHIFTA, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_INTEGER, di, GFC_STD_F2008,
+	     gfc_check_shift, gfc_simplify_shifta, gfc_resolve_shift,
+	     i, BT_INTEGER, di, REQUIRED,
+	     sh, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("shifta", GFC_ISYM_SHIFTA, GFC_STD_F2008);
+
+  add_sym_2 ("shiftl", GFC_ISYM_SHIFTL, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_INTEGER, di, GFC_STD_F2008,
+	     gfc_check_shift, gfc_simplify_shiftl, gfc_resolve_shift,
+	     i, BT_INTEGER, di, REQUIRED,
+	     sh, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("shiftl", GFC_ISYM_SHIFTL, GFC_STD_F2008);
+
+  add_sym_2 ("shiftr", GFC_ISYM_SHIFTR, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_INTEGER, di, GFC_STD_F2008,
+	     gfc_check_shift, gfc_simplify_shiftr, gfc_resolve_shift,
+	     i, BT_INTEGER, di, REQUIRED,
+	     sh, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("shiftr", GFC_ISYM_SHIFTR, GFC_STD_F2008);
+
+  add_sym_2 ("sign", GFC_ISYM_SIGN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
+	     gfc_check_sign, gfc_simplify_sign, gfc_resolve_sign,
+	     a, BT_REAL, dr, REQUIRED, b, BT_REAL, dr, REQUIRED);
+
+  add_sym_2 ("isign", GFC_ISYM_SIGN, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
+	     NULL, gfc_simplify_sign, gfc_resolve_sign,
+	     a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED);
+
+  add_sym_2 ("dsign", GFC_ISYM_SIGN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
+	     gfc_check_x_yd, gfc_simplify_sign, gfc_resolve_sign,
+	     a, BT_REAL, dd, REQUIRED, b, BT_REAL, dd, REQUIRED);
+
+  make_generic ("sign", GFC_ISYM_SIGN, GFC_STD_F77);
+
+  add_sym_2 ("signal", GFC_ISYM_SIGNAL, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
+	     di, GFC_STD_GNU, gfc_check_signal, NULL, gfc_resolve_signal,
+	     num, BT_INTEGER, di, REQUIRED, han, BT_VOID, 0, REQUIRED);
+
+  make_generic ("signal", GFC_ISYM_SIGNAL, GFC_STD_GNU);
+
+  add_sym_1 ("sin", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
+	     gfc_check_fn_rc, gfc_simplify_sin, gfc_resolve_sin,
+	     x, BT_REAL, dr, REQUIRED);
+
+  add_sym_1 ("dsin", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
+	     gfc_check_fn_d, gfc_simplify_sin, gfc_resolve_sin,
+	     x, BT_REAL, dd, REQUIRED);
+
+  add_sym_1 ("csin", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77,
+	     NULL, gfc_simplify_sin, gfc_resolve_sin,
+	     x, BT_COMPLEX, dz, REQUIRED);
+
+  add_sym_1 ("zsin", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU,
+	     NULL, gfc_simplify_sin, gfc_resolve_sin,
+	     x, BT_COMPLEX, dd, REQUIRED);
+
+  make_alias ("cdsin", GFC_STD_GNU);
+
+  make_generic ("sin", GFC_ISYM_SIN, GFC_STD_F77);
+
+  add_sym_1 ("sinh", GFC_ISYM_SINH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
+	     gfc_check_fn_rc2008, gfc_simplify_sinh, gfc_resolve_sinh,
+	     x, BT_REAL, dr, REQUIRED);
+
+  add_sym_1 ("dsinh", GFC_ISYM_SINH,CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
+	     gfc_check_fn_d, gfc_simplify_sinh, gfc_resolve_sinh,
+	     x, BT_REAL, dd, REQUIRED);
+
+  make_generic ("sinh", GFC_ISYM_SINH, GFC_STD_F77);
+
+  add_sym_3 ("size", GFC_ISYM_SIZE, CLASS_INQUIRY, ACTUAL_NO,
+	     BT_INTEGER, di, GFC_STD_F95,
+	     gfc_check_size, gfc_simplify_size, gfc_resolve_size,
+	     ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
+	     kind, BT_INTEGER, di, OPTIONAL);
+
+  make_generic ("size", GFC_ISYM_SIZE, GFC_STD_F95);
+
+  /* Obtain the stride for a given dimensions; to be used only internally.
+     "make_from_module" makes inaccessible for external users.  */
+  add_sym_2 (GFC_PREFIX ("stride"), GFC_ISYM_STRIDE, CLASS_INQUIRY, ACTUAL_NO,
+	     BT_INTEGER, gfc_index_integer_kind, GFC_STD_GNU,
+	     NULL, NULL, gfc_resolve_stride,
+	     ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
+  make_from_module();
+
+  add_sym_1 ("sizeof", GFC_ISYM_SIZEOF, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, ii,
+	     GFC_STD_GNU, gfc_check_sizeof, gfc_simplify_sizeof, NULL,
+	     x, BT_UNKNOWN, 0, REQUIRED);
+
+  make_generic ("sizeof", GFC_ISYM_SIZEOF, GFC_STD_GNU);
+
+  /* The following functions are part of ISO_C_BINDING.  */
+  add_sym_2 ("c_associated", GFC_ISYM_C_ASSOCIATED, CLASS_INQUIRY, ACTUAL_NO,
+	     BT_LOGICAL, dl, GFC_STD_F2003, gfc_check_c_associated, NULL, NULL,
+	     "C_PTR_1", BT_VOID, 0, REQUIRED,
+	     "C_PTR_2", BT_VOID, 0, OPTIONAL);
+  make_from_module();
+
+  add_sym_1 ("c_loc", GFC_ISYM_C_LOC, CLASS_INQUIRY, ACTUAL_NO,
+	     BT_VOID, 0, GFC_STD_F2003,
+	     gfc_check_c_loc, NULL, gfc_resolve_c_loc,
+	     x, BT_UNKNOWN, 0, REQUIRED);
+  make_from_module();
+
+  add_sym_1 ("c_funloc", GFC_ISYM_C_FUNLOC, CLASS_INQUIRY, ACTUAL_NO,
+	     BT_VOID, 0, GFC_STD_F2003,
+	     gfc_check_c_funloc, NULL, gfc_resolve_c_funloc,
+	     x, BT_UNKNOWN, 0, REQUIRED);
+  make_from_module();
+
+  add_sym_1 ("c_sizeof", GFC_ISYM_C_SIZEOF, CLASS_INQUIRY, ACTUAL_NO,
+	     BT_INTEGER, gfc_index_integer_kind, GFC_STD_F2008,
+	     gfc_check_c_sizeof, gfc_simplify_sizeof, NULL,
+	     x, BT_UNKNOWN, 0, REQUIRED);
+  make_from_module();
+
+  /* COMPILER_OPTIONS and COMPILER_VERSION are part of ISO_FORTRAN_ENV.  */  
+  add_sym_0 ("compiler_options", GFC_ISYM_COMPILER_OPTIONS, CLASS_INQUIRY,
+	     ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F2008,
+	     NULL, gfc_simplify_compiler_options, NULL);
+  make_from_module();
+
+  add_sym_0 ("compiler_version", GFC_ISYM_COMPILER_VERSION, CLASS_INQUIRY,
+	     ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F2008,
+	     NULL, gfc_simplify_compiler_version, NULL);
+  make_from_module();
+
+  add_sym_1 ("spacing", GFC_ISYM_SPACING, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
+	     gfc_check_x, gfc_simplify_spacing, gfc_resolve_spacing,
+	     x, BT_REAL, dr, REQUIRED);
+
+  make_generic ("spacing", GFC_ISYM_SPACING, GFC_STD_F95);
+
+  add_sym_3 ("spread", GFC_ISYM_SPREAD, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
+	     gfc_check_spread, gfc_simplify_spread, gfc_resolve_spread,
+	     src, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, REQUIRED,
+	     ncopies, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("spread", GFC_ISYM_SPREAD, GFC_STD_F95);
+
+  add_sym_1 ("sqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
+	     gfc_check_fn_rc, gfc_simplify_sqrt, gfc_resolve_sqrt,
+	     x, BT_REAL, dr, REQUIRED);
+
+  add_sym_1 ("dsqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
+	     gfc_check_fn_d, gfc_simplify_sqrt, gfc_resolve_sqrt,
+	     x, BT_REAL, dd, REQUIRED);
+
+  add_sym_1 ("csqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77,
+	     NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
+	     x, BT_COMPLEX, dz, REQUIRED);
+
+  add_sym_1 ("zsqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU,
+	     NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
+	     x, BT_COMPLEX, dd, REQUIRED);
+
+  make_alias ("cdsqrt", GFC_STD_GNU);
+
+  make_generic ("sqrt", GFC_ISYM_SQRT, GFC_STD_F77);
+
+  add_sym_2_intent ("stat", GFC_ISYM_STAT, CLASS_IMPURE, ACTUAL_NO,
+		    BT_INTEGER, di, GFC_STD_GNU,
+		    gfc_check_stat, NULL, gfc_resolve_stat,
+		    nm, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
+		    vl, BT_INTEGER, di, REQUIRED, INTENT_OUT);
+
+  make_generic ("stat", GFC_ISYM_STAT, GFC_STD_GNU);
+
+  add_sym_2 ("storage_size", GFC_ISYM_STORAGE_SIZE, CLASS_INQUIRY, ACTUAL_NO,
+	     BT_INTEGER, di, GFC_STD_F2008,
+	     gfc_check_storage_size, gfc_simplify_storage_size,
+	     gfc_resolve_storage_size,
+	     a, BT_UNKNOWN, 0, REQUIRED,
+	     kind, BT_INTEGER, di, OPTIONAL);
+  
+  add_sym_3red ("sum", GFC_ISYM_SUM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
+		gfc_check_product_sum, gfc_simplify_sum, gfc_resolve_sum,
+		ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
+		msk, BT_LOGICAL, dl, OPTIONAL);
+
+  make_generic ("sum", GFC_ISYM_SUM, GFC_STD_F95);
+
+  add_sym_2 ("symlnk", GFC_ISYM_SYMLNK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di,
+	     GFC_STD_GNU, gfc_check_symlnk, NULL, gfc_resolve_symlnk,
+	     p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED);
+
+  make_generic ("symlnk", GFC_ISYM_SYMLNK, GFC_STD_GNU);
+
+  add_sym_1 ("system", GFC_ISYM_SYSTEM, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di,
+	     GFC_STD_GNU, NULL, NULL, NULL,
+	     com, BT_CHARACTER, dc, REQUIRED);
+
+  make_generic ("system", GFC_ISYM_SYSTEM, GFC_STD_GNU);
+
+  add_sym_1 ("tan", GFC_ISYM_TAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
+	     gfc_check_fn_rc2008, gfc_simplify_tan, gfc_resolve_tan,
+	     x, BT_REAL, dr, REQUIRED);
+
+  add_sym_1 ("dtan", GFC_ISYM_TAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
+	     gfc_check_fn_d, gfc_simplify_tan, gfc_resolve_tan,
+	     x, BT_REAL, dd, REQUIRED);
+
+  make_generic ("tan", GFC_ISYM_TAN, GFC_STD_F77);
+
+  add_sym_1 ("tanh", GFC_ISYM_TANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
+	     gfc_check_fn_rc2008, gfc_simplify_tanh, gfc_resolve_tanh,
+	     x, BT_REAL, dr, REQUIRED);
+
+  add_sym_1 ("dtanh", GFC_ISYM_TANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
+	     gfc_check_fn_d, gfc_simplify_tanh, gfc_resolve_tanh,
+	     x, BT_REAL, dd, REQUIRED);
+
+  make_generic ("tanh", GFC_ISYM_TANH, GFC_STD_F77);
+
+  add_sym_2 ("this_image", GFC_ISYM_THIS_IMAGE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008,
+	     gfc_check_this_image, gfc_simplify_this_image, gfc_resolve_this_image,
+	     ca, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL);
+
+  add_sym_0 ("time", GFC_ISYM_TIME, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
+	     di, GFC_STD_GNU, NULL, NULL, gfc_resolve_time);
+
+  make_generic ("time", GFC_ISYM_TIME, GFC_STD_GNU);
+
+  add_sym_0 ("time8", GFC_ISYM_TIME8, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
+	     di, GFC_STD_GNU, NULL, NULL, gfc_resolve_time8);
+
+  make_generic ("time8", GFC_ISYM_TIME8, GFC_STD_GNU);
+
+  add_sym_1 ("tiny", GFC_ISYM_TINY, CLASS_INQUIRY, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
+	     gfc_check_x, gfc_simplify_tiny, NULL,
+	     x, BT_REAL, dr, REQUIRED);
+
+  make_generic ("tiny", GFC_ISYM_TINY, GFC_STD_F95);
+
+  add_sym_1 ("trailz", GFC_ISYM_TRAILZ, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_INTEGER, di, GFC_STD_F2008,
+	     gfc_check_i, gfc_simplify_trailz, NULL,
+	     i, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("trailz", GFC_ISYM_TRAILZ, GFC_STD_F2008);
+
+  add_sym_3 ("transfer", GFC_ISYM_TRANSFER, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
+	     gfc_check_transfer, gfc_simplify_transfer, gfc_resolve_transfer,
+	     src, BT_REAL, dr, REQUIRED, mo, BT_REAL, dr, REQUIRED,
+	     sz, BT_INTEGER, di, OPTIONAL);
+
+  make_generic ("transfer", GFC_ISYM_TRANSFER, GFC_STD_F95);
+
+  add_sym_1 ("transpose", GFC_ISYM_TRANSPOSE, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
+	     gfc_check_transpose, gfc_simplify_transpose, gfc_resolve_transpose,
+	     m, BT_REAL, dr, REQUIRED);
+
+  make_generic ("transpose", GFC_ISYM_TRANSPOSE, GFC_STD_F95);
+
+  add_sym_1 ("trim", GFC_ISYM_TRIM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F95,
+	     gfc_check_trim, gfc_simplify_trim, gfc_resolve_trim,
+	     stg, BT_CHARACTER, dc, REQUIRED);
+
+  make_generic ("trim", GFC_ISYM_TRIM, GFC_STD_F95);
+
+  add_sym_1 ("ttynam", GFC_ISYM_TTYNAM, CLASS_IMPURE, ACTUAL_NO, BT_CHARACTER,
+	     0, GFC_STD_GNU, gfc_check_ttynam, NULL, gfc_resolve_ttynam,
+	     ut, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("ttynam", GFC_ISYM_TTYNAM, GFC_STD_GNU);
+
+  add_sym_3 ("ubound", GFC_ISYM_UBOUND, CLASS_INQUIRY, ACTUAL_NO,
+	     BT_INTEGER, di, GFC_STD_F95,
+	     gfc_check_ubound, gfc_simplify_ubound, gfc_resolve_ubound,
+	     ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
+	     kind, BT_INTEGER, di, OPTIONAL);
+
+  make_generic ("ubound", GFC_ISYM_UBOUND, GFC_STD_F95);
+
+  add_sym_3 ("ucobound", GFC_ISYM_UCOBOUND, CLASS_INQUIRY, ACTUAL_NO,
+	    BT_INTEGER, di, GFC_STD_F2008,
+	    gfc_check_ucobound, gfc_simplify_ucobound, gfc_resolve_ucobound,
+	    ca, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
+	    kind, BT_INTEGER, di, OPTIONAL);
+
+  make_generic ("ucobound", GFC_ISYM_UCOBOUND, GFC_STD_F2008);
+
+  /* g77 compatibility for UMASK.  */
+  add_sym_1 ("umask", GFC_ISYM_UMASK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di,
+	     GFC_STD_GNU, gfc_check_umask, NULL, gfc_resolve_umask,
+	     msk, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("umask", GFC_ISYM_UMASK, GFC_STD_GNU);
+
+  /* g77 compatibility for UNLINK.  */
+  add_sym_1 ("unlink", GFC_ISYM_UNLINK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
+	     di, GFC_STD_GNU, gfc_check_unlink, NULL, gfc_resolve_unlink,
+	     "path", BT_CHARACTER, dc, REQUIRED);
+
+  make_generic ("unlink", GFC_ISYM_UNLINK, GFC_STD_GNU);
+
+  add_sym_3 ("unpack", GFC_ISYM_UNPACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
+	     gfc_check_unpack, gfc_simplify_unpack, gfc_resolve_unpack,
+	     v, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED,
+	     f, BT_REAL, dr, REQUIRED);
+
+  make_generic ("unpack", GFC_ISYM_UNPACK, GFC_STD_F95);
+
+  add_sym_4 ("verify", GFC_ISYM_VERIFY, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_INTEGER, di, GFC_STD_F95,
+	     gfc_check_verify, gfc_simplify_verify, gfc_resolve_verify,
+	     stg, BT_CHARACTER, dc, REQUIRED, set, BT_CHARACTER, dc, REQUIRED,
+	     bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL);
+
+  make_generic ("verify", GFC_ISYM_VERIFY, GFC_STD_F95);
+    
+  add_sym_1 ("loc", GFC_ISYM_LOC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, ii,
+	     GFC_STD_GNU, gfc_check_loc, NULL, gfc_resolve_loc,
+	     x, BT_UNKNOWN, 0, REQUIRED);
+		
+  make_generic ("loc", GFC_ISYM_LOC, GFC_STD_GNU);
+}
+
+
+/* Add intrinsic subroutines.  */
+
+static void
+add_subroutines (void)
+{
+  /* Argument names as in the standard (to be used as argument keywords).  */
+  const char
+    *h = "harvest", *dt = "date", *vl = "values", *pt = "put",
+    *c = "count", *tm = "time", *tp = "topos", *gt = "get",
+    *t = "to", *zn = "zone", *fp = "frompos", *cm = "count_max",
+    *f = "from", *sz = "size", *ln = "len", *cr = "count_rate",
+    *com = "command", *length = "length", *st = "status",
+    *val = "value", *num = "number", *name = "name",
+    *trim_name = "trim_name", *ut = "unit", *han = "handler",
+    *sec = "seconds", *res = "result", *of = "offset", *md = "mode",
+    *whence = "whence", *pos = "pos", *ptr = "ptr", *p1 = "path1",
+    *p2 = "path2", *msk = "mask", *old = "old";
+
+  int di, dr, dc, dl, ii;
+
+  di = gfc_default_integer_kind;
+  dr = gfc_default_real_kind;
+  dc = gfc_default_character_kind;
+  dl = gfc_default_logical_kind;
+  ii = gfc_index_integer_kind;
+
+  add_sym_0s ("abort", GFC_ISYM_ABORT, GFC_STD_GNU, NULL);
+
+  make_noreturn();
+
+  add_sym_2s ("atomic_define", GFC_ISYM_ATOMIC_DEF, CLASS_ATOMIC,
+	      BT_UNKNOWN, 0, GFC_STD_F2008,
+	      gfc_check_atomic_def, NULL, gfc_resolve_atomic_def,
+	      "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT,
+	      "value", BT_INTEGER, di, REQUIRED, INTENT_IN);
+
+  add_sym_2s ("atomic_ref", GFC_ISYM_ATOMIC_REF, CLASS_ATOMIC,
+	      BT_UNKNOWN, 0, GFC_STD_F2008,
+	      gfc_check_atomic_ref, NULL, gfc_resolve_atomic_ref,
+	      "value", BT_INTEGER, di, REQUIRED, INTENT_OUT,
+	      "atom", BT_INTEGER, di, REQUIRED, INTENT_IN);
+
+  add_sym_0s ("backtrace", GFC_ISYM_BACKTRACE, GFC_STD_GNU, NULL);
+
+  add_sym_1s ("cpu_time", GFC_ISYM_CPU_TIME, CLASS_IMPURE, BT_UNKNOWN, 0,
+	      GFC_STD_F95, gfc_check_cpu_time, NULL, gfc_resolve_cpu_time,
+	      tm, BT_REAL, dr, REQUIRED, INTENT_OUT);
+
+  /* More G77 compatibility garbage.  */
+  add_sym_2s ("ctime", GFC_ISYM_CTIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
+	      gfc_check_ctime_sub, NULL, gfc_resolve_ctime_sub,
+	      tm, BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      res, BT_CHARACTER, dc, REQUIRED, INTENT_OUT);
+
+  add_sym_1s ("idate", GFC_ISYM_IDATE, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
+	      gfc_check_itime_idate, NULL, gfc_resolve_idate,
+	      vl, BT_INTEGER, 4, REQUIRED, INTENT_OUT);
+
+  add_sym_1s ("itime", GFC_ISYM_ITIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
+	      gfc_check_itime_idate, NULL, gfc_resolve_itime,
+	      vl, BT_INTEGER, 4, REQUIRED, INTENT_OUT);
+
+  add_sym_2s ("ltime", GFC_ISYM_LTIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
+	      gfc_check_ltime_gmtime, NULL, gfc_resolve_ltime,
+	      tm, BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      vl, BT_INTEGER, di, REQUIRED, INTENT_OUT);
+
+  add_sym_2s ("gmtime", GFC_ISYM_GMTIME, CLASS_IMPURE, BT_UNKNOWN, 0,
+	      GFC_STD_GNU, gfc_check_ltime_gmtime, NULL, gfc_resolve_gmtime,
+	      tm, BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      vl, BT_INTEGER, di, REQUIRED, INTENT_OUT);
+
+  add_sym_1s ("second", GFC_ISYM_SECOND, CLASS_IMPURE, BT_UNKNOWN, 0,
+	      GFC_STD_GNU, gfc_check_second_sub, NULL, gfc_resolve_second_sub,
+	      tm, BT_REAL, dr, REQUIRED, INTENT_OUT);
+
+  add_sym_2s ("chdir", GFC_ISYM_CHDIR, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
+	      gfc_check_chdir_sub, NULL, gfc_resolve_chdir_sub,
+	      name, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
+	      st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  add_sym_3s ("chmod", GFC_ISYM_CHMOD, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
+	      gfc_check_chmod_sub, NULL, gfc_resolve_chmod_sub,
+	      name, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
+	      md, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
+	      st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  add_sym_4s ("date_and_time", GFC_ISYM_DATE_AND_TIME, CLASS_IMPURE, BT_UNKNOWN,
+	      0, GFC_STD_F95, gfc_check_date_and_time, NULL, NULL,
+	      dt, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
+	      tm, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
+	      zn, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
+	      vl, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  /* More G77 compatibility garbage.  */
+  add_sym_2s ("etime", GFC_ISYM_ETIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
+	      gfc_check_dtime_etime_sub, NULL, gfc_resolve_etime_sub,
+	      vl, BT_REAL, 4, REQUIRED, INTENT_OUT,
+	      tm, BT_REAL, 4, REQUIRED, INTENT_OUT);
+
+  add_sym_2s ("dtime", GFC_ISYM_DTIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
+	      gfc_check_dtime_etime_sub, NULL, gfc_resolve_dtime_sub,
+	      vl, BT_REAL, 4, REQUIRED, INTENT_OUT,
+	      tm, BT_REAL, 4, REQUIRED, INTENT_OUT);
+
+  add_sym_5s ("execute_command_line", GFC_ISYM_EXECUTE_COMMAND_LINE,
+	      CLASS_IMPURE , BT_UNKNOWN, 0, GFC_STD_F2008,
+	      NULL, NULL, gfc_resolve_execute_command_line,
+	      "command", BT_CHARACTER, dc, REQUIRED, INTENT_IN,
+	      "wait", BT_LOGICAL, dl, OPTIONAL, INTENT_IN,
+	      "exitstat", BT_INTEGER, di, OPTIONAL, INTENT_INOUT,
+	      "cmdstat", BT_INTEGER, di, OPTIONAL, INTENT_OUT,
+	      "cmdmsg", BT_CHARACTER, dc, OPTIONAL, INTENT_INOUT);
+
+  add_sym_1s ("fdate", GFC_ISYM_FDATE, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
+	      gfc_check_fdate_sub, NULL, gfc_resolve_fdate_sub,
+	      dt, BT_CHARACTER, dc, REQUIRED, INTENT_OUT);
+
+  add_sym_1s ("gerror", GFC_ISYM_GERROR, CLASS_IMPURE, BT_UNKNOWN,
+	      0, GFC_STD_GNU, gfc_check_gerror, NULL, gfc_resolve_gerror,
+	      res, BT_CHARACTER, dc, REQUIRED, INTENT_OUT);
+
+  add_sym_2s ("getcwd", GFC_ISYM_GETCWD, CLASS_IMPURE, BT_UNKNOWN, 0,
+	      GFC_STD_GNU, gfc_check_getcwd_sub, NULL, gfc_resolve_getcwd_sub,
+	      c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT,
+	      st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  add_sym_2s ("getenv", GFC_ISYM_GETENV, CLASS_IMPURE, BT_UNKNOWN,
+	      0, GFC_STD_GNU, NULL, NULL, NULL,
+	      name, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
+	      val, BT_CHARACTER, dc, REQUIRED, INTENT_OUT);
+
+  add_sym_2s ("getarg", GFC_ISYM_GETARG, CLASS_IMPURE, BT_UNKNOWN,
+	      0, GFC_STD_GNU, gfc_check_getarg, NULL, gfc_resolve_getarg,
+	      pos, BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      val, BT_CHARACTER, dc, REQUIRED, INTENT_OUT);
+
+  add_sym_1s ("getlog", GFC_ISYM_GETLOG, CLASS_IMPURE, BT_UNKNOWN,
+	      0, GFC_STD_GNU, gfc_check_getlog, NULL, gfc_resolve_getlog,
+	      c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT);
+
+  /* F2003 commandline routines.  */
+
+  add_sym_3s ("get_command", GFC_ISYM_GET_COMMAND, CLASS_IMPURE,
+	      BT_UNKNOWN, 0, GFC_STD_F2003,
+	      NULL, NULL, gfc_resolve_get_command,
+	      com, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
+	      length, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
+	      st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  add_sym_4s ("get_command_argument", GFC_ISYM_GET_COMMAND_ARGUMENT,
+	      CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_F2003, NULL, NULL,
+	      gfc_resolve_get_command_argument,
+	      num, BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      val, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
+	      length, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
+	      st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  /* F2003 subroutine to get environment variables.  */
+
+  add_sym_5s ("get_environment_variable", GFC_ISYM_GET_ENVIRONMENT_VARIABLE,
+	      CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_F2003,
+	      NULL, NULL, gfc_resolve_get_environment_variable,
+	      name, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
+	      val, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
+	      length, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
+	      st, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
+	      trim_name, BT_LOGICAL, dl, OPTIONAL, INTENT_IN);
+
+  add_sym_2s ("move_alloc", GFC_ISYM_MOVE_ALLOC, CLASS_PURE, BT_UNKNOWN, 0,
+	      GFC_STD_F2003,
+	      gfc_check_move_alloc, NULL, NULL,
+	      f, BT_UNKNOWN, 0, REQUIRED, INTENT_INOUT,
+	      t, BT_UNKNOWN, 0, REQUIRED, INTENT_OUT);
+
+  add_sym_5s ("mvbits", GFC_ISYM_MVBITS, CLASS_ELEMENTAL, BT_UNKNOWN, 0,
+	      GFC_STD_F95, gfc_check_mvbits, gfc_simplify_mvbits,
+	      gfc_resolve_mvbits,
+	      f, BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      fp, BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      ln, BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      t, BT_INTEGER, di, REQUIRED, INTENT_INOUT,
+	      tp, BT_INTEGER, di, REQUIRED, INTENT_IN);
+
+  add_sym_1s ("random_number", GFC_ISYM_RANDOM_NUMBER, CLASS_IMPURE,
+	      BT_UNKNOWN, 0, GFC_STD_F95,
+	      gfc_check_random_number, NULL, gfc_resolve_random_number,
+	      h, BT_REAL, dr, REQUIRED, INTENT_OUT);
+
+  add_sym_3s ("random_seed", GFC_ISYM_RANDOM_SEED, CLASS_IMPURE,
+	      BT_UNKNOWN, 0, GFC_STD_F95,
+	      gfc_check_random_seed, NULL, gfc_resolve_random_seed,
+	      sz, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
+	      pt, BT_INTEGER, di, OPTIONAL, INTENT_IN,
+	      gt, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  /* The following subroutines are part of ISO_C_BINDING.  */
+
+  add_sym_3s ("c_f_pointer", GFC_ISYM_C_F_POINTER, CLASS_IMPURE, BT_UNKNOWN, 0,
+	      GFC_STD_F2003, gfc_check_c_f_pointer, NULL, NULL,
+	      "cptr", BT_VOID, 0, REQUIRED, INTENT_IN,
+	      "fptr", BT_UNKNOWN, 0, REQUIRED, INTENT_OUT,
+	      "shape", BT_INTEGER, di, OPTIONAL, INTENT_IN);
+  make_from_module();
+
+  add_sym_2s ("c_f_procpointer", GFC_ISYM_C_F_PROCPOINTER, CLASS_IMPURE,
+	      BT_UNKNOWN, 0, GFC_STD_F2003, gfc_check_c_f_procpointer,
+	      NULL, NULL,
+	      "cptr", BT_VOID, 0, REQUIRED, INTENT_IN,
+	      "fptr", BT_UNKNOWN, 0, REQUIRED, INTENT_OUT);
+  make_from_module();
+
+  /* More G77 compatibility garbage.  */
+  add_sym_3s ("alarm", GFC_ISYM_ALARM, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
+	      gfc_check_alarm_sub, NULL, gfc_resolve_alarm_sub,
+	      sec, BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      han, BT_UNKNOWN, 0, REQUIRED, INTENT_IN,
+	      st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  add_sym_1s ("srand", GFC_ISYM_SRAND, CLASS_IMPURE, BT_UNKNOWN,
+	      di, GFC_STD_GNU, gfc_check_srand, NULL, gfc_resolve_srand,
+	      "seed", BT_INTEGER, 4, REQUIRED, INTENT_IN);
+
+  add_sym_1s ("exit", GFC_ISYM_EXIT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
+	      gfc_check_exit, NULL, gfc_resolve_exit,
+	      st, BT_INTEGER, di, OPTIONAL, INTENT_IN);
+
+  make_noreturn();
+
+  add_sym_3s ("fgetc", GFC_ISYM_FGETC, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
+	      gfc_check_fgetputc_sub, NULL, gfc_resolve_fgetc_sub,
+	      ut, BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT,
+	      st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  add_sym_2s ("fget", GFC_ISYM_FGET, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
+	      gfc_check_fgetput_sub, NULL, gfc_resolve_fget_sub,
+	      c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT,
+	      st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  add_sym_1s ("flush", GFC_ISYM_FLUSH, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
+	      gfc_check_flush, NULL, gfc_resolve_flush,
+	      ut, BT_INTEGER, di, OPTIONAL, INTENT_IN);
+
+  add_sym_3s ("fputc", GFC_ISYM_FPUTC, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
+	      gfc_check_fgetputc_sub, NULL, gfc_resolve_fputc_sub,
+	      ut, BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      c, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
+	      st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  add_sym_2s ("fput", GFC_ISYM_FPUT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
+	      gfc_check_fgetput_sub, NULL, gfc_resolve_fput_sub,
+	      c, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
+	      st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  add_sym_1s ("free", GFC_ISYM_FREE, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
+	      gfc_check_free, NULL, gfc_resolve_free,
+	      ptr, BT_INTEGER, ii, REQUIRED, INTENT_INOUT);
+
+  add_sym_4s ("fseek", GFC_ISYM_FSEEK, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
+	      gfc_check_fseek_sub, NULL, gfc_resolve_fseek_sub,
+	      ut, BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      of, BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      whence, BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  add_sym_2s ("ftell", GFC_ISYM_FTELL, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
+	      gfc_check_ftell_sub, NULL, gfc_resolve_ftell_sub,
+	      ut, BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      of, BT_INTEGER, ii, REQUIRED, INTENT_OUT);
+
+  add_sym_2s ("hostnm", GFC_ISYM_HOSTNM, CLASS_IMPURE, BT_UNKNOWN, 0,
+	      GFC_STD_GNU, gfc_check_hostnm_sub, NULL, gfc_resolve_hostnm_sub,
+	      c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT,
+	      st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  add_sym_3s ("kill", GFC_ISYM_KILL, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
+	      gfc_check_kill_sub, NULL, gfc_resolve_kill_sub,
+	      c, BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      val, BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  add_sym_3s ("link", GFC_ISYM_LINK, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
+	      gfc_check_link_sub, NULL, gfc_resolve_link_sub,
+	      p1, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
+	      p2, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
+	      st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  add_sym_1s ("perror", GFC_ISYM_PERROR, CLASS_IMPURE, BT_UNKNOWN,
+	      0, GFC_STD_GNU, gfc_check_perror, NULL, gfc_resolve_perror,
+	      "string", BT_CHARACTER, dc, REQUIRED, INTENT_IN);
+
+  add_sym_3s ("rename", GFC_ISYM_RENAME, CLASS_IMPURE, BT_UNKNOWN, 0,
+	      GFC_STD_GNU, gfc_check_rename_sub, NULL, gfc_resolve_rename_sub,
+	      p1, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
+	      p2, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
+	      st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  add_sym_1s ("sleep", GFC_ISYM_SLEEP, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
+	      gfc_check_sleep_sub, NULL, gfc_resolve_sleep_sub,
+	      sec, BT_INTEGER, di, REQUIRED, INTENT_IN);
+
+  add_sym_3s ("fstat", GFC_ISYM_FSTAT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
+	      gfc_check_fstat_sub, NULL, gfc_resolve_fstat_sub,
+	      ut, BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      vl, BT_INTEGER, di, REQUIRED, INTENT_OUT,
+	      st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  add_sym_3s ("lstat", GFC_ISYM_LSTAT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
+	      gfc_check_stat_sub, NULL, gfc_resolve_lstat_sub,
+	      name, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
+	      vl, BT_INTEGER, di, REQUIRED, INTENT_OUT,
+	      st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  add_sym_3s ("stat", GFC_ISYM_STAT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
+	      gfc_check_stat_sub, NULL, gfc_resolve_stat_sub,
+	      name, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
+	      vl, BT_INTEGER, di, REQUIRED, INTENT_OUT,
+	      st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  add_sym_3s ("signal", GFC_ISYM_SIGNAL, CLASS_IMPURE, BT_UNKNOWN, 0,
+	      GFC_STD_GNU, gfc_check_signal_sub, NULL, gfc_resolve_signal_sub,
+	      num, BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      han, BT_UNKNOWN, 0, REQUIRED, INTENT_IN,
+	      st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  add_sym_3s ("symlnk", GFC_ISYM_SYMLINK, CLASS_IMPURE, BT_UNKNOWN, 0,
+	      GFC_STD_GNU, gfc_check_symlnk_sub, NULL, gfc_resolve_symlnk_sub,
+	      p1, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
+	      p2, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
+	      st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  add_sym_2s ("system", GFC_ISYM_SYSTEM, CLASS_IMPURE, BT_UNKNOWN,
+	      0, GFC_STD_GNU, NULL, NULL, gfc_resolve_system_sub,
+	      com, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
+	      st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  add_sym_3s ("system_clock", GFC_ISYM_SYSTEM_CLOCK, CLASS_IMPURE,
+	      BT_UNKNOWN, 0, GFC_STD_F95,
+	      gfc_check_system_clock, NULL, gfc_resolve_system_clock,
+	      c, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
+	      cr, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
+	      cm, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  add_sym_2s ("ttynam", GFC_ISYM_TTYNAM, CLASS_IMPURE, BT_UNKNOWN, 0,
+	      GFC_STD_GNU, gfc_check_ttynam_sub, NULL, gfc_resolve_ttynam_sub,
+	      ut, BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      name, BT_CHARACTER, dc, REQUIRED, INTENT_OUT);
+
+  add_sym_2s ("umask", GFC_ISYM_UMASK, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
+	      gfc_check_umask_sub, NULL, gfc_resolve_umask_sub,
+	      msk, BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      old, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  add_sym_2s ("unlink", GFC_ISYM_UNLINK, CLASS_IMPURE, BT_UNKNOWN, 0,
+	      GFC_STD_GNU, gfc_check_unlink_sub, NULL, gfc_resolve_unlink_sub,
+	      "path", BT_CHARACTER, dc, REQUIRED, INTENT_IN,
+	      st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+}
+
+
+/* Add a function to the list of conversion symbols.  */
+
+static void
+add_conv (bt from_type, int from_kind, bt to_type, int to_kind, int standard)
+{
+  gfc_typespec from, to;
+  gfc_intrinsic_sym *sym;
+
+  if (sizing == SZ_CONVS)
+    {
+      nconv++;
+      return;
+    }
+
+  gfc_clear_ts (&from);
+  from.type = from_type;
+  from.kind = from_kind;
+
+  gfc_clear_ts (&to);
+  to.type = to_type;
+  to.kind = to_kind;
+
+  sym = conversion + nconv;
+
+  sym->name = conv_name (&from, &to);
+  sym->lib_name = sym->name;
+  sym->simplify.cc = gfc_convert_constant;
+  sym->standard = standard;
+  sym->elemental = 1;
+  sym->pure = 1;
+  sym->conversion = 1;
+  sym->ts = to;
+  sym->id = GFC_ISYM_CONVERSION;
+
+  nconv++;
+}
+
+
+/* Create gfc_intrinsic_sym nodes for all intrinsic conversion
+   functions by looping over the kind tables.  */
+
+static void
+add_conversions (void)
+{
+  int i, j;
+
+  /* Integer-Integer conversions.  */
+  for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
+    for (j = 0; gfc_integer_kinds[j].kind != 0; j++)
+      {
+	if (i == j)
+	  continue;
+
+	add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
+		  BT_INTEGER, gfc_integer_kinds[j].kind, GFC_STD_F77);
+      }
+
+  /* Integer-Real/Complex conversions.  */
+  for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
+    for (j = 0; gfc_real_kinds[j].kind != 0; j++)
+      {
+	add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
+		  BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
+
+	add_conv (BT_REAL, gfc_real_kinds[j].kind,
+		  BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77);
+
+	add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
+		  BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
+
+	add_conv (BT_COMPLEX, gfc_real_kinds[j].kind,
+		  BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77);
+      }
+
+  if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0)
+    {
+      /* Hollerith-Integer conversions.  */
+      for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
+	add_conv (BT_HOLLERITH, gfc_default_character_kind,
+		  BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY);
+      /* Hollerith-Real conversions.  */
+      for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+	add_conv (BT_HOLLERITH, gfc_default_character_kind,
+		  BT_REAL, gfc_real_kinds[i].kind, GFC_STD_LEGACY);
+      /* Hollerith-Complex conversions.  */
+      for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+	add_conv (BT_HOLLERITH, gfc_default_character_kind,
+		  BT_COMPLEX, gfc_real_kinds[i].kind, GFC_STD_LEGACY);
+
+      /* Hollerith-Character conversions.  */
+      add_conv (BT_HOLLERITH, gfc_default_character_kind, BT_CHARACTER,
+		  gfc_default_character_kind, GFC_STD_LEGACY);
+
+      /* Hollerith-Logical conversions.  */
+      for (i = 0; gfc_logical_kinds[i].kind != 0; i++)
+	add_conv (BT_HOLLERITH, gfc_default_character_kind,
+		  BT_LOGICAL, gfc_logical_kinds[i].kind, GFC_STD_LEGACY);
+    }
+
+  /* Real/Complex - Real/Complex conversions.  */
+  for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+    for (j = 0; gfc_real_kinds[j].kind != 0; j++)
+      {
+	if (i != j)
+	  {
+	    add_conv (BT_REAL, gfc_real_kinds[i].kind,
+		      BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
+
+	    add_conv (BT_COMPLEX, gfc_real_kinds[i].kind,
+		      BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
+	  }
+
+	add_conv (BT_REAL, gfc_real_kinds[i].kind,
+		  BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
+
+	add_conv (BT_COMPLEX, gfc_real_kinds[i].kind,
+		  BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
+      }
+
+  /* Logical/Logical kind conversion.  */
+  for (i = 0; gfc_logical_kinds[i].kind; i++)
+    for (j = 0; gfc_logical_kinds[j].kind; j++)
+      {
+	if (i == j)
+	  continue;
+
+	add_conv (BT_LOGICAL, gfc_logical_kinds[i].kind,
+		  BT_LOGICAL, gfc_logical_kinds[j].kind, GFC_STD_F77);
+      }
+
+  /* Integer-Logical and Logical-Integer conversions.  */
+  if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0)
+    for (i=0; gfc_integer_kinds[i].kind; i++)
+      for (j=0; gfc_logical_kinds[j].kind; j++)
+	{
+	  add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
+		    BT_LOGICAL, gfc_logical_kinds[j].kind, GFC_STD_LEGACY);
+	  add_conv (BT_LOGICAL, gfc_logical_kinds[j].kind,
+		    BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY);
+	}
+}
+
+
+static void
+add_char_conversions (void)
+{
+  int n, i, j;
+
+  /* Count possible conversions.  */
+  for (i = 0; gfc_character_kinds[i].kind != 0; i++)
+    for (j = 0; gfc_character_kinds[j].kind != 0; j++)
+      if (i != j)
+	ncharconv++;
+
+  /* Allocate memory.  */
+  char_conversions = XCNEWVEC (gfc_intrinsic_sym, ncharconv);
+
+  /* Add the conversions themselves.  */
+  n = 0;
+  for (i = 0; gfc_character_kinds[i].kind != 0; i++)
+    for (j = 0; gfc_character_kinds[j].kind != 0; j++)
+      {
+	gfc_typespec from, to;
+
+	if (i == j)
+	  continue;
+
+	gfc_clear_ts (&from);
+	from.type = BT_CHARACTER;
+	from.kind = gfc_character_kinds[i].kind;
+
+	gfc_clear_ts (&to);
+	to.type = BT_CHARACTER;
+	to.kind = gfc_character_kinds[j].kind;
+
+	char_conversions[n].name = conv_name (&from, &to);
+	char_conversions[n].lib_name = char_conversions[n].name;
+	char_conversions[n].simplify.cc = gfc_convert_char_constant;
+	char_conversions[n].standard = GFC_STD_F2003;
+	char_conversions[n].elemental = 1;
+	char_conversions[n].pure = 1;
+	char_conversions[n].conversion = 0;
+	char_conversions[n].ts = to;
+	char_conversions[n].id = GFC_ISYM_CONVERSION;
+
+	n++;
+      }
+}
+
+
+/* Initialize the table of intrinsics.  */
+void
+gfc_intrinsic_init_1 (void)
+{
+  nargs = nfunc = nsub = nconv = 0;
+
+  /* Create a namespace to hold the resolved intrinsic symbols.  */
+  gfc_intrinsic_namespace = gfc_get_namespace (NULL, 0);
+
+  sizing = SZ_FUNCS;
+  add_functions ();
+  sizing = SZ_SUBS;
+  add_subroutines ();
+  sizing = SZ_CONVS;
+  add_conversions ();
+
+  functions = XCNEWVAR (struct gfc_intrinsic_sym,
+			sizeof (gfc_intrinsic_sym) * (nfunc + nsub)
+			+ sizeof (gfc_intrinsic_arg) * nargs);
+
+  next_sym = functions;
+  subroutines = functions + nfunc;
+
+  conversion = XCNEWVEC (gfc_intrinsic_sym, nconv);
+
+  next_arg = ((gfc_intrinsic_arg *) (subroutines + nsub)) - 1;
+
+  sizing = SZ_NOTHING;
+  nconv = 0;
+
+  add_functions ();
+  add_subroutines ();
+  add_conversions ();
+
+  /* Character conversion intrinsics need to be treated separately.  */
+  add_char_conversions ();
+}
+
+
+void
+gfc_intrinsic_done_1 (void)
+{
+  free (functions);
+  free (conversion);
+  free (char_conversions);
+  gfc_free_namespace (gfc_intrinsic_namespace);
+}
+
+
+/******** Subroutines to check intrinsic interfaces ***********/
+
+/* Given a formal argument list, remove any NULL arguments that may
+   have been left behind by a sort against some formal argument list.  */
+
+static void
+remove_nullargs (gfc_actual_arglist **ap)
+{
+  gfc_actual_arglist *head, *tail, *next;
+
+  tail = NULL;
+
+  for (head = *ap; head; head = next)
+    {
+      next = head->next;
+
+      if (head->expr == NULL && !head->label)
+	{
+	  head->next = NULL;
+	  gfc_free_actual_arglist (head);
+	}
+      else
+	{
+	  if (tail == NULL)
+	    *ap = head;
+	  else
+	    tail->next = head;
+
+	  tail = head;
+	  tail->next = NULL;
+	}
+    }
+
+  if (tail == NULL)
+    *ap = NULL;
+}
+
+
+/* Given an actual arglist and a formal arglist, sort the actual
+   arglist so that its arguments are in a one-to-one correspondence
+   with the format arglist.  Arguments that are not present are given
+   a blank gfc_actual_arglist structure.  If something is obviously
+   wrong (say, a missing required argument) we abort sorting and
+   return false.  */
+
+static bool
+sort_actual (const char *name, gfc_actual_arglist **ap,
+	     gfc_intrinsic_arg *formal, locus *where)
+{
+  gfc_actual_arglist *actual, *a;
+  gfc_intrinsic_arg *f;
+
+  remove_nullargs (ap);
+  actual = *ap;
+
+  for (f = formal; f; f = f->next)
+    f->actual = NULL;
+
+  f = formal;
+  a = actual;
+
+  if (f == NULL && a == NULL)	/* No arguments */
+    return true;
+
+  for (;;)
+    {		/* Put the nonkeyword arguments in a 1:1 correspondence */
+      if (f == NULL)
+	break;
+      if (a == NULL)
+	goto optional;
+
+      if (a->name != NULL)
+	goto keywords;
+
+      f->actual = a;
+
+      f = f->next;
+      a = a->next;
+    }
+
+  if (a == NULL)
+    goto do_sort;
+
+  gfc_error ("Too many arguments in call to '%s' at %L", name, where);
+  return false;
+
+keywords:
+  /* Associate the remaining actual arguments, all of which have
+     to be keyword arguments.  */
+  for (; a; a = a->next)
+    {
+      for (f = formal; f; f = f->next)
+	if (strcmp (a->name, f->name) == 0)
+	  break;
+
+      if (f == NULL)
+	{
+	  if (a->name[0] == '%')
+	    gfc_error ("The argument list functions %%VAL, %%LOC or %%REF "
+		       "are not allowed in this context at %L", where);
+	  else
+	    gfc_error ("Can't find keyword named '%s' in call to '%s' at %L",
+		       a->name, name, where);
+	  return false;
+	}
+
+      if (f->actual != NULL)
+	{
+	  gfc_error ("Argument '%s' appears twice in call to '%s' at %L",
+		     f->name, name, where);
+	  return false;
+	}
+
+      f->actual = a;
+    }
+
+optional:
+  /* At this point, all unmatched formal args must be optional.  */
+  for (f = formal; f; f = f->next)
+    {
+      if (f->actual == NULL && f->optional == 0)
+	{
+	  gfc_error ("Missing actual argument '%s' in call to '%s' at %L",
+		     f->name, name, where);
+	  return false;
+	}
+    }
+
+do_sort:
+  /* Using the formal argument list, string the actual argument list
+     together in a way that corresponds with the formal list.  */
+  actual = NULL;
+
+  for (f = formal; f; f = f->next)
+    {
+      if (f->actual && f->actual->label != NULL && f->ts.type)
+	{
+	  gfc_error ("ALTERNATE RETURN not permitted at %L", where);
+	  return false;
+	}
+
+      if (f->actual == NULL)
+	{
+	  a = gfc_get_actual_arglist ();
+	  a->missing_arg_type = f->ts.type;
+	}
+      else
+	a = f->actual;
+
+      if (actual == NULL)
+	*ap = a;
+      else
+	actual->next = a;
+
+      actual = a;
+    }
+  actual->next = NULL;		/* End the sorted argument list.  */
+
+  return true;
+}
+
+
+/* Compare an actual argument list with an intrinsic's formal argument
+   list.  The lists are checked for agreement of type.  We don't check
+   for arrayness here.  */
+
+static bool
+check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym,
+	       int error_flag)
+{
+  gfc_actual_arglist *actual;
+  gfc_intrinsic_arg *formal;
+  int i;
+
+  formal = sym->formal;
+  actual = *ap;
+
+  i = 0;
+  for (; formal; formal = formal->next, actual = actual->next, i++)
+    {
+      gfc_typespec ts;
+
+      if (actual->expr == NULL)
+	continue;
+
+      ts = formal->ts;
+
+      /* A kind of 0 means we don't check for kind.  */
+      if (ts.kind == 0)
+	ts.kind = actual->expr->ts.kind;
+
+      if (!gfc_compare_types (&ts, &actual->expr->ts))
+	{
+	  if (error_flag)
+	    gfc_error ("Type of argument '%s' in call to '%s' at %L should "
+		       "be %s, not %s", gfc_current_intrinsic_arg[i]->name,
+		       gfc_current_intrinsic, &actual->expr->where,
+		       gfc_typename (&formal->ts),
+		       gfc_typename (&actual->expr->ts));
+	  return false;
+	}
+
+      /* If the formal argument is INTENT([IN]OUT), check for definability.  */
+      if (formal->intent == INTENT_INOUT || formal->intent == INTENT_OUT)
+	{
+	  const char* context = (error_flag
+				 ? _("actual argument to INTENT = OUT/INOUT")
+				 : NULL);
+
+	  /* No pointer arguments for intrinsics.  */
+	  if (!gfc_check_vardef_context (actual->expr, false, false, false, context))
+	    return false;
+	}
+    }
+
+  return true;
+}
+
+
+/* Given a pointer to an intrinsic symbol and an expression node that
+   represent the function call to that subroutine, figure out the type
+   of the result.  This may involve calling a resolution subroutine.  */
+
+static void
+resolve_intrinsic (gfc_intrinsic_sym *specific, gfc_expr *e)
+{
+  gfc_expr *a1, *a2, *a3, *a4, *a5;
+  gfc_actual_arglist *arg;
+
+  if (specific->resolve.f1 == NULL)
+    {
+      if (e->value.function.name == NULL)
+	e->value.function.name = specific->lib_name;
+
+      if (e->ts.type == BT_UNKNOWN)
+	e->ts = specific->ts;
+      return;
+    }
+
+  arg = e->value.function.actual;
+
+  /* Special case hacks for MIN and MAX.  */
+  if (specific->resolve.f1m == gfc_resolve_max
+      || specific->resolve.f1m == gfc_resolve_min)
+    {
+      (*specific->resolve.f1m) (e, arg);
+      return;
+    }
+
+  if (arg == NULL)
+    {
+      (*specific->resolve.f0) (e);
+      return;
+    }
+
+  a1 = arg->expr;
+  arg = arg->next;
+
+  if (arg == NULL)
+    {
+      (*specific->resolve.f1) (e, a1);
+      return;
+    }
+
+  a2 = arg->expr;
+  arg = arg->next;
+
+  if (arg == NULL)
+    {
+      (*specific->resolve.f2) (e, a1, a2);
+      return;
+    }
+
+  a3 = arg->expr;
+  arg = arg->next;
+
+  if (arg == NULL)
+    {
+      (*specific->resolve.f3) (e, a1, a2, a3);
+      return;
+    }
+
+  a4 = arg->expr;
+  arg = arg->next;
+
+  if (arg == NULL)
+    {
+      (*specific->resolve.f4) (e, a1, a2, a3, a4);
+      return;
+    }
+
+  a5 = arg->expr;
+  arg = arg->next;
+
+  if (arg == NULL)
+    {
+      (*specific->resolve.f5) (e, a1, a2, a3, a4, a5);
+      return;
+    }
+
+  gfc_internal_error ("resolve_intrinsic(): Too many args for intrinsic");
+}
+
+
+/* Given an intrinsic symbol node and an expression node, call the
+   simplification function (if there is one), perhaps replacing the
+   expression with something simpler.  We return false on an error
+   of the simplification, true if the simplification worked, even
+   if nothing has changed in the expression itself.  */
+
+static bool
+do_simplify (gfc_intrinsic_sym *specific, gfc_expr *e)
+{
+  gfc_expr *result, *a1, *a2, *a3, *a4, *a5;
+  gfc_actual_arglist *arg;
+
+  /* Max and min require special handling due to the variable number
+     of args.  */
+  if (specific->simplify.f1 == gfc_simplify_min)
+    {
+      result = gfc_simplify_min (e);
+      goto finish;
+    }
+
+  if (specific->simplify.f1 == gfc_simplify_max)
+    {
+      result = gfc_simplify_max (e);
+      goto finish;
+    }
+
+  if (specific->simplify.f1 == NULL)
+    {
+      result = NULL;
+      goto finish;
+    }
+
+  arg = e->value.function.actual;
+
+  if (arg == NULL)
+    {
+      result = (*specific->simplify.f0) ();
+      goto finish;
+    }
+
+  a1 = arg->expr;
+  arg = arg->next;
+
+  if (specific->simplify.cc == gfc_convert_constant
+      || specific->simplify.cc == gfc_convert_char_constant)
+    {
+      result = specific->simplify.cc (a1, specific->ts.type, specific->ts.kind);
+      goto finish;
+    }
+
+  if (arg == NULL)
+    result = (*specific->simplify.f1) (a1);
+  else
+    {
+      a2 = arg->expr;
+      arg = arg->next;
+
+      if (arg == NULL)
+	result = (*specific->simplify.f2) (a1, a2);
+      else
+	{
+	  a3 = arg->expr;
+	  arg = arg->next;
+
+	  if (arg == NULL)
+	    result = (*specific->simplify.f3) (a1, a2, a3);
+	  else
+	    {
+	      a4 = arg->expr;
+	      arg = arg->next;
+
+	      if (arg == NULL)
+		result = (*specific->simplify.f4) (a1, a2, a3, a4);
+	      else
+		{
+		  a5 = arg->expr;
+		  arg = arg->next;
+
+		  if (arg == NULL)
+		    result = (*specific->simplify.f5) (a1, a2, a3, a4, a5);
+		  else
+		    gfc_internal_error
+		      ("do_simplify(): Too many args for intrinsic");
+		}
+	    }
+	}
+    }
+
+finish:
+  if (result == &gfc_bad_expr)
+    return false;
+
+  if (result == NULL)
+    resolve_intrinsic (specific, e);	/* Must call at run-time */
+  else
+    {
+      result->where = e->where;
+      gfc_replace_expr (e, result);
+    }
+
+  return true;
+}
+
+
+/* Initialize the gfc_current_intrinsic_arg[] array for the benefit of
+   error messages.  This subroutine returns false if a subroutine
+   has more than MAX_INTRINSIC_ARGS, in which case the actual argument
+   list cannot match any intrinsic.  */
+
+static void
+init_arglist (gfc_intrinsic_sym *isym)
+{
+  gfc_intrinsic_arg *formal;
+  int i;
+
+  gfc_current_intrinsic = isym->name;
+
+  i = 0;
+  for (formal = isym->formal; formal; formal = formal->next)
+    {
+      if (i >= MAX_INTRINSIC_ARGS)
+	gfc_internal_error ("init_arglist(): too many arguments");
+      gfc_current_intrinsic_arg[i++] = formal;
+    }
+}
+
+
+/* Given a pointer to an intrinsic symbol and an expression consisting
+   of a function call, see if the function call is consistent with the
+   intrinsic's formal argument list.  Return true if the expression
+   and intrinsic match, false otherwise.  */
+
+static bool
+check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag)
+{
+  gfc_actual_arglist *arg, **ap;
+  bool t;
+
+  ap = &expr->value.function.actual;
+
+  init_arglist (specific);
+
+  /* Don't attempt to sort the argument list for min or max.  */
+  if (specific->check.f1m == gfc_check_min_max
+      || specific->check.f1m == gfc_check_min_max_integer
+      || specific->check.f1m == gfc_check_min_max_real
+      || specific->check.f1m == gfc_check_min_max_double)
+    {
+      if (!do_ts29113_check (specific, *ap))
+	return false;
+      return (*specific->check.f1m) (*ap);
+    }
+
+  if (!sort_actual (specific->name, ap, specific->formal, &expr->where))
+    return false;
+
+  if (!do_ts29113_check (specific, *ap))
+    return false;
+
+  if (specific->check.f3ml == gfc_check_minloc_maxloc)
+    /* This is special because we might have to reorder the argument list.  */
+    t = gfc_check_minloc_maxloc (*ap);
+  else if (specific->check.f3red == gfc_check_minval_maxval)
+    /* This is also special because we also might have to reorder the
+       argument list.  */
+    t = gfc_check_minval_maxval (*ap);
+  else if (specific->check.f3red == gfc_check_product_sum)
+    /* Same here. The difference to the previous case is that we allow a
+       general numeric type.  */
+    t = gfc_check_product_sum (*ap);
+  else if (specific->check.f3red == gfc_check_transf_bit_intrins)
+    /* Same as for PRODUCT and SUM, but different checks.  */
+    t = gfc_check_transf_bit_intrins (*ap);
+  else
+     {
+       if (specific->check.f1 == NULL)
+	 {
+	   t = check_arglist (ap, specific, error_flag);
+	   if (t)
+	     expr->ts = specific->ts;
+	 }
+       else
+	 t = do_check (specific, *ap);
+     }
+
+  /* Check conformance of elemental intrinsics.  */
+  if (t && specific->elemental)
+    {
+      int n = 0;
+      gfc_expr *first_expr;
+      arg = expr->value.function.actual;
+
+      /* There is no elemental intrinsic without arguments.  */
+      gcc_assert(arg != NULL);
+      first_expr = arg->expr;
+
+      for ( ; arg && arg->expr; arg = arg->next, n++)
+	if (!gfc_check_conformance (first_expr, arg->expr, 
+				    "arguments '%s' and '%s' for "
+				    "intrinsic '%s'", 
+				    gfc_current_intrinsic_arg[0]->name, 
+				    gfc_current_intrinsic_arg[n]->name, 
+				    gfc_current_intrinsic))
+	  return false;
+    }
+
+  if (!t)
+    remove_nullargs (ap);
+
+  return t;
+}
+
+
+/* Check whether an intrinsic belongs to whatever standard the user
+   has chosen, taking also into account -fall-intrinsics.  Here, no
+   warning/error is emitted; but if symstd is not NULL, it is pointed to a
+   textual representation of the symbols standard status (like
+   "new in Fortran 2008", "a GNU extension" or "obsolescent in Fortran 95") that
+   can be used to construct a detailed warning/error message in case of
+   a false.  */
+
+bool
+gfc_check_intrinsic_standard (const gfc_intrinsic_sym* isym,
+			      const char** symstd, bool silent, locus where)
+{
+  const char* symstd_msg;
+
+  /* For -fall-intrinsics, just succeed.  */
+  if (gfc_option.flag_all_intrinsics)
+    return true;
+
+  /* Find the symbol's standard message for later usage.  */
+  switch (isym->standard)
+    {
+    case GFC_STD_F77:
+      symstd_msg = "available since Fortran 77";
+      break;
+
+    case GFC_STD_F95_OBS:
+      symstd_msg = "obsolescent in Fortran 95";
+      break;
+
+    case GFC_STD_F95_DEL:
+      symstd_msg = "deleted in Fortran 95";
+      break;
+
+    case GFC_STD_F95:
+      symstd_msg = "new in Fortran 95";
+      break;
+
+    case GFC_STD_F2003:
+      symstd_msg = "new in Fortran 2003";
+      break;
+
+    case GFC_STD_F2008:
+      symstd_msg = "new in Fortran 2008";
+      break;
+
+    case GFC_STD_F2008_TS:
+      symstd_msg = "new in TS 29113";
+      break;
+
+    case GFC_STD_GNU:
+      symstd_msg = "a GNU Fortran extension";
+      break;
+
+    case GFC_STD_LEGACY:
+      symstd_msg = "for backward compatibility";
+      break;
+
+    default:
+      gfc_internal_error ("Invalid standard code on intrinsic '%s' (%d)",
+			  isym->name, isym->standard);
+    }
+
+  /* If warning about the standard, warn and succeed.  */
+  if (gfc_option.warn_std & isym->standard)
+    {
+      /* Do only print a warning if not a GNU extension.  */
+      if (!silent && isym->standard != GFC_STD_GNU)
+	gfc_warning ("Intrinsic '%s' (is %s) is used at %L",
+		     isym->name, _(symstd_msg), &where);
+
+      return true;
+    }
+
+  /* If allowing the symbol's standard, succeed, too.  */
+  if (gfc_option.allow_std & isym->standard)
+    return true;
+
+  /* Otherwise, fail.  */
+  if (symstd)
+    *symstd = _(symstd_msg);
+  return false;
+}
+
+
+/* See if a function call corresponds to an intrinsic function call.
+   We return:
+
+    MATCH_YES    if the call corresponds to an intrinsic, simplification
+		 is done if possible.
+
+    MATCH_NO     if the call does not correspond to an intrinsic
+
+    MATCH_ERROR  if the call corresponds to an intrinsic but there was an
+		 error during the simplification process.
+
+   The error_flag parameter enables an error reporting.  */
+
+match
+gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag)
+{
+  gfc_intrinsic_sym *isym, *specific;
+  gfc_actual_arglist *actual;
+  const char *name;
+  int flag;
+
+  if (expr->value.function.isym != NULL)
+    return (!do_simplify(expr->value.function.isym, expr))
+	   ? MATCH_ERROR : MATCH_YES;
+
+  if (!error_flag)
+    gfc_push_suppress_errors ();
+  flag = 0;
+
+  for (actual = expr->value.function.actual; actual; actual = actual->next)
+    if (actual->expr != NULL)
+      flag |= (actual->expr->ts.type != BT_INTEGER
+	       && actual->expr->ts.type != BT_CHARACTER);
+
+  name = expr->symtree->n.sym->name;
+
+  if (expr->symtree->n.sym->intmod_sym_id)
+    {
+      gfc_isym_id id = gfc_isym_id_by_intmod_sym (expr->symtree->n.sym);
+      isym = specific = gfc_intrinsic_function_by_id (id);
+    }
+  else
+    isym = specific = gfc_find_function (name);
+
+  if (isym == NULL)
+    {
+      if (!error_flag)
+	gfc_pop_suppress_errors ();
+      return MATCH_NO;
+    }
+
+  if ((isym->id == GFC_ISYM_REAL || isym->id == GFC_ISYM_DBLE
+       || isym->id == GFC_ISYM_CMPLX)
+      && gfc_init_expr_flag
+      && !gfc_notify_std (GFC_STD_F2003, "Function '%s' as initialization "
+			  "expression at %L", name, &expr->where))
+    {
+      if (!error_flag)
+	gfc_pop_suppress_errors ();
+      return MATCH_ERROR;
+    }
+
+  gfc_current_intrinsic_where = &expr->where;
+
+  /* Bypass the generic list for min, max and ISO_C_Binding's c_loc.  */
+  if (isym->check.f1m == gfc_check_min_max)
+    {
+      init_arglist (isym);
+
+      if (isym->check.f1m(expr->value.function.actual))
+	goto got_specific;
+
+      if (!error_flag)
+	gfc_pop_suppress_errors ();
+      return MATCH_NO;
+    }
+
+  /* If the function is generic, check all of its specific
+     incarnations.  If the generic name is also a specific, we check
+     that name last, so that any error message will correspond to the
+     specific.  */
+  gfc_push_suppress_errors ();
+
+  if (isym->generic)
+    {
+      for (specific = isym->specific_head; specific;
+	   specific = specific->next)
+	{
+	  if (specific == isym)
+	    continue;
+	  if (check_specific (specific, expr, 0))
+	    {
+	      gfc_pop_suppress_errors ();
+	      goto got_specific;
+	    }
+	}
+    }
+
+  gfc_pop_suppress_errors ();
+
+  if (!check_specific (isym, expr, error_flag))
+    {
+      if (!error_flag)
+	gfc_pop_suppress_errors ();
+      return MATCH_NO;
+    }
+
+  specific = isym;
+
+got_specific:
+  expr->value.function.isym = specific;
+  if (!expr->symtree->n.sym->module)
+    gfc_intrinsic_symbol (expr->symtree->n.sym);
+
+  if (!error_flag)
+    gfc_pop_suppress_errors ();
+
+  if (!do_simplify (specific, expr))
+    return MATCH_ERROR;
+
+  /* F95, 7.1.6.1, Initialization expressions
+     (4) An elemental intrinsic function reference of type integer or
+         character where each argument is an initialization expression
+         of type integer or character
+
+     F2003, 7.1.7 Initialization expression
+     (4)   A reference to an elemental standard intrinsic function,
+           where each argument is an initialization expression  */
+
+  if (gfc_init_expr_flag && isym->elemental && flag
+      && !gfc_notify_std (GFC_STD_F2003, "Elemental function as "
+			  "initialization expression with non-integer/non-"
+			  "character arguments at %L", &expr->where))
+    return MATCH_ERROR;
+
+  return MATCH_YES;
+}
+
+
+/* See if a CALL statement corresponds to an intrinsic subroutine.
+   Returns MATCH_YES if the subroutine corresponds to an intrinsic,
+   MATCH_NO if not, and MATCH_ERROR if there was an error (but did
+   correspond).  */
+
+match
+gfc_intrinsic_sub_interface (gfc_code *c, int error_flag)
+{
+  gfc_intrinsic_sym *isym;
+  const char *name;
+
+  name = c->symtree->n.sym->name;
+
+  if (c->symtree->n.sym->intmod_sym_id)
+    {
+      gfc_isym_id id;
+      id = gfc_isym_id_by_intmod_sym (c->symtree->n.sym);
+      isym = gfc_intrinsic_subroutine_by_id (id);
+    }
+  else
+    isym = gfc_find_subroutine (name);
+  if (isym == NULL)
+    return MATCH_NO;
+
+  if (!error_flag)
+    gfc_push_suppress_errors ();
+
+  init_arglist (isym);
+
+  if (!sort_actual (name, &c->ext.actual, isym->formal, &c->loc))
+    goto fail;
+
+  if (!do_ts29113_check (isym, c->ext.actual))
+    goto fail;
+
+  if (isym->check.f1 != NULL)
+    {
+      if (!do_check (isym, c->ext.actual))
+	goto fail;
+    }
+  else
+    {
+      if (!check_arglist (&c->ext.actual, isym, 1))
+	goto fail;
+    }
+
+  /* The subroutine corresponds to an intrinsic.  Allow errors to be
+     seen at this point.  */
+  if (!error_flag)
+    gfc_pop_suppress_errors ();
+
+  c->resolved_isym = isym;
+  if (isym->resolve.s1 != NULL)
+    isym->resolve.s1 (c);
+  else
+    {
+      c->resolved_sym = gfc_get_intrinsic_sub_symbol (isym->lib_name);
+      c->resolved_sym->attr.elemental = isym->elemental;
+    }
+
+  if (gfc_do_concurrent_flag && !isym->pure)
+    {
+      gfc_error ("Subroutine call to intrinsic '%s' in DO CONCURRENT "
+		 "block at %L is not PURE", name, &c->loc);
+      return MATCH_ERROR;
+    }
+
+  if (!isym->pure && gfc_pure (NULL))
+    {
+      gfc_error ("Subroutine call to intrinsic '%s' at %L is not PURE", name,
+		 &c->loc);
+      return MATCH_ERROR;
+    }
+
+  if (!isym->pure)
+    gfc_unset_implicit_pure (NULL);
+
+  c->resolved_sym->attr.noreturn = isym->noreturn;
+
+  return MATCH_YES;
+
+fail:
+  if (!error_flag)
+    gfc_pop_suppress_errors ();
+  return MATCH_NO;
+}
+
+
+/* Call gfc_convert_type() with warning enabled.  */
+
+bool
+gfc_convert_type (gfc_expr *expr, gfc_typespec *ts, int eflag)
+{
+  return gfc_convert_type_warn (expr, ts, eflag, 1);
+}
+
+
+/* Try to convert an expression (in place) from one type to another.
+   'eflag' controls the behavior on error.
+
+   The possible values are:
+
+     1 Generate a gfc_error()
+     2 Generate a gfc_internal_error().
+
+   'wflag' controls the warning related to conversion.  */
+
+bool
+gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag)
+{
+  gfc_intrinsic_sym *sym;
+  gfc_typespec from_ts;
+  locus old_where;
+  gfc_expr *new_expr;
+  int rank;
+  mpz_t *shape;
+
+  from_ts = expr->ts;		/* expr->ts gets clobbered */
+
+  if (ts->type == BT_UNKNOWN)
+    goto bad;
+
+  /* NULL and zero size arrays get their type here.  */
+  if (expr->expr_type == EXPR_NULL
+      || (expr->expr_type == EXPR_ARRAY && expr->value.constructor == NULL))
+    {
+      /* Sometimes the RHS acquire the type.  */
+      expr->ts = *ts;
+      return true;
+    }
+
+  if (expr->ts.type == BT_UNKNOWN)
+    goto bad;
+
+  if (expr->ts.type == BT_DERIVED && ts->type == BT_DERIVED
+      && gfc_compare_types (&expr->ts, ts))
+    return true;
+
+  sym = find_conv (&expr->ts, ts);
+  if (sym == NULL)
+    goto bad;
+
+  /* At this point, a conversion is necessary. A warning may be needed.  */
+  if ((gfc_option.warn_std & sym->standard) != 0)
+    {
+      gfc_warning_now ("Extension: Conversion from %s to %s at %L",
+		       gfc_typename (&from_ts), gfc_typename (ts),
+		       &expr->where);
+    }
+  else if (wflag)
+    {
+      if (gfc_option.flag_range_check
+	  && expr->expr_type == EXPR_CONSTANT
+	  && from_ts.type == ts->type)
+	{
+	  /* Do nothing. Constants of the same type are range-checked
+	     elsewhere. If a value too large for the target type is
+	     assigned, an error is generated. Not checking here avoids
+	     duplications of warnings/errors.
+	     If range checking was disabled, but -Wconversion enabled,
+	     a non range checked warning is generated below.  */
+	}
+      else if (from_ts.type == BT_LOGICAL || ts->type == BT_LOGICAL)
+	{
+	  /* Do nothing. This block exists only to simplify the other
+	     else-if expressions.
+	       LOGICAL <> LOGICAL    no warning, independent of kind values
+	       LOGICAL <> INTEGER    extension, warned elsewhere
+	       LOGICAL <> REAL       invalid, error generated elsewhere
+	       LOGICAL <> COMPLEX    invalid, error generated elsewhere  */
+	}
+      else if (from_ts.type == ts->type
+	       || (from_ts.type == BT_INTEGER && ts->type == BT_REAL)
+	       || (from_ts.type == BT_INTEGER && ts->type == BT_COMPLEX)
+	       || (from_ts.type == BT_REAL && ts->type == BT_COMPLEX))
+	{
+	  /* Larger kinds can hold values of smaller kinds without problems.
+	     Hence, only warn if target kind is smaller than the source
+	     kind - or if -Wconversion-extra is specified.  */
+	  if (gfc_option.warn_conversion_extra)
+	    gfc_warning_now ("Conversion from %s to %s at %L",
+			     gfc_typename (&from_ts), gfc_typename (ts),
+			     &expr->where);
+	  else if (gfc_option.gfc_warn_conversion
+		   && from_ts.kind > ts->kind)
+	    gfc_warning_now ("Possible change of value in conversion "
+			     "from %s to %s at %L", gfc_typename (&from_ts),
+			     gfc_typename (ts), &expr->where);
+	}
+      else if ((from_ts.type == BT_REAL && ts->type == BT_INTEGER)
+	       || (from_ts.type == BT_COMPLEX && ts->type == BT_INTEGER)
+	       || (from_ts.type == BT_COMPLEX && ts->type == BT_REAL))
+	{
+	  /* Conversion from REAL/COMPLEX to INTEGER or COMPLEX to REAL
+	     usually comes with a loss of information, regardless of kinds.  */
+	  if (gfc_option.warn_conversion_extra
+	      || gfc_option.gfc_warn_conversion)
+	    gfc_warning_now ("Possible change of value in conversion "
+			     "from %s to %s at %L", gfc_typename (&from_ts),
+			     gfc_typename (ts), &expr->where);
+	}
+      else if (from_ts.type == BT_HOLLERITH || ts->type == BT_HOLLERITH)
+	{
+	  /* If HOLLERITH is involved, all bets are off.  */
+	  if (gfc_option.warn_conversion_extra
+	      || gfc_option.gfc_warn_conversion)
+	    gfc_warning_now ("Conversion from %s to %s at %L",
+			     gfc_typename (&from_ts), gfc_typename (ts),
+			     &expr->where);
+	}
+      else
+        gcc_unreachable ();
+    }
+
+  /* Insert a pre-resolved function call to the right function.  */
+  old_where = expr->where;
+  rank = expr->rank;
+  shape = expr->shape;
+
+  new_expr = gfc_get_expr ();
+  *new_expr = *expr;
+
+  new_expr = gfc_build_conversion (new_expr);
+  new_expr->value.function.name = sym->lib_name;
+  new_expr->value.function.isym = sym;
+  new_expr->where = old_where;
+  new_expr->rank = rank;
+  new_expr->shape = gfc_copy_shape (shape, rank);
+
+  gfc_get_ha_sym_tree (sym->name, &new_expr->symtree);
+  new_expr->symtree->n.sym->result = new_expr->symtree->n.sym;
+  new_expr->symtree->n.sym->ts = *ts;
+  new_expr->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+  new_expr->symtree->n.sym->attr.function = 1;
+  new_expr->symtree->n.sym->attr.elemental = 1;
+  new_expr->symtree->n.sym->attr.pure = 1;
+  new_expr->symtree->n.sym->attr.referenced = 1;
+  gfc_intrinsic_symbol(new_expr->symtree->n.sym);
+  gfc_commit_symbol (new_expr->symtree->n.sym);
+
+  *expr = *new_expr;
+
+  free (new_expr);
+  expr->ts = *ts;
+
+  if (gfc_is_constant_expr (expr->value.function.actual->expr)
+      && !do_simplify (sym, expr))
+    {
+
+      if (eflag == 2)
+	goto bad;
+      return false;		/* Error already generated in do_simplify() */
+    }
+
+  return true;
+
+bad:
+  if (eflag == 1)
+    {
+      gfc_error ("Can't convert %s to %s at %L",
+		 gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
+      return false;
+    }
+
+  gfc_internal_error ("Can't convert %s to %s at %L",
+		      gfc_typename (&from_ts), gfc_typename (ts),
+		      &expr->where);
+  /* Not reached */
+}
+
+
+bool
+gfc_convert_chartype (gfc_expr *expr, gfc_typespec *ts)
+{
+  gfc_intrinsic_sym *sym;
+  locus old_where;
+  gfc_expr *new_expr;
+  int rank;
+  mpz_t *shape;
+
+  gcc_assert (expr->ts.type == BT_CHARACTER && ts->type == BT_CHARACTER);
+
+  sym = find_char_conv (&expr->ts, ts);
+  gcc_assert (sym);
+
+  /* Insert a pre-resolved function call to the right function.  */
+  old_where = expr->where;
+  rank = expr->rank;
+  shape = expr->shape;
+
+  new_expr = gfc_get_expr ();
+  *new_expr = *expr;
+
+  new_expr = gfc_build_conversion (new_expr);
+  new_expr->value.function.name = sym->lib_name;
+  new_expr->value.function.isym = sym;
+  new_expr->where = old_where;
+  new_expr->rank = rank;
+  new_expr->shape = gfc_copy_shape (shape, rank);
+
+  gfc_get_ha_sym_tree (sym->name, &new_expr->symtree);
+  new_expr->symtree->n.sym->ts = *ts;
+  new_expr->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+  new_expr->symtree->n.sym->attr.function = 1;
+  new_expr->symtree->n.sym->attr.elemental = 1;
+  new_expr->symtree->n.sym->attr.referenced = 1;
+  gfc_intrinsic_symbol(new_expr->symtree->n.sym);
+  gfc_commit_symbol (new_expr->symtree->n.sym);
+
+  *expr = *new_expr;
+
+  free (new_expr);
+  expr->ts = *ts;
+
+  if (gfc_is_constant_expr (expr->value.function.actual->expr)
+      && !do_simplify (sym, expr))
+    {
+      /* Error already generated in do_simplify() */
+      return false;
+    }
+
+  return true;
+}
+
+
+/* Check if the passed name is name of an intrinsic (taking into account the
+   current -std=* and -fall-intrinsic settings).  If it is, see if we should
+   warn about this as a user-procedure having the same name as an intrinsic
+   (-Wintrinsic-shadow enabled) and do so if we should.  */
+
+void
+gfc_warn_intrinsic_shadow (const gfc_symbol* sym, bool in_module, bool func)
+{
+  gfc_intrinsic_sym* isym;
+
+  /* If the warning is disabled, do nothing at all.  */
+  if (!gfc_option.warn_intrinsic_shadow)
+    return;
+
+  /* Try to find an intrinsic of the same name.  */
+  if (func)
+    isym = gfc_find_function (sym->name);
+  else  
+    isym = gfc_find_subroutine (sym->name);
+
+  /* If no intrinsic was found with this name or it's not included in the
+     selected standard, everything's fine.  */
+  if (!isym || !gfc_check_intrinsic_standard (isym, NULL, true, 
+					      sym->declared_at))
+    return;
+
+  /* Emit the warning.  */
+  if (in_module || sym->ns->proc_name)
+    gfc_warning ("'%s' declared at %L may shadow the intrinsic of the same"
+		 " name.  In order to call the intrinsic, explicit INTRINSIC"
+		 " declarations may be required.",
+		 sym->name, &sym->declared_at);
+  else
+    gfc_warning ("'%s' declared at %L is also the name of an intrinsic.  It can"
+		 " only be called via an explicit interface or if declared"
+		 " EXTERNAL.", sym->name, &sym->declared_at);
+}
diff --git a/gcc-4.9/gcc/fortran/intrinsic.h b/gcc-4.9/gcc/fortran/intrinsic.h
new file mode 100644
index 000000000..d7f795400
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/intrinsic.h
@@ -0,0 +1,641 @@
+/* Header file for intrinsics check, resolve and simplify function
+   prototypes.
+   Copyright (C) 2000-2014 Free Software Foundation, Inc.
+   Contributed by Andy Vaught & Katherine Holcomb
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+/* Expression returned when simplification fails.  */
+
+extern gfc_expr gfc_bad_expr;
+
+
+/* Check functions.  */
+bool gfc_check_a_ikind (gfc_expr *, gfc_expr *);
+bool gfc_check_a_xkind (gfc_expr *, gfc_expr *);
+bool gfc_check_a_p (gfc_expr *, gfc_expr *);
+bool gfc_check_x_yd (gfc_expr *, gfc_expr *);
+
+bool gfc_check_abs (gfc_expr *);
+bool gfc_check_access_func (gfc_expr *, gfc_expr *);
+bool gfc_check_achar (gfc_expr *, gfc_expr *);
+bool gfc_check_all_any (gfc_expr *, gfc_expr *);
+bool gfc_check_allocated (gfc_expr *);
+bool gfc_check_associated (gfc_expr *, gfc_expr *);
+bool gfc_check_atan_2 (gfc_expr *, gfc_expr *);
+bool gfc_check_atan2 (gfc_expr *, gfc_expr *);
+bool gfc_check_atomic_def (gfc_expr *, gfc_expr *);
+bool gfc_check_atomic_ref (gfc_expr *, gfc_expr *);
+bool gfc_check_besn (gfc_expr *, gfc_expr *);
+bool gfc_check_bessel_n2 (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_bge_bgt_ble_blt (gfc_expr *, gfc_expr *);
+bool gfc_check_bitfcn (gfc_expr *, gfc_expr *);
+bool gfc_check_char (gfc_expr *, gfc_expr *);
+bool gfc_check_chdir (gfc_expr *);
+bool gfc_check_chmod (gfc_expr *, gfc_expr *);
+bool gfc_check_cmplx (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_complex (gfc_expr *, gfc_expr *);
+bool gfc_check_count (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_cshift (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_ctime (gfc_expr *);
+bool gfc_check_datan2 (gfc_expr *, gfc_expr *);
+bool gfc_check_dcmplx (gfc_expr *, gfc_expr *);
+bool gfc_check_dble (gfc_expr *);
+bool gfc_check_digits (gfc_expr *);
+bool gfc_check_dot_product (gfc_expr *, gfc_expr *);
+bool gfc_check_dprod (gfc_expr *, gfc_expr *);
+bool gfc_check_dshift (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_dtime_etime (gfc_expr *);
+bool gfc_check_fgetputc (gfc_expr *, gfc_expr *);
+bool gfc_check_fgetput (gfc_expr *);
+bool gfc_check_float (gfc_expr *);
+bool gfc_check_fstat (gfc_expr *, gfc_expr *);
+bool gfc_check_ftell (gfc_expr *);
+bool gfc_check_fn_c (gfc_expr *);
+bool gfc_check_fn_d (gfc_expr *);
+bool gfc_check_fn_r (gfc_expr *);
+bool gfc_check_fn_rc (gfc_expr *);
+bool gfc_check_fn_rc2008 (gfc_expr *);
+bool gfc_check_fnum (gfc_expr *);
+bool gfc_check_hostnm (gfc_expr *);
+bool gfc_check_huge (gfc_expr *);
+bool gfc_check_hypot (gfc_expr *, gfc_expr *);
+bool gfc_check_i (gfc_expr *);
+bool gfc_check_iand (gfc_expr *, gfc_expr *);
+bool gfc_check_and (gfc_expr *, gfc_expr *);
+bool gfc_check_ibits (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_ichar_iachar (gfc_expr *, gfc_expr *);
+bool gfc_check_idnint (gfc_expr *);
+bool gfc_check_ieor (gfc_expr *, gfc_expr *);
+bool gfc_check_index (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_int (gfc_expr *, gfc_expr *);
+bool gfc_check_intconv (gfc_expr *);
+bool gfc_check_ior (gfc_expr *, gfc_expr *);
+bool gfc_check_irand (gfc_expr *);
+bool gfc_check_isatty (gfc_expr *);
+bool gfc_check_isnan (gfc_expr *);
+bool gfc_check_ishft (gfc_expr *, gfc_expr *);
+bool gfc_check_ishftc (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_kill (gfc_expr *, gfc_expr *);
+bool gfc_check_kind (gfc_expr *);
+bool gfc_check_lbound (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_lcobound (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_len_lentrim (gfc_expr *, gfc_expr *);
+bool gfc_check_link (gfc_expr *, gfc_expr *);
+bool gfc_check_lge_lgt_lle_llt (gfc_expr *, gfc_expr *);
+bool gfc_check_loc (gfc_expr *);
+bool gfc_check_logical (gfc_expr *, gfc_expr *);
+bool gfc_check_min_max (gfc_actual_arglist *);
+bool gfc_check_min_max_integer (gfc_actual_arglist *);
+bool gfc_check_min_max_real (gfc_actual_arglist *);
+bool gfc_check_min_max_double (gfc_actual_arglist *);
+bool gfc_check_malloc (gfc_expr *);
+bool gfc_check_mask (gfc_expr *, gfc_expr *);
+bool gfc_check_matmul (gfc_expr *, gfc_expr *);
+bool gfc_check_merge (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_merge_bits (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_minloc_maxloc (gfc_actual_arglist *);
+bool gfc_check_minval_maxval (gfc_actual_arglist *);
+bool gfc_check_nearest (gfc_expr *, gfc_expr *);
+bool gfc_check_new_line (gfc_expr *);
+bool gfc_check_norm2 (gfc_expr *, gfc_expr *);
+bool gfc_check_null (gfc_expr *);
+bool gfc_check_pack (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_parity (gfc_expr *, gfc_expr *);
+bool gfc_check_precision (gfc_expr *);
+bool gfc_check_present (gfc_expr *);
+bool gfc_check_product_sum (gfc_actual_arglist *);
+bool gfc_check_radix (gfc_expr *);
+bool gfc_check_rand (gfc_expr *);
+bool gfc_check_range (gfc_expr *);
+bool gfc_check_rank (gfc_expr *);
+bool gfc_check_real (gfc_expr *, gfc_expr *);
+bool gfc_check_rename (gfc_expr *, gfc_expr *);
+bool gfc_check_repeat (gfc_expr *, gfc_expr *);
+bool gfc_check_reshape (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_same_type_as (gfc_expr *, gfc_expr *);
+bool gfc_check_scale (gfc_expr *, gfc_expr *);
+bool gfc_check_scan (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_second_sub (gfc_expr *);
+bool gfc_check_secnds (gfc_expr *);
+bool gfc_check_selected_char_kind (gfc_expr *);
+bool gfc_check_selected_int_kind (gfc_expr *);
+bool gfc_check_selected_real_kind (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_set_exponent (gfc_expr *, gfc_expr *);
+bool gfc_check_shape (gfc_expr *, gfc_expr *);
+bool gfc_check_shift (gfc_expr *, gfc_expr *);
+bool gfc_check_size (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_sign (gfc_expr *, gfc_expr *);
+bool gfc_check_signal (gfc_expr *, gfc_expr *);
+bool gfc_check_sizeof (gfc_expr *);
+bool gfc_check_c_associated (gfc_expr *, gfc_expr *);
+bool gfc_check_c_f_pointer (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_c_f_procpointer (gfc_expr *, gfc_expr *);
+bool gfc_check_c_funloc (gfc_expr *);
+bool gfc_check_c_loc (gfc_expr *);
+bool gfc_check_c_sizeof (gfc_expr *);
+bool gfc_check_sngl (gfc_expr *);
+bool gfc_check_spread (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_srand (gfc_expr *);
+bool gfc_check_stat (gfc_expr *, gfc_expr *);
+bool gfc_check_storage_size (gfc_expr *, gfc_expr *);
+bool gfc_check_sum (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_symlnk (gfc_expr *, gfc_expr *);
+bool gfc_check_transf_bit_intrins (gfc_actual_arglist *);
+bool gfc_check_transfer (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_transpose (gfc_expr *);
+bool gfc_check_trim (gfc_expr *);
+bool gfc_check_ttynam (gfc_expr *);
+bool gfc_check_ubound (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_ucobound (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_umask (gfc_expr *);
+bool gfc_check_unlink (gfc_expr *);
+bool gfc_check_unpack (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_verify (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_x (gfc_expr *);
+
+
+/* Intrinsic subroutines.  */
+bool gfc_check_alarm_sub (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_chdir_sub (gfc_expr *, gfc_expr *);
+bool gfc_check_chmod_sub (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_cpu_time (gfc_expr *);
+bool gfc_check_ctime_sub (gfc_expr *, gfc_expr *);
+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_flush (gfc_expr *);
+bool gfc_check_free (gfc_expr *);
+bool gfc_check_fstat_sub (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_gerror (gfc_expr *);
+bool gfc_check_getarg (gfc_expr *, gfc_expr *);
+bool gfc_check_getlog (gfc_expr *);
+bool gfc_check_move_alloc (gfc_expr *, gfc_expr *);
+bool gfc_check_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
+		      gfc_expr *);
+bool gfc_check_random_number (gfc_expr *);
+bool gfc_check_random_seed (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_dtime_etime_sub (gfc_expr *, gfc_expr *);
+bool gfc_check_fgetputc_sub (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_fgetput_sub (gfc_expr *, gfc_expr *);
+bool gfc_check_fseek_sub (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_ftell_sub (gfc_expr *, gfc_expr *);
+bool gfc_check_getcwd_sub (gfc_expr *, gfc_expr *);
+bool gfc_check_hostnm_sub (gfc_expr *, gfc_expr *);
+bool gfc_check_image_index (gfc_expr *, gfc_expr *);
+bool gfc_check_itime_idate (gfc_expr *);
+bool gfc_check_kill_sub (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_ltime_gmtime (gfc_expr *, gfc_expr *);
+bool gfc_check_perror (gfc_expr *);
+bool gfc_check_rename_sub (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_link_sub (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_symlnk_sub (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_signal_sub (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_sleep_sub (gfc_expr *);
+bool gfc_check_stat_sub (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_system_sub (gfc_expr *, gfc_expr *);
+bool gfc_check_this_image (gfc_expr *, gfc_expr *);
+bool gfc_check_ttynam_sub (gfc_expr *, gfc_expr *);
+bool gfc_check_umask_sub (gfc_expr *, gfc_expr *);
+bool gfc_check_unlink_sub (gfc_expr *, gfc_expr *);
+
+
+/* Simplification functions.  */
+gfc_expr *gfc_simplify_abs (gfc_expr *);
+gfc_expr *gfc_simplify_achar (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_acos (gfc_expr *);
+gfc_expr *gfc_simplify_acosh (gfc_expr *);
+gfc_expr *gfc_simplify_adjustl (gfc_expr *);
+gfc_expr *gfc_simplify_adjustr (gfc_expr *);
+gfc_expr *gfc_simplify_aimag (gfc_expr *);
+gfc_expr *gfc_simplify_aint (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_all (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_dint (gfc_expr *);
+gfc_expr *gfc_simplify_anint (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_dnint (gfc_expr *);
+gfc_expr *gfc_simplify_and (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_any (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_asin (gfc_expr *);
+gfc_expr *gfc_simplify_asinh (gfc_expr *);
+gfc_expr *gfc_simplify_atan (gfc_expr *);
+gfc_expr *gfc_simplify_atanh (gfc_expr *);
+gfc_expr *gfc_simplify_atan2 (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_bessel_j0 (gfc_expr *);
+gfc_expr *gfc_simplify_bessel_j1 (gfc_expr *);
+gfc_expr *gfc_simplify_bessel_jn (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_bessel_jn2 (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_bessel_y0 (gfc_expr *);
+gfc_expr *gfc_simplify_bessel_y1 (gfc_expr *);
+gfc_expr *gfc_simplify_bessel_yn (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_bessel_yn2 (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_bge (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_bgt (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_bit_size (gfc_expr *);
+gfc_expr *gfc_simplify_ble (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_blt (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_btest (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_ceiling (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_char (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_cmplx (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_compiler_options (void);
+gfc_expr *gfc_simplify_compiler_version (void);
+gfc_expr *gfc_simplify_complex (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_conjg (gfc_expr *);
+gfc_expr *gfc_simplify_cos (gfc_expr *);
+gfc_expr *gfc_simplify_cosh (gfc_expr *);
+gfc_expr *gfc_simplify_count (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_dcmplx (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_dble (gfc_expr *);
+gfc_expr *gfc_simplify_digits (gfc_expr *);
+gfc_expr *gfc_simplify_dim (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_dprod (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_dot_product (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_dreal (gfc_expr *);
+gfc_expr *gfc_simplify_dshiftl (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_dshiftr (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_epsilon (gfc_expr *);
+gfc_expr *gfc_simplify_erf (gfc_expr *);
+gfc_expr *gfc_simplify_erfc (gfc_expr *);
+gfc_expr *gfc_simplify_erfc_scaled (gfc_expr *);
+gfc_expr *gfc_simplify_exp (gfc_expr *);
+gfc_expr *gfc_simplify_exponent (gfc_expr *);
+gfc_expr *gfc_simplify_extends_type_of (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_float (gfc_expr *);
+gfc_expr *gfc_simplify_floor (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_fraction (gfc_expr *);
+gfc_expr *gfc_simplify_gamma (gfc_expr *);
+gfc_expr *gfc_simplify_huge (gfc_expr *);
+gfc_expr *gfc_simplify_hypot (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_iachar (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_iall (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_iand (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_iany (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_ibclr (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_ibits (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_ibset (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_ichar (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_ieor (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_image_index (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_index (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_int (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_int2 (gfc_expr *);
+gfc_expr *gfc_simplify_int8 (gfc_expr *);
+gfc_expr *gfc_simplify_long (gfc_expr *);
+gfc_expr *gfc_simplify_ifix (gfc_expr *);
+gfc_expr *gfc_simplify_idint (gfc_expr *);
+gfc_expr *gfc_simplify_ior (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_iparity (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_is_iostat_end (gfc_expr *);
+gfc_expr *gfc_simplify_is_iostat_eor (gfc_expr *);
+gfc_expr *gfc_simplify_isnan (gfc_expr *);
+gfc_expr *gfc_simplify_ishft (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_ishftc (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_kind (gfc_expr *);
+gfc_expr *gfc_simplify_lbound (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_lcobound (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_leadz (gfc_expr *);
+gfc_expr *gfc_simplify_len (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_len_trim (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_lgamma (gfc_expr *);
+gfc_expr *gfc_simplify_lge (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_lgt (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_lle (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_llt (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_log (gfc_expr *);
+gfc_expr *gfc_simplify_log10 (gfc_expr *);
+gfc_expr *gfc_simplify_logical (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_lshift (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_matmul (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_maskl (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_maskr (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_merge (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_merge_bits (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_min (gfc_expr *);
+gfc_expr *gfc_simplify_minval (gfc_expr *, gfc_expr*, gfc_expr*);
+gfc_expr *gfc_simplify_max (gfc_expr *);
+gfc_expr *gfc_simplify_maxval (gfc_expr *, gfc_expr*, gfc_expr*);
+gfc_expr *gfc_simplify_maxexponent (gfc_expr *);
+gfc_expr *gfc_simplify_minexponent (gfc_expr *);
+gfc_expr *gfc_simplify_mod (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_modulo (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
+			       gfc_expr *);
+gfc_expr *gfc_simplify_nearest (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_new_line (gfc_expr *);
+gfc_expr *gfc_simplify_nint (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_norm2 (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_null (gfc_expr *);
+gfc_expr *gfc_simplify_num_images (void);
+gfc_expr *gfc_simplify_idnint (gfc_expr *);
+gfc_expr *gfc_simplify_not (gfc_expr *);
+gfc_expr *gfc_simplify_or (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_pack (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_parity (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_popcnt (gfc_expr *);
+gfc_expr *gfc_simplify_poppar (gfc_expr *);
+gfc_expr *gfc_simplify_precision (gfc_expr *);
+gfc_expr *gfc_simplify_product (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_radix (gfc_expr *);
+gfc_expr *gfc_simplify_range (gfc_expr *);
+gfc_expr *gfc_simplify_rank (gfc_expr *);
+gfc_expr *gfc_simplify_real (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_realpart (gfc_expr *);
+gfc_expr *gfc_simplify_repeat (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_reshape (gfc_expr *, gfc_expr *, gfc_expr *,
+				gfc_expr *);
+gfc_expr *gfc_simplify_rrspacing (gfc_expr *);
+gfc_expr *gfc_simplify_rshift (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_same_type_as (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_scale (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_scan (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_selected_char_kind (gfc_expr *);
+gfc_expr *gfc_simplify_selected_int_kind (gfc_expr *);
+gfc_expr *gfc_simplify_selected_real_kind (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_set_exponent (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_sign (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_shape (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_shifta (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_shiftl (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_shiftr (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_sin (gfc_expr *);
+gfc_expr *gfc_simplify_sinh (gfc_expr *);
+gfc_expr *gfc_simplify_size (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_sizeof (gfc_expr *);
+gfc_expr *gfc_simplify_storage_size (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_sngl (gfc_expr *);
+gfc_expr *gfc_simplify_spacing (gfc_expr *);
+gfc_expr *gfc_simplify_spread (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_sqrt (gfc_expr *);
+gfc_expr *gfc_simplify_sum (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_tan (gfc_expr *);
+gfc_expr *gfc_simplify_tanh (gfc_expr *);
+gfc_expr *gfc_simplify_this_image (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_tiny (gfc_expr *);
+gfc_expr *gfc_simplify_trailz (gfc_expr *);
+gfc_expr *gfc_simplify_transfer (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_transpose (gfc_expr *);
+gfc_expr *gfc_simplify_trim (gfc_expr *);
+gfc_expr *gfc_simplify_ubound (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_ucobound (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_unpack (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_verify (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_xor (gfc_expr *, gfc_expr *);
+
+/* Constant conversion simplification.  */
+gfc_expr *gfc_convert_constant (gfc_expr *, bt, int);
+gfc_expr *gfc_convert_char_constant (gfc_expr *, bt, int);
+
+
+/* Resolution functions.  */
+void gfc_resolve_abs (gfc_expr *, gfc_expr *);
+void gfc_resolve_access (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_adjustl (gfc_expr *, gfc_expr *);
+void gfc_resolve_adjustr (gfc_expr *, gfc_expr *);
+void gfc_resolve_achar (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_acos (gfc_expr *, gfc_expr *);
+void gfc_resolve_acosh (gfc_expr *, gfc_expr *);
+void gfc_resolve_aimag (gfc_expr *, gfc_expr *);
+void gfc_resolve_aint (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_dint (gfc_expr *, gfc_expr *);
+void gfc_resolve_all (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_anint (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_dnint (gfc_expr *, gfc_expr *);
+void gfc_resolve_and (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_any (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_asin (gfc_expr *, gfc_expr *);
+void gfc_resolve_asinh (gfc_expr *, gfc_expr *);
+void gfc_resolve_atan (gfc_expr *, gfc_expr *);
+void gfc_resolve_atanh (gfc_expr *, gfc_expr *);
+void gfc_resolve_atan2 (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_atomic_def (gfc_code *);
+void gfc_resolve_atomic_ref (gfc_code *);
+void gfc_resolve_besn (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_bessel_n2 (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *a);
+void gfc_resolve_btest (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_c_loc (gfc_expr *, gfc_expr *);
+void gfc_resolve_c_funloc (gfc_expr *, gfc_expr *);
+void gfc_resolve_ceiling (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_char (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_chdir (gfc_expr *, gfc_expr *);
+void gfc_resolve_chmod (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_cmplx (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_dcmplx (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_complex (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_conjg (gfc_expr *, gfc_expr *);
+void gfc_resolve_cos (gfc_expr *, gfc_expr *);
+void gfc_resolve_cosh (gfc_expr *, gfc_expr *);
+void gfc_resolve_count (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_cshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_ctime (gfc_expr *, gfc_expr *);
+void gfc_resolve_dble (gfc_expr *, gfc_expr *);
+void gfc_resolve_dim (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_dot_product (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_dprod (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_dshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_dtime_sub (gfc_code *);
+void gfc_resolve_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
+			  gfc_expr *);
+void gfc_resolve_etime_sub (gfc_code *);
+void gfc_resolve_exp (gfc_expr *, gfc_expr *);
+void gfc_resolve_exponent (gfc_expr *, gfc_expr *);
+void gfc_resolve_extends_type_of (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_fdate (gfc_expr *);
+void gfc_resolve_floor (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_fnum (gfc_expr *, gfc_expr *);
+void gfc_resolve_fraction (gfc_expr *, gfc_expr *);
+void gfc_resolve_fstat (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_ftell (gfc_expr *, gfc_expr *);
+void gfc_resolve_fgetc (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_fget (gfc_expr *, gfc_expr *);
+void gfc_resolve_fputc (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_fput (gfc_expr *, gfc_expr *);
+void gfc_resolve_g77_math1 (gfc_expr *, gfc_expr *);
+void gfc_resolve_gamma (gfc_expr *, gfc_expr *);
+void gfc_resolve_getcwd (gfc_expr *, gfc_expr *);
+void gfc_resolve_getgid (gfc_expr *);
+void gfc_resolve_getpid (gfc_expr *);
+void gfc_resolve_getuid (gfc_expr *);
+void gfc_resolve_hostnm (gfc_expr *, gfc_expr *);
+void gfc_resolve_hypot (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_iand (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_ibclr (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_ibits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_ibset (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_image_index (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_index_func (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
+			     gfc_expr *);
+void gfc_resolve_ierrno (gfc_expr *);
+void gfc_resolve_ieor (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_ichar (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_iachar (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_iall (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_iany (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_idnint (gfc_expr *, gfc_expr *);
+void gfc_resolve_int (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_int2 (gfc_expr *, gfc_expr *);
+void gfc_resolve_int8 (gfc_expr *, gfc_expr *);
+void gfc_resolve_long (gfc_expr *, gfc_expr *);
+void gfc_resolve_ior (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_iparity (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_isatty (gfc_expr *, gfc_expr *);
+void gfc_resolve_rank (gfc_expr *, gfc_expr *);
+void gfc_resolve_rshift (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_lshift (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_ishft (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_ishftc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_kill (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_lbound (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_lcobound (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_len (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_len_trim (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_lgamma (gfc_expr *, gfc_expr *);
+void gfc_resolve_link (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_loc (gfc_expr *, gfc_expr *);
+void gfc_resolve_log (gfc_expr *, gfc_expr *);
+void gfc_resolve_log10 (gfc_expr *, gfc_expr *);
+void gfc_resolve_logical (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_lstat (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_malloc (gfc_expr *, gfc_expr *);
+void gfc_resolve_matmul (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_max (gfc_expr *, gfc_actual_arglist *);
+void gfc_resolve_maxloc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_maxval (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_mclock (gfc_expr *);
+void gfc_resolve_mclock8 (gfc_expr *);
+void gfc_resolve_mask (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_merge (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_merge_bits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_min (gfc_expr *, gfc_actual_arglist *);
+void gfc_resolve_minloc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_minval (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_mod (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_modulo (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_nearest (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_nint (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_norm2 (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_not (gfc_expr *, gfc_expr *);
+void gfc_resolve_or (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_pack (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_parity (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_product (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_real (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_realpart (gfc_expr *, gfc_expr *);
+void gfc_resolve_rename (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_repeat (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_reshape (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
+			  gfc_expr *);
+void gfc_resolve_rrspacing (gfc_expr *, gfc_expr *);
+void gfc_resolve_scale (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_scan (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
+		       gfc_expr *);
+void gfc_resolve_second_sub (gfc_code *);
+void gfc_resolve_secnds (gfc_expr *, gfc_expr *);
+void gfc_resolve_set_exponent (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_shape (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_shift (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_sign (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_signal (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_sin (gfc_expr *, gfc_expr *);
+void gfc_resolve_sinh (gfc_expr *, gfc_expr *);
+void gfc_resolve_size (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_stride (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_spacing (gfc_expr *, gfc_expr *);
+void gfc_resolve_spread (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_sqrt (gfc_expr *, gfc_expr *);
+void gfc_resolve_stat (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a, gfc_expr *kind);
+void gfc_resolve_srand (gfc_code *);
+void gfc_resolve_sum (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_symlnk (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_system (gfc_expr *, gfc_expr *);
+void gfc_resolve_tan (gfc_expr *, gfc_expr *);
+void gfc_resolve_tanh (gfc_expr *, gfc_expr *);
+void gfc_resolve_this_image (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_time (gfc_expr *);
+void gfc_resolve_time8 (gfc_expr *);
+void gfc_resolve_transfer (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_transpose (gfc_expr *, gfc_expr *);
+void gfc_resolve_trim (gfc_expr *, gfc_expr *);
+void gfc_resolve_ttynam (gfc_expr *, gfc_expr *);
+void gfc_resolve_ubound (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_ucobound (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_umask (gfc_expr *, gfc_expr *);
+void gfc_resolve_unlink (gfc_expr *, gfc_expr *);
+void gfc_resolve_unpack (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_verify (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
+			 gfc_expr *);
+void gfc_resolve_xor (gfc_expr *, gfc_expr *, gfc_expr *);
+
+
+/* Intrinsic subroutine resolution.  */
+void gfc_resolve_alarm_sub (gfc_code *);
+void gfc_resolve_chdir_sub (gfc_code *);
+void gfc_resolve_chmod_sub (gfc_code *);
+void gfc_resolve_cpu_time (gfc_code *);
+void gfc_resolve_ctime_sub (gfc_code *);
+void gfc_resolve_execute_command_line (gfc_code *);
+void gfc_resolve_exit (gfc_code *);
+void gfc_resolve_fdate_sub (gfc_code *);
+void gfc_resolve_flush (gfc_code *);
+void gfc_resolve_free (gfc_code *);
+void gfc_resolve_fseek_sub (gfc_code *);
+void gfc_resolve_fstat_sub (gfc_code *);
+void gfc_resolve_ftell_sub (gfc_code *);
+void gfc_resolve_fgetc_sub (gfc_code *);
+void gfc_resolve_fget_sub (gfc_code *);
+void gfc_resolve_fputc_sub (gfc_code *);
+void gfc_resolve_fput_sub (gfc_code *);
+void gfc_resolve_gerror (gfc_code *);
+void gfc_resolve_getarg (gfc_code *);
+void gfc_resolve_getcwd_sub (gfc_code *);
+void gfc_resolve_getlog (gfc_code *);
+void gfc_resolve_get_command (gfc_code *);
+void gfc_resolve_get_command_argument (gfc_code *);
+void gfc_resolve_get_environment_variable (gfc_code *);
+void gfc_resolve_gmtime (gfc_code *);
+void gfc_resolve_hostnm_sub (gfc_code *);
+void gfc_resolve_idate (gfc_code *);
+void gfc_resolve_itime (gfc_code *);
+void gfc_resolve_kill_sub (gfc_code *);
+void gfc_resolve_lstat_sub (gfc_code *);
+void gfc_resolve_ltime (gfc_code *);
+void gfc_resolve_mvbits (gfc_code *);
+void gfc_resolve_perror (gfc_code *);
+void gfc_resolve_random_number (gfc_code *);
+void gfc_resolve_random_seed (gfc_code *);
+void gfc_resolve_rename_sub (gfc_code *);
+void gfc_resolve_link_sub (gfc_code *);
+void gfc_resolve_symlnk_sub (gfc_code *);
+void gfc_resolve_signal_sub (gfc_code *);
+void gfc_resolve_sleep_sub (gfc_code *);
+void gfc_resolve_stat_sub (gfc_code *);
+void gfc_resolve_system_clock (gfc_code *);
+void gfc_resolve_system_sub (gfc_code *);
+void gfc_resolve_ttynam_sub (gfc_code *);
+void gfc_resolve_umask_sub (gfc_code *);
+void gfc_resolve_unlink_sub (gfc_code *);
+
+
+/* The mvbits() subroutine requires the most arguments: five.  */
+
+#define MAX_INTRINSIC_ARGS 5
+
+extern const char *gfc_current_intrinsic;
+extern gfc_intrinsic_arg *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS];
+extern locus *gfc_current_intrinsic_where;
diff --git a/gcc-4.9/gcc/fortran/intrinsic.texi b/gcc-4.9/gcc/fortran/intrinsic.texi
new file mode 100644
index 000000000..792518d46
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/intrinsic.texi
@@ -0,0 +1,13231 @@
+@ignore
+Copyright (C) 2005-2014 Free Software Foundation, Inc.
+This is part of the GNU Fortran manual.   
+For copying conditions, see the file gfortran.texi.
+
+Permission is granted to copy, distribute and/or modify this document
+under the terms of the GNU Free Documentation License, Version 1.3 or
+any later version published by the Free Software Foundation; with the
+Invariant Sections being ``Funding Free Software'', the Front-Cover
+Texts being (a) (see below), and with the Back-Cover Texts being (b)
+(see below).  A copy of the license is included in the gfdl(7) man page.
+
+
+Some basic guidelines for editing this document:
+
+  (1) The intrinsic procedures are to be listed in alphabetical order.
+  (2) The generic name is to be used.
+  (3) The specific names are included in the function index and in a
+      table at the end of the node (See ABS entry).
+  (4) Try to maintain the same style for each entry.
+
+
+@end ignore
+
+@tex
+\gdef\acos{\mathop{\rm acos}\nolimits}
+\gdef\asin{\mathop{\rm asin}\nolimits}
+\gdef\atan{\mathop{\rm atan}\nolimits}
+\gdef\acosh{\mathop{\rm acosh}\nolimits}
+\gdef\asinh{\mathop{\rm asinh}\nolimits}
+\gdef\atanh{\mathop{\rm atanh}\nolimits}
+@end tex
+
+
+@node Intrinsic Procedures
+@chapter Intrinsic Procedures
+@cindex intrinsic procedures
+
+@menu
+* Introduction:         Introduction to Intrinsics
+* @code{ABORT}:         ABORT,     Abort the program     
+* @code{ABS}:           ABS,       Absolute value     
+* @code{ACCESS}:        ACCESS,    Checks file access modes
+* @code{ACHAR}:         ACHAR,     Character in @acronym{ASCII} collating sequence
+* @code{ACOS}:          ACOS,      Arccosine function
+* @code{ACOSH}:         ACOSH,     Inverse hyperbolic cosine function
+* @code{ADJUSTL}:       ADJUSTL,   Left adjust a string
+* @code{ADJUSTR}:       ADJUSTR,   Right adjust a string
+* @code{AIMAG}:         AIMAG,     Imaginary part of complex number
+* @code{AINT}:          AINT,      Truncate to a whole number
+* @code{ALARM}:         ALARM,     Set an alarm clock
+* @code{ALL}:           ALL,       Determine if all values are true
+* @code{ALLOCATED}:     ALLOCATED, Status of allocatable entity
+* @code{AND}:           AND,       Bitwise logical AND
+* @code{ANINT}:         ANINT,     Nearest whole number
+* @code{ANY}:           ANY,       Determine if any values are true
+* @code{ASIN}:          ASIN,      Arcsine function
+* @code{ASINH}:         ASINH,     Inverse hyperbolic sine function
+* @code{ASSOCIATED}:    ASSOCIATED, Status of a pointer or pointer/target pair
+* @code{ATAN}:          ATAN,      Arctangent function
+* @code{ATAN2}:         ATAN2,     Arctangent function
+* @code{ATANH}:         ATANH,     Inverse hyperbolic tangent function
+* @code{ATOMIC_DEFINE}: ATOMIC_DEFINE, Setting a variable atomically
+* @code{ATOMIC_REF}:    ATOMIC_REF, Obtaining the value of a variable atomically
+* @code{BACKTRACE}:     BACKTRACE, Show a backtrace
+* @code{BESSEL_J0}:     BESSEL_J0, Bessel function of the first kind of order 0
+* @code{BESSEL_J1}:     BESSEL_J1, Bessel function of the first kind of order 1
+* @code{BESSEL_JN}:     BESSEL_JN, Bessel function of the first kind
+* @code{BESSEL_Y0}:     BESSEL_Y0, Bessel function of the second kind of order 0
+* @code{BESSEL_Y1}:     BESSEL_Y1, Bessel function of the second kind of order 1
+* @code{BESSEL_YN}:     BESSEL_YN, Bessel function of the second kind
+* @code{BGE}:           BGE,       Bitwise greater than or equal to
+* @code{BGT}:           BGT,       Bitwise greater than
+* @code{BIT_SIZE}:      BIT_SIZE,  Bit size inquiry function
+* @code{BLE}:           BLE,       Bitwise less than or equal to
+* @code{BLT}:           BLT,       Bitwise less than
+* @code{BTEST}:         BTEST,     Bit test function
+* @code{C_ASSOCIATED}:  C_ASSOCIATED, Status of a C pointer
+* @code{C_F_POINTER}:   C_F_POINTER, Convert C into Fortran pointer
+* @code{C_F_PROCPOINTER}: C_F_PROCPOINTER, Convert C into Fortran procedure pointer
+* @code{C_FUNLOC}:      C_FUNLOC,  Obtain the C address of a procedure
+* @code{C_LOC}:         C_LOC,     Obtain the C address of an object
+* @code{C_SIZEOF}:      C_SIZEOF,  Size in bytes of an expression
+* @code{CEILING}:       CEILING,   Integer ceiling function
+* @code{CHAR}:          CHAR,      Integer-to-character conversion function
+* @code{CHDIR}:         CHDIR,     Change working directory
+* @code{CHMOD}:         CHMOD,     Change access permissions of files
+* @code{CMPLX}:         CMPLX,     Complex conversion function
+* @code{COMMAND_ARGUMENT_COUNT}: COMMAND_ARGUMENT_COUNT, Get number of command line arguments
+* @code{COMPILER_OPTIONS}: COMPILER_OPTIONS, Options passed to the compiler
+* @code{COMPILER_VERSION}: COMPILER_VERSION, Compiler version string
+* @code{COMPLEX}:       COMPLEX,   Complex conversion function
+* @code{CONJG}:         CONJG,     Complex conjugate function
+* @code{COS}:           COS,       Cosine function
+* @code{COSH}:          COSH,      Hyperbolic cosine function
+* @code{COUNT}:         COUNT,     Count occurrences of TRUE in an array
+* @code{CPU_TIME}:      CPU_TIME,  CPU time subroutine
+* @code{CSHIFT}:        CSHIFT,    Circular shift elements of an array
+* @code{CTIME}:         CTIME,     Subroutine (or function) to convert a time into a string
+* @code{DATE_AND_TIME}: DATE_AND_TIME, Date and time subroutine
+* @code{DBLE}:          DBLE,      Double precision conversion function
+* @code{DCMPLX}:        DCMPLX,    Double complex conversion function
+* @code{DIGITS}:        DIGITS,    Significant digits function
+* @code{DIM}:           DIM,       Positive difference
+* @code{DOT_PRODUCT}:   DOT_PRODUCT, Dot product function
+* @code{DPROD}:         DPROD,     Double product function
+* @code{DREAL}:         DREAL,     Double real part function
+* @code{DSHIFTL}:       DSHIFTL,   Combined left shift
+* @code{DSHIFTR}:       DSHIFTR,   Combined right shift
+* @code{DTIME}:         DTIME,     Execution time subroutine (or function)
+* @code{EOSHIFT}:       EOSHIFT,   End-off shift elements of an array
+* @code{EPSILON}:       EPSILON,   Epsilon function
+* @code{ERF}:           ERF,       Error function
+* @code{ERFC}:          ERFC,      Complementary error function
+* @code{ERFC_SCALED}:   ERFC_SCALED, Exponentially-scaled complementary error function
+* @code{ETIME}:         ETIME,     Execution time subroutine (or function)
+* @code{EXECUTE_COMMAND_LINE}: EXECUTE_COMMAND_LINE, Execute a shell command
+* @code{EXIT}:          EXIT,      Exit the program with status.
+* @code{EXP}:           EXP,       Exponential function
+* @code{EXPONENT}:      EXPONENT,  Exponent function
+* @code{EXTENDS_TYPE_OF}: EXTENDS_TYPE_OF,  Query dynamic type for extension
+* @code{FDATE}:         FDATE,     Subroutine (or function) to get the current time as a string
+* @code{FGET}:          FGET,      Read a single character in stream mode from stdin
+* @code{FGETC}:         FGETC,     Read a single character in stream mode
+* @code{FLOOR}:         FLOOR,     Integer floor function
+* @code{FLUSH}:         FLUSH,     Flush I/O unit(s)
+* @code{FNUM}:          FNUM,      File number function
+* @code{FPUT}:          FPUT,      Write a single character in stream mode to stdout
+* @code{FPUTC}:         FPUTC,     Write a single character in stream mode
+* @code{FRACTION}:      FRACTION,  Fractional part of the model representation
+* @code{FREE}:          FREE,      Memory de-allocation subroutine
+* @code{FSEEK}:         FSEEK,     Low level file positioning subroutine
+* @code{FSTAT}:         FSTAT,     Get file status
+* @code{FTELL}:         FTELL,     Current stream position
+* @code{GAMMA}:         GAMMA,     Gamma function
+* @code{GERROR}:        GERROR,    Get last system error message
+* @code{GETARG}:        GETARG,    Get command line arguments
+* @code{GET_COMMAND}:   GET_COMMAND, Get the entire command line
+* @code{GET_COMMAND_ARGUMENT}: GET_COMMAND_ARGUMENT, Get command line arguments
+* @code{GETCWD}:        GETCWD,    Get current working directory
+* @code{GETENV}:        GETENV,    Get an environmental variable
+* @code{GET_ENVIRONMENT_VARIABLE}: GET_ENVIRONMENT_VARIABLE, Get an environmental variable
+* @code{GETGID}:        GETGID,    Group ID function
+* @code{GETLOG}:        GETLOG,    Get login name
+* @code{GETPID}:        GETPID,    Process ID function
+* @code{GETUID}:        GETUID,    User ID function
+* @code{GMTIME}:        GMTIME,    Convert time to GMT info
+* @code{HOSTNM}:        HOSTNM,    Get system host name
+* @code{HUGE}:          HUGE,      Largest number of a kind
+* @code{HYPOT}:         HYPOT,     Euclidean distance function
+* @code{IACHAR}:        IACHAR,    Code in @acronym{ASCII} collating sequence
+* @code{IALL}:          IALL,      Bitwise AND of array elements
+* @code{IAND}:          IAND,      Bitwise logical and
+* @code{IANY}:          IANY,      Bitwise OR of array elements
+* @code{IARGC}:         IARGC,     Get the number of command line arguments
+* @code{IBCLR}:         IBCLR,     Clear bit
+* @code{IBITS}:         IBITS,     Bit extraction
+* @code{IBSET}:         IBSET,     Set bit
+* @code{ICHAR}:         ICHAR,     Character-to-integer conversion function
+* @code{IDATE}:         IDATE,     Current local time (day/month/year)
+* @code{IEOR}:          IEOR,      Bitwise logical exclusive or
+* @code{IERRNO}:        IERRNO,    Function to get the last system error number
+* @code{IMAGE_INDEX}:   IMAGE_INDEX, Cosubscript to image index conversion
+* @code{INDEX}:         INDEX intrinsic, Position of a substring within a string
+* @code{INT}:           INT,       Convert to integer type
+* @code{INT2}:          INT2,      Convert to 16-bit integer type
+* @code{INT8}:          INT8,      Convert to 64-bit integer type
+* @code{IOR}:           IOR,       Bitwise logical or
+* @code{IPARITY}:       IPARITY,   Bitwise XOR of array elements
+* @code{IRAND}:         IRAND,     Integer pseudo-random number
+* @code{IS_IOSTAT_END}:  IS_IOSTAT_END, Test for end-of-file value
+* @code{IS_IOSTAT_EOR}:  IS_IOSTAT_EOR, Test for end-of-record value
+* @code{ISATTY}:        ISATTY,    Whether a unit is a terminal device
+* @code{ISHFT}:         ISHFT,     Shift bits
+* @code{ISHFTC}:        ISHFTC,    Shift bits circularly
+* @code{ISNAN}:         ISNAN,     Tests for a NaN
+* @code{ITIME}:         ITIME,     Current local time (hour/minutes/seconds)
+* @code{KILL}:          KILL,      Send a signal to a process
+* @code{KIND}:          KIND,      Kind of an entity
+* @code{LBOUND}:        LBOUND,    Lower dimension bounds of an array
+* @code{LCOBOUND}:      LCOBOUND,  Lower codimension bounds of an array
+* @code{LEADZ}:         LEADZ,     Number of leading zero bits of an integer
+* @code{LEN}:           LEN,       Length of a character entity
+* @code{LEN_TRIM}:      LEN_TRIM,  Length of a character entity without trailing blank characters
+* @code{LGE}:           LGE,       Lexical greater than or equal
+* @code{LGT}:           LGT,       Lexical greater than
+* @code{LINK}:          LINK,      Create a hard link
+* @code{LLE}:           LLE,       Lexical less than or equal
+* @code{LLT}:           LLT,       Lexical less than
+* @code{LNBLNK}:        LNBLNK,    Index of the last non-blank character in a string
+* @code{LOC}:           LOC,       Returns the address of a variable
+* @code{LOG}:           LOG,       Logarithm function
+* @code{LOG10}:         LOG10,     Base 10 logarithm function 
+* @code{LOG_GAMMA}:     LOG_GAMMA, Logarithm of the Gamma function
+* @code{LOGICAL}:       LOGICAL,   Convert to logical type
+* @code{LONG}:          LONG,      Convert to integer type
+* @code{LSHIFT}:        LSHIFT,    Left shift bits
+* @code{LSTAT}:         LSTAT,     Get file status
+* @code{LTIME}:         LTIME,     Convert time to local time info
+* @code{MALLOC}:        MALLOC,    Dynamic memory allocation function
+* @code{MASKL}:         MASKL,     Left justified mask
+* @code{MASKR}:         MASKR,     Right justified mask
+* @code{MATMUL}:        MATMUL,    matrix multiplication
+* @code{MAX}:           MAX,       Maximum value of an argument list
+* @code{MAXEXPONENT}:   MAXEXPONENT, Maximum exponent of a real kind
+* @code{MAXLOC}:        MAXLOC,    Location of the maximum value within an array
+* @code{MAXVAL}:        MAXVAL,    Maximum value of an array
+* @code{MCLOCK}:        MCLOCK,    Time function
+* @code{MCLOCK8}:       MCLOCK8,   Time function (64-bit)
+* @code{MERGE}:         MERGE,     Merge arrays
+* @code{MERGE_BITS}:    MERGE_BITS, Merge of bits under mask
+* @code{MIN}:           MIN,       Minimum value of an argument list
+* @code{MINEXPONENT}:   MINEXPONENT, Minimum exponent of a real kind
+* @code{MINLOC}:        MINLOC,    Location of the minimum value within an array
+* @code{MINVAL}:        MINVAL,    Minimum value of an array
+* @code{MOD}:           MOD,       Remainder function
+* @code{MODULO}:        MODULO,    Modulo function
+* @code{MOVE_ALLOC}:    MOVE_ALLOC, Move allocation from one object to another
+* @code{MVBITS}:        MVBITS,    Move bits from one integer to another
+* @code{NEAREST}:       NEAREST,   Nearest representable number
+* @code{NEW_LINE}:      NEW_LINE,  New line character
+* @code{NINT}:          NINT,      Nearest whole number
+* @code{NORM2}:         NORM2,     Euclidean vector norm
+* @code{NOT}:           NOT,       Logical negation
+* @code{NULL}:          NULL,      Function that returns an disassociated pointer
+* @code{NUM_IMAGES}:    NUM_IMAGES, Number of images
+* @code{OR}:            OR,        Bitwise logical OR
+* @code{PACK}:          PACK,      Pack an array into an array of rank one
+* @code{PARITY}:        PARITY,    Reduction with exclusive OR
+* @code{PERROR}:        PERROR,    Print system error message
+* @code{POPCNT}:        POPCNT,    Number of bits set
+* @code{POPPAR}:        POPPAR,    Parity of the number of bits set
+* @code{PRECISION}:     PRECISION, Decimal precision of a real kind
+* @code{PRESENT}:       PRESENT,   Determine whether an optional dummy argument is specified
+* @code{PRODUCT}:       PRODUCT,   Product of array elements
+* @code{RADIX}:         RADIX,     Base of a data model
+* @code{RAN}:           RAN,       Real pseudo-random number
+* @code{RAND}:          RAND,      Real pseudo-random number
+* @code{RANDOM_NUMBER}: RANDOM_NUMBER, Pseudo-random number
+* @code{RANDOM_SEED}:   RANDOM_SEED, Initialize a pseudo-random number sequence
+* @code{RANGE}:         RANGE,     Decimal exponent range
+* @code{RANK} :         RANK,      Rank of a data object
+* @code{REAL}:          REAL,      Convert to real type 
+* @code{RENAME}:        RENAME,    Rename a file
+* @code{REPEAT}:        REPEAT,    Repeated string concatenation
+* @code{RESHAPE}:       RESHAPE,   Function to reshape an array
+* @code{RRSPACING}:     RRSPACING, Reciprocal of the relative spacing
+* @code{RSHIFT}:        RSHIFT,    Right shift bits
+* @code{SAME_TYPE_AS}:  SAME_TYPE_AS,  Query dynamic types for equality
+* @code{SCALE}:         SCALE,     Scale a real value
+* @code{SCAN}:          SCAN,      Scan a string for the presence of a set of characters
+* @code{SECNDS}:        SECNDS,    Time function
+* @code{SECOND}:        SECOND,    CPU time function
+* @code{SELECTED_CHAR_KIND}: SELECTED_CHAR_KIND,  Choose character kind
+* @code{SELECTED_INT_KIND}: SELECTED_INT_KIND,  Choose integer kind
+* @code{SELECTED_REAL_KIND}: SELECTED_REAL_KIND,  Choose real kind
+* @code{SET_EXPONENT}:  SET_EXPONENT, Set the exponent of the model
+* @code{SHAPE}:         SHAPE,     Determine the shape of an array
+* @code{SHIFTA}:        SHIFTA,    Right shift with fill
+* @code{SHIFTL}:        SHIFTL,    Left shift
+* @code{SHIFTR}:        SHIFTR,    Right shift
+* @code{SIGN}:          SIGN,      Sign copying function
+* @code{SIGNAL}:        SIGNAL,    Signal handling subroutine (or function)
+* @code{SIN}:           SIN,       Sine function
+* @code{SINH}:          SINH,      Hyperbolic sine function
+* @code{SIZE}:          SIZE,      Function to determine the size of an array
+* @code{SIZEOF}:        SIZEOF,    Determine the size in bytes of an expression
+* @code{SLEEP}:         SLEEP,     Sleep for the specified number of seconds
+* @code{SPACING}:       SPACING,   Smallest distance between two numbers of a given type
+* @code{SPREAD}:        SPREAD,    Add a dimension to an array 
+* @code{SQRT}:          SQRT,      Square-root function
+* @code{SRAND}:         SRAND,     Reinitialize the random number generator
+* @code{STAT}:          STAT,      Get file status
+* @code{STORAGE_SIZE}:  STORAGE_SIZE, Storage size in bits
+* @code{SUM}:           SUM,       Sum of array elements
+* @code{SYMLNK}:        SYMLNK,    Create a symbolic link
+* @code{SYSTEM}:        SYSTEM,    Execute a shell command
+* @code{SYSTEM_CLOCK}:  SYSTEM_CLOCK, Time function
+* @code{TAN}:           TAN,       Tangent function
+* @code{TANH}:          TANH,      Hyperbolic tangent function
+* @code{THIS_IMAGE}:    THIS_IMAGE, Cosubscript index of this image
+* @code{TIME}:          TIME,      Time function
+* @code{TIME8}:         TIME8,     Time function (64-bit)
+* @code{TINY}:          TINY,      Smallest positive number of a real kind
+* @code{TRAILZ}:        TRAILZ,    Number of trailing zero bits of an integer
+* @code{TRANSFER}:      TRANSFER,  Transfer bit patterns
+* @code{TRANSPOSE}:     TRANSPOSE, Transpose an array of rank two
+* @code{TRIM}:          TRIM,      Remove trailing blank characters of a string
+* @code{TTYNAM}:        TTYNAM,    Get the name of a terminal device.
+* @code{UBOUND}:        UBOUND,    Upper dimension bounds of an array
+* @code{UCOBOUND}:      UCOBOUND,  Upper codimension bounds of an array
+* @code{UMASK}:         UMASK,     Set the file creation mask
+* @code{UNLINK}:        UNLINK,    Remove a file from the file system
+* @code{UNPACK}:        UNPACK,    Unpack an array of rank one into an array
+* @code{VERIFY}:        VERIFY,    Scan a string for the absence of a set of characters
+* @code{XOR}:           XOR,       Bitwise logical exclusive or
+@end menu
+
+@node Introduction to Intrinsics
+@section Introduction to intrinsic procedures
+
+The intrinsic procedures provided by GNU Fortran include all of the
+intrinsic procedures required by the Fortran 95 standard, a set of
+intrinsic procedures for backwards compatibility with G77, and a
+selection of intrinsic procedures from the Fortran 2003 and Fortran 2008
+standards.  Any conflict between a description here and a description in
+either the Fortran 95 standard, the Fortran 2003 standard or the Fortran
+2008 standard is unintentional, and the standard(s) should be considered
+authoritative.
+
+The enumeration of the @code{KIND} type parameter is processor defined in
+the Fortran 95 standard.  GNU Fortran defines the default integer type and
+default real type by @code{INTEGER(KIND=4)} and @code{REAL(KIND=4)},
+respectively.  The standard mandates that both data types shall have
+another kind, which have more precision.  On typical target architectures
+supported by @command{gfortran}, this kind type parameter is @code{KIND=8}.
+Hence, @code{REAL(KIND=8)} and @code{DOUBLE PRECISION} are equivalent.
+In the description of generic intrinsic procedures, the kind type parameter
+will be specified by @code{KIND=*}, and in the description of specific
+names for an intrinsic procedure the kind type parameter will be explicitly
+given (e.g., @code{REAL(KIND=4)} or @code{REAL(KIND=8)}).  Finally, for
+brevity the optional @code{KIND=} syntax will be omitted.
+
+Many of the intrinsic procedures take one or more optional arguments.
+This document follows the convention used in the Fortran 95 standard,
+and denotes such arguments by square brackets.
+
+GNU Fortran offers the @option{-std=f95} and @option{-std=gnu} options,
+which can be used to restrict the set of intrinsic procedures to a 
+given standard.  By default, @command{gfortran} sets the @option{-std=gnu}
+option, and so all intrinsic procedures described here are accepted.  There
+is one caveat.  For a select group of intrinsic procedures, @command{g77}
+implemented both a function and a subroutine.  Both classes 
+have been implemented in @command{gfortran} for backwards compatibility
+with @command{g77}.  It is noted here that these functions and subroutines
+cannot be intermixed in a given subprogram.  In the descriptions that follow,
+the applicable standard for each intrinsic procedure is noted.
+
+
+
+@node ABORT
+@section @code{ABORT} --- Abort the program
+@fnindex ABORT
+@cindex program termination, with core dump
+@cindex terminate program, with core dump
+@cindex core, dump
+
+@table @asis
+@item @emph{Description}:
+@code{ABORT} causes immediate termination of the program.  On operating
+systems that support a core dump, @code{ABORT} will produce a core dump.
+It will also print a backtrace, unless @code{-fno-backtrace} is given.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine
+
+@item @emph{Syntax}:
+@code{CALL ABORT}
+
+@item @emph{Return value}:
+Does not return.
+
+@item @emph{Example}:
+@smallexample
+program test_abort
+  integer :: i = 1, j = 2
+  if (i /= j) call abort
+end program test_abort
+@end smallexample
+
+@item @emph{See also}:
+@ref{EXIT}, @ref{KILL}, @ref{BACKTRACE}
+
+@end table
+
+
+
+@node ABS
+@section @code{ABS} --- Absolute value
+@fnindex ABS
+@fnindex CABS
+@fnindex DABS
+@fnindex IABS
+@fnindex ZABS
+@fnindex CDABS
+@cindex absolute value
+
+@table @asis
+@item @emph{Description}:
+@code{ABS(A)} computes the absolute value of @code{A}.
+
+@item @emph{Standard}:
+Fortran 77 and later, has overloads that are GNU extensions
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = ABS(A)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{A} @tab The type of the argument shall be an @code{INTEGER},
+@code{REAL}, or @code{COMPLEX}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of the same type and
+kind as the argument except the return value is @code{REAL} for a
+@code{COMPLEX} argument.
+
+@item @emph{Example}:
+@smallexample
+program test_abs
+  integer :: i = -1
+  real :: x = -1.e0
+  complex :: z = (-1.e0,0.e0)
+  i = abs(i)
+  x = abs(x)
+  x = abs(z)
+end program test_abs
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name            @tab Argument            @tab Return type       @tab Standard
+@item @code{ABS(A)}   @tab @code{REAL(4) A}    @tab @code{REAL(4)}    @tab Fortran 77 and later
+@item @code{CABS(A)}  @tab @code{COMPLEX(4) A} @tab @code{REAL(4)}    @tab Fortran 77 and later
+@item @code{DABS(A)}  @tab @code{REAL(8) A}    @tab @code{REAL(8)}    @tab Fortran 77 and later
+@item @code{IABS(A)}  @tab @code{INTEGER(4) A} @tab @code{INTEGER(4)} @tab Fortran 77 and later
+@item @code{ZABS(A)}  @tab @code{COMPLEX(8) A} @tab @code{COMPLEX(8)} @tab GNU extension
+@item @code{CDABS(A)} @tab @code{COMPLEX(8) A} @tab @code{COMPLEX(8)} @tab GNU extension
+@end multitable
+@end table
+
+
+
+@node ACCESS
+@section @code{ACCESS} --- Checks file access modes
+@fnindex ACCESS
+@cindex file system, access mode
+
+@table @asis
+@item @emph{Description}:
+@code{ACCESS(NAME, MODE)} checks whether the file @var{NAME} 
+exists, is readable, writable or executable. Except for the
+executable check, @code{ACCESS} can be replaced by
+Fortran 95's @code{INQUIRE}.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{RESULT = ACCESS(NAME, MODE)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{NAME} @tab Scalar @code{CHARACTER} of default kind with the
+file name. Tailing blank are ignored unless the character @code{achar(0)}
+is present, then all characters up to and excluding @code{achar(0)} are
+used as file name.
+@item @var{MODE} @tab Scalar @code{CHARACTER} of default kind with the
+file access mode, may be any concatenation of @code{"r"} (readable),
+@code{"w"} (writable) and @code{"x"} (executable), or @code{" "} to check
+for existence.
+@end multitable
+
+@item @emph{Return value}:
+Returns a scalar @code{INTEGER}, which is @code{0} if the file is
+accessible in the given mode; otherwise or if an invalid argument
+has been given for @code{MODE} the value @code{1} is returned.
+
+@item @emph{Example}:
+@smallexample
+program access_test
+  implicit none
+  character(len=*), parameter :: file  = 'test.dat'
+  character(len=*), parameter :: file2 = 'test.dat  '//achar(0)
+  if(access(file,' ') == 0) print *, trim(file),' is exists'
+  if(access(file,'r') == 0) print *, trim(file),' is readable'
+  if(access(file,'w') == 0) print *, trim(file),' is writable'
+  if(access(file,'x') == 0) print *, trim(file),' is executable'
+  if(access(file2,'rwx') == 0) &
+    print *, trim(file2),' is readable, writable and executable'
+end program access_test
+@end smallexample
+@item @emph{Specific names}:
+@item @emph{See also}:
+
+@end table
+
+
+
+@node ACHAR
+@section @code{ACHAR} --- Character in @acronym{ASCII} collating sequence 
+@fnindex ACHAR
+@cindex @acronym{ASCII} collating sequence
+@cindex collating sequence, @acronym{ASCII}
+
+@table @asis
+@item @emph{Description}:
+@code{ACHAR(I)} returns the character located at position @code{I}
+in the @acronym{ASCII} collating sequence.
+
+@item @emph{Standard}:
+Fortran 77 and later, with @var{KIND} argument Fortran 2003 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = ACHAR(I [, KIND])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I}    @tab The type shall be @code{INTEGER}.
+@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
+expression indicating the kind parameter of the result.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{CHARACTER} with a length of one.
+If the @var{KIND} argument is present, the return value is of the
+specified kind and of the default kind otherwise.
+
+@item @emph{Example}:
+@smallexample
+program test_achar
+  character c
+  c = achar(32)
+end program test_achar
+@end smallexample
+
+@item @emph{Note}:
+See @ref{ICHAR} for a discussion of converting between numerical values
+and formatted string representations.
+
+@item @emph{See also}:
+@ref{CHAR}, @ref{IACHAR}, @ref{ICHAR}
+
+@end table
+
+
+
+@node ACOS
+@section @code{ACOS} --- Arccosine function 
+@fnindex ACOS
+@fnindex DACOS
+@cindex trigonometric function, cosine, inverse
+@cindex cosine, inverse
+
+@table @asis
+@item @emph{Description}:
+@code{ACOS(X)} computes the arccosine of @var{X} (inverse of @code{COS(X)}).
+
+@item @emph{Standard}:
+Fortran 77 and later, for a complex argument Fortran 2008 or later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = ACOS(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall either be @code{REAL} with a magnitude that is
+less than or equal to one - or the type shall be @code{COMPLEX}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of the same type and kind as @var{X}.
+The real part of the result is in radians and lies in the range
+@math{0 \leq \Re \acos(x) \leq \pi}.
+
+@item @emph{Example}:
+@smallexample
+program test_acos
+  real(8) :: x = 0.866_8
+  x = acos(x)
+end program test_acos
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name            @tab Argument         @tab Return type     @tab Standard
+@item @code{ACOS(X)}  @tab @code{REAL(4) X} @tab @code{REAL(4)}  @tab Fortran 77 and later
+@item @code{DACOS(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)}  @tab Fortran 77 and later
+@end multitable
+
+@item @emph{See also}:
+Inverse function: @ref{COS}
+
+@end table
+
+
+
+@node ACOSH
+@section @code{ACOSH} --- Inverse hyperbolic cosine function
+@fnindex ACOSH
+@fnindex DACOSH
+@cindex area hyperbolic cosine
+@cindex inverse hyperbolic cosine
+@cindex hyperbolic function, cosine, inverse
+@cindex cosine, hyperbolic, inverse
+
+@table @asis
+@item @emph{Description}:
+@code{ACOSH(X)} computes the inverse hyperbolic cosine of @var{X}.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = ACOSH(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be @code{REAL} or @code{COMPLEX}.
+@end multitable
+
+@item @emph{Return value}:
+The return value has the same type and kind as @var{X}. If @var{X} is
+complex, the imaginary part of the result is in radians and lies between
+@math{ 0 \leq \Im \acosh(x) \leq \pi}.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_acosh
+  REAL(8), DIMENSION(3) :: x = (/ 1.0, 2.0, 3.0 /)
+  WRITE (*,*) ACOSH(x)
+END PROGRAM
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name             @tab Argument          @tab Return type       @tab Standard
+@item @code{DACOSH(X)} @tab @code{REAL(8) X}  @tab @code{REAL(8)}    @tab GNU extension
+@end multitable
+
+@item @emph{See also}:
+Inverse function: @ref{COSH}
+@end table
+
+
+
+@node ADJUSTL
+@section @code{ADJUSTL} --- Left adjust a string 
+@fnindex ADJUSTL
+@cindex string, adjust left
+@cindex adjust string
+
+@table @asis
+@item @emph{Description}:
+@code{ADJUSTL(STRING)} will left adjust a string by removing leading spaces.
+Spaces are inserted at the end of the string as needed.
+
+@item @emph{Standard}:
+Fortran 90 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = ADJUSTL(STRING)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{STRING} @tab The type shall be @code{CHARACTER}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{CHARACTER} and of the same kind as
+@var{STRING} where leading spaces are removed and the same number of
+spaces are inserted on the end of @var{STRING}.
+
+@item @emph{Example}:
+@smallexample
+program test_adjustl
+  character(len=20) :: str = '   gfortran'
+  str = adjustl(str)
+  print *, str
+end program test_adjustl
+@end smallexample
+
+@item @emph{See also}:
+@ref{ADJUSTR}, @ref{TRIM}
+@end table
+
+
+
+@node ADJUSTR
+@section @code{ADJUSTR} --- Right adjust a string 
+@fnindex ADJUSTR
+@cindex string, adjust right
+@cindex adjust string
+
+@table @asis
+@item @emph{Description}:
+@code{ADJUSTR(STRING)} will right adjust a string by removing trailing spaces.
+Spaces are inserted at the start of the string as needed.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = ADJUSTR(STRING)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{STR} @tab The type shall be @code{CHARACTER}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{CHARACTER} and of the same kind as
+@var{STRING} where trailing spaces are removed and the same number of
+spaces are inserted at the start of @var{STRING}.
+
+@item @emph{Example}:
+@smallexample
+program test_adjustr
+  character(len=20) :: str = 'gfortran'
+  str = adjustr(str)
+  print *, str
+end program test_adjustr
+@end smallexample
+
+@item @emph{See also}:
+@ref{ADJUSTL}, @ref{TRIM}
+@end table
+
+
+
+@node AIMAG
+@section @code{AIMAG} --- Imaginary part of complex number  
+@fnindex AIMAG
+@fnindex DIMAG
+@fnindex IMAG
+@fnindex IMAGPART
+@cindex complex numbers, imaginary part
+
+@table @asis
+@item @emph{Description}:
+@code{AIMAG(Z)} yields the imaginary part of complex argument @code{Z}.
+The @code{IMAG(Z)} and @code{IMAGPART(Z)} intrinsic functions are provided
+for compatibility with @command{g77}, and their use in new code is 
+strongly discouraged.
+
+@item @emph{Standard}:
+Fortran 77 and later, has overloads that are GNU extensions
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = AIMAG(Z)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{Z} @tab The type of the argument shall be @code{COMPLEX}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{REAL} with the
+kind type parameter of the argument.
+
+@item @emph{Example}:
+@smallexample
+program test_aimag
+  complex(4) z4
+  complex(8) z8
+  z4 = cmplx(1.e0_4, 0.e0_4)
+  z8 = cmplx(0.e0_8, 1.e0_8)
+  print *, aimag(z4), dimag(z8)
+end program test_aimag
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name               @tab Argument            @tab Return type     @tab Standard
+@item @code{AIMAG(Z)}    @tab @code{COMPLEX Z}    @tab @code{REAL}     @tab GNU extension
+@item @code{DIMAG(Z)}    @tab @code{COMPLEX(8) Z} @tab @code{REAL(8)}  @tab GNU extension
+@item @code{IMAG(Z)}     @tab @code{COMPLEX Z}    @tab @code{REAL}     @tab GNU extension
+@item @code{IMAGPART(Z)} @tab @code{COMPLEX Z}    @tab @code{REAL}     @tab GNU extension
+@end multitable
+@end table
+
+
+
+@node AINT
+@section @code{AINT} --- Truncate to a whole number
+@fnindex AINT
+@fnindex DINT
+@cindex floor
+@cindex rounding, floor
+
+@table @asis
+@item @emph{Description}:
+@code{AINT(A [, KIND])} truncates its argument to a whole number.
+
+@item @emph{Standard}:
+Fortran 77 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = AINT(A [, KIND])} 
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{A}    @tab The type of the argument shall be @code{REAL}.
+@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
+expression indicating the kind parameter of the result.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{REAL} with the kind type parameter of the
+argument if the optional @var{KIND} is absent; otherwise, the kind
+type parameter will be given by @var{KIND}.  If the magnitude of 
+@var{X} is less than one, @code{AINT(X)} returns zero.  If the
+magnitude is equal to or greater than one then it returns the largest
+whole number that does not exceed its magnitude.  The sign is the same
+as the sign of @var{X}. 
+
+@item @emph{Example}:
+@smallexample
+program test_aint
+  real(4) x4
+  real(8) x8
+  x4 = 1.234E0_4
+  x8 = 4.321_8
+  print *, aint(x4), dint(x8)
+  x8 = aint(x4,8)
+end program test_aint
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name           @tab Argument         @tab Return type      @tab Standard
+@item @code{AINT(A)} @tab @code{REAL(4) A} @tab @code{REAL(4)}   @tab Fortran 77 and later
+@item @code{DINT(A)} @tab @code{REAL(8) A} @tab @code{REAL(8)}   @tab Fortran 77 and later
+@end multitable
+@end table
+
+
+
+@node ALARM
+@section @code{ALARM} --- Execute a routine after a given delay
+@fnindex ALARM
+@cindex delayed execution
+
+@table @asis
+@item @emph{Description}:
+@code{ALARM(SECONDS, HANDLER [, STATUS])} causes external subroutine @var{HANDLER}
+to be executed after a delay of @var{SECONDS} by using @code{alarm(2)} to
+set up a signal and @code{signal(2)} to catch it. If @var{STATUS} is
+supplied, it will be returned with the number of seconds remaining until
+any previously scheduled alarm was due to be delivered, or zero if there
+was no previously scheduled alarm.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine
+
+@item @emph{Syntax}:
+@code{CALL ALARM(SECONDS, HANDLER [, STATUS])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{SECONDS} @tab The type of the argument shall be a scalar
+@code{INTEGER}. It is @code{INTENT(IN)}.
+@item @var{HANDLER} @tab Signal handler (@code{INTEGER FUNCTION} or
+@code{SUBROUTINE}) or dummy/global @code{INTEGER} scalar. The scalar 
+values may be either @code{SIG_IGN=1} to ignore the alarm generated 
+or @code{SIG_DFL=0} to set the default action. It is @code{INTENT(IN)}.
+@item @var{STATUS}  @tab (Optional) @var{STATUS} shall be a scalar
+variable of the default @code{INTEGER} kind. It is @code{INTENT(OUT)}.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+program test_alarm
+  external handler_print
+  integer i
+  call alarm (3, handler_print, i)
+  print *, i
+  call sleep(10)
+end program test_alarm
+@end smallexample
+This will cause the external routine @var{handler_print} to be called
+after 3 seconds.
+@end table
+
+
+
+@node ALL
+@section @code{ALL} --- All values in @var{MASK} along @var{DIM} are true 
+@fnindex ALL
+@cindex array, apply condition
+@cindex array, condition testing
+
+@table @asis
+@item @emph{Description}:
+@code{ALL(MASK [, DIM])} determines if all the values are true in @var{MASK}
+in the array along dimension @var{DIM}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@code{RESULT = ALL(MASK [, DIM])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{MASK} @tab The type of the argument shall be @code{LOGICAL} and
+it shall not be scalar.
+@item @var{DIM}  @tab (Optional) @var{DIM} shall be a scalar integer
+with a value that lies between one and the rank of @var{MASK}.
+@end multitable
+
+@item @emph{Return value}:
+@code{ALL(MASK)} returns a scalar value of type @code{LOGICAL} where
+the kind type parameter is the same as the kind type parameter of
+@var{MASK}.  If @var{DIM} is present, then @code{ALL(MASK, DIM)} returns
+an array with the rank of @var{MASK} minus 1.  The shape is determined from
+the shape of @var{MASK} where the @var{DIM} dimension is elided. 
+
+@table @asis
+@item (A)
+@code{ALL(MASK)} is true if all elements of @var{MASK} are true.
+It also is true if @var{MASK} has zero size; otherwise, it is false.
+@item (B)
+If the rank of @var{MASK} is one, then @code{ALL(MASK,DIM)} is equivalent
+to @code{ALL(MASK)}.  If the rank is greater than one, then @code{ALL(MASK,DIM)}
+is determined by applying @code{ALL} to the array sections.
+@end table
+
+@item @emph{Example}:
+@smallexample
+program test_all
+  logical l
+  l = all((/.true., .true., .true./))
+  print *, l
+  call section
+  contains
+    subroutine section
+      integer a(2,3), b(2,3)
+      a = 1
+      b = 1
+      b(2,2) = 2
+      print *, all(a .eq. b, 1)
+      print *, all(a .eq. b, 2)
+    end subroutine section
+end program test_all
+@end smallexample
+@end table
+
+
+
+@node ALLOCATED
+@section @code{ALLOCATED} --- Status of an allocatable entity
+@fnindex ALLOCATED
+@cindex allocation, status
+
+@table @asis
+@item @emph{Description}:
+@code{ALLOCATED(ARRAY)} and @code{ALLOCATED(SCALAR)} check the allocation
+status of @var{ARRAY} and @var{SCALAR}, respectively.
+
+@item @emph{Standard}:
+Fortran 95 and later.  Note, the @code{SCALAR=} keyword and allocatable
+scalar entities are available in Fortran 2003 and later.
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{RESULT = ALLOCATED(ARRAY)}
+@item @code{RESULT = ALLOCATED(SCALAR)} 
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ARRAY}    @tab The argument shall be an @code{ALLOCATABLE} array.
+@item @var{SCALAR}   @tab The argument shall be an @code{ALLOCATABLE} scalar.
+@end multitable
+
+@item @emph{Return value}:
+The return value is a scalar @code{LOGICAL} with the default logical
+kind type parameter.  If the argument is allocated, then the result is
+@code{.TRUE.}; otherwise, it returns @code{.FALSE.} 
+
+@item @emph{Example}:
+@smallexample
+program test_allocated
+  integer :: i = 4
+  real(4), allocatable :: x(:)
+  if (.not. allocated(x)) allocate(x(i))
+end program test_allocated
+@end smallexample
+@end table
+
+
+
+@node AND
+@section @code{AND} --- Bitwise logical AND
+@fnindex AND
+@cindex bitwise logical and
+@cindex logical and, bitwise
+
+@table @asis
+@item @emph{Description}:
+Bitwise logical @code{AND}.
+
+This intrinsic routine is provided for backwards compatibility with 
+GNU Fortran 77.  For integer arguments, programmers should consider
+the use of the @ref{IAND} intrinsic defined by the Fortran standard.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Function
+
+@item @emph{Syntax}:
+@code{RESULT = AND(I, J)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab The type shall be either a scalar @code{INTEGER}
+type or a scalar @code{LOGICAL} type.
+@item @var{J} @tab The type shall be the same as the type of @var{I}.
+@end multitable
+
+@item @emph{Return value}:
+The return type is either a scalar @code{INTEGER} or a scalar
+@code{LOGICAL}.  If the kind type parameters differ, then the
+smaller kind type is implicitly converted to larger kind, and the 
+return has the larger kind.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_and
+  LOGICAL :: T = .TRUE., F = .FALSE.
+  INTEGER :: a, b
+  DATA a / Z'F' /, b / Z'3' /
+
+  WRITE (*,*) AND(T, T), AND(T, F), AND(F, T), AND(F, F)
+  WRITE (*,*) AND(a, b)
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+Fortran 95 elemental function: @ref{IAND}
+@end table
+
+
+
+@node ANINT
+@section @code{ANINT} --- Nearest whole number
+@fnindex ANINT
+@fnindex DNINT
+@cindex ceiling
+@cindex rounding, ceiling
+
+@table @asis
+@item @emph{Description}:
+@code{ANINT(A [, KIND])} rounds its argument to the nearest whole number.
+
+@item @emph{Standard}:
+Fortran 77 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = ANINT(A [, KIND])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{A}    @tab The type of the argument shall be @code{REAL}.
+@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
+expression indicating the kind parameter of the result.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type real with the kind type parameter of the
+argument if the optional @var{KIND} is absent; otherwise, the kind
+type parameter will be given by @var{KIND}.  If @var{A} is greater than
+zero, @code{ANINT(A)} returns @code{AINT(X+0.5)}.  If @var{A} is
+less than or equal to zero then it returns @code{AINT(X-0.5)}.
+
+@item @emph{Example}:
+@smallexample
+program test_anint
+  real(4) x4
+  real(8) x8
+  x4 = 1.234E0_4
+  x8 = 4.321_8
+  print *, anint(x4), dnint(x8)
+  x8 = anint(x4,8)
+end program test_anint
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name            @tab Argument         @tab Return type      @tab Standard
+@item @code{AINT(A)}  @tab @code{REAL(4) A} @tab @code{REAL(4)}   @tab Fortran 77 and later
+@item @code{DNINT(A)} @tab @code{REAL(8) A} @tab @code{REAL(8)}   @tab Fortran 77 and later
+@end multitable
+@end table
+
+
+
+@node ANY
+@section @code{ANY} --- Any value in @var{MASK} along @var{DIM} is true 
+@fnindex ANY
+@cindex array, apply condition
+@cindex array, condition testing
+
+@table @asis
+@item @emph{Description}:
+@code{ANY(MASK [, DIM])} determines if any of the values in the logical array
+@var{MASK} along dimension @var{DIM} are @code{.TRUE.}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@code{RESULT = ANY(MASK [, DIM])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{MASK} @tab The type of the argument shall be @code{LOGICAL} and
+it shall not be scalar.
+@item @var{DIM}  @tab (Optional) @var{DIM} shall be a scalar integer
+with a value that lies between one and the rank of @var{MASK}.
+@end multitable
+
+@item @emph{Return value}:
+@code{ANY(MASK)} returns a scalar value of type @code{LOGICAL} where
+the kind type parameter is the same as the kind type parameter of
+@var{MASK}.  If @var{DIM} is present, then @code{ANY(MASK, DIM)} returns
+an array with the rank of @var{MASK} minus 1.  The shape is determined from
+the shape of @var{MASK} where the @var{DIM} dimension is elided. 
+
+@table @asis
+@item (A)
+@code{ANY(MASK)} is true if any element of @var{MASK} is true;
+otherwise, it is false.  It also is false if @var{MASK} has zero size.
+@item (B)
+If the rank of @var{MASK} is one, then @code{ANY(MASK,DIM)} is equivalent
+to @code{ANY(MASK)}.  If the rank is greater than one, then @code{ANY(MASK,DIM)}
+is determined by applying @code{ANY} to the array sections.
+@end table
+
+@item @emph{Example}:
+@smallexample
+program test_any
+  logical l
+  l = any((/.true., .true., .true./))
+  print *, l
+  call section
+  contains
+    subroutine section
+      integer a(2,3), b(2,3)
+      a = 1
+      b = 1
+      b(2,2) = 2
+      print *, any(a .eq. b, 1)
+      print *, any(a .eq. b, 2)
+    end subroutine section
+end program test_any
+@end smallexample
+@end table
+
+
+
+@node ASIN
+@section @code{ASIN} --- Arcsine function 
+@fnindex ASIN
+@fnindex DASIN
+@cindex trigonometric function, sine, inverse
+@cindex sine, inverse
+
+@table @asis
+@item @emph{Description}:
+@code{ASIN(X)} computes the arcsine of its @var{X} (inverse of @code{SIN(X)}).
+
+@item @emph{Standard}:
+Fortran 77 and later, for a complex argument Fortran 2008 or later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = ASIN(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be either @code{REAL} and a magnitude that is
+less than or equal to one - or be @code{COMPLEX}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of the same type and kind as @var{X}.
+The real part of the result is in radians and lies in the range
+@math{-\pi/2 \leq \Re \asin(x) \leq \pi/2}.
+
+@item @emph{Example}:
+@smallexample
+program test_asin
+  real(8) :: x = 0.866_8
+  x = asin(x)
+end program test_asin
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name            @tab Argument          @tab Return type       @tab Standard
+@item @code{ASIN(X)}  @tab @code{REAL(4) X}  @tab @code{REAL(4)}    @tab Fortran 77 and later
+@item @code{DASIN(X)} @tab @code{REAL(8) X}  @tab @code{REAL(8)}    @tab Fortran 77 and later
+@end multitable
+
+@item @emph{See also}:
+Inverse function: @ref{SIN}
+
+@end table
+
+
+
+@node ASINH
+@section @code{ASINH} --- Inverse hyperbolic sine function
+@fnindex ASINH
+@fnindex DASINH
+@cindex area hyperbolic sine
+@cindex inverse hyperbolic sine
+@cindex hyperbolic function, sine, inverse
+@cindex sine, hyperbolic, inverse
+
+@table @asis
+@item @emph{Description}:
+@code{ASINH(X)} computes the inverse hyperbolic sine of @var{X}.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = ASINH(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be @code{REAL} or @code{COMPLEX}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of the same type and kind as  @var{X}. If @var{X} is
+complex, the imaginary part of the result is in radians and lies between
+@math{-\pi/2 \leq \Im \asinh(x) \leq \pi/2}.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_asinh
+  REAL(8), DIMENSION(3) :: x = (/ -1.0, 0.0, 1.0 /)
+  WRITE (*,*) ASINH(x)
+END PROGRAM
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name             @tab Argument          @tab Return type       @tab Standard
+@item @code{DASINH(X)} @tab @code{REAL(8) X}  @tab @code{REAL(8)}    @tab GNU extension.
+@end multitable
+
+@item @emph{See also}:
+Inverse function: @ref{SINH}
+@end table
+
+
+
+@node ASSOCIATED
+@section @code{ASSOCIATED} --- Status of a pointer or pointer/target pair 
+@fnindex ASSOCIATED
+@cindex pointer, status
+@cindex association status
+
+@table @asis
+@item @emph{Description}:
+@code{ASSOCIATED(POINTER [, TARGET])} determines the status of the pointer
+@var{POINTER} or if @var{POINTER} is associated with the target @var{TARGET}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{RESULT = ASSOCIATED(POINTER [, TARGET])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{POINTER} @tab @var{POINTER} shall have the @code{POINTER} attribute
+and it can be of any type.
+@item @var{TARGET} @tab (Optional) @var{TARGET} shall be a pointer or
+a target.  It must have the same type, kind type parameter, and
+array rank as @var{POINTER}.
+@end multitable
+The association status of neither @var{POINTER} nor @var{TARGET} shall be
+undefined.
+
+@item @emph{Return value}:
+@code{ASSOCIATED(POINTER)} returns a scalar value of type @code{LOGICAL(4)}.
+There are several cases:
+@table @asis
+@item (A) When the optional @var{TARGET} is not present then
+@code{ASSOCIATED(POINTER)} is true if @var{POINTER} is associated with a target; otherwise, it returns false.
+@item (B) If @var{TARGET} is present and a scalar target, the result is true if
+@var{TARGET} is not a zero-sized storage sequence and the target associated with @var{POINTER} occupies the same storage units.  If @var{POINTER} is
+disassociated, the result is false.
+@item (C) If @var{TARGET} is present and an array target, the result is true if
+@var{TARGET} and @var{POINTER} have the same shape, are not zero-sized arrays,
+are arrays whose elements are not zero-sized storage sequences, and
+@var{TARGET} and @var{POINTER} occupy the same storage units in array element
+order.
+As in case(B), the result is false, if @var{POINTER} is disassociated.
+@item (D) If @var{TARGET} is present and an scalar pointer, the result is true
+if @var{TARGET} is associated with @var{POINTER}, the target associated with
+@var{TARGET} are not zero-sized storage sequences and occupy the same storage
+units.
+The result is false, if either @var{TARGET} or @var{POINTER} is disassociated.
+@item (E) If @var{TARGET} is present and an array pointer, the result is true if
+target associated with @var{POINTER} and the target associated with @var{TARGET}
+have the same shape, are not zero-sized arrays, are arrays whose elements are
+not zero-sized storage sequences, and @var{TARGET} and @var{POINTER} occupy
+the same storage units in array element order.
+The result is false, if either @var{TARGET} or @var{POINTER} is disassociated.
+@end table
+
+@item @emph{Example}:
+@smallexample
+program test_associated
+   implicit none
+   real, target  :: tgt(2) = (/1., 2./)
+   real, pointer :: ptr(:)
+   ptr => tgt
+   if (associated(ptr)     .eqv. .false.) call abort
+   if (associated(ptr,tgt) .eqv. .false.) call abort
+end program test_associated
+@end smallexample
+
+@item @emph{See also}:
+@ref{NULL}
+@end table
+
+
+
+@node ATAN
+@section @code{ATAN} --- Arctangent function 
+@fnindex ATAN
+@fnindex DATAN
+@cindex trigonometric function, tangent, inverse
+@cindex tangent, inverse
+
+@table @asis
+@item @emph{Description}:
+@code{ATAN(X)} computes the arctangent of @var{X}.
+
+@item @emph{Standard}:
+Fortran 77 and later, for a complex argument and for two arguments
+Fortran 2008 or later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{RESULT = ATAN(X)}
+@item @code{RESULT = ATAN(Y, X)}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be @code{REAL} or @code{COMPLEX};
+if @var{Y} is present, @var{X} shall be REAL.
+@item @var{Y} shall be of the same type and kind as @var{X}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of the same type and kind as @var{X}.
+If @var{Y} is present, the result is identical to @code{ATAN2(Y,X)}.
+Otherwise, it the arcus tangent of @var{X}, where the real part of
+the result is in radians and lies in the range
+@math{-\pi/2 \leq \Re \atan(x) \leq \pi/2}.
+
+@item @emph{Example}:
+@smallexample
+program test_atan
+  real(8) :: x = 2.866_8
+  x = atan(x)
+end program test_atan
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name            @tab Argument          @tab Return type       @tab Standard
+@item @code{ATAN(X)}  @tab @code{REAL(4) X}  @tab @code{REAL(4)}    @tab Fortran 77 and later
+@item @code{DATAN(X)} @tab @code{REAL(8) X}  @tab @code{REAL(8)}    @tab Fortran 77 and later
+@end multitable
+
+@item @emph{See also}:
+Inverse function: @ref{TAN}
+
+@end table
+
+
+
+@node ATAN2
+@section @code{ATAN2} --- Arctangent function 
+@fnindex ATAN2
+@fnindex DATAN2
+@cindex trigonometric function, tangent, inverse
+@cindex tangent, inverse
+
+@table @asis
+@item @emph{Description}:
+@code{ATAN2(Y, X)} computes the principal value of the argument
+function of the complex number @math{X + i Y}. This function can
+be used to transform from Cartesian into polar coordinates and
+allows to determine the angle in the correct quadrant.
+
+@item @emph{Standard}:
+Fortran 77 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = ATAN2(Y, X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{Y} @tab The type shall be @code{REAL}.
+@item @var{X} @tab The type and kind type parameter shall be the same as @var{Y}.
+If @var{Y} is zero, then @var{X} must be nonzero.
+@end multitable
+
+@item @emph{Return value}:
+The return value has the same type and kind type parameter as @var{Y}. It
+is the principal value of the complex number @math{X + i Y}.  If @var{X}
+is nonzero, then it lies in the range @math{-\pi \le \atan (x) \leq \pi}.
+The sign is positive if @var{Y} is positive.  If @var{Y} is zero, then
+the return value is zero if @var{X} is strictly positive, @math{\pi} if
+@var{X} is negative and @var{Y} is positive zero (or the processor does
+not handle signed zeros), and @math{-\pi} if @var{X} is negative and
+@var{Y} is negative zero.  Finally, if @var{X} is zero, then the
+magnitude of the result is @math{\pi/2}.
+
+@item @emph{Example}:
+@smallexample
+program test_atan2
+  real(4) :: x = 1.e0_4, y = 0.5e0_4
+  x = atan2(y,x)
+end program test_atan2
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name                @tab Argument            @tab Return type    @tab Standard
+@item @code{ATAN2(X, Y)}  @tab @code{REAL(4) X, Y} @tab @code{REAL(4)} @tab Fortran 77 and later
+@item @code{DATAN2(X, Y)} @tab @code{REAL(8) X, Y} @tab @code{REAL(8)} @tab Fortran 77 and later
+@end multitable
+@end table
+
+
+
+@node ATANH
+@section @code{ATANH} --- Inverse hyperbolic tangent function
+@fnindex ATANH
+@fnindex DATANH
+@cindex area hyperbolic tangent
+@cindex inverse hyperbolic tangent
+@cindex hyperbolic function, tangent, inverse
+@cindex tangent, hyperbolic, inverse
+
+@table @asis
+@item @emph{Description}:
+@code{ATANH(X)} computes the inverse hyperbolic tangent of @var{X}.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = ATANH(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be @code{REAL} or @code{COMPLEX}.
+@end multitable
+
+@item @emph{Return value}:
+The return value has same type and kind as @var{X}. If @var{X} is
+complex, the imaginary part of the result is in radians and lies between
+@math{-\pi/2 \leq \Im \atanh(x) \leq \pi/2}.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_atanh
+  REAL, DIMENSION(3) :: x = (/ -1.0, 0.0, 1.0 /)
+  WRITE (*,*) ATANH(x)
+END PROGRAM
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name             @tab Argument          @tab Return type       @tab Standard
+@item @code{DATANH(X)} @tab @code{REAL(8) X}  @tab @code{REAL(8)}    @tab GNU extension
+@end multitable
+
+@item @emph{See also}:
+Inverse function: @ref{TANH}
+@end table
+
+
+
+@node ATOMIC_DEFINE
+@section @code{ATOMIC_DEFINE} --- Setting a variable atomically
+@fnindex ATOMIC_DEFINE
+@cindex Atomic subroutine, define
+
+@table @asis
+@item @emph{Description}:
+@code{ATOMIC_DEFINE(ATOM, VALUE)} defines the variable @var{ATOM} with the value
+@var{VALUE} atomically.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Atomic subroutine
+
+@item @emph{Syntax}:
+@code{CALL ATOMIC_DEFINE(ATOM, VALUE)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ATOM}   @tab Scalar coarray or coindexed variable of either integer
+                        type with @code{ATOMIC_INT_KIND} kind or logical type
+                        with @code{ATOMIC_LOGICAL_KIND} kind.
+@item @var{VALURE} @tab Scalar and of the same type as @var{ATOM}. If the kind
+                        is different, the value is converted to the kind of
+                        @var{ATOM}.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+program atomic
+  use iso_fortran_env
+  integer(atomic_int_kind) :: atom[*]
+  call atomic_define (atom[1], this_image())
+end program atomic
+@end smallexample
+
+@item @emph{See also}:
+@ref{ATOMIC_REF}, @ref{ISO_FORTRAN_ENV}
+@end table
+
+
+
+@node ATOMIC_REF
+@section @code{ATOMIC_REF} --- Obtaining the value of a variable atomically
+@fnindex ATOMIC_REF
+@cindex Atomic subroutine, reference
+
+@table @asis
+@item @emph{Description}:
+@code{ATOMIC_DEFINE(ATOM, VALUE)} atomically assigns the value of the
+variable @var{ATOM} to @var{VALUE}.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Atomic subroutine
+
+@item @emph{Syntax}:
+@code{CALL ATOMIC_REF(VALUE, ATOM)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{VALURE} @tab Scalar and of the same type as @var{ATOM}. If the kind
+                        is different, the value is converted to the kind of
+                        @var{ATOM}.
+@item @var{ATOM}   @tab Scalar coarray or coindexed variable of either integer
+                        type with @code{ATOMIC_INT_KIND} kind or logical type
+                        with @code{ATOMIC_LOGICAL_KIND} kind.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+program atomic
+  use iso_fortran_env
+  logical(atomic_logical_kind) :: atom[*]
+  logical :: val
+  call atomic_ref (atom, .false.)
+  ! ...
+  call atomic_ref (atom, val)
+  if (val) then
+    print *, "Obtained"
+  end if
+end program atomic
+@end smallexample
+
+@item @emph{See also}:
+@ref{ATOMIC_DEFINE}, @ref{ISO_FORTRAN_ENV}
+@end table
+
+
+
+@node BACKTRACE
+@section @code{BACKTRACE} --- Show a backtrace
+@fnindex BACKTRACE
+@cindex backtrace
+
+@table @asis
+@item @emph{Description}:
+@code{BACKTRACE} shows a backtrace at an arbitrary place in user code. Program
+execution continues normally afterwards. The backtrace information is printed
+to the unit corresponding to @code{ERROR_UNIT} in @code{ISO_FORTRAN_ENV}.
+
+@item @emph{Standard}:
+GNU Extension
+
+@item @emph{Class}:
+Subroutine
+
+@item @emph{Syntax}:
+@code{CALL BACKTRACE}
+
+@item @emph{Arguments}:
+None
+
+@item @emph{See also}:
+@ref{ABORT}
+@end table
+
+
+
+@node BESSEL_J0
+@section @code{BESSEL_J0} --- Bessel function of the first kind of order 0
+@fnindex BESSEL_J0
+@fnindex BESJ0
+@fnindex DBESJ0
+@cindex Bessel function, first kind
+
+@table @asis
+@item @emph{Description}:
+@code{BESSEL_J0(X)} computes the Bessel function of the first kind of
+order 0 of @var{X}. This function is available under the name
+@code{BESJ0} as a GNU extension.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = BESSEL_J0(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be @code{REAL}, and it shall be scalar.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{REAL} and lies in the
+range @math{ - 0.4027... \leq Bessel (0,x) \leq 1}. It has the same
+kind as @var{X}.
+
+@item @emph{Example}:
+@smallexample
+program test_besj0
+  real(8) :: x = 0.0_8
+  x = bessel_j0(x)
+end program test_besj0
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name            @tab Argument          @tab Return type       @tab Standard
+@item @code{DBESJ0(X)} @tab @code{REAL(8) X}  @tab @code{REAL(8)}   @tab GNU extension
+@end multitable
+@end table
+
+
+
+@node BESSEL_J1
+@section @code{BESSEL_J1} --- Bessel function of the first kind of order 1
+@fnindex BESSEL_J1
+@fnindex BESJ1
+@fnindex DBESJ1
+@cindex Bessel function, first kind
+
+@table @asis
+@item @emph{Description}:
+@code{BESSEL_J1(X)} computes the Bessel function of the first kind of
+order 1 of @var{X}. This function is available under the name
+@code{BESJ1} as a GNU extension.
+
+@item @emph{Standard}:
+Fortran 2008
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = BESSEL_J1(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be @code{REAL}, and it shall be scalar.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{REAL} and it lies in the
+range @math{ - 0.5818... \leq Bessel (0,x) \leq 0.5818 }. It has the same
+kind as @var{X}.
+
+@item @emph{Example}:
+@smallexample
+program test_besj1
+  real(8) :: x = 1.0_8
+  x = bessel_j1(x)
+end program test_besj1
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name             @tab Argument          @tab Return type       @tab Standard
+@item @code{DBESJ1(X)} @tab @code{REAL(8) X}  @tab @code{REAL(8)}    @tab GNU extension
+@end multitable
+@end table
+
+
+
+@node BESSEL_JN
+@section @code{BESSEL_JN} --- Bessel function of the first kind
+@fnindex BESSEL_JN
+@fnindex BESJN
+@fnindex DBESJN
+@cindex Bessel function, first kind
+
+@table @asis
+@item @emph{Description}:
+@code{BESSEL_JN(N, X)} computes the Bessel function of the first kind of
+order @var{N} of @var{X}. This function is available under the name
+@code{BESJN} as a GNU extension.  If @var{N} and @var{X} are arrays,
+their ranks and shapes shall conform.  
+
+@code{BESSEL_JN(N1, N2, X)} returns an array with the Bessel functions
+of the first kind of the orders @var{N1} to @var{N2}.
+
+@item @emph{Standard}:
+Fortran 2008 and later, negative @var{N} is allowed as GNU extension
+
+@item @emph{Class}:
+Elemental function, except for the transformational function
+@code{BESSEL_JN(N1, N2, X)}
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{RESULT = BESSEL_JN(N, X)}
+@item @code{RESULT = BESSEL_JN(N1, N2, X)}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{N} @tab Shall be a scalar or an array of type  @code{INTEGER}.
+@item @var{N1} @tab Shall be a non-negative scalar of type  @code{INTEGER}.
+@item @var{N2} @tab Shall be a non-negative scalar of type  @code{INTEGER}.
+@item @var{X} @tab Shall be a scalar or an array of type  @code{REAL};
+for @code{BESSEL_JN(N1, N2, X)} it shall be scalar.
+@end multitable
+
+@item @emph{Return value}:
+The return value is a scalar of type @code{REAL}. It has the same
+kind as @var{X}.
+
+@item @emph{Note}:
+The transformational function uses a recurrence algorithm which might,
+for some values of @var{X}, lead to different results than calls to
+the elemental function.
+
+@item @emph{Example}:
+@smallexample
+program test_besjn
+  real(8) :: x = 1.0_8
+  x = bessel_jn(5,x)
+end program test_besjn
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name                @tab Argument            @tab Return type       @tab Standard
+@item @code{DBESJN(N, X)} @tab @code{INTEGER N}    @tab @code{REAL(8)}    @tab GNU extension
+@item                     @tab @code{REAL(8) X}    @tab                   @tab
+@end multitable
+@end table
+
+
+
+@node BESSEL_Y0
+@section @code{BESSEL_Y0} --- Bessel function of the second kind of order 0
+@fnindex BESSEL_Y0
+@fnindex BESY0
+@fnindex DBESY0
+@cindex Bessel function, second kind
+
+@table @asis
+@item @emph{Description}:
+@code{BESSEL_Y0(X)} computes the Bessel function of the second kind of
+order 0 of @var{X}. This function is available under the name
+@code{BESY0} as a GNU extension.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = BESSEL_Y0(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be @code{REAL}, and it shall be scalar.
+@end multitable
+
+@item @emph{Return value}:
+The return value is a scalar of type @code{REAL}. It has the same
+kind as @var{X}.
+
+@item @emph{Example}:
+@smallexample
+program test_besy0
+  real(8) :: x = 0.0_8
+  x = bessel_y0(x)
+end program test_besy0
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name            @tab Argument          @tab Return type       @tab Standard
+@item @code{DBESY0(X)}@tab @code{REAL(8) X}  @tab @code{REAL(8)}    @tab GNU extension
+@end multitable
+@end table
+
+
+
+@node BESSEL_Y1
+@section @code{BESSEL_Y1} --- Bessel function of the second kind of order 1
+@fnindex BESSEL_Y1
+@fnindex BESY1
+@fnindex DBESY1
+@cindex Bessel function, second kind
+
+@table @asis
+@item @emph{Description}:
+@code{BESSEL_Y1(X)} computes the Bessel function of the second kind of
+order 1 of @var{X}. This function is available under the name
+@code{BESY1} as a GNU extension.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = BESSEL_Y1(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be @code{REAL}, and it shall be scalar.
+@end multitable
+
+@item @emph{Return value}:
+The return value is a scalar of type @code{REAL}. It has the same
+kind as @var{X}.
+
+@item @emph{Example}:
+@smallexample
+program test_besy1
+  real(8) :: x = 1.0_8
+  x = bessel_y1(x)
+end program test_besy1
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name            @tab Argument          @tab Return type       @tab Standard
+@item @code{DBESY1(X)}@tab @code{REAL(8) X}  @tab @code{REAL(8)}    @tab GNU extension
+@end multitable
+@end table
+
+
+
+@node BESSEL_YN
+@section @code{BESSEL_YN} --- Bessel function of the second kind
+@fnindex BESSEL_YN
+@fnindex BESYN
+@fnindex DBESYN
+@cindex Bessel function, second kind
+
+@table @asis
+@item @emph{Description}:
+@code{BESSEL_YN(N, X)} computes the Bessel function of the second kind of
+order @var{N} of @var{X}. This function is available under the name
+@code{BESYN} as a GNU extension.  If @var{N} and @var{X} are arrays,
+their ranks and shapes shall conform.  
+
+@code{BESSEL_YN(N1, N2, X)} returns an array with the Bessel functions
+of the first kind of the orders @var{N1} to @var{N2}.
+
+@item @emph{Standard}:
+Fortran 2008 and later, negative @var{N} is allowed as GNU extension
+
+@item @emph{Class}:
+Elemental function, except for the transformational function
+@code{BESSEL_YN(N1, N2, X)}
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{RESULT = BESSEL_YN(N, X)}
+@item @code{RESULT = BESSEL_YN(N1, N2, X)}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{N} @tab Shall be a scalar or an array of type  @code{INTEGER} .
+@item @var{N1} @tab Shall be a non-negative scalar of type  @code{INTEGER}.
+@item @var{N2} @tab Shall be a non-negative scalar of type  @code{INTEGER}.
+@item @var{X} @tab Shall be a scalar or an array of type  @code{REAL};
+for @code{BESSEL_YN(N1, N2, X)} it shall be scalar.
+@end multitable
+
+@item @emph{Return value}:
+The return value is a scalar of type @code{REAL}. It has the same
+kind as @var{X}.
+
+@item @emph{Note}:
+The transformational function uses a recurrence algorithm which might,
+for some values of @var{X}, lead to different results than calls to
+the elemental function.
+
+@item @emph{Example}:
+@smallexample
+program test_besyn
+  real(8) :: x = 1.0_8
+  x = bessel_yn(5,x)
+end program test_besyn
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name               @tab Argument            @tab Return type     @tab Standard
+@item @code{DBESYN(N,X)} @tab @code{INTEGER N} @tab @code{REAL(8)}  @tab GNU extension
+@item                    @tab @code{REAL(8) X} @tab                 @tab 
+@end multitable
+@end table
+
+
+
+@node BGE
+@section @code{BGE} --- Bitwise greater than or equal to
+@fnindex BGE
+@cindex bitwise comparison
+
+@table @asis
+@item @emph{Description}:
+Determines whether an integral is a bitwise greater than or equal to
+another.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = BGE(I, J)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab Shall be of @code{INTEGER} type.
+@item @var{J} @tab Shall be of @code{INTEGER} type, and of the same kind
+as @var{I}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{LOGICAL} and of the default kind.
+
+@item @emph{See also}:
+@ref{BGT}, @ref{BLE}, @ref{BLT}
+@end table
+
+
+
+@node BGT
+@section @code{BGT} --- Bitwise greater than
+@fnindex BGT
+@cindex bitwise comparison
+
+@table @asis
+@item @emph{Description}:
+Determines whether an integral is a bitwise greater than another.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = BGT(I, J)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab Shall be of @code{INTEGER} type.
+@item @var{J} @tab Shall be of @code{INTEGER} type, and of the same kind
+as @var{I}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{LOGICAL} and of the default kind.
+
+@item @emph{See also}:
+@ref{BGE}, @ref{BLE}, @ref{BLT}
+@end table
+
+
+
+@node BIT_SIZE
+@section @code{BIT_SIZE} --- Bit size inquiry function
+@fnindex BIT_SIZE
+@cindex bits, number of
+@cindex size of a variable, in bits
+
+@table @asis
+@item @emph{Description}:
+@code{BIT_SIZE(I)} returns the number of bits (integer precision plus sign bit)
+represented by the type of @var{I}.  The result of @code{BIT_SIZE(I)} is
+independent of the actual value of @var{I}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{RESULT = BIT_SIZE(I)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab The type shall be @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER}
+
+@item @emph{Example}:
+@smallexample
+program test_bit_size
+    integer :: i = 123
+    integer :: size
+    size = bit_size(i)
+    print *, size
+end program test_bit_size
+@end smallexample
+@end table
+
+
+
+@node BLE
+@section @code{BLE} --- Bitwise less than or equal to
+@fnindex BLE
+@cindex bitwise comparison
+
+@table @asis
+@item @emph{Description}:
+Determines whether an integral is a bitwise less than or equal to
+another.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = BLE(I, J)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab Shall be of @code{INTEGER} type.
+@item @var{J} @tab Shall be of @code{INTEGER} type, and of the same kind
+as @var{I}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{LOGICAL} and of the default kind.
+
+@item @emph{See also}:
+@ref{BGT}, @ref{BGE}, @ref{BLT}
+@end table
+
+
+
+@node BLT
+@section @code{BLT} --- Bitwise less than
+@fnindex BLT
+@cindex bitwise comparison
+
+@table @asis
+@item @emph{Description}:
+Determines whether an integral is a bitwise less than another.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = BLT(I, J)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab Shall be of @code{INTEGER} type.
+@item @var{J} @tab Shall be of @code{INTEGER} type, and of the same kind
+as @var{I}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{LOGICAL} and of the default kind.
+
+@item @emph{See also}:
+@ref{BGE}, @ref{BGT}, @ref{BLE}
+@end table
+
+
+
+@node BTEST
+@section @code{BTEST} --- Bit test function
+@fnindex BTEST
+@cindex bits, testing
+
+@table @asis
+@item @emph{Description}:
+@code{BTEST(I,POS)} returns logical @code{.TRUE.} if the bit at @var{POS}
+in @var{I} is set.  The counting of the bits starts at 0.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = BTEST(I, POS)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab The type shall be @code{INTEGER}.
+@item @var{POS} @tab The type shall be @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{LOGICAL}
+
+@item @emph{Example}:
+@smallexample
+program test_btest
+    integer :: i = 32768 + 1024 + 64
+    integer :: pos
+    logical :: bool
+    do pos=0,16
+        bool = btest(i, pos) 
+        print *, pos, bool
+    end do
+end program test_btest
+@end smallexample
+@end table
+
+
+@node C_ASSOCIATED
+@section @code{C_ASSOCIATED} --- Status of a C pointer
+@fnindex C_ASSOCIATED
+@cindex association status, C pointer
+@cindex pointer, C association status
+
+@table @asis
+@item @emph{Description}:
+@code{C_ASSOCIATED(c_prt_1[, c_ptr_2])} determines the status of the C pointer
+@var{c_ptr_1} or if @var{c_ptr_1} is associated with the target @var{c_ptr_2}.
+
+@item @emph{Standard}:
+Fortran 2003 and later
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{RESULT = C_ASSOCIATED(c_prt_1[, c_ptr_2])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{c_ptr_1} @tab Scalar of the type @code{C_PTR} or @code{C_FUNPTR}.
+@item @var{c_ptr_2} @tab (Optional) Scalar of the same type as @var{c_ptr_1}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{LOGICAL}; it is @code{.false.} if either
+@var{c_ptr_1} is a C NULL pointer or if @var{c_ptr1} and @var{c_ptr_2}
+point to different addresses.
+
+@item @emph{Example}:
+@smallexample
+subroutine association_test(a,b)
+  use iso_c_binding, only: c_associated, c_loc, c_ptr
+  implicit none
+  real, pointer :: a
+  type(c_ptr) :: b
+  if(c_associated(b, c_loc(a))) &
+     stop 'b and a do not point to same target'
+end subroutine association_test
+@end smallexample
+
+@item @emph{See also}:
+@ref{C_LOC}, @ref{C_FUNLOC}
+@end table
+
+
+@node C_F_POINTER
+@section @code{C_F_POINTER} --- Convert C into Fortran pointer
+@fnindex C_F_POINTER
+@cindex pointer, convert C to Fortran
+
+@table @asis
+@item @emph{Description}:
+@code{C_F_POINTER(CPTR, FPTR[, SHAPE])} assigns the target of the C pointer
+@var{CPTR} to the Fortran pointer @var{FPTR} and specifies its shape.
+
+@item @emph{Standard}:
+Fortran 2003 and later
+
+@item @emph{Class}:
+Subroutine
+
+@item @emph{Syntax}:
+@code{CALL C_F_POINTER(CPTR, FPTR[, SHAPE])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{CPTR}  @tab scalar of the type @code{C_PTR}. It is
+@code{INTENT(IN)}.
+@item @var{FPTR}  @tab pointer interoperable with @var{cptr}. It is
+@code{INTENT(OUT)}.
+@item @var{SHAPE} @tab (Optional) Rank-one array of type @code{INTEGER}
+with @code{INTENT(IN)}. It shall be present
+if and only if @var{fptr} is an array. The size
+must be equal to the rank of @var{fptr}.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+program main
+  use iso_c_binding
+  implicit none
+  interface
+    subroutine my_routine(p) bind(c,name='myC_func')
+      import :: c_ptr
+      type(c_ptr), intent(out) :: p
+    end subroutine
+  end interface
+  type(c_ptr) :: cptr
+  real,pointer :: a(:)
+  call my_routine(cptr)
+  call c_f_pointer(cptr, a, [12])
+end program main
+@end smallexample
+
+@item @emph{See also}:
+@ref{C_LOC}, @ref{C_F_PROCPOINTER}
+@end table
+
+
+@node C_F_PROCPOINTER
+@section @code{C_F_PROCPOINTER} --- Convert C into Fortran procedure pointer
+@fnindex C_F_PROCPOINTER
+@cindex pointer, C address of pointers
+
+@table @asis
+@item @emph{Description}:
+@code{C_F_PROCPOINTER(CPTR, FPTR)} Assign the target of the C function pointer
+@var{CPTR} to the Fortran procedure pointer @var{FPTR}.
+
+@item @emph{Standard}:
+Fortran 2003 and later
+
+@item @emph{Class}:
+Subroutine
+
+@item @emph{Syntax}:
+@code{CALL C_F_PROCPOINTER(cptr, fptr)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{CPTR}  @tab scalar of the type @code{C_FUNPTR}. It is
+@code{INTENT(IN)}.
+@item @var{FPTR}  @tab procedure pointer interoperable with @var{cptr}. It is
+@code{INTENT(OUT)}.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+program main
+  use iso_c_binding
+  implicit none
+  abstract interface
+    function func(a)
+      import :: c_float
+      real(c_float), intent(in) :: a
+      real(c_float) :: func
+    end function
+  end interface
+  interface
+     function getIterFunc() bind(c,name="getIterFunc")
+       import :: c_funptr
+       type(c_funptr) :: getIterFunc
+     end function
+  end interface
+  type(c_funptr) :: cfunptr
+  procedure(func), pointer :: myFunc
+  cfunptr = getIterFunc()
+  call c_f_procpointer(cfunptr, myFunc)
+end program main
+@end smallexample
+
+@item @emph{See also}:
+@ref{C_LOC}, @ref{C_F_POINTER}
+@end table
+
+
+@node C_FUNLOC
+@section @code{C_FUNLOC} --- Obtain the C address of a procedure
+@fnindex C_FUNLOC
+@cindex pointer, C address of procedures
+
+@table @asis
+@item @emph{Description}:
+@code{C_FUNLOC(x)} determines the C address of the argument.
+
+@item @emph{Standard}:
+Fortran 2003 and later
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{RESULT = C_FUNLOC(x)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{x} @tab Interoperable function or pointer to such function.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{C_FUNPTR} and contains the C address
+of the argument.
+
+@item @emph{Example}:
+@smallexample
+module x
+  use iso_c_binding
+  implicit none
+contains
+  subroutine sub(a) bind(c)
+    real(c_float) :: a
+    a = sqrt(a)+5.0
+  end subroutine sub
+end module x
+program main
+  use iso_c_binding
+  use x
+  implicit none
+  interface
+    subroutine my_routine(p) bind(c,name='myC_func')
+      import :: c_funptr
+      type(c_funptr), intent(in) :: p
+    end subroutine
+  end interface
+  call my_routine(c_funloc(sub))
+end program main
+@end smallexample
+
+@item @emph{See also}:
+@ref{C_ASSOCIATED}, @ref{C_LOC}, @ref{C_F_POINTER}, @ref{C_F_PROCPOINTER}
+@end table
+
+
+@node C_LOC
+@section @code{C_LOC} --- Obtain the C address of an object
+@fnindex C_LOC
+@cindex procedure pointer, convert C to Fortran
+
+@table @asis
+@item @emph{Description}:
+@code{C_LOC(X)} determines the C address of the argument.
+
+@item @emph{Standard}:
+Fortran 2003 and later
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{RESULT = C_LOC(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .10 .75
+@item @var{X} @tab  Shall have either the POINTER or TARGET attribute. It shall not be a coindexed object. It shall either be a variable with interoperable type and kind type parameters, or be a scalar, nonpolymorphic variable with no length type parameters.
+
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{C_PTR} and contains the C address
+of the argument.
+
+@item @emph{Example}:
+@smallexample
+subroutine association_test(a,b)
+  use iso_c_binding, only: c_associated, c_loc, c_ptr
+  implicit none
+  real, pointer :: a
+  type(c_ptr) :: b
+  if(c_associated(b, c_loc(a))) &
+     stop 'b and a do not point to same target'
+end subroutine association_test
+@end smallexample
+
+@item @emph{See also}:
+@ref{C_ASSOCIATED}, @ref{C_FUNLOC}, @ref{C_F_POINTER}, @ref{C_F_PROCPOINTER}
+@end table
+
+
+@node C_SIZEOF
+@section @code{C_SIZEOF} --- Size in bytes of an expression
+@fnindex C_SIZEOF
+@cindex expression size
+@cindex size of an expression
+
+@table @asis
+@item @emph{Description}:
+@code{C_SIZEOF(X)} calculates the number of bytes of storage the
+expression @code{X} occupies.
+
+@item @emph{Standard}:
+Fortran 2008
+
+@item @emph{Class}:
+Inquiry function of the module @code{ISO_C_BINDING}
+
+@item @emph{Syntax}:
+@code{N = C_SIZEOF(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The argument shall be an interoperable data entity.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type integer and of the system-dependent kind
+@code{C_SIZE_T} (from the @code{ISO_C_BINDING} module). Its value is the
+number of bytes occupied by the argument.  If the argument has the
+@code{POINTER} attribute, the number of bytes of the storage area pointed
+to is returned.  If the argument is of a derived type with @code{POINTER}
+or @code{ALLOCATABLE} components, the return value does not account for
+the sizes of the data pointed to by these components.
+
+@item @emph{Example}:
+@smallexample
+   use iso_c_binding
+   integer(c_int) :: i
+   real(c_float) :: r, s(5)
+   print *, (c_sizeof(s)/c_sizeof(r) == 5)
+   end
+@end smallexample
+The example will print @code{.TRUE.} unless you are using a platform
+where default @code{REAL} variables are unusually padded.
+
+@item @emph{See also}:
+@ref{SIZEOF}, @ref{STORAGE_SIZE}
+@end table
+
+
+@node CEILING
+@section @code{CEILING} --- Integer ceiling function
+@fnindex CEILING
+@cindex ceiling
+@cindex rounding, ceiling
+
+@table @asis
+@item @emph{Description}:
+@code{CEILING(A)} returns the least integer greater than or equal to @var{A}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = CEILING(A [, KIND])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{A} @tab The type shall be @code{REAL}.
+@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
+expression indicating the kind parameter of the result.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER(KIND)} if @var{KIND} is present
+and a default-kind @code{INTEGER} otherwise.
+
+@item @emph{Example}:
+@smallexample
+program test_ceiling
+    real :: x = 63.29
+    real :: y = -63.59
+    print *, ceiling(x) ! returns 64
+    print *, ceiling(y) ! returns -63
+end program test_ceiling
+@end smallexample
+
+@item @emph{See also}:
+@ref{FLOOR}, @ref{NINT}
+
+@end table
+
+
+
+@node CHAR
+@section @code{CHAR} --- Character conversion function
+@fnindex CHAR
+@cindex conversion, to character
+
+@table @asis
+@item @emph{Description}:
+@code{CHAR(I [, KIND])} returns the character represented by the integer @var{I}.
+
+@item @emph{Standard}:
+Fortran 77 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = CHAR(I [, KIND])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab The type shall be @code{INTEGER}.
+@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
+expression indicating the kind parameter of the result.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{CHARACTER(1)}
+
+@item @emph{Example}:
+@smallexample
+program test_char
+    integer :: i = 74
+    character(1) :: c
+    c = char(i)
+    print *, i, c ! returns 'J'
+end program test_char
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name           @tab Argument         @tab Return type             @tab Standard
+@item @code{CHAR(I)} @tab @code{INTEGER I} @tab @code{CHARACTER(LEN=1)} @tab F77 and later
+@end multitable
+
+@item @emph{Note}:
+See @ref{ICHAR} for a discussion of converting between numerical values
+and formatted string representations.
+
+@item @emph{See also}:
+@ref{ACHAR}, @ref{IACHAR}, @ref{ICHAR}
+
+@end table
+
+
+
+@node CHDIR
+@section @code{CHDIR} --- Change working directory
+@fnindex CHDIR
+@cindex system, working directory
+
+@table @asis
+@item @emph{Description}:
+Change current working directory to a specified path.
+
+This intrinsic is provided in both subroutine and function forms; however,
+only one form can be used in any given program unit.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine, function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{CALL CHDIR(NAME [, STATUS])}
+@item @code{STATUS = CHDIR(NAME)}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{NAME}   @tab The type shall be @code{CHARACTER} of default
+kind and shall specify a valid path within the file system.
+@item @var{STATUS} @tab (Optional) @code{INTEGER} status flag of the default
+kind.  Returns 0 on success, and a system specific and nonzero error code
+otherwise.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_chdir
+  CHARACTER(len=255) :: path
+  CALL getcwd(path)
+  WRITE(*,*) TRIM(path)
+  CALL chdir("/tmp")
+  CALL getcwd(path)
+  WRITE(*,*) TRIM(path)
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{GETCWD}
+@end table
+
+
+
+@node CHMOD
+@section @code{CHMOD} --- Change access permissions of files
+@fnindex CHMOD
+@cindex file system, change access mode
+
+@table @asis
+@item @emph{Description}:
+@code{CHMOD} changes the permissions of a file.
+
+This intrinsic is provided in both subroutine and function forms; however,
+only one form can be used in any given program unit.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine, function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{CALL CHMOD(NAME, MODE[, STATUS])}
+@item @code{STATUS = CHMOD(NAME, MODE)}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+
+@item @var{NAME} @tab Scalar @code{CHARACTER} of default kind with the
+file name. Trailing blanks are ignored unless the character
+@code{achar(0)} is present, then all characters up to and excluding
+@code{achar(0)} are used as the file name.
+
+@item @var{MODE} @tab Scalar @code{CHARACTER} of default kind giving the
+file permission. @var{MODE} uses the same syntax as the @code{chmod} utility
+as defined by the POSIX standard. The argument shall either be a string of
+a nonnegative octal number or a symbolic mode.
+
+@item @var{STATUS} @tab (optional) scalar @code{INTEGER}, which is
+@code{0} on success and nonzero otherwise.
+@end multitable
+
+@item @emph{Return value}:
+In either syntax, @var{STATUS} is set to @code{0} on success and nonzero
+otherwise.
+
+@item @emph{Example}:
+@code{CHMOD} as subroutine
+@smallexample
+program chmod_test
+  implicit none
+  integer :: status
+  call chmod('test.dat','u+x',status)
+  print *, 'Status: ', status
+end program chmod_test
+@end smallexample
+@code{CHMOD} as function:
+@smallexample
+program chmod_test
+  implicit none
+  integer :: status
+  status = chmod('test.dat','u+x')
+  print *, 'Status: ', status
+end program chmod_test
+@end smallexample
+
+@end table
+
+
+
+@node CMPLX
+@section @code{CMPLX} --- Complex conversion function
+@fnindex CMPLX
+@cindex complex numbers, conversion to
+@cindex conversion, to complex
+
+@table @asis
+@item @emph{Description}:
+@code{CMPLX(X [, Y [, KIND]])} returns a complex number where @var{X} is converted to
+the real component.  If @var{Y} is present it is converted to the imaginary
+component.  If @var{Y} is not present then the imaginary component is set to
+0.0.  If @var{X} is complex then @var{Y} must not be present.
+
+@item @emph{Standard}:
+Fortran 77 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = CMPLX(X [, Y [, KIND]])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type may be @code{INTEGER}, @code{REAL},
+or @code{COMPLEX}.
+@item @var{Y} @tab (Optional; only allowed if @var{X} is not
+@code{COMPLEX}.)  May be @code{INTEGER} or @code{REAL}.
+@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
+expression indicating the kind parameter of the result.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of @code{COMPLEX} type, with a kind equal to
+@var{KIND} if it is specified.  If @var{KIND} is not specified, the
+result is of the default @code{COMPLEX} kind, regardless of the kinds of
+@var{X} and @var{Y}. 
+
+@item @emph{Example}:
+@smallexample
+program test_cmplx
+    integer :: i = 42
+    real :: x = 3.14
+    complex :: z
+    z = cmplx(i, x)
+    print *, z, cmplx(x)
+end program test_cmplx
+@end smallexample
+
+@item @emph{See also}:
+@ref{COMPLEX}
+@end table
+
+
+
+@node COMMAND_ARGUMENT_COUNT
+@section @code{COMMAND_ARGUMENT_COUNT} --- Get number of command line arguments
+@fnindex COMMAND_ARGUMENT_COUNT
+@cindex command-line arguments
+@cindex command-line arguments, number of
+@cindex arguments, to program
+
+@table @asis
+@item @emph{Description}:
+@code{COMMAND_ARGUMENT_COUNT} returns the number of arguments passed on the
+command line when the containing program was invoked.
+
+@item @emph{Standard}:
+Fortran 2003 and later
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{RESULT = COMMAND_ARGUMENT_COUNT()}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item None
+@end multitable
+
+@item @emph{Return value}:
+The return value is an @code{INTEGER} of default kind.
+
+@item @emph{Example}:
+@smallexample
+program test_command_argument_count
+    integer :: count
+    count = command_argument_count()
+    print *, count
+end program test_command_argument_count
+@end smallexample
+
+@item @emph{See also}:
+@ref{GET_COMMAND}, @ref{GET_COMMAND_ARGUMENT}
+@end table
+
+
+
+@node COMPILER_OPTIONS
+@section @code{COMPILER_OPTIONS} --- Options passed to the compiler
+@fnindex COMPILER_OPTIONS
+@cindex flags inquiry function
+@cindex options inquiry function
+@cindex compiler flags inquiry function
+
+@table @asis
+@item @emph{Description}:
+@code{COMPILER_OPTIONS} returns a string with the options used for
+compiling.
+
+@item @emph{Standard}:
+Fortran 2008
+
+@item @emph{Class}:
+Inquiry function of the module @code{ISO_FORTRAN_ENV}
+
+@item @emph{Syntax}:
+@code{STR = COMPILER_OPTIONS()}
+
+@item @emph{Arguments}:
+None.
+
+@item @emph{Return value}:
+The return value is a default-kind string with system-dependent length.
+It contains the compiler flags used to compile the file, which called
+the @code{COMPILER_OPTIONS} intrinsic.
+
+@item @emph{Example}:
+@smallexample
+   use iso_fortran_env
+   print '(4a)', 'This file was compiled by ', &
+                 compiler_version(), ' using the options ', &
+                 compiler_options()
+   end
+@end smallexample
+
+@item @emph{See also}:
+@ref{COMPILER_VERSION}, @ref{ISO_FORTRAN_ENV}
+@end table
+
+
+
+@node COMPILER_VERSION
+@section @code{COMPILER_VERSION} --- Compiler version string
+@fnindex COMPILER_VERSION
+@cindex compiler, name and version
+@cindex version of the compiler
+
+@table @asis
+@item @emph{Description}:
+@code{COMPILER_VERSION} returns a string with the name and the
+version of the compiler.
+
+@item @emph{Standard}:
+Fortran 2008
+
+@item @emph{Class}:
+Inquiry function of the module @code{ISO_FORTRAN_ENV}
+
+@item @emph{Syntax}:
+@code{STR = COMPILER_VERSION()}
+
+@item @emph{Arguments}:
+None.
+
+@item @emph{Return value}:
+The return value is a default-kind string with system-dependent length.
+It contains the name of the compiler and its version number.
+
+@item @emph{Example}:
+@smallexample
+   use iso_fortran_env
+   print '(4a)', 'This file was compiled by ', &
+                 compiler_version(), ' using the options ', &
+                 compiler_options()
+   end
+@end smallexample
+
+@item @emph{See also}:
+@ref{COMPILER_OPTIONS}, @ref{ISO_FORTRAN_ENV}
+@end table
+
+
+
+@node COMPLEX
+@section @code{COMPLEX} --- Complex conversion function
+@fnindex COMPLEX
+@cindex complex numbers, conversion to
+@cindex conversion, to complex
+
+@table @asis
+@item @emph{Description}:
+@code{COMPLEX(X, Y)} returns a complex number where @var{X} is converted
+to the real component and @var{Y} is converted to the imaginary
+component.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = COMPLEX(X, Y)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type may be @code{INTEGER} or @code{REAL}.
+@item @var{Y} @tab The type may be @code{INTEGER} or @code{REAL}.
+@end multitable
+
+@item @emph{Return value}:
+If @var{X} and @var{Y} are both of @code{INTEGER} type, then the return
+value is of default @code{COMPLEX} type.
+
+If @var{X} and @var{Y} are of @code{REAL} type, or one is of @code{REAL}
+type and one is of @code{INTEGER} type, then the return value is of
+@code{COMPLEX} type with a kind equal to that of the @code{REAL}
+argument with the highest precision.  
+
+@item @emph{Example}:
+@smallexample
+program test_complex
+    integer :: i = 42
+    real :: x = 3.14
+    print *, complex(i, x)
+end program test_complex
+@end smallexample
+
+@item @emph{See also}:
+@ref{CMPLX}
+@end table
+
+
+
+@node CONJG
+@section @code{CONJG} --- Complex conjugate function 
+@fnindex CONJG
+@fnindex DCONJG
+@cindex complex conjugate
+
+@table @asis
+@item @emph{Description}:
+@code{CONJG(Z)} returns the conjugate of @var{Z}.  If @var{Z} is @code{(x, y)}
+then the result is @code{(x, -y)}
+
+@item @emph{Standard}:
+Fortran 77 and later, has overloads that are GNU extensions
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{Z = CONJG(Z)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{Z} @tab The type shall be @code{COMPLEX}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{COMPLEX}.
+
+@item @emph{Example}:
+@smallexample
+program test_conjg
+    complex :: z = (2.0, 3.0)
+    complex(8) :: dz = (2.71_8, -3.14_8)
+    z= conjg(z)
+    print *, z
+    dz = dconjg(dz)
+    print *, dz
+end program test_conjg
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name             @tab Argument             @tab Return type       @tab Standard
+@item @code{CONJG(Z)}  @tab @code{COMPLEX Z}     @tab @code{COMPLEX}    @tab GNU extension
+@item @code{DCONJG(Z)} @tab @code{COMPLEX(8) Z}  @tab @code{COMPLEX(8)} @tab GNU extension
+@end multitable
+@end table
+
+
+
+@node COS
+@section @code{COS} --- Cosine function 
+@fnindex COS
+@fnindex DCOS
+@fnindex CCOS
+@fnindex ZCOS
+@fnindex CDCOS
+@cindex trigonometric function, cosine
+@cindex cosine
+
+@table @asis
+@item @emph{Description}:
+@code{COS(X)} computes the cosine of @var{X}.
+
+@item @emph{Standard}:
+Fortran 77 and later, has overloads that are GNU extensions
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = COS(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be @code{REAL} or
+@code{COMPLEX}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of the same type and kind as @var{X}. The real part
+of the result is in radians. If @var{X} is of the type @code{REAL},
+the return value lies in the range @math{ -1 \leq \cos (x) \leq 1}.
+
+@item @emph{Example}:
+@smallexample
+program test_cos
+  real :: x = 0.0
+  x = cos(x)
+end program test_cos
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name            @tab Argument            @tab Return type       @tab Standard
+@item @code{COS(X)}   @tab @code{REAL(4) X}    @tab @code{REAL(4)}    @tab Fortran 77 and later
+@item @code{DCOS(X)}  @tab @code{REAL(8) X}    @tab @code{REAL(8)}    @tab Fortran 77 and later
+@item @code{CCOS(X)}  @tab @code{COMPLEX(4) X} @tab @code{COMPLEX(4)} @tab Fortran 77 and later
+@item @code{ZCOS(X)}  @tab @code{COMPLEX(8) X} @tab @code{COMPLEX(8)} @tab GNU extension
+@item @code{CDCOS(X)} @tab @code{COMPLEX(8) X} @tab @code{COMPLEX(8)} @tab GNU extension
+@end multitable
+
+@item @emph{See also}:
+Inverse function: @ref{ACOS}
+
+@end table
+
+
+
+@node COSH
+@section @code{COSH} --- Hyperbolic cosine function 
+@fnindex COSH
+@fnindex DCOSH
+@cindex hyperbolic cosine
+@cindex hyperbolic function, cosine
+@cindex cosine, hyperbolic
+
+@table @asis
+@item @emph{Description}:
+@code{COSH(X)} computes the hyperbolic cosine of @var{X}.
+
+@item @emph{Standard}:
+Fortran 77 and later, for a complex argument Fortran 2008 or later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{X = COSH(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be @code{REAL} or @code{COMPLEX}.
+@end multitable
+
+@item @emph{Return value}:
+The return value has same type and kind as @var{X}. If @var{X} is
+complex, the imaginary part of the result is in radians. If @var{X}
+is @code{REAL}, the return value has a lower bound of one,
+@math{\cosh (x) \geq 1}.
+
+@item @emph{Example}:
+@smallexample
+program test_cosh
+  real(8) :: x = 1.0_8
+  x = cosh(x)
+end program test_cosh
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name            @tab Argument          @tab Return type       @tab Standard
+@item @code{COSH(X)}  @tab @code{REAL(4) X}  @tab @code{REAL(4)}    @tab Fortran 77 and later
+@item @code{DCOSH(X)} @tab @code{REAL(8) X}  @tab @code{REAL(8)}    @tab Fortran 77 and later
+@end multitable
+
+@item @emph{See also}:
+Inverse function: @ref{ACOSH}
+
+@end table
+
+
+
+@node COUNT
+@section @code{COUNT} --- Count function
+@fnindex COUNT
+@cindex array, conditionally count elements
+@cindex array, element counting
+@cindex array, number of elements
+
+@table @asis
+@item @emph{Description}:
+
+Counts the number of @code{.TRUE.} elements in a logical @var{MASK},
+or, if the @var{DIM} argument is supplied, counts the number of
+elements along each row of the array in the @var{DIM} direction.
+If the array has zero size, or all of the elements of @var{MASK} are
+@code{.FALSE.}, then the result is @code{0}.
+
+@item @emph{Standard}:
+Fortran 95 and later, with @var{KIND} argument Fortran 2003 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@code{RESULT = COUNT(MASK [, DIM, KIND])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{MASK} @tab The type shall be @code{LOGICAL}.
+@item @var{DIM}  @tab (Optional) The type shall be @code{INTEGER}.
+@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
+expression indicating the kind parameter of the result.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of kind @var{KIND}. If
+@var{KIND} is absent, the return value is of default integer kind.
+If @var{DIM} is present, the result is an array with a rank one less
+than the rank of @var{ARRAY}, and a size corresponding to the shape
+of @var{ARRAY} with the @var{DIM} dimension removed.
+
+@item @emph{Example}:
+@smallexample
+program test_count
+    integer, dimension(2,3) :: a, b
+    logical, dimension(2,3) :: mask
+    a = reshape( (/ 1, 2, 3, 4, 5, 6 /), (/ 2, 3 /))
+    b = reshape( (/ 0, 7, 3, 4, 5, 8 /), (/ 2, 3 /))
+    print '(3i3)', a(1,:)
+    print '(3i3)', a(2,:)
+    print *
+    print '(3i3)', b(1,:)
+    print '(3i3)', b(2,:)
+    print *
+    mask = a.ne.b
+    print '(3l3)', mask(1,:)
+    print '(3l3)', mask(2,:)
+    print *
+    print '(3i3)', count(mask)
+    print *
+    print '(3i3)', count(mask, 1)
+    print *
+    print '(3i3)', count(mask, 2)
+end program test_count
+@end smallexample
+@end table
+
+
+
+@node CPU_TIME
+@section @code{CPU_TIME} --- CPU elapsed time in seconds
+@fnindex CPU_TIME
+@cindex time, elapsed
+
+@table @asis
+@item @emph{Description}:
+Returns a @code{REAL} value representing the elapsed CPU time in
+seconds.  This is useful for testing segments of code to determine
+execution time.
+
+If a time source is available, time will be reported with microsecond
+resolution. If no time source is available, @var{TIME} is set to
+@code{-1.0}.
+
+Note that @var{TIME} may contain a, system dependent, arbitrary offset
+and may not start with @code{0.0}. For @code{CPU_TIME}, the absolute
+value is meaningless, only differences between subsequent calls to
+this subroutine, as shown in the example below, should be used.
+
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Subroutine
+
+@item @emph{Syntax}:
+@code{CALL CPU_TIME(TIME)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{TIME} @tab The type shall be @code{REAL} with @code{INTENT(OUT)}.
+@end multitable
+
+@item @emph{Return value}:
+None
+
+@item @emph{Example}:
+@smallexample
+program test_cpu_time
+    real :: start, finish
+    call cpu_time(start)
+        ! put code to test here
+    call cpu_time(finish)
+    print '("Time = ",f6.3," seconds.")',finish-start
+end program test_cpu_time
+@end smallexample
+
+@item @emph{See also}:
+@ref{SYSTEM_CLOCK}, @ref{DATE_AND_TIME}
+@end table
+
+
+
+@node CSHIFT
+@section @code{CSHIFT} --- Circular shift elements of an array
+@fnindex CSHIFT
+@cindex array, shift circularly
+@cindex array, permutation
+@cindex array, rotate
+
+@table @asis
+@item @emph{Description}:
+@code{CSHIFT(ARRAY, SHIFT [, DIM])} performs a circular shift on elements of
+@var{ARRAY} along the dimension of @var{DIM}.  If @var{DIM} is omitted it is
+taken to be @code{1}.  @var{DIM} is a scalar of type @code{INTEGER} in the
+range of @math{1 \leq DIM \leq n)} where @math{n} is the rank of @var{ARRAY}.
+If the rank of @var{ARRAY} is one, then all elements of @var{ARRAY} are shifted
+by @var{SHIFT} places.  If rank is greater than one, then all complete rank one
+sections of @var{ARRAY} along the given dimension are shifted.  Elements
+shifted out one end of each rank one section are shifted back in the other end.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@code{RESULT = CSHIFT(ARRAY, SHIFT [, DIM])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ARRAY}  @tab Shall be an array of any type.
+@item @var{SHIFT}  @tab The type shall be @code{INTEGER}.
+@item @var{DIM}    @tab The type shall be @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+Returns an array of same type and rank as the @var{ARRAY} argument.
+
+@item @emph{Example}:
+@smallexample
+program test_cshift
+    integer, dimension(3,3) :: a
+    a = reshape( (/ 1, 2, 3, 4, 5, 6, 7, 8, 9 /), (/ 3, 3 /))
+    print '(3i3)', a(1,:)
+    print '(3i3)', a(2,:)
+    print '(3i3)', a(3,:)    
+    a = cshift(a, SHIFT=(/1, 2, -1/), DIM=2)
+    print *
+    print '(3i3)', a(1,:)
+    print '(3i3)', a(2,:)
+    print '(3i3)', a(3,:)
+end program test_cshift
+@end smallexample
+@end table
+
+
+
+@node CTIME
+@section @code{CTIME} --- Convert a time into a string
+@fnindex CTIME
+@cindex time, conversion to string
+@cindex conversion, to string
+
+@table @asis
+@item @emph{Description}:
+@code{CTIME} converts a system time value, such as returned by
+@code{TIME8}, to a string. Unless the application has called
+@code{setlocale}, the output will be in the default locale, of length
+24 and of the form @samp{Sat Aug 19 18:13:14 1995}. In other locales,
+a longer string may result.
+
+This intrinsic is provided in both subroutine and function forms; however,
+only one form can be used in any given program unit.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine, function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{CALL CTIME(TIME, RESULT)}.
+@item @code{RESULT = CTIME(TIME)}.
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{TIME}    @tab The type shall be of type @code{INTEGER}.
+@item @var{RESULT}  @tab The type shall be of type @code{CHARACTER} and
+of default kind. It is an @code{INTENT(OUT)} argument. If the length
+of this variable is too short for the time and date string to fit
+completely, it will be blank on procedure return.
+@end multitable
+
+@item @emph{Return value}:
+The converted date and time as a string. 
+
+@item @emph{Example}:
+@smallexample
+program test_ctime
+    integer(8) :: i
+    character(len=30) :: date
+    i = time8()
+
+    ! Do something, main part of the program
+    
+    call ctime(i,date)
+    print *, 'Program was started on ', date
+end program test_ctime
+@end smallexample
+
+@item @emph{See Also}:
+@ref{DATE_AND_TIME}, @ref{GMTIME}, @ref{LTIME}, @ref{TIME}, @ref{TIME8}
+@end table
+
+
+
+@node DATE_AND_TIME
+@section @code{DATE_AND_TIME} --- Date and time subroutine
+@fnindex DATE_AND_TIME
+@cindex date, current
+@cindex current date
+@cindex time, current
+@cindex current time
+
+@table @asis
+@item @emph{Description}:
+@code{DATE_AND_TIME(DATE, TIME, ZONE, VALUES)} gets the corresponding date and
+time information from the real-time system clock.  @var{DATE} is
+@code{INTENT(OUT)} and has form ccyymmdd.  @var{TIME} is @code{INTENT(OUT)} and
+has form hhmmss.sss.  @var{ZONE} is @code{INTENT(OUT)} and has form (+-)hhmm,
+representing the difference with respect to Coordinated Universal Time (UTC).
+Unavailable time and date parameters return blanks.
+
+@var{VALUES} is @code{INTENT(OUT)} and provides the following:
+
+@multitable @columnfractions .15 .30 .40
+@item @tab @code{VALUE(1)}: @tab The year
+@item @tab @code{VALUE(2)}: @tab The month
+@item @tab @code{VALUE(3)}: @tab The day of the month
+@item @tab @code{VALUE(4)}: @tab Time difference with UTC in minutes
+@item @tab @code{VALUE(5)}: @tab The hour of the day
+@item @tab @code{VALUE(6)}: @tab The minutes of the hour
+@item @tab @code{VALUE(7)}: @tab The seconds of the minute
+@item @tab @code{VALUE(8)}: @tab The milliseconds of the second
+@end multitable
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Subroutine
+
+@item @emph{Syntax}:
+@code{CALL DATE_AND_TIME([DATE, TIME, ZONE, VALUES])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{DATE}  @tab (Optional) The type shall be @code{CHARACTER(LEN=8)}
+or larger, and of default kind.
+@item @var{TIME}  @tab (Optional) The type shall be @code{CHARACTER(LEN=10)}
+or larger, and of default kind.
+@item @var{ZONE}  @tab (Optional) The type shall be @code{CHARACTER(LEN=5)}
+or larger, and of default kind.
+@item @var{VALUES}@tab (Optional) The type shall be @code{INTEGER(8)}.
+@end multitable
+
+@item @emph{Return value}:
+None
+
+@item @emph{Example}:
+@smallexample
+program test_time_and_date
+    character(8)  :: date
+    character(10) :: time
+    character(5)  :: zone
+    integer,dimension(8) :: values
+    ! using keyword arguments
+    call date_and_time(date,time,zone,values)
+    call date_and_time(DATE=date,ZONE=zone)
+    call date_and_time(TIME=time)
+    call date_and_time(VALUES=values)
+    print '(a,2x,a,2x,a)', date, time, zone
+    print '(8i5)', values
+end program test_time_and_date
+@end smallexample
+
+@item @emph{See also}:
+@ref{CPU_TIME}, @ref{SYSTEM_CLOCK}
+@end table
+
+
+
+@node DBLE
+@section @code{DBLE} --- Double conversion function 
+@fnindex DBLE
+@cindex conversion, to real
+
+@table @asis
+@item @emph{Description}:
+@code{DBLE(A)} Converts @var{A} to double precision real type.
+
+@item @emph{Standard}:
+Fortran 77 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = DBLE(A)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{A} @tab The type shall be @code{INTEGER}, @code{REAL},
+or @code{COMPLEX}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type double precision real.
+
+@item @emph{Example}:
+@smallexample
+program test_dble
+    real    :: x = 2.18
+    integer :: i = 5
+    complex :: z = (2.3,1.14)
+    print *, dble(x), dble(i), dble(z)
+end program test_dble
+@end smallexample
+
+@item @emph{See also}:
+@ref{REAL}
+@end table
+
+
+
+@node DCMPLX
+@section @code{DCMPLX} --- Double complex conversion function
+@fnindex DCMPLX
+@cindex complex numbers, conversion to
+@cindex conversion, to complex
+
+@table @asis
+@item @emph{Description}:
+@code{DCMPLX(X [,Y])} returns a double complex number where @var{X} is
+converted to the real component.  If @var{Y} is present it is converted to the
+imaginary component.  If @var{Y} is not present then the imaginary component is
+set to 0.0.  If @var{X} is complex then @var{Y} must not be present.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = DCMPLX(X [, Y])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type may be @code{INTEGER}, @code{REAL},
+or @code{COMPLEX}.
+@item @var{Y} @tab (Optional if @var{X} is not @code{COMPLEX}.) May be
+@code{INTEGER} or @code{REAL}. 
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{COMPLEX(8)}
+
+@item @emph{Example}:
+@smallexample
+program test_dcmplx
+    integer :: i = 42
+    real :: x = 3.14
+    complex :: z
+    z = cmplx(i, x)
+    print *, dcmplx(i)
+    print *, dcmplx(x)
+    print *, dcmplx(z)
+    print *, dcmplx(x,i)
+end program test_dcmplx
+@end smallexample
+@end table
+
+
+@node DIGITS
+@section @code{DIGITS} --- Significant binary digits function
+@fnindex DIGITS
+@cindex model representation, significant digits
+
+@table @asis
+@item @emph{Description}:
+@code{DIGITS(X)} returns the number of significant binary digits of the internal
+model representation of @var{X}.  For example, on a system using a 32-bit
+floating point representation, a default real number would likely return 24.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{RESULT = DIGITS(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type may be @code{INTEGER} or @code{REAL}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER}.
+
+@item @emph{Example}:
+@smallexample
+program test_digits
+    integer :: i = 12345
+    real :: x = 3.143
+    real(8) :: y = 2.33
+    print *, digits(i)
+    print *, digits(x)
+    print *, digits(y)
+end program test_digits
+@end smallexample
+@end table
+
+
+
+@node DIM
+@section @code{DIM} --- Positive difference
+@fnindex DIM
+@fnindex IDIM
+@fnindex DDIM
+@cindex positive difference
+
+@table @asis
+@item @emph{Description}:
+@code{DIM(X,Y)} returns the difference @code{X-Y} if the result is positive;
+otherwise returns zero.
+
+@item @emph{Standard}:
+Fortran 77 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = DIM(X, Y)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be @code{INTEGER} or @code{REAL}
+@item @var{Y} @tab The type shall be the same type and kind as @var{X}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} or @code{REAL}.
+
+@item @emph{Example}:
+@smallexample
+program test_dim
+    integer :: i
+    real(8) :: x
+    i = dim(4, 15)
+    x = dim(4.345_8, 2.111_8)
+    print *, i
+    print *, x
+end program test_dim
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name             @tab Argument               @tab Return type       @tab Standard
+@item @code{DIM(X,Y)}  @tab @code{REAL(4) X, Y}    @tab @code{REAL(4)}    @tab Fortran 77 and later
+@item @code{IDIM(X,Y)} @tab @code{INTEGER(4) X, Y} @tab @code{INTEGER(4)} @tab Fortran 77 and later
+@item @code{DDIM(X,Y)} @tab @code{REAL(8) X, Y}    @tab @code{REAL(8)}    @tab Fortran 77 and later
+@end multitable
+@end table
+
+
+
+@node DOT_PRODUCT
+@section @code{DOT_PRODUCT} --- Dot product function
+@fnindex DOT_PRODUCT
+@cindex dot product
+@cindex vector product
+@cindex product, vector
+
+@table @asis
+@item @emph{Description}:
+@code{DOT_PRODUCT(VECTOR_A, VECTOR_B)} computes the dot product multiplication
+of two vectors @var{VECTOR_A} and @var{VECTOR_B}.  The two vectors may be
+either numeric or logical and must be arrays of rank one and of equal size. If
+the vectors are @code{INTEGER} or @code{REAL}, the result is
+@code{SUM(VECTOR_A*VECTOR_B)}. If the vectors are @code{COMPLEX}, the result
+is @code{SUM(CONJG(VECTOR_A)*VECTOR_B)}. If the vectors are @code{LOGICAL},
+the result is @code{ANY(VECTOR_A .AND. VECTOR_B)}.  
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@code{RESULT = DOT_PRODUCT(VECTOR_A, VECTOR_B)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{VECTOR_A} @tab The type shall be numeric or @code{LOGICAL}, rank 1.
+@item @var{VECTOR_B} @tab The type shall be numeric if @var{VECTOR_A} is of numeric type or @code{LOGICAL} if @var{VECTOR_A} is of type @code{LOGICAL}. @var{VECTOR_B} shall be a rank-one array.
+@end multitable
+
+@item @emph{Return value}:
+If the arguments are numeric, the return value is a scalar of numeric type,
+@code{INTEGER}, @code{REAL}, or @code{COMPLEX}.  If the arguments are
+@code{LOGICAL}, the return value is @code{.TRUE.} or @code{.FALSE.}.
+
+@item @emph{Example}:
+@smallexample
+program test_dot_prod
+    integer, dimension(3) :: a, b
+    a = (/ 1, 2, 3 /)
+    b = (/ 4, 5, 6 /)
+    print '(3i3)', a
+    print *
+    print '(3i3)', b
+    print *
+    print *, dot_product(a,b)
+end program test_dot_prod
+@end smallexample
+@end table
+
+
+
+@node DPROD
+@section @code{DPROD} --- Double product function
+@fnindex DPROD
+@cindex product, double-precision
+
+@table @asis
+@item @emph{Description}:
+@code{DPROD(X,Y)} returns the product @code{X*Y}.
+
+@item @emph{Standard}:
+Fortran 77 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = DPROD(X, Y)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be @code{REAL}.
+@item @var{Y} @tab The type shall be @code{REAL}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{REAL(8)}.
+
+@item @emph{Example}:
+@smallexample
+program test_dprod
+    real :: x = 5.2
+    real :: y = 2.3
+    real(8) :: d
+    d = dprod(x,y)
+    print *, d
+end program test_dprod
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name              @tab Argument               @tab Return type       @tab Standard
+@item @code{DPROD(X,Y)} @tab @code{REAL(4) X, Y}    @tab @code{REAL(4)}    @tab Fortran 77 and later
+@end multitable
+
+@end table
+
+
+@node DREAL
+@section @code{DREAL} --- Double real part function
+@fnindex DREAL
+@cindex complex numbers, real part
+
+@table @asis
+@item @emph{Description}:
+@code{DREAL(Z)} returns the real part of complex variable @var{Z}.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = DREAL(A)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{A} @tab The type shall be @code{COMPLEX(8)}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{REAL(8)}.
+
+@item @emph{Example}:
+@smallexample
+program test_dreal
+    complex(8) :: z = (1.3_8,7.2_8)
+    print *, dreal(z)
+end program test_dreal
+@end smallexample
+
+@item @emph{See also}:
+@ref{AIMAG}
+
+@end table
+
+
+
+@node DSHIFTL
+@section @code{DSHIFTL} --- Combined left shift
+@fnindex DSHIFTL
+@cindex left shift, combined
+@cindex shift, left
+
+@table @asis
+@item @emph{Description}:
+@code{DSHIFTL(I, J, SHIFT)} combines bits of @var{I} and @var{J}. The
+rightmost @var{SHIFT} bits of the result are the leftmost @var{SHIFT}
+bits of @var{J}, and the remaining bits are the rightmost bits of
+@var{I}.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = DSHIFTL(I, J, SHIFT)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab Shall be of type @code{INTEGER} or a BOZ constant.
+@item @var{J} @tab Shall be of type @code{INTEGER} or a BOZ constant.
+If both @var{I} and @var{J} have integer type, then they shall have
+the same kind type parameter. @var{I} and @var{J} shall not both be
+BOZ constants.
+@item @var{SHIFT} @tab Shall be of type @code{INTEGER}. It shall
+be nonnegative.  If @var{I} is not a BOZ constant, then @var{SHIFT}
+shall be less than or equal to @code{BIT_SIZE(I)}; otherwise,
+@var{SHIFT} shall be less than or equal to @code{BIT_SIZE(J)}.
+@end multitable
+
+@item @emph{Return value}:
+If either @var{I} or @var{J} is a BOZ constant, it is first converted
+as if by the intrinsic function @code{INT} to an integer type with the
+kind type parameter of the other.
+
+@item @emph{See also}:
+@ref{DSHIFTR}
+@end table
+
+
+@node DSHIFTR
+@section @code{DSHIFTR} --- Combined right shift
+@fnindex DSHIFTR
+@cindex right shift, combined
+@cindex shift, right
+
+@table @asis
+@item @emph{Description}:
+@code{DSHIFTR(I, J, SHIFT)} combines bits of @var{I} and @var{J}. The
+leftmost @var{SHIFT} bits of the result are the rightmost @var{SHIFT}
+bits of @var{I}, and the remaining bits are the leftmost bits of
+@var{J}.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = DSHIFTR(I, J, SHIFT)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab Shall be of type @code{INTEGER} or a BOZ constant.
+@item @var{J} @tab Shall be of type @code{INTEGER} or a BOZ constant.
+If both @var{I} and @var{J} have integer type, then they shall have
+the same kind type parameter. @var{I} and @var{J} shall not both be
+BOZ constants.
+@item @var{SHIFT} @tab Shall be of type @code{INTEGER}. It shall
+be nonnegative.  If @var{I} is not a BOZ constant, then @var{SHIFT}
+shall be less than or equal to @code{BIT_SIZE(I)}; otherwise,
+@var{SHIFT} shall be less than or equal to @code{BIT_SIZE(J)}.
+@end multitable
+
+@item @emph{Return value}:
+If either @var{I} or @var{J} is a BOZ constant, it is first converted
+as if by the intrinsic function @code{INT} to an integer type with the
+kind type parameter of the other.
+
+@item @emph{See also}:
+@ref{DSHIFTL}
+@end table
+
+
+@node DTIME
+@section @code{DTIME} --- Execution time subroutine (or function)
+@fnindex DTIME
+@cindex time, elapsed
+@cindex elapsed time
+
+@table @asis
+@item @emph{Description}:
+@code{DTIME(VALUES, TIME)} initially returns the number of seconds of runtime
+since the start of the process's execution in @var{TIME}.  @var{VALUES}
+returns the user and system components of this time in @code{VALUES(1)} and
+@code{VALUES(2)} respectively. @var{TIME} is equal to @code{VALUES(1) +
+VALUES(2)}.
+
+Subsequent invocations of @code{DTIME} return values accumulated since the
+previous invocation.
+
+On some systems, the underlying timings are represented using types with
+sufficiently small limits that overflows (wrap around) are possible, such as
+32-bit types. Therefore, the values returned by this intrinsic might be, or
+become, negative, or numerically less than previous values, during a single
+run of the compiled program.
+
+Please note, that this implementation is thread safe if used within OpenMP
+directives, i.e., its state will be consistent while called from multiple
+threads. However, if @code{DTIME} is called from multiple threads, the result
+is still the time since the last invocation. This may not give the intended
+results. If possible, use @code{CPU_TIME} instead.
+
+This intrinsic is provided in both subroutine and function forms; however,
+only one form can be used in any given program unit.
+
+@var{VALUES} and @var{TIME} are @code{INTENT(OUT)} and provide the following:
+
+@multitable @columnfractions .15 .30 .40
+@item @tab @code{VALUES(1)}: @tab User time in seconds.
+@item @tab @code{VALUES(2)}: @tab System time in seconds.
+@item @tab @code{TIME}: @tab Run time since start in seconds.
+@end multitable
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine, function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{CALL DTIME(VALUES, TIME)}.
+@item @code{TIME = DTIME(VALUES)}, (not recommended).
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{VALUES}@tab The type shall be @code{REAL(4), DIMENSION(2)}.
+@item @var{TIME}@tab The type shall be @code{REAL(4)}.
+@end multitable
+
+@item @emph{Return value}:
+Elapsed time in seconds since the last invocation or since the start of program
+execution if not called before.
+
+@item @emph{Example}:
+@smallexample
+program test_dtime
+    integer(8) :: i, j
+    real, dimension(2) :: tarray
+    real :: result
+    call dtime(tarray, result)
+    print *, result
+    print *, tarray(1)
+    print *, tarray(2)   
+    do i=1,100000000    ! Just a delay
+        j = i * i - i
+    end do
+    call dtime(tarray, result)
+    print *, result
+    print *, tarray(1)
+    print *, tarray(2)
+end program test_dtime
+@end smallexample
+
+@item @emph{See also}:
+@ref{CPU_TIME}
+
+@end table
+
+
+
+@node EOSHIFT
+@section @code{EOSHIFT} --- End-off shift elements of an array
+@fnindex EOSHIFT
+@cindex array, shift
+
+@table @asis
+@item @emph{Description}:
+@code{EOSHIFT(ARRAY, SHIFT[, BOUNDARY, DIM])} performs an end-off shift on
+elements of @var{ARRAY} along the dimension of @var{DIM}.  If @var{DIM} is
+omitted it is taken to be @code{1}.  @var{DIM} is a scalar of type
+@code{INTEGER} in the range of @math{1 \leq DIM \leq n)} where @math{n} is the
+rank of @var{ARRAY}.  If the rank of @var{ARRAY} is one, then all elements of
+@var{ARRAY} are shifted by @var{SHIFT} places.  If rank is greater than one,
+then all complete rank one sections of @var{ARRAY} along the given dimension are
+shifted.  Elements shifted out one end of each rank one section are dropped.  If
+@var{BOUNDARY} is present then the corresponding value of from @var{BOUNDARY}
+is copied back in the other end.  If @var{BOUNDARY} is not present then the
+following are copied in depending on the type of @var{ARRAY}.
+
+@multitable @columnfractions .15 .80
+@item @emph{Array Type} @tab @emph{Boundary Value}
+@item Numeric  @tab 0 of the type and kind of @var{ARRAY}.
+@item Logical  @tab @code{.FALSE.}.
+@item Character(@var{len}) @tab @var{len} blanks.
+@end multitable
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@code{RESULT = EOSHIFT(ARRAY, SHIFT [, BOUNDARY, DIM])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ARRAY}  @tab May be any type, not scalar.
+@item @var{SHIFT}  @tab The type shall be @code{INTEGER}.
+@item @var{BOUNDARY} @tab Same type as @var{ARRAY}. 
+@item @var{DIM}    @tab The type shall be @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+Returns an array of same type and rank as the @var{ARRAY} argument.
+
+@item @emph{Example}:
+@smallexample
+program test_eoshift
+    integer, dimension(3,3) :: a
+    a = reshape( (/ 1, 2, 3, 4, 5, 6, 7, 8, 9 /), (/ 3, 3 /))
+    print '(3i3)', a(1,:)
+    print '(3i3)', a(2,:)
+    print '(3i3)', a(3,:)    
+    a = EOSHIFT(a, SHIFT=(/1, 2, 1/), BOUNDARY=-5, DIM=2)
+    print *
+    print '(3i3)', a(1,:)
+    print '(3i3)', a(2,:)
+    print '(3i3)', a(3,:)
+end program test_eoshift
+@end smallexample
+@end table
+
+
+
+@node EPSILON
+@section @code{EPSILON} --- Epsilon function
+@fnindex EPSILON
+@cindex model representation, epsilon
+
+@table @asis
+@item @emph{Description}:
+@code{EPSILON(X)} returns the smallest number @var{E} of the same kind
+as @var{X} such that @math{1 + E > 1}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{RESULT = EPSILON(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be @code{REAL}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of same type as the argument.
+
+@item @emph{Example}:
+@smallexample
+program test_epsilon
+    real :: x = 3.143
+    real(8) :: y = 2.33
+    print *, EPSILON(x)
+    print *, EPSILON(y)
+end program test_epsilon
+@end smallexample
+@end table
+
+
+
+@node ERF
+@section @code{ERF} --- Error function 
+@fnindex ERF
+@cindex error function
+
+@table @asis
+@item @emph{Description}:
+@code{ERF(X)} computes the error function of @var{X}.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = ERF(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be @code{REAL}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{REAL}, of the same kind as
+@var{X} and lies in the range @math{-1 \leq erf (x) \leq 1 }.
+
+@item @emph{Example}:
+@smallexample
+program test_erf
+  real(8) :: x = 0.17_8
+  x = erf(x)
+end program test_erf
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name            @tab Argument          @tab Return type       @tab Standard
+@item @code{DERF(X)}  @tab @code{REAL(8) X}  @tab @code{REAL(8)}    @tab GNU extension
+@end multitable
+@end table
+
+
+
+@node ERFC
+@section @code{ERFC} --- Error function 
+@fnindex ERFC
+@cindex error function, complementary
+
+@table @asis
+@item @emph{Description}:
+@code{ERFC(X)} computes the complementary error function of @var{X}.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = ERFC(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be @code{REAL}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{REAL} and of the same kind as @var{X}.
+It lies in the range @math{ 0 \leq erfc (x) \leq 2 }.
+
+@item @emph{Example}:
+@smallexample
+program test_erfc
+  real(8) :: x = 0.17_8
+  x = erfc(x)
+end program test_erfc
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name            @tab Argument          @tab Return type       @tab Standard
+@item @code{DERFC(X)} @tab @code{REAL(8) X}  @tab @code{REAL(8)}    @tab GNU extension
+@end multitable
+@end table
+
+
+
+@node ERFC_SCALED
+@section @code{ERFC_SCALED} --- Error function 
+@fnindex ERFC_SCALED
+@cindex error function, complementary, exponentially-scaled
+
+@table @asis
+@item @emph{Description}:
+@code{ERFC_SCALED(X)} computes the exponentially-scaled complementary
+error function of @var{X}.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = ERFC_SCALED(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be @code{REAL}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{REAL} and of the same kind as @var{X}.
+
+@item @emph{Example}:
+@smallexample
+program test_erfc_scaled
+  real(8) :: x = 0.17_8
+  x = erfc_scaled(x)
+end program test_erfc_scaled
+@end smallexample
+@end table
+
+
+
+@node ETIME
+@section @code{ETIME} --- Execution time subroutine (or function)
+@fnindex ETIME
+@cindex time, elapsed
+
+@table @asis
+@item @emph{Description}:
+@code{ETIME(VALUES, TIME)} returns the number of seconds of runtime
+since the start of the process's execution in @var{TIME}.  @var{VALUES}
+returns the user and system components of this time in @code{VALUES(1)} and
+@code{VALUES(2)} respectively. @var{TIME} is equal to @code{VALUES(1) + VALUES(2)}.
+
+On some systems, the underlying timings are represented using types with
+sufficiently small limits that overflows (wrap around) are possible, such as
+32-bit types. Therefore, the values returned by this intrinsic might be, or
+become, negative, or numerically less than previous values, during a single
+run of the compiled program.
+
+This intrinsic is provided in both subroutine and function forms; however,
+only one form can be used in any given program unit.
+
+@var{VALUES} and @var{TIME} are @code{INTENT(OUT)} and provide the following:
+
+@multitable @columnfractions .15 .30 .60
+@item @tab @code{VALUES(1)}: @tab User time in seconds.
+@item @tab @code{VALUES(2)}: @tab System time in seconds.
+@item @tab @code{TIME}: @tab Run time since start in seconds.
+@end multitable
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine, function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{CALL ETIME(VALUES, TIME)}.
+@item @code{TIME = ETIME(VALUES)}, (not recommended).
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{VALUES}@tab The type shall be @code{REAL(4), DIMENSION(2)}.
+@item @var{TIME}@tab The type shall be @code{REAL(4)}.
+@end multitable
+
+@item @emph{Return value}:
+Elapsed time in seconds since the start of program execution.
+
+@item @emph{Example}:
+@smallexample
+program test_etime
+    integer(8) :: i, j
+    real, dimension(2) :: tarray
+    real :: result
+    call ETIME(tarray, result)
+    print *, result
+    print *, tarray(1)
+    print *, tarray(2)   
+    do i=1,100000000    ! Just a delay
+        j = i * i - i
+    end do
+    call ETIME(tarray, result)
+    print *, result
+    print *, tarray(1)
+    print *, tarray(2)
+end program test_etime
+@end smallexample
+
+@item @emph{See also}:
+@ref{CPU_TIME}
+
+@end table
+
+
+
+@node EXECUTE_COMMAND_LINE
+@section @code{EXECUTE_COMMAND_LINE} --- Execute a shell command
+@fnindex EXECUTE_COMMAND_LINE
+@cindex system, system call
+@cindex command line
+
+@table @asis
+@item @emph{Description}:
+@code{EXECUTE_COMMAND_LINE} runs a shell command, synchronously or
+asynchronously.
+
+The @code{COMMAND} argument is passed to the shell and executed, using
+the C library's @code{system} call.  (The shell is @code{sh} on Unix
+systems, and @code{cmd.exe} on Windows.)  If @code{WAIT} is present
+and has the value false, the execution of the command is asynchronous
+if the system supports it; otherwise, the command is executed
+synchronously.
+
+The three last arguments allow the user to get status information.  After
+synchronous execution, @code{EXITSTAT} contains the integer exit code of
+the command, as returned by @code{system}.  @code{CMDSTAT} is set to zero
+if the command line was executed (whatever its exit status was).
+@code{CMDMSG} is assigned an error message if an error has occurred.
+
+Note that the @code{system} function need not be thread-safe. It is
+the responsibility of the user to ensure that @code{system} is not
+called concurrently.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Subroutine
+
+@item @emph{Syntax}:
+@code{CALL EXECUTE_COMMAND_LINE(COMMAND [, WAIT, EXITSTAT, CMDSTAT, CMDMSG ])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{COMMAND} @tab Shall be a default @code{CHARACTER} scalar.
+@item @var{WAIT} @tab (Optional) Shall be a default @code{LOGICAL} scalar.
+@item @var{EXITSTAT} @tab (Optional) Shall be an @code{INTEGER} of the
+default kind.
+@item @var{CMDSTAT} @tab (Optional) Shall be an @code{INTEGER} of the
+default kind.
+@item @var{CMDMSG} @tab (Optional) Shall be an @code{CHARACTER} scalar of the
+default kind.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+program test_exec
+  integer :: i
+
+  call execute_command_line ("external_prog.exe", exitstat=i)
+  print *, "Exit status of external_prog.exe was ", i
+
+  call execute_command_line ("reindex_files.exe", wait=.false.)
+  print *, "Now reindexing files in the background"
+
+end program test_exec
+@end smallexample
+
+
+@item @emph{Note}:
+
+Because this intrinsic is implemented in terms of the @code{system}
+function call, its behavior with respect to signaling is processor
+dependent. In particular, on POSIX-compliant systems, the SIGINT and
+SIGQUIT signals will be ignored, and the SIGCHLD will be blocked. As
+such, if the parent process is terminated, the child process might not be
+terminated alongside.
+
+
+@item @emph{See also}:
+@ref{SYSTEM}
+@end table
+
+
+
+@node EXIT
+@section @code{EXIT} --- Exit the program with status. 
+@fnindex EXIT
+@cindex program termination
+@cindex terminate program
+
+@table @asis
+@item @emph{Description}:
+@code{EXIT} causes immediate termination of the program with status.  If status
+is omitted it returns the canonical @emph{success} for the system.  All Fortran
+I/O units are closed. 
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine
+
+@item @emph{Syntax}:
+@code{CALL EXIT([STATUS])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{STATUS} @tab Shall be an @code{INTEGER} of the default kind.
+@end multitable
+
+@item @emph{Return value}:
+@code{STATUS} is passed to the parent process on exit.
+
+@item @emph{Example}:
+@smallexample
+program test_exit
+  integer :: STATUS = 0
+  print *, 'This program is going to exit.'
+  call EXIT(STATUS)
+end program test_exit
+@end smallexample
+
+@item @emph{See also}:
+@ref{ABORT}, @ref{KILL}
+@end table
+
+
+
+@node EXP
+@section @code{EXP} --- Exponential function 
+@fnindex EXP
+@fnindex DEXP
+@fnindex CEXP
+@fnindex ZEXP
+@fnindex CDEXP
+@cindex exponential function
+@cindex logarithm function, inverse
+
+@table @asis
+@item @emph{Description}:
+@code{EXP(X)} computes the base @math{e} exponential of @var{X}.
+
+@item @emph{Standard}:
+Fortran 77 and later, has overloads that are GNU extensions
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = EXP(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be @code{REAL} or
+@code{COMPLEX}.
+@end multitable
+
+@item @emph{Return value}:
+The return value has same type and kind as @var{X}.
+
+@item @emph{Example}:
+@smallexample
+program test_exp
+  real :: x = 1.0
+  x = exp(x)
+end program test_exp
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name            @tab Argument             @tab Return type         @tab Standard
+@item @code{EXP(X)}   @tab @code{REAL(4) X}     @tab @code{REAL(4)}      @tab Fortran 77 and later
+@item @code{DEXP(X)}  @tab @code{REAL(8) X}     @tab @code{REAL(8)}      @tab Fortran 77 and later
+@item @code{CEXP(X)}  @tab @code{COMPLEX(4) X}  @tab @code{COMPLEX(4)}   @tab Fortran 77 and later
+@item @code{ZEXP(X)}  @tab @code{COMPLEX(8) X}  @tab @code{COMPLEX(8)}   @tab GNU extension
+@item @code{CDEXP(X)} @tab @code{COMPLEX(8) X}  @tab @code{COMPLEX(8)}   @tab GNU extension
+@end multitable
+@end table
+
+
+
+@node EXPONENT
+@section @code{EXPONENT} --- Exponent function 
+@fnindex EXPONENT
+@cindex real number, exponent
+@cindex floating point, exponent
+
+@table @asis
+@item @emph{Description}:
+@code{EXPONENT(X)} returns the value of the exponent part of @var{X}. If @var{X}
+is zero the value returned is zero. 
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = EXPONENT(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be @code{REAL}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type default @code{INTEGER}.
+
+@item @emph{Example}:
+@smallexample
+program test_exponent
+  real :: x = 1.0
+  integer :: i
+  i = exponent(x)
+  print *, i
+  print *, exponent(0.0)
+end program test_exponent
+@end smallexample
+@end table
+
+
+
+@node EXTENDS_TYPE_OF
+@section @code{EXTENDS_TYPE_OF} ---  Query dynamic type for extension
+@fnindex EXTENDS_TYPE_OF
+
+@table @asis
+@item @emph{Description}:
+Query dynamic type for extension.
+
+@item @emph{Standard}:
+Fortran 2003 and later
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{RESULT = EXTENDS_TYPE_OF(A, MOLD)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{A} @tab Shall be an object of extensible declared type or
+unlimited polymorphic. 
+@item @var{MOLD} @tab Shall be an object of extensible declared type or
+unlimited polymorphic. 
+@end multitable
+
+@item @emph{Return value}:
+The return value is a scalar of type default logical. It is true if and only if
+the dynamic type of A is an extension type of the dynamic type of MOLD.
+
+
+@item @emph{See also}:
+@ref{SAME_TYPE_AS}
+@end table
+
+
+
+@node FDATE
+@section @code{FDATE} --- Get the current time as a string
+@fnindex FDATE
+@cindex time, current
+@cindex current time
+@cindex date, current
+@cindex current date
+
+@table @asis
+@item @emph{Description}:
+@code{FDATE(DATE)} returns the current date (using the same format as
+@code{CTIME}) in @var{DATE}. It is equivalent to @code{CALL CTIME(DATE,
+TIME())}.
+
+This intrinsic is provided in both subroutine and function forms; however,
+only one form can be used in any given program unit.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine, function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{CALL FDATE(DATE)}.
+@item @code{DATE = FDATE()}.
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{DATE}@tab The type shall be of type @code{CHARACTER} of the
+default kind. It is an @code{INTENT(OUT)} argument.  If the length of
+this variable is too short for the date and time string to fit
+completely, it will be blank on procedure return.
+@end multitable
+
+@item @emph{Return value}:
+The current date and time as a string.
+
+@item @emph{Example}:
+@smallexample
+program test_fdate
+    integer(8) :: i, j
+    character(len=30) :: date
+    call fdate(date)
+    print *, 'Program started on ', date
+    do i = 1, 100000000 ! Just a delay
+        j = i * i - i
+    end do
+    call fdate(date)
+    print *, 'Program ended on ', date
+end program test_fdate
+@end smallexample
+
+@item @emph{See also}:
+@ref{DATE_AND_TIME}, @ref{CTIME}
+@end table
+
+
+@node FGET
+@section @code{FGET} --- Read a single character in stream mode from stdin 
+@fnindex FGET
+@cindex read character, stream mode
+@cindex stream mode, read character
+@cindex file operation, read character
+
+@table @asis
+@item @emph{Description}:
+Read a single character in stream mode from stdin by bypassing normal 
+formatted output. Stream I/O should not be mixed with normal record-oriented 
+(formatted or unformatted) I/O on the same unit; the results are unpredictable.
+
+This intrinsic is provided in both subroutine and function forms; however,
+only one form can be used in any given program unit.
+
+Note that the @code{FGET} intrinsic is provided for backwards compatibility with 
+@command{g77}.  GNU Fortran provides the Fortran 2003 Stream facility.
+Programmers should consider the use of new stream IO feature in new code 
+for future portability. See also @ref{Fortran 2003 status}.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine, function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{CALL FGET(C [, STATUS])}
+@item @code{STATUS = FGET(C)}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{C}      @tab The type shall be @code{CHARACTER} and of default
+kind.
+@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}.
+Returns 0 on success, -1 on end-of-file, and a system specific positive
+error code otherwise.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_fget
+  INTEGER, PARAMETER :: strlen = 100
+  INTEGER :: status, i = 1
+  CHARACTER(len=strlen) :: str = ""
+
+  WRITE (*,*) 'Enter text:'
+  DO
+    CALL fget(str(i:i), status)
+    if (status /= 0 .OR. i > strlen) exit
+    i = i + 1
+  END DO
+  WRITE (*,*) TRIM(str)
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{FGETC}, @ref{FPUT}, @ref{FPUTC}
+@end table
+
+
+
+@node FGETC
+@section @code{FGETC} --- Read a single character in stream mode
+@fnindex FGETC
+@cindex read character, stream mode
+@cindex stream mode, read character
+@cindex file operation, read character
+
+@table @asis
+@item @emph{Description}:
+Read a single character in stream mode by bypassing normal formatted output. 
+Stream I/O should not be mixed with normal record-oriented (formatted or 
+unformatted) I/O on the same unit; the results are unpredictable.
+
+This intrinsic is provided in both subroutine and function forms; however,
+only one form can be used in any given program unit.
+
+Note that the @code{FGET} intrinsic is provided for backwards compatibility
+with @command{g77}.  GNU Fortran provides the Fortran 2003 Stream facility.
+Programmers should consider the use of new stream IO feature in new code 
+for future portability. See also @ref{Fortran 2003 status}.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine, function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{CALL FGETC(UNIT, C [, STATUS])}
+@item @code{STATUS = FGETC(UNIT, C)}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{UNIT}   @tab The type shall be @code{INTEGER}.
+@item @var{C}      @tab The type shall be @code{CHARACTER} and of default
+kind.
+@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}.
+Returns 0 on success, -1 on end-of-file and a system specific positive
+error code otherwise.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_fgetc
+  INTEGER :: fd = 42, status
+  CHARACTER :: c
+
+  OPEN(UNIT=fd, FILE="/etc/passwd", ACTION="READ", STATUS = "OLD")
+  DO
+    CALL fgetc(fd, c, status)
+    IF (status /= 0) EXIT
+    call fput(c)
+  END DO
+  CLOSE(UNIT=fd)
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{FGET}, @ref{FPUT}, @ref{FPUTC}
+@end table
+
+
+
+@node FLOOR
+@section @code{FLOOR} --- Integer floor function
+@fnindex FLOOR
+@cindex floor
+@cindex rounding, floor
+
+@table @asis
+@item @emph{Description}:
+@code{FLOOR(A)} returns the greatest integer less than or equal to @var{X}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = FLOOR(A [, KIND])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{A} @tab The type shall be @code{REAL}.
+@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
+expression indicating the kind parameter of the result.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER(KIND)} if @var{KIND} is present
+and of default-kind @code{INTEGER} otherwise.
+
+@item @emph{Example}:
+@smallexample
+program test_floor
+    real :: x = 63.29
+    real :: y = -63.59
+    print *, floor(x) ! returns 63
+    print *, floor(y) ! returns -64
+end program test_floor
+@end smallexample
+
+@item @emph{See also}:
+@ref{CEILING}, @ref{NINT}
+
+@end table
+
+
+
+@node FLUSH
+@section @code{FLUSH} --- Flush I/O unit(s)
+@fnindex FLUSH
+@cindex file operation, flush
+
+@table @asis
+@item @emph{Description}:
+Flushes Fortran unit(s) currently open for output. Without the optional
+argument, all units are flushed, otherwise just the unit specified.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine
+
+@item @emph{Syntax}:
+@code{CALL FLUSH(UNIT)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{UNIT} @tab (Optional) The type shall be @code{INTEGER}.
+@end multitable
+
+@item @emph{Note}:
+Beginning with the Fortran 2003 standard, there is a @code{FLUSH}
+statement that should be preferred over the @code{FLUSH} intrinsic.
+
+The @code{FLUSH} intrinsic and the Fortran 2003 @code{FLUSH} statement
+have identical effect: they flush the runtime library's I/O buffer so
+that the data becomes visible to other processes. This does not guarantee
+that the data is committed to disk.
+
+On POSIX systems, you can request that all data is transferred  to  the
+storage device by calling the @code{fsync} function, with the POSIX file
+descriptor of the I/O unit as argument (retrieved with GNU intrinsic
+@code{FNUM}). The following example shows how:
+
+@smallexample
+  ! Declare the interface for POSIX fsync function
+  interface
+    function fsync (fd) bind(c,name="fsync")
+    use iso_c_binding, only: c_int
+      integer(c_int), value :: fd
+      integer(c_int) :: fsync
+    end function fsync
+  end interface
+
+  ! Variable declaration
+  integer :: ret
+
+  ! Opening unit 10
+  open (10,file="foo")
+
+  ! ...
+  ! Perform I/O on unit 10
+  ! ...
+
+  ! Flush and sync
+  flush(10)
+  ret = fsync(fnum(10))
+
+  ! Handle possible error
+  if (ret /= 0) stop "Error calling FSYNC"
+@end smallexample
+
+@end table
+
+
+
+@node FNUM
+@section @code{FNUM} --- File number function
+@fnindex FNUM
+@cindex file operation, file number
+
+@table @asis
+@item @emph{Description}:
+@code{FNUM(UNIT)} returns the POSIX file descriptor number corresponding to the
+open Fortran I/O unit @code{UNIT}.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Function
+
+@item @emph{Syntax}:
+@code{RESULT = FNUM(UNIT)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{UNIT} @tab The type shall be @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER}
+
+@item @emph{Example}:
+@smallexample
+program test_fnum
+  integer :: i
+  open (unit=10, status = "scratch")
+  i = fnum(10)
+  print *, i
+  close (10)
+end program test_fnum
+@end smallexample
+@end table
+
+
+
+@node FPUT
+@section @code{FPUT} --- Write a single character in stream mode to stdout 
+@fnindex FPUT
+@cindex write character, stream mode
+@cindex stream mode, write character
+@cindex file operation, write character
+
+@table @asis
+@item @emph{Description}:
+Write a single character in stream mode to stdout by bypassing normal 
+formatted output. Stream I/O should not be mixed with normal record-oriented 
+(formatted or unformatted) I/O on the same unit; the results are unpredictable.
+
+This intrinsic is provided in both subroutine and function forms; however,
+only one form can be used in any given program unit.
+
+Note that the @code{FGET} intrinsic is provided for backwards compatibility with 
+@command{g77}.  GNU Fortran provides the Fortran 2003 Stream facility.
+Programmers should consider the use of new stream IO feature in new code 
+for future portability. See also @ref{Fortran 2003 status}.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine, function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{CALL FPUT(C [, STATUS])}
+@item @code{STATUS = FPUT(C)}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{C}      @tab The type shall be @code{CHARACTER} and of default
+kind.
+@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}.
+Returns 0 on success, -1 on end-of-file and a system specific positive
+error code otherwise.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_fput
+  CHARACTER(len=10) :: str = "gfortran"
+  INTEGER :: i
+  DO i = 1, len_trim(str)
+    CALL fput(str(i:i))
+  END DO
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{FPUTC}, @ref{FGET}, @ref{FGETC}
+@end table
+
+
+
+@node FPUTC
+@section @code{FPUTC} --- Write a single character in stream mode
+@fnindex FPUTC
+@cindex write character, stream mode
+@cindex stream mode, write character
+@cindex file operation, write character
+
+@table @asis
+@item @emph{Description}:
+Write a single character in stream mode by bypassing normal formatted 
+output. Stream I/O should not be mixed with normal record-oriented 
+(formatted or unformatted) I/O on the same unit; the results are unpredictable.
+
+This intrinsic is provided in both subroutine and function forms; however,
+only one form can be used in any given program unit.
+
+Note that the @code{FGET} intrinsic is provided for backwards compatibility with 
+@command{g77}.  GNU Fortran provides the Fortran 2003 Stream facility.
+Programmers should consider the use of new stream IO feature in new code 
+for future portability. See also @ref{Fortran 2003 status}.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine, function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{CALL FPUTC(UNIT, C [, STATUS])}
+@item @code{STATUS = FPUTC(UNIT, C)}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{UNIT}   @tab The type shall be @code{INTEGER}.
+@item @var{C}      @tab The type shall be @code{CHARACTER} and of default
+kind.
+@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}.
+Returns 0 on success, -1 on end-of-file and a system specific positive
+error code otherwise.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_fputc
+  CHARACTER(len=10) :: str = "gfortran"
+  INTEGER :: fd = 42, i
+
+  OPEN(UNIT = fd, FILE = "out", ACTION = "WRITE", STATUS="NEW")
+  DO i = 1, len_trim(str)
+    CALL fputc(fd, str(i:i))
+  END DO
+  CLOSE(fd)
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{FPUT}, @ref{FGET}, @ref{FGETC}
+@end table
+
+
+
+@node FRACTION
+@section @code{FRACTION} --- Fractional part of the model representation
+@fnindex FRACTION
+@cindex real number, fraction
+@cindex floating point, fraction
+
+@table @asis
+@item @emph{Description}:
+@code{FRACTION(X)} returns the fractional part of the model
+representation of @code{X}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{Y = FRACTION(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type of the argument shall be a @code{REAL}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of the same type and kind as the argument.
+The fractional part of the model representation of @code{X} is returned;
+it is @code{X * RADIX(X)**(-EXPONENT(X))}.
+
+@item @emph{Example}:
+@smallexample
+program test_fraction
+  real :: x
+  x = 178.1387e-4
+  print *, fraction(x), x * radix(x)**(-exponent(x))
+end program test_fraction
+@end smallexample
+
+@end table
+
+
+
+@node FREE
+@section @code{FREE} --- Frees memory
+@fnindex FREE
+@cindex pointer, cray
+
+@table @asis
+@item @emph{Description}:
+Frees memory previously allocated by @code{MALLOC}. The @code{FREE}
+intrinsic is an extension intended to be used with Cray pointers, and is
+provided in GNU Fortran to allow user to compile legacy code. For
+new code using Fortran 95 pointers, the memory de-allocation intrinsic is
+@code{DEALLOCATE}.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine
+
+@item @emph{Syntax}:
+@code{CALL FREE(PTR)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{PTR} @tab The type shall be @code{INTEGER}. It represents the
+location of the memory that should be de-allocated.
+@end multitable
+
+@item @emph{Return value}:
+None
+
+@item @emph{Example}:
+See @code{MALLOC} for an example.
+
+@item @emph{See also}:
+@ref{MALLOC}
+@end table
+
+
+
+@node FSEEK
+@section @code{FSEEK} --- Low level file positioning subroutine
+@fnindex FSEEK
+@cindex file operation, seek
+@cindex file operation, position
+
+@table @asis
+@item @emph{Description}:
+Moves @var{UNIT} to the specified @var{OFFSET}. If @var{WHENCE} 
+is set to 0, the @var{OFFSET} is taken as an absolute value @code{SEEK_SET},
+if set to 1, @var{OFFSET} is taken to be relative to the current position 
+@code{SEEK_CUR}, and if set to 2 relative to the end of the file @code{SEEK_END}.
+On error, @var{STATUS} is set to a nonzero value. If @var{STATUS} the seek 
+fails silently.
+
+This intrinsic routine is not fully backwards compatible with @command{g77}. 
+In @command{g77}, the @code{FSEEK} takes a statement label instead of a 
+@var{STATUS} variable. If FSEEK is used in old code, change
+@smallexample
+  CALL FSEEK(UNIT, OFFSET, WHENCE, *label)
+@end smallexample 
+to
+@smallexample
+  INTEGER :: status
+  CALL FSEEK(UNIT, OFFSET, WHENCE, status)
+  IF (status /= 0) GOTO label
+@end smallexample 
+
+Please note that GNU Fortran provides the Fortran 2003 Stream facility.
+Programmers should consider the use of new stream IO feature in new code 
+for future portability. See also @ref{Fortran 2003 status}.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine
+
+@item @emph{Syntax}:
+@code{CALL FSEEK(UNIT, OFFSET, WHENCE[, STATUS])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{UNIT}   @tab Shall be a scalar of type @code{INTEGER}.
+@item @var{OFFSET} @tab Shall be a scalar of type @code{INTEGER}.
+@item @var{WHENCE} @tab Shall be a scalar of type @code{INTEGER}.
+Its value shall be either 0, 1 or 2.
+@item @var{STATUS} @tab (Optional) shall be a scalar of type 
+@code{INTEGER(4)}.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_fseek
+  INTEGER, PARAMETER :: SEEK_SET = 0, SEEK_CUR = 1, SEEK_END = 2
+  INTEGER :: fd, offset, ierr
+
+  ierr   = 0
+  offset = 5
+  fd     = 10
+
+  OPEN(UNIT=fd, FILE="fseek.test")
+  CALL FSEEK(fd, offset, SEEK_SET, ierr)  ! move to OFFSET
+  print *, FTELL(fd), ierr
+
+  CALL FSEEK(fd, 0, SEEK_END, ierr)       ! move to end
+  print *, FTELL(fd), ierr
+
+  CALL FSEEK(fd, 0, SEEK_SET, ierr)       ! move to beginning
+  print *, FTELL(fd), ierr
+
+  CLOSE(UNIT=fd)
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{FTELL}
+@end table
+
+
+
+@node FSTAT
+@section @code{FSTAT} --- Get file status
+@fnindex FSTAT
+@cindex file system, file status
+
+@table @asis
+@item @emph{Description}:
+@code{FSTAT} is identical to @ref{STAT}, except that information about an 
+already opened file is obtained.
+
+The elements in @code{VALUES} are the same as described by @ref{STAT}.
+
+This intrinsic is provided in both subroutine and function forms; however,
+only one form can be used in any given program unit.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine, function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{CALL FSTAT(UNIT, VALUES [, STATUS])}
+@item @code{STATUS = FSTAT(UNIT, VALUES)}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{UNIT}   @tab An open I/O unit number of type @code{INTEGER}.
+@item @var{VALUES} @tab The type shall be @code{INTEGER(4), DIMENSION(13)}.
+@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER(4)}. Returns 0 
+on success and a system specific error code otherwise.
+@end multitable
+
+@item @emph{Example}:
+See @ref{STAT} for an example.
+
+@item @emph{See also}:
+To stat a link: @ref{LSTAT}, to stat a file: @ref{STAT}
+@end table
+
+
+
+@node FTELL
+@section @code{FTELL} --- Current stream position
+@fnindex FTELL
+@cindex file operation, position
+
+@table @asis
+@item @emph{Description}:
+Retrieves the current position within an open file.
+
+This intrinsic is provided in both subroutine and function forms; however,
+only one form can be used in any given program unit.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine, function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{CALL FTELL(UNIT, OFFSET)}
+@item @code{OFFSET = FTELL(UNIT)}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{OFFSET}  @tab Shall of type @code{INTEGER}.
+@item @var{UNIT}    @tab Shall of type @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+In either syntax, @var{OFFSET} is set to the current offset of unit
+number @var{UNIT}, or to @math{-1} if the unit is not currently open.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_ftell
+  INTEGER :: i
+  OPEN(10, FILE="temp.dat")
+  CALL ftell(10,i)
+  WRITE(*,*) i
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{FSEEK}
+@end table
+
+
+
+@node GAMMA
+@section @code{GAMMA} --- Gamma function
+@fnindex GAMMA
+@fnindex DGAMMA
+@cindex Gamma function
+@cindex Factorial function
+
+@table @asis
+@item @emph{Description}:
+@code{GAMMA(X)} computes Gamma (@math{\Gamma}) of @var{X}. For positive,
+integer values of @var{X} the Gamma function simplifies to the factorial
+function @math{\Gamma(x)=(x-1)!}.
+
+@tex
+$$
+\Gamma(x) = \int_0^\infty t^{x-1}{\rm e}^{-t}\,{\rm d}t
+$$
+@end tex
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{X = GAMMA(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab Shall be of type @code{REAL} and neither zero
+nor a negative integer.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{REAL} of the same kind as @var{X}.
+
+@item @emph{Example}:
+@smallexample
+program test_gamma
+  real :: x = 1.0
+  x = gamma(x) ! returns 1.0
+end program test_gamma
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name             @tab Argument         @tab Return type       @tab Standard
+@item @code{GAMMA(X)}  @tab @code{REAL(4) X} @tab @code{REAL(4)}    @tab GNU Extension
+@item @code{DGAMMA(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)}    @tab GNU Extension
+@end multitable
+
+@item @emph{See also}:
+Logarithm of the Gamma function: @ref{LOG_GAMMA}
+
+@end table
+
+
+
+@node GERROR
+@section @code{GERROR} --- Get last system error message
+@fnindex GERROR
+@cindex system, error handling
+
+@table @asis
+@item @emph{Description}:
+Returns the system error message corresponding to the last system error.
+This resembles the functionality of @code{strerror(3)} in C.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine
+
+@item @emph{Syntax}:
+@code{CALL GERROR(RESULT)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{RESULT}  @tab Shall of type @code{CHARACTER} and of default
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_gerror
+  CHARACTER(len=100) :: msg
+  CALL gerror(msg)
+  WRITE(*,*) msg
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{IERRNO}, @ref{PERROR}
+@end table
+
+
+
+@node GETARG
+@section @code{GETARG} --- Get command line arguments
+@fnindex GETARG
+@cindex command-line arguments
+@cindex arguments, to program
+
+@table @asis
+@item @emph{Description}:
+Retrieve the @var{POS}-th argument that was passed on the
+command line when the containing program was invoked.
+
+This intrinsic routine is provided for backwards compatibility with 
+GNU Fortran 77.  In new code, programmers should consider the use of 
+the @ref{GET_COMMAND_ARGUMENT} intrinsic defined by the Fortran 2003 
+standard.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine
+
+@item @emph{Syntax}:
+@code{CALL GETARG(POS, VALUE)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{POS}   @tab Shall be of type @code{INTEGER} and not wider than
+the default integer kind; @math{@var{POS} \geq 0}
+@item @var{VALUE} @tab Shall be of type @code{CHARACTER} and of default
+kind.
+@item @var{VALUE} @tab Shall be of type @code{CHARACTER}. 
+@end multitable
+
+@item @emph{Return value}:
+After @code{GETARG} returns, the @var{VALUE} argument holds the
+@var{POS}th command line argument. If @var{VALUE} can not hold the
+argument, it is truncated to fit the length of @var{VALUE}. If there are
+less than @var{POS} arguments specified at the command line, @var{VALUE}
+will be filled with blanks. If @math{@var{POS} = 0}, @var{VALUE} is set
+to the name of the program (on systems that support this feature).
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_getarg
+  INTEGER :: i
+  CHARACTER(len=32) :: arg
+
+  DO i = 1, iargc()
+    CALL getarg(i, arg)
+    WRITE (*,*) arg
+  END DO
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+GNU Fortran 77 compatibility function: @ref{IARGC}
+
+Fortran 2003 functions and subroutines: @ref{GET_COMMAND},
+@ref{GET_COMMAND_ARGUMENT}, @ref{COMMAND_ARGUMENT_COUNT}
+@end table
+
+
+
+@node GET_COMMAND
+@section @code{GET_COMMAND} --- Get the entire command line
+@fnindex GET_COMMAND
+@cindex command-line arguments
+@cindex arguments, to program
+
+@table @asis
+@item @emph{Description}:
+Retrieve the entire command line that was used to invoke the program.
+
+@item @emph{Standard}:
+Fortran 2003 and later
+
+@item @emph{Class}:
+Subroutine
+
+@item @emph{Syntax}:
+@code{CALL GET_COMMAND([COMMAND, LENGTH, STATUS])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{COMMAND} @tab (Optional) shall be of type @code{CHARACTER} and
+of default kind.
+@item @var{LENGTH} @tab (Optional) Shall be of type @code{INTEGER} and of
+default kind.
+@item @var{STATUS} @tab (Optional) Shall be of type @code{INTEGER} and of
+default kind.
+@end multitable
+
+@item @emph{Return value}:
+If @var{COMMAND} is present, stores the entire command line that was used
+to invoke the program in @var{COMMAND}. If @var{LENGTH} is present, it is
+assigned the length of the command line. If @var{STATUS} is present, it
+is assigned 0 upon success of the command, -1 if @var{COMMAND} is too
+short to store the command line, or a positive value in case of an error.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_get_command
+  CHARACTER(len=255) :: cmd
+  CALL get_command(cmd)
+  WRITE (*,*) TRIM(cmd)
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{GET_COMMAND_ARGUMENT}, @ref{COMMAND_ARGUMENT_COUNT}
+@end table
+
+
+
+@node GET_COMMAND_ARGUMENT
+@section @code{GET_COMMAND_ARGUMENT} --- Get command line arguments
+@fnindex GET_COMMAND_ARGUMENT
+@cindex command-line arguments
+@cindex arguments, to program
+
+@table @asis
+@item @emph{Description}:
+Retrieve the @var{NUMBER}-th argument that was passed on the
+command line when the containing program was invoked.
+
+@item @emph{Standard}:
+Fortran 2003 and later
+
+@item @emph{Class}:
+Subroutine
+
+@item @emph{Syntax}:
+@code{CALL GET_COMMAND_ARGUMENT(NUMBER [, VALUE, LENGTH, STATUS])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{NUMBER} @tab Shall be a scalar of type @code{INTEGER} and of
+default kind, @math{@var{NUMBER} \geq 0}
+@item @var{VALUE}  @tab (Optional) Shall be a scalar of type @code{CHARACTER}
+and of default kind.
+@item @var{LENGTH} @tab (Optional) Shall be a scalar of type @code{INTEGER}
+and of default kind.
+@item @var{STATUS} @tab (Optional) Shall be a scalar of type @code{INTEGER}
+and of default kind.
+@end multitable
+
+@item @emph{Return value}:
+After @code{GET_COMMAND_ARGUMENT} returns, the @var{VALUE} argument holds the 
+@var{NUMBER}-th command line argument. If @var{VALUE} can not hold the argument, it is 
+truncated to fit the length of @var{VALUE}. If there are less than @var{NUMBER}
+arguments specified at the command line, @var{VALUE} will be filled with blanks. 
+If @math{@var{NUMBER} = 0}, @var{VALUE} is set to the name of the program (on
+systems that support this feature). The @var{LENGTH} argument contains the
+length of the @var{NUMBER}-th command line argument. If the argument retrieval
+fails, @var{STATUS} is a positive number; if @var{VALUE} contains a truncated
+command line argument, @var{STATUS} is -1; and otherwise the @var{STATUS} is
+zero.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_get_command_argument
+  INTEGER :: i
+  CHARACTER(len=32) :: arg
+
+  i = 0
+  DO
+    CALL get_command_argument(i, arg)
+    IF (LEN_TRIM(arg) == 0) EXIT
+
+    WRITE (*,*) TRIM(arg)
+    i = i+1
+  END DO
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{GET_COMMAND}, @ref{COMMAND_ARGUMENT_COUNT}
+@end table
+
+
+
+@node GETCWD
+@section @code{GETCWD} --- Get current working directory
+@fnindex GETCWD
+@cindex system, working directory
+
+@table @asis
+@item @emph{Description}:
+Get current working directory.
+
+This intrinsic is provided in both subroutine and function forms; however,
+only one form can be used in any given program unit.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine, function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{CALL GETCWD(C [, STATUS])}
+@item @code{STATUS = GETCWD(C)}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{C} @tab The type shall be @code{CHARACTER} and of default kind.
+@item @var{STATUS} @tab (Optional) status flag. Returns 0 on success, 
+a system specific and nonzero error code otherwise.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_getcwd
+  CHARACTER(len=255) :: cwd
+  CALL getcwd(cwd)
+  WRITE(*,*) TRIM(cwd)
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{CHDIR}
+@end table
+
+
+
+@node GETENV
+@section @code{GETENV} --- Get an environmental variable
+@fnindex GETENV
+@cindex environment variable
+
+@table @asis
+@item @emph{Description}:
+Get the @var{VALUE} of the environmental variable @var{NAME}.
+
+This intrinsic routine is provided for backwards compatibility with
+GNU Fortran 77.  In new code, programmers should consider the use of
+the @ref{GET_ENVIRONMENT_VARIABLE} intrinsic defined by the Fortran
+2003 standard.
+
+Note that @code{GETENV} need not be thread-safe. It is the
+responsibility of the user to ensure that the environment is not being
+updated concurrently with a call to the @code{GETENV} intrinsic.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine
+
+@item @emph{Syntax}:
+@code{CALL GETENV(NAME, VALUE)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{NAME}  @tab Shall be of type @code{CHARACTER} and of default kind.
+@item @var{VALUE} @tab Shall be of type @code{CHARACTER} and of default kind.
+@end multitable
+
+@item @emph{Return value}:
+Stores the value of @var{NAME} in @var{VALUE}. If @var{VALUE} is 
+not large enough to hold the data, it is truncated. If @var{NAME}
+is not set, @var{VALUE} will be filled with blanks.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_getenv
+  CHARACTER(len=255) :: homedir
+  CALL getenv("HOME", homedir)
+  WRITE (*,*) TRIM(homedir)
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{GET_ENVIRONMENT_VARIABLE}
+@end table
+
+
+
+@node GET_ENVIRONMENT_VARIABLE
+@section @code{GET_ENVIRONMENT_VARIABLE} --- Get an environmental variable
+@fnindex GET_ENVIRONMENT_VARIABLE
+@cindex environment variable
+
+@table @asis
+@item @emph{Description}:
+Get the @var{VALUE} of the environmental variable @var{NAME}.
+
+Note that @code{GET_ENVIRONMENT_VARIABLE} need not be thread-safe. It
+is the responsibility of the user to ensure that the environment is
+not being updated concurrently with a call to the
+@code{GET_ENVIRONMENT_VARIABLE} intrinsic.
+
+@item @emph{Standard}:
+Fortran 2003 and later
+
+@item @emph{Class}:
+Subroutine
+
+@item @emph{Syntax}:
+@code{CALL GET_ENVIRONMENT_VARIABLE(NAME[, VALUE, LENGTH, STATUS, TRIM_NAME)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{NAME}      @tab Shall be a scalar of type @code{CHARACTER}
+and of default kind.
+@item @var{VALUE}     @tab (Optional) Shall be a scalar of type @code{CHARACTER}
+and of default kind.
+@item @var{LENGTH}    @tab (Optional) Shall be a scalar of type @code{INTEGER}
+and of default kind.
+@item @var{STATUS}    @tab (Optional) Shall be a scalar of type @code{INTEGER}
+and of default kind.
+@item @var{TRIM_NAME} @tab (Optional) Shall be a scalar of type @code{LOGICAL}
+and of default kind.
+@end multitable
+
+@item @emph{Return value}:
+Stores the value of @var{NAME} in @var{VALUE}. If @var{VALUE} is 
+not large enough to hold the data, it is truncated. If @var{NAME}
+is not set, @var{VALUE} will be filled with blanks. Argument @var{LENGTH}
+contains the length needed for storing the environment variable @var{NAME}
+or zero if it is not present. @var{STATUS} is -1 if @var{VALUE} is present
+but too short for the environment variable; it is 1 if the environment
+variable does not exist and 2 if the processor does not support environment
+variables; in all other cases @var{STATUS} is zero. If @var{TRIM_NAME} is
+present with the value @code{.FALSE.}, the trailing blanks in @var{NAME}
+are significant; otherwise they are not part of the environment variable
+name.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_getenv
+  CHARACTER(len=255) :: homedir
+  CALL get_environment_variable("HOME", homedir)
+  WRITE (*,*) TRIM(homedir)
+END PROGRAM
+@end smallexample
+@end table
+
+
+
+@node GETGID
+@section @code{GETGID} --- Group ID function
+@fnindex GETGID
+@cindex system, group ID
+
+@table @asis
+@item @emph{Description}:
+Returns the numerical group ID of the current process.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Function
+
+@item @emph{Syntax}:
+@code{RESULT = GETGID()}
+
+@item @emph{Return value}:
+The return value of @code{GETGID} is an @code{INTEGER} of the default
+kind.
+
+
+@item @emph{Example}:
+See @code{GETPID} for an example.
+
+@item @emph{See also}:
+@ref{GETPID}, @ref{GETUID}
+@end table
+
+
+
+@node GETLOG
+@section @code{GETLOG} --- Get login name
+@fnindex GETLOG
+@cindex system, login name
+@cindex login name
+
+@table @asis
+@item @emph{Description}:
+Gets the username under which the program is running.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine
+
+@item @emph{Syntax}:
+@code{CALL GETLOG(C)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{C} @tab Shall be of type @code{CHARACTER} and of default kind.
+@end multitable
+
+@item @emph{Return value}:
+Stores the current user name in @var{LOGIN}.  (On systems where POSIX
+functions @code{geteuid} and @code{getpwuid} are not available, and 
+the @code{getlogin} function is not implemented either, this will
+return a blank string.)
+
+@item @emph{Example}:
+@smallexample
+PROGRAM TEST_GETLOG
+  CHARACTER(32) :: login
+  CALL GETLOG(login)
+  WRITE(*,*) login
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{GETUID}
+@end table
+
+
+
+@node GETPID
+@section @code{GETPID} --- Process ID function
+@fnindex GETPID
+@cindex system, process ID
+@cindex process ID
+
+@table @asis
+@item @emph{Description}:
+Returns the numerical process identifier of the current process.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Function
+
+@item @emph{Syntax}:
+@code{RESULT = GETPID()}
+
+@item @emph{Return value}:
+The return value of @code{GETPID} is an @code{INTEGER} of the default
+kind.
+
+
+@item @emph{Example}:
+@smallexample
+program info
+  print *, "The current process ID is ", getpid()
+  print *, "Your numerical user ID is ", getuid()
+  print *, "Your numerical group ID is ", getgid()
+end program info
+@end smallexample
+
+@item @emph{See also}:
+@ref{GETGID}, @ref{GETUID}
+@end table
+
+
+
+@node GETUID
+@section @code{GETUID} --- User ID function
+@fnindex GETUID
+@cindex system, user ID
+@cindex user id
+
+@table @asis
+@item @emph{Description}:
+Returns the numerical user ID of the current process.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Function
+
+@item @emph{Syntax}:
+@code{RESULT = GETUID()}
+
+@item @emph{Return value}:
+The return value of @code{GETUID} is an @code{INTEGER} of the default
+kind.
+
+
+@item @emph{Example}:
+See @code{GETPID} for an example.
+
+@item @emph{See also}:
+@ref{GETPID}, @ref{GETLOG}
+@end table
+
+
+
+@node GMTIME
+@section @code{GMTIME} --- Convert time to GMT info
+@fnindex GMTIME
+@cindex time, conversion to GMT info
+
+@table @asis
+@item @emph{Description}:
+Given a system time value @var{TIME} (as provided by the @code{TIME8}
+intrinsic), fills @var{VALUES} with values extracted from it appropriate
+to the UTC time zone (Universal Coordinated Time, also known in some
+countries as GMT, Greenwich Mean Time), using @code{gmtime(3)}.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine
+
+@item @emph{Syntax}:
+@code{CALL GMTIME(TIME, VALUES)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{TIME}   @tab An @code{INTEGER} scalar expression
+corresponding to a system time, with @code{INTENT(IN)}.
+@item @var{VALUES} @tab A default @code{INTEGER} array with 9 elements,
+with @code{INTENT(OUT)}.
+@end multitable
+
+@item @emph{Return value}:
+The elements of @var{VALUES} are assigned as follows:
+@enumerate
+@item Seconds after the minute, range 0--59 or 0--61 to allow for leap
+seconds
+@item Minutes after the hour, range 0--59
+@item Hours past midnight, range 0--23
+@item Day of month, range 0--31
+@item Number of months since January, range 0--12
+@item Years since 1900
+@item Number of days since Sunday, range 0--6
+@item Days since January 1
+@item Daylight savings indicator: positive if daylight savings is in
+effect, zero if not, and negative if the information is not available.
+@end enumerate
+
+@item @emph{See also}:
+@ref{CTIME}, @ref{LTIME}, @ref{TIME}, @ref{TIME8}
+
+@end table
+
+
+
+@node HOSTNM
+@section @code{HOSTNM} --- Get system host name
+@fnindex HOSTNM
+@cindex system, host name
+
+@table @asis
+@item @emph{Description}:
+Retrieves the host name of the system on which the program is running.
+
+This intrinsic is provided in both subroutine and function forms; however,
+only one form can be used in any given program unit.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine, function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{CALL HOSTNM(C [, STATUS])}
+@item @code{STATUS = HOSTNM(NAME)}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{C}    @tab Shall of type @code{CHARACTER} and of default kind.
+@item @var{STATUS}  @tab (Optional) status flag of type @code{INTEGER}.
+Returns 0 on success, or a system specific error code otherwise.
+@end multitable
+
+@item @emph{Return value}:
+In either syntax, @var{NAME} is set to the current hostname if it can
+be obtained, or to a blank string otherwise.
+
+@end table
+
+
+
+@node HUGE
+@section @code{HUGE} --- Largest number of a kind
+@fnindex HUGE
+@cindex limits, largest number
+@cindex model representation, largest number
+
+@table @asis
+@item @emph{Description}:
+@code{HUGE(X)} returns the largest number that is not an infinity in
+the model of the type of @code{X}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{RESULT = HUGE(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab Shall be of type @code{REAL} or @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of the same type and kind as @var{X}
+
+@item @emph{Example}:
+@smallexample
+program test_huge_tiny
+  print *, huge(0), huge(0.0), huge(0.0d0)
+  print *, tiny(0.0), tiny(0.0d0)
+end program test_huge_tiny
+@end smallexample
+@end table
+
+
+
+@node HYPOT
+@section @code{HYPOT} --- Euclidean distance function
+@fnindex HYPOT
+@cindex Euclidean distance
+
+@table @asis
+@item @emph{Description}:
+@code{HYPOT(X,Y)} is the Euclidean distance function. It is equal to
+@math{\sqrt{X^2 + Y^2}}, without undue underflow or overflow.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = HYPOT(X, Y)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be @code{REAL}.
+@item @var{Y} @tab The type and kind type parameter shall be the same as
+@var{X}.
+@end multitable
+
+@item @emph{Return value}:
+The return value has the same type and kind type parameter as @var{X}.
+
+@item @emph{Example}:
+@smallexample
+program test_hypot
+  real(4) :: x = 1.e0_4, y = 0.5e0_4
+  x = hypot(x,y)
+end program test_hypot
+@end smallexample
+@end table
+
+
+
+@node IACHAR
+@section @code{IACHAR} --- Code in @acronym{ASCII} collating sequence 
+@fnindex IACHAR
+@cindex @acronym{ASCII} collating sequence
+@cindex collating sequence, @acronym{ASCII}
+@cindex conversion, to integer
+
+@table @asis
+@item @emph{Description}:
+@code{IACHAR(C)} returns the code for the @acronym{ASCII} character
+in the first character position of @code{C}.
+
+@item @emph{Standard}:
+Fortran 95 and later, with @var{KIND} argument Fortran 2003 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = IACHAR(C [, KIND])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{C}    @tab Shall be a scalar @code{CHARACTER}, with @code{INTENT(IN)}
+@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
+expression indicating the kind parameter of the result.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of kind @var{KIND}. If
+@var{KIND} is absent, the return value is of default integer kind.
+
+@item @emph{Example}:
+@smallexample
+program test_iachar
+  integer i
+  i = iachar(' ')
+end program test_iachar
+@end smallexample
+
+@item @emph{Note}:
+See @ref{ICHAR} for a discussion of converting between numerical values
+and formatted string representations.
+
+@item @emph{See also}:
+@ref{ACHAR}, @ref{CHAR}, @ref{ICHAR}
+
+@end table
+
+
+
+@node IALL
+@section @code{IALL} --- Bitwise AND of array elements
+@fnindex IALL
+@cindex array, AND
+@cindex bits, AND of array elements
+
+@table @asis
+@item @emph{Description}:
+Reduces with bitwise AND the elements of @var{ARRAY} along dimension @var{DIM}
+if the corresponding element in @var{MASK} is @code{TRUE}.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{RESULT = IALL(ARRAY[, MASK])}
+@item @code{RESULT = IALL(ARRAY, DIM[, MASK])}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ARRAY} @tab Shall be an array of type @code{INTEGER}
+@item @var{DIM}   @tab (Optional) shall be a scalar of type 
+@code{INTEGER} with a value in the range from 1 to n, where n 
+equals the rank of @var{ARRAY}.
+@item @var{MASK}  @tab (Optional) shall be of type @code{LOGICAL} 
+and either be a scalar or an array of the same shape as @var{ARRAY}.
+@end multitable
+
+@item @emph{Return value}:
+The result is of the same type as @var{ARRAY}.
+
+If @var{DIM} is absent, a scalar with the bitwise ALL of all elements in
+@var{ARRAY} is returned. Otherwise, an array of rank n-1, where n equals
+the rank of @var{ARRAY}, and a shape similar to that of @var{ARRAY} with
+dimension @var{DIM} dropped is returned.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_iall
+  INTEGER(1) :: a(2)
+
+  a(1) = b'00100100'
+  a(2) = b'01101010'
+
+  ! prints 00100000
+  PRINT '(b8.8)', IALL(a)
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{IANY}, @ref{IPARITY}, @ref{IAND}
+@end table
+
+
+
+@node IAND
+@section @code{IAND} --- Bitwise logical and
+@fnindex IAND
+@cindex bitwise logical and
+@cindex logical and, bitwise
+
+@table @asis
+@item @emph{Description}:
+Bitwise logical @code{AND}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = IAND(I, J)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab The type shall be @code{INTEGER}.
+@item @var{J} @tab The type shall be @code{INTEGER}, of the same
+kind as @var{I}.  (As a GNU extension, different kinds are also 
+permitted.)
+@end multitable
+
+@item @emph{Return value}:
+The return type is @code{INTEGER}, of the same kind as the
+arguments.  (If the argument kinds differ, it is of the same kind as
+the larger argument.)
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_iand
+  INTEGER :: a, b
+  DATA a / Z'F' /, b / Z'3' /
+  WRITE (*,*) IAND(a, b)
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{IOR}, @ref{IEOR}, @ref{IBITS}, @ref{IBSET}, @ref{IBCLR}, @ref{NOT}
+
+@end table
+
+
+
+@node IANY
+@section @code{IANY} --- Bitwise OR of array elements
+@fnindex IANY
+@cindex array, OR
+@cindex bits, OR of array elements
+
+@table @asis
+@item @emph{Description}:
+Reduces with bitwise OR (inclusive or) the elements of @var{ARRAY} along
+dimension @var{DIM} if the corresponding element in @var{MASK} is @code{TRUE}.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{RESULT = IANY(ARRAY[, MASK])}
+@item @code{RESULT = IANY(ARRAY, DIM[, MASK])}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ARRAY} @tab Shall be an array of type @code{INTEGER}
+@item @var{DIM}   @tab (Optional) shall be a scalar of type 
+@code{INTEGER} with a value in the range from 1 to n, where n 
+equals the rank of @var{ARRAY}.
+@item @var{MASK}  @tab (Optional) shall be of type @code{LOGICAL} 
+and either be a scalar or an array of the same shape as @var{ARRAY}.
+@end multitable
+
+@item @emph{Return value}:
+The result is of the same type as @var{ARRAY}.
+
+If @var{DIM} is absent, a scalar with the bitwise OR of all elements in
+@var{ARRAY} is returned. Otherwise, an array of rank n-1, where n equals
+the rank of @var{ARRAY}, and a shape similar to that of @var{ARRAY} with
+dimension @var{DIM} dropped is returned.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_iany
+  INTEGER(1) :: a(2)
+
+  a(1) = b'00100100'
+  a(2) = b'01101010'
+
+  ! prints 01101110
+  PRINT '(b8.8)', IANY(a)
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{IPARITY}, @ref{IALL}, @ref{IOR}
+@end table
+
+
+
+@node IARGC
+@section @code{IARGC} --- Get the number of command line arguments
+@fnindex IARGC
+@cindex command-line arguments
+@cindex command-line arguments, number of
+@cindex arguments, to program
+
+@table @asis
+@item @emph{Description}:
+@code{IARGC} returns the number of arguments passed on the
+command line when the containing program was invoked.
+
+This intrinsic routine is provided for backwards compatibility with 
+GNU Fortran 77.  In new code, programmers should consider the use of 
+the @ref{COMMAND_ARGUMENT_COUNT} intrinsic defined by the Fortran 2003 
+standard.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Function
+
+@item @emph{Syntax}:
+@code{RESULT = IARGC()}
+
+@item @emph{Arguments}:
+None.
+
+@item @emph{Return value}:
+The number of command line arguments, type @code{INTEGER(4)}.
+
+@item @emph{Example}:
+See @ref{GETARG}
+
+@item @emph{See also}:
+GNU Fortran 77 compatibility subroutine: @ref{GETARG}
+
+Fortran 2003 functions and subroutines: @ref{GET_COMMAND},
+@ref{GET_COMMAND_ARGUMENT}, @ref{COMMAND_ARGUMENT_COUNT}
+@end table
+
+
+
+@node IBCLR
+@section @code{IBCLR} --- Clear bit
+@fnindex IBCLR
+@cindex bits, unset
+@cindex bits, clear
+
+@table @asis
+@item @emph{Description}:
+@code{IBCLR} returns the value of @var{I} with the bit at position
+@var{POS} set to zero.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = IBCLR(I, POS)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab The type shall be @code{INTEGER}.
+@item @var{POS} @tab The type shall be @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of the same kind as
+@var{I}.
+
+@item @emph{See also}:
+@ref{IBITS}, @ref{IBSET}, @ref{IAND}, @ref{IOR}, @ref{IEOR}, @ref{MVBITS}
+
+@end table
+
+
+
+@node IBITS
+@section @code{IBITS} --- Bit extraction
+@fnindex IBITS
+@cindex bits, get
+@cindex bits, extract
+
+@table @asis
+@item @emph{Description}:
+@code{IBITS} extracts a field of length @var{LEN} from @var{I},
+starting from bit position @var{POS} and extending left for @var{LEN}
+bits.  The result is right-justified and the remaining bits are
+zeroed.  The value of @code{POS+LEN} must be less than or equal to the
+value @code{BIT_SIZE(I)}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = IBITS(I, POS, LEN)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I}   @tab The type shall be @code{INTEGER}.
+@item @var{POS} @tab The type shall be @code{INTEGER}.
+@item @var{LEN} @tab The type shall be @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of the same kind as
+@var{I}.
+
+@item @emph{See also}:
+@ref{BIT_SIZE}, @ref{IBCLR}, @ref{IBSET}, @ref{IAND}, @ref{IOR}, @ref{IEOR}
+@end table
+
+
+
+@node IBSET
+@section @code{IBSET} --- Set bit
+@fnindex IBSET
+@cindex bits, set
+
+@table @asis
+@item @emph{Description}:
+@code{IBSET} returns the value of @var{I} with the bit at position
+@var{POS} set to one.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = IBSET(I, POS)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab The type shall be @code{INTEGER}.
+@item @var{POS} @tab The type shall be @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of the same kind as
+@var{I}.
+
+@item @emph{See also}:
+@ref{IBCLR}, @ref{IBITS}, @ref{IAND}, @ref{IOR}, @ref{IEOR}, @ref{MVBITS}
+
+@end table
+
+
+
+@node ICHAR
+@section @code{ICHAR} --- Character-to-integer conversion function
+@fnindex ICHAR
+@cindex conversion, to integer
+
+@table @asis
+@item @emph{Description}:
+@code{ICHAR(C)} returns the code for the character in the first character
+position of @code{C} in the system's native character set.
+The correspondence between characters and their codes is not necessarily
+the same across different GNU Fortran implementations.
+
+@item @emph{Standard}:
+Fortran 95 and later, with @var{KIND} argument Fortran 2003 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = ICHAR(C [, KIND])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{C}    @tab Shall be a scalar @code{CHARACTER}, with @code{INTENT(IN)}
+@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
+expression indicating the kind parameter of the result.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of kind @var{KIND}. If
+@var{KIND} is absent, the return value is of default integer kind.
+
+@item @emph{Example}:
+@smallexample
+program test_ichar
+  integer i
+  i = ichar(' ')
+end program test_ichar
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name             @tab Argument             @tab Return type       @tab Standard
+@item @code{ICHAR(C)}  @tab @code{CHARACTER C}   @tab @code{INTEGER(4)}    @tab Fortran 77 and later
+@end multitable
+
+@item @emph{Note}:
+No intrinsic exists to convert between a numeric value and a formatted
+character string representation -- for instance, given the
+@code{CHARACTER} value @code{'154'}, obtaining an @code{INTEGER} or
+@code{REAL} value with the value 154, or vice versa. Instead, this
+functionality is provided by internal-file I/O, as in the following
+example:
+@smallexample
+program read_val
+  integer value
+  character(len=10) string, string2
+  string = '154'
+  
+  ! Convert a string to a numeric value
+  read (string,'(I10)') value
+  print *, value
+  
+  ! Convert a value to a formatted string
+  write (string2,'(I10)') value
+  print *, string2
+end program read_val
+@end smallexample
+
+@item @emph{See also}:
+@ref{ACHAR}, @ref{CHAR}, @ref{IACHAR}
+
+@end table
+
+
+
+@node IDATE
+@section @code{IDATE} --- Get current local time subroutine (day/month/year) 
+@fnindex IDATE
+@cindex date, current
+@cindex current date
+
+@table @asis
+@item @emph{Description}:
+@code{IDATE(VALUES)} Fills @var{VALUES} with the numerical values at the  
+current local time. The day (in the range 1-31), month (in the range 1-12), 
+and year appear in elements 1, 2, and 3 of @var{VALUES}, respectively. 
+The year has four significant digits.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine
+
+@item @emph{Syntax}:
+@code{CALL IDATE(VALUES)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{VALUES} @tab The type shall be @code{INTEGER, DIMENSION(3)} and
+the kind shall be the default integer kind.
+@end multitable
+
+@item @emph{Return value}:
+Does not return anything.
+
+@item @emph{Example}:
+@smallexample
+program test_idate
+  integer, dimension(3) :: tarray
+  call idate(tarray)
+  print *, tarray(1)
+  print *, tarray(2)
+  print *, tarray(3)
+end program test_idate
+@end smallexample
+@end table
+
+
+
+@node IEOR
+@section @code{IEOR} --- Bitwise logical exclusive or
+@fnindex IEOR
+@cindex bitwise logical exclusive or
+@cindex logical exclusive or, bitwise
+
+@table @asis
+@item @emph{Description}:
+@code{IEOR} returns the bitwise Boolean exclusive-OR of @var{I} and
+@var{J}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = IEOR(I, J)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab The type shall be @code{INTEGER}.
+@item @var{J} @tab The type shall be @code{INTEGER}, of the same
+kind as @var{I}.  (As a GNU extension, different kinds are also 
+permitted.)
+@end multitable
+
+@item @emph{Return value}:
+The return type is @code{INTEGER}, of the same kind as the
+arguments.  (If the argument kinds differ, it is of the same kind as
+the larger argument.)
+
+@item @emph{See also}:
+@ref{IOR}, @ref{IAND}, @ref{IBITS}, @ref{IBSET}, @ref{IBCLR}, @ref{NOT}
+@end table
+
+
+
+@node IERRNO
+@section @code{IERRNO} --- Get the last system error number
+@fnindex IERRNO
+@cindex system, error handling
+
+@table @asis
+@item @emph{Description}:
+Returns the last system error number, as given by the C @code{errno}
+variable.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Function
+
+@item @emph{Syntax}:
+@code{RESULT = IERRNO()}
+
+@item @emph{Arguments}:
+None.
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of the default integer
+kind.
+
+@item @emph{See also}:
+@ref{PERROR}
+@end table
+
+
+
+@node IMAGE_INDEX
+@section @code{IMAGE_INDEX} --- Function that converts a cosubscript to an image index
+@fnindex IMAGE_INDEX
+@cindex coarray, @code{IMAGE_INDEX}
+@cindex images, cosubscript to image index conversion
+
+@table @asis
+@item @emph{Description}:
+Returns the image index belonging to a cosubscript.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Inquiry function.
+
+@item @emph{Syntax}:
+@code{RESULT = IMAGE_INDEX(COARRAY, SUB)}
+
+@item @emph{Arguments}: None.
+@multitable @columnfractions .15 .70
+@item @var{COARRAY} @tab Coarray of any type.
+@item @var{SUB}     @tab default integer rank-1 array of a size equal to
+the corank of @var{COARRAY}.
+@end multitable
+
+
+@item @emph{Return value}:
+Scalar default integer with the value of the image index which corresponds
+to the cosubscripts. For invalid cosubscripts the result is zero.
+
+@item @emph{Example}:
+@smallexample
+INTEGER :: array[2,-1:4,8,*]
+! Writes  28 (or 0 if there are fewer than 28 images)
+WRITE (*,*) IMAGE_INDEX (array, [2,0,3,1])
+@end smallexample
+
+@item @emph{See also}:
+@ref{THIS_IMAGE}, @ref{NUM_IMAGES}
+@end table
+
+
+
+@node INDEX intrinsic
+@section @code{INDEX} --- Position of a substring within a string
+@fnindex INDEX
+@cindex substring position
+@cindex string, find substring
+
+@table @asis
+@item @emph{Description}:
+Returns the position of the start of the first occurrence of string
+@var{SUBSTRING} as a substring in @var{STRING}, counting from one.  If
+@var{SUBSTRING} is not present in @var{STRING}, zero is returned.  If 
+the @var{BACK} argument is present and true, the return value is the
+start of the last occurrence rather than the first.
+
+@item @emph{Standard}:
+Fortran 77 and later, with @var{KIND} argument Fortran 2003 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = INDEX(STRING, SUBSTRING [, BACK [, KIND]])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{STRING} @tab Shall be a scalar @code{CHARACTER}, with
+@code{INTENT(IN)}
+@item @var{SUBSTRING} @tab Shall be a scalar @code{CHARACTER}, with
+@code{INTENT(IN)}
+@item @var{BACK} @tab (Optional) Shall be a scalar @code{LOGICAL}, with
+@code{INTENT(IN)}
+@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
+expression indicating the kind parameter of the result.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of kind @var{KIND}. If
+@var{KIND} is absent, the return value is of default integer kind.
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name                            @tab Argument           @tab Return type       @tab Standard
+@item @code{INDEX(STRING, SUBSTRING)} @tab @code{CHARACTER}   @tab @code{INTEGER(4)} @tab Fortran 77 and later
+@end multitable
+
+@item @emph{See also}:
+@ref{SCAN}, @ref{VERIFY}
+@end table
+
+
+
+@node INT
+@section @code{INT} --- Convert to integer type
+@fnindex INT
+@fnindex IFIX
+@fnindex IDINT
+@cindex conversion, to integer
+
+@table @asis
+@item @emph{Description}:
+Convert to integer type
+
+@item @emph{Standard}:
+Fortran 77 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = INT(A [, KIND))}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{A}    @tab Shall be of type @code{INTEGER},
+@code{REAL}, or @code{COMPLEX}.
+@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
+expression indicating the kind parameter of the result.
+@end multitable
+
+@item @emph{Return value}:
+These functions return a @code{INTEGER} variable or array under 
+the following rules: 
+
+@table @asis
+@item (A)
+If @var{A} is of type @code{INTEGER}, @code{INT(A) = A} 
+@item (B)
+If @var{A} is of type @code{REAL} and @math{|A| < 1}, @code{INT(A)} equals @code{0}. 
+If @math{|A| \geq 1}, then @code{INT(A)} equals the largest integer that does not exceed 
+the range of @var{A} and whose sign is the same as the sign of @var{A}.
+@item (C)
+If @var{A} is of type @code{COMPLEX}, rule B is applied to the real part of @var{A}.
+@end table
+
+@item @emph{Example}:
+@smallexample
+program test_int
+  integer :: i = 42
+  complex :: z = (-3.7, 1.0)
+  print *, int(i)
+  print *, int(z), int(z,8)
+end program
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name            @tab Argument          @tab Return type       @tab Standard
+@item @code{INT(A)}   @tab @code{REAL(4) A}  @tab @code{INTEGER}    @tab Fortran 77 and later
+@item @code{IFIX(A)}  @tab @code{REAL(4) A}  @tab @code{INTEGER}    @tab Fortran 77 and later
+@item @code{IDINT(A)} @tab @code{REAL(8) A}  @tab @code{INTEGER}    @tab Fortran 77 and later
+@end multitable
+
+@end table
+
+
+@node INT2
+@section @code{INT2} --- Convert to 16-bit integer type
+@fnindex INT2
+@fnindex SHORT
+@cindex conversion, to integer
+
+@table @asis
+@item @emph{Description}:
+Convert to a @code{KIND=2} integer type. This is equivalent to the
+standard @code{INT} intrinsic with an optional argument of
+@code{KIND=2}, and is only included for backwards compatibility.
+
+The @code{SHORT} intrinsic is equivalent to @code{INT2}.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = INT2(A)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{A}    @tab Shall be of type @code{INTEGER},
+@code{REAL}, or @code{COMPLEX}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is a @code{INTEGER(2)} variable.
+
+@item @emph{See also}:
+@ref{INT}, @ref{INT8}, @ref{LONG}
+@end table
+
+
+
+@node INT8
+@section @code{INT8} --- Convert to 64-bit integer type
+@fnindex INT8
+@cindex conversion, to integer
+
+@table @asis
+@item @emph{Description}:
+Convert to a @code{KIND=8} integer type. This is equivalent to the
+standard @code{INT} intrinsic with an optional argument of
+@code{KIND=8}, and is only included for backwards compatibility.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = INT8(A)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{A}    @tab Shall be of type @code{INTEGER},
+@code{REAL}, or @code{COMPLEX}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is a @code{INTEGER(8)} variable.
+
+@item @emph{See also}:
+@ref{INT}, @ref{INT2}, @ref{LONG}
+@end table
+
+
+
+@node IOR
+@section @code{IOR} --- Bitwise logical or
+@fnindex IOR
+@cindex bitwise logical or
+@cindex logical or, bitwise
+
+@table @asis
+@item @emph{Description}:
+@code{IOR} returns the bitwise Boolean inclusive-OR of @var{I} and
+@var{J}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = IOR(I, J)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab The type shall be @code{INTEGER}.
+@item @var{J} @tab The type shall be @code{INTEGER}, of the same
+kind as @var{I}.  (As a GNU extension, different kinds are also 
+permitted.)
+@end multitable
+
+@item @emph{Return value}:
+The return type is @code{INTEGER}, of the same kind as the
+arguments.  (If the argument kinds differ, it is of the same kind as
+the larger argument.)
+
+@item @emph{See also}:
+@ref{IEOR}, @ref{IAND}, @ref{IBITS}, @ref{IBSET}, @ref{IBCLR}, @ref{NOT}
+@end table
+
+
+
+@node IPARITY
+@section @code{IPARITY} --- Bitwise XOR of array elements
+@fnindex IPARITY
+@cindex array, parity
+@cindex array, XOR
+@cindex bits, XOR of array elements
+
+@table @asis
+@item @emph{Description}:
+Reduces with bitwise XOR (exclusive or) the elements of @var{ARRAY} along
+dimension @var{DIM} if the corresponding element in @var{MASK} is @code{TRUE}.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{RESULT = IPARITY(ARRAY[, MASK])}
+@item @code{RESULT = IPARITY(ARRAY, DIM[, MASK])}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ARRAY} @tab Shall be an array of type @code{INTEGER}
+@item @var{DIM}   @tab (Optional) shall be a scalar of type 
+@code{INTEGER} with a value in the range from 1 to n, where n 
+equals the rank of @var{ARRAY}.
+@item @var{MASK}  @tab (Optional) shall be of type @code{LOGICAL} 
+and either be a scalar or an array of the same shape as @var{ARRAY}.
+@end multitable
+
+@item @emph{Return value}:
+The result is of the same type as @var{ARRAY}.
+
+If @var{DIM} is absent, a scalar with the bitwise XOR of all elements in
+@var{ARRAY} is returned. Otherwise, an array of rank n-1, where n equals
+the rank of @var{ARRAY}, and a shape similar to that of @var{ARRAY} with
+dimension @var{DIM} dropped is returned.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_iparity
+  INTEGER(1) :: a(2)
+
+  a(1) = b'00100100'
+  a(2) = b'01101010'
+
+  ! prints 01001110
+  PRINT '(b8.8)', IPARITY(a)
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{IANY}, @ref{IALL}, @ref{IEOR}, @ref{PARITY}
+@end table
+
+
+
+@node IRAND
+@section @code{IRAND} --- Integer pseudo-random number
+@fnindex IRAND
+@cindex random number generation
+
+@table @asis
+@item @emph{Description}:
+@code{IRAND(FLAG)} returns a pseudo-random number from a uniform
+distribution between 0 and a system-dependent limit (which is in most
+cases 2147483647). If @var{FLAG} is 0, the next number
+in the current sequence is returned; if @var{FLAG} is 1, the generator
+is restarted by @code{CALL SRAND(0)}; if @var{FLAG} has any other value,
+it is used as a new seed with @code{SRAND}.
+
+This intrinsic routine is provided for backwards compatibility with
+GNU Fortran 77. It implements a simple modulo generator as provided 
+by @command{g77}. For new code, one should consider the use of 
+@ref{RANDOM_NUMBER} as it implements a superior algorithm.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Function
+
+@item @emph{Syntax}:
+@code{RESULT = IRAND(I)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab Shall be a scalar @code{INTEGER} of kind 4.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of @code{INTEGER(kind=4)} type.
+
+@item @emph{Example}:
+@smallexample
+program test_irand
+  integer,parameter :: seed = 86456
+  
+  call srand(seed)
+  print *, irand(), irand(), irand(), irand()
+  print *, irand(seed), irand(), irand(), irand()
+end program test_irand
+@end smallexample
+
+@end table
+
+
+
+@node IS_IOSTAT_END
+@section @code{IS_IOSTAT_END} --- Test for end-of-file value
+@fnindex IS_IOSTAT_END
+@cindex @code{IOSTAT}, end of file
+
+@table @asis
+@item @emph{Description}:
+@code{IS_IOSTAT_END} tests whether an variable has the value of the I/O
+status ``end of file''. The function is equivalent to comparing the variable
+with the @code{IOSTAT_END} parameter of the intrinsic module
+@code{ISO_FORTRAN_ENV}.
+
+@item @emph{Standard}:
+Fortran 2003 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = IS_IOSTAT_END(I)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab Shall be of the type @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+Returns a @code{LOGICAL} of the default kind, which @code{.TRUE.} if
+@var{I} has the value which indicates an end of file condition for
+@code{IOSTAT=} specifiers, and is @code{.FALSE.} otherwise.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM iostat
+  IMPLICIT NONE
+  INTEGER :: stat, i
+  OPEN(88, FILE='test.dat')
+  READ(88, *, IOSTAT=stat) i
+  IF(IS_IOSTAT_END(stat)) STOP 'END OF FILE'
+END PROGRAM
+@end smallexample
+@end table
+
+
+
+@node IS_IOSTAT_EOR
+@section @code{IS_IOSTAT_EOR} --- Test for end-of-record value
+@fnindex IS_IOSTAT_EOR
+@cindex @code{IOSTAT}, end of record
+
+@table @asis
+@item @emph{Description}:
+@code{IS_IOSTAT_EOR} tests whether an variable has the value of the I/O
+status ``end of record''. The function is equivalent to comparing the
+variable with the @code{IOSTAT_EOR} parameter of the intrinsic module
+@code{ISO_FORTRAN_ENV}.
+
+@item @emph{Standard}:
+Fortran 2003 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = IS_IOSTAT_EOR(I)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab Shall be of the type @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+Returns a @code{LOGICAL} of the default kind, which @code{.TRUE.} if
+@var{I} has the value which indicates an end of file condition for
+@code{IOSTAT=} specifiers, and is @code{.FALSE.} otherwise.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM iostat
+  IMPLICIT NONE
+  INTEGER :: stat, i(50)
+  OPEN(88, FILE='test.dat', FORM='UNFORMATTED')
+  READ(88, IOSTAT=stat) i
+  IF(IS_IOSTAT_EOR(stat)) STOP 'END OF RECORD'
+END PROGRAM
+@end smallexample
+@end table
+
+
+
+@node ISATTY
+@section @code{ISATTY} --- Whether a unit is a terminal device.
+@fnindex ISATTY
+@cindex system, terminal
+
+@table @asis
+@item @emph{Description}:
+Determine whether a unit is connected to a terminal device.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Function
+
+@item @emph{Syntax}:
+@code{RESULT = ISATTY(UNIT)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{UNIT} @tab Shall be a scalar @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+Returns @code{.TRUE.} if the @var{UNIT} is connected to a terminal 
+device, @code{.FALSE.} otherwise.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_isatty
+  INTEGER(kind=1) :: unit
+  DO unit = 1, 10
+    write(*,*) isatty(unit=unit)
+  END DO
+END PROGRAM
+@end smallexample
+@item @emph{See also}:
+@ref{TTYNAM}
+@end table
+
+
+
+@node ISHFT
+@section @code{ISHFT} --- Shift bits
+@fnindex ISHFT
+@cindex bits, shift
+
+@table @asis
+@item @emph{Description}:
+@code{ISHFT} returns a value corresponding to @var{I} with all of the
+bits shifted @var{SHIFT} places.  A value of @var{SHIFT} greater than
+zero corresponds to a left shift, a value of zero corresponds to no
+shift, and a value less than zero corresponds to a right shift.  If the
+absolute value of @var{SHIFT} is greater than @code{BIT_SIZE(I)}, the
+value is undefined.  Bits shifted out from the left end or right end are
+lost; zeros are shifted in from the opposite end.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = ISHFT(I, SHIFT)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab The type shall be @code{INTEGER}.
+@item @var{SHIFT} @tab The type shall be @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of the same kind as
+@var{I}.
+
+@item @emph{See also}:
+@ref{ISHFTC}
+@end table
+
+
+
+@node ISHFTC
+@section @code{ISHFTC} --- Shift bits circularly
+@fnindex ISHFTC
+@cindex bits, shift circular
+
+@table @asis
+@item @emph{Description}:
+@code{ISHFTC} returns a value corresponding to @var{I} with the
+rightmost @var{SIZE} bits shifted circularly @var{SHIFT} places; that
+is, bits shifted out one end are shifted into the opposite end.  A value
+of @var{SHIFT} greater than zero corresponds to a left shift, a value of
+zero corresponds to no shift, and a value less than zero corresponds to
+a right shift.  The absolute value of @var{SHIFT} must be less than
+@var{SIZE}.  If the @var{SIZE} argument is omitted, it is taken to be
+equivalent to @code{BIT_SIZE(I)}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = ISHFTC(I, SHIFT [, SIZE])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab The type shall be @code{INTEGER}.
+@item @var{SHIFT} @tab The type shall be @code{INTEGER}.
+@item @var{SIZE} @tab (Optional) The type shall be @code{INTEGER};
+the value must be greater than zero and less than or equal to
+@code{BIT_SIZE(I)}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of the same kind as
+@var{I}.
+
+@item @emph{See also}:
+@ref{ISHFT}
+@end table
+
+
+
+@node ISNAN
+@section @code{ISNAN} --- Test for a NaN
+@fnindex ISNAN
+@cindex IEEE, ISNAN
+
+@table @asis
+@item @emph{Description}:
+@code{ISNAN} tests whether a floating-point value is an IEEE
+Not-a-Number (NaN).
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{ISNAN(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab Variable of the type @code{REAL}.
+
+@end multitable
+
+@item @emph{Return value}:
+Returns a default-kind @code{LOGICAL}. The returned value is @code{TRUE}
+if @var{X} is a NaN and @code{FALSE} otherwise.
+
+@item @emph{Example}:
+@smallexample
+program test_nan
+  implicit none
+  real :: x
+  x = -1.0
+  x = sqrt(x)
+  if (isnan(x)) stop '"x" is a NaN'
+end program test_nan
+@end smallexample
+@end table
+
+
+
+@node ITIME
+@section @code{ITIME} --- Get current local time subroutine (hour/minutes/seconds) 
+@fnindex ITIME
+@cindex time, current
+@cindex current time
+
+@table @asis
+@item @emph{Description}:
+@code{IDATE(VALUES)} Fills @var{VALUES} with the numerical values at the  
+current local time. The hour (in the range 1-24), minute (in the range 1-60), 
+and seconds (in the range 1-60) appear in elements 1, 2, and 3 of @var{VALUES}, 
+respectively.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine
+
+@item @emph{Syntax}:
+@code{CALL ITIME(VALUES)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{VALUES} @tab The type shall be @code{INTEGER, DIMENSION(3)}
+and the kind shall be the default integer kind.
+@end multitable
+
+@item @emph{Return value}:
+Does not return anything.
+
+
+@item @emph{Example}:
+@smallexample
+program test_itime
+  integer, dimension(3) :: tarray
+  call itime(tarray)
+  print *, tarray(1)
+  print *, tarray(2)
+  print *, tarray(3)
+end program test_itime
+@end smallexample
+@end table
+
+
+
+@node KILL
+@section @code{KILL} --- Send a signal to a process
+@fnindex KILL
+
+@table @asis
+@item @emph{Description}:
+@item @emph{Standard}:
+Sends the signal specified by @var{SIGNAL} to the process @var{PID}.
+See @code{kill(2)}.
+
+This intrinsic is provided in both subroutine and function forms; however,
+only one form can be used in any given program unit.
+
+@item @emph{Class}:
+Subroutine, function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{CALL KILL(C, VALUE [, STATUS])}
+@item @code{STATUS = KILL(C, VALUE)}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{C} @tab Shall be a scalar @code{INTEGER}, with
+@code{INTENT(IN)}
+@item @var{VALUE} @tab Shall be a scalar @code{INTEGER}, with
+@code{INTENT(IN)}
+@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER(4)} or
+@code{INTEGER(8)}. Returns 0 on success, or a system-specific error code
+otherwise.
+@end multitable
+
+@item @emph{See also}:
+@ref{ABORT}, @ref{EXIT}
+@end table
+
+
+
+@node KIND
+@section @code{KIND} --- Kind of an entity
+@fnindex KIND
+@cindex kind
+
+@table @asis
+@item @emph{Description}:
+@code{KIND(X)} returns the kind value of the entity @var{X}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{K = KIND(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab Shall be of type @code{LOGICAL}, @code{INTEGER},
+@code{REAL}, @code{COMPLEX} or @code{CHARACTER}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is a scalar of type @code{INTEGER} and of the default
+integer kind.
+
+@item @emph{Example}:
+@smallexample
+program test_kind
+  integer,parameter :: kc = kind(' ')
+  integer,parameter :: kl = kind(.true.)
+
+  print *, "The default character kind is ", kc
+  print *, "The default logical kind is ", kl
+end program test_kind
+@end smallexample
+
+@end table
+
+
+
+@node LBOUND
+@section @code{LBOUND} --- Lower dimension bounds of an array
+@fnindex LBOUND
+@cindex array, lower bound
+
+@table @asis
+@item @emph{Description}:
+Returns the lower bounds of an array, or a single lower bound
+along the @var{DIM} dimension.
+@item @emph{Standard}:
+Fortran 95 and later, with @var{KIND} argument Fortran 2003 and later
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{RESULT = LBOUND(ARRAY [, DIM [, KIND]])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ARRAY} @tab Shall be an array, of any type.
+@item @var{DIM} @tab (Optional) Shall be a scalar @code{INTEGER}.
+@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
+expression indicating the kind parameter of the result.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of kind @var{KIND}. If
+@var{KIND} is absent, the return value is of default integer kind.
+If @var{DIM} is absent, the result is an array of the lower bounds of
+@var{ARRAY}.  If @var{DIM} is present, the result is a scalar
+corresponding to the lower bound of the array along that dimension.  If
+@var{ARRAY} is an expression rather than a whole array or array
+structure component, or if it has a zero extent along the relevant
+dimension, the lower bound is taken to be 1.
+
+@item @emph{See also}:
+@ref{UBOUND}, @ref{LCOBOUND}
+@end table
+
+
+
+@node LCOBOUND
+@section @code{LCOBOUND} --- Lower codimension bounds of an array
+@fnindex LCOBOUND
+@cindex coarray, lower bound
+
+@table @asis
+@item @emph{Description}:
+Returns the lower bounds of a coarray, or a single lower cobound
+along the @var{DIM} codimension.
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{RESULT = LCOBOUND(COARRAY [, DIM [, KIND]])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ARRAY} @tab Shall be an coarray, of any type.
+@item @var{DIM} @tab (Optional) Shall be a scalar @code{INTEGER}.
+@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
+expression indicating the kind parameter of the result.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of kind @var{KIND}. If
+@var{KIND} is absent, the return value is of default integer kind.
+If @var{DIM} is absent, the result is an array of the lower cobounds of
+@var{COARRAY}.  If @var{DIM} is present, the result is a scalar
+corresponding to the lower cobound of the array along that codimension.
+
+@item @emph{See also}:
+@ref{UCOBOUND}, @ref{LBOUND}
+@end table
+
+
+
+@node LEADZ
+@section @code{LEADZ} --- Number of leading zero bits of an integer
+@fnindex LEADZ
+@cindex zero bits
+
+@table @asis
+@item @emph{Description}:
+@code{LEADZ} returns the number of leading zero bits of an integer.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = LEADZ(I)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab Shall be of type @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The type of the return value is the default @code{INTEGER}.
+If all the bits of @code{I} are zero, the result value is @code{BIT_SIZE(I)}.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_leadz
+  WRITE (*,*) BIT_SIZE(1)  ! prints 32
+  WRITE (*,*) LEADZ(1)     ! prints 31
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{BIT_SIZE}, @ref{TRAILZ}, @ref{POPCNT}, @ref{POPPAR}
+@end table
+
+
+
+@node LEN
+@section @code{LEN} --- Length of a character entity
+@fnindex LEN
+@cindex string, length
+
+@table @asis
+@item @emph{Description}:
+Returns the length of a character string.  If @var{STRING} is an array,
+the length of an element of @var{STRING} is returned.  Note that
+@var{STRING} need not be defined when this intrinsic is invoked, since
+only the length, not the content, of @var{STRING} is needed.
+
+@item @emph{Standard}:
+Fortran 77 and later, with @var{KIND} argument Fortran 2003 and later
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{L = LEN(STRING [, KIND])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{STRING} @tab Shall be a scalar or array of type
+@code{CHARACTER}, with @code{INTENT(IN)}
+@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
+expression indicating the kind parameter of the result.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of kind @var{KIND}. If
+@var{KIND} is absent, the return value is of default integer kind.
+
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name               @tab Argument          @tab Return type       @tab Standard
+@item @code{LEN(STRING)} @tab @code{CHARACTER}  @tab @code{INTEGER}    @tab Fortran 77 and later
+@end multitable
+
+
+@item @emph{See also}:
+@ref{LEN_TRIM}, @ref{ADJUSTL}, @ref{ADJUSTR}
+@end table
+
+
+
+@node LEN_TRIM
+@section @code{LEN_TRIM} --- Length of a character entity without trailing blank characters
+@fnindex LEN_TRIM
+@cindex string, length, without trailing whitespace
+
+@table @asis
+@item @emph{Description}:
+Returns the length of a character string, ignoring any trailing blanks.
+
+@item @emph{Standard}:
+Fortran 95 and later, with @var{KIND} argument Fortran 2003 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = LEN_TRIM(STRING [, KIND])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{STRING} @tab Shall be a scalar of type @code{CHARACTER},
+with @code{INTENT(IN)}
+@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
+expression indicating the kind parameter of the result.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of kind @var{KIND}. If
+@var{KIND} is absent, the return value is of default integer kind.
+
+@item @emph{See also}:
+@ref{LEN}, @ref{ADJUSTL}, @ref{ADJUSTR}
+@end table
+
+
+
+@node LGE
+@section @code{LGE} --- Lexical greater than or equal
+@fnindex LGE
+@cindex lexical comparison of strings
+@cindex string, comparison
+
+@table @asis
+@item @emph{Description}:
+Determines whether one string is lexically greater than or equal to
+another string, where the two strings are interpreted as containing
+ASCII character codes.  If the String A and String B are not the same
+length, the shorter is compared as if spaces were appended to it to form
+a value that has the same length as the longer.
+
+In general, the lexical comparison intrinsics @code{LGE}, @code{LGT},
+@code{LLE}, and @code{LLT} differ from the corresponding intrinsic
+operators @code{.GE.}, @code{.GT.}, @code{.LE.}, and @code{.LT.}, in
+that the latter use the processor's character ordering (which is not
+ASCII on some targets), whereas the former always use the ASCII
+ordering.
+
+@item @emph{Standard}:
+Fortran 77 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = LGE(STRING_A, STRING_B)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{STRING_A} @tab Shall be of default @code{CHARACTER} type.
+@item @var{STRING_B} @tab Shall be of default @code{CHARACTER} type.
+@end multitable
+
+@item @emph{Return value}:
+Returns @code{.TRUE.} if @code{STRING_A >= STRING_B}, and @code{.FALSE.}
+otherwise, based on the ASCII ordering.
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name                           @tab Argument          @tab Return type       @tab Standard
+@item @code{LGE(STRING_A, STRING_B)} @tab @code{CHARACTER}  @tab @code{LOGICAL}    @tab Fortran 77 and later
+@end multitable
+
+@item @emph{See also}:
+@ref{LGT}, @ref{LLE}, @ref{LLT}
+@end table
+
+
+
+@node LGT
+@section @code{LGT} --- Lexical greater than
+@fnindex LGT
+@cindex lexical comparison of strings
+@cindex string, comparison
+
+@table @asis
+@item @emph{Description}:
+Determines whether one string is lexically greater than another string,
+where the two strings are interpreted as containing ASCII character
+codes.  If the String A and String B are not the same length, the
+shorter is compared as if spaces were appended to it to form a value
+that has the same length as the longer.
+
+In general, the lexical comparison intrinsics @code{LGE}, @code{LGT},
+@code{LLE}, and @code{LLT} differ from the corresponding intrinsic
+operators @code{.GE.}, @code{.GT.}, @code{.LE.}, and @code{.LT.}, in
+that the latter use the processor's character ordering (which is not
+ASCII on some targets), whereas the former always use the ASCII
+ordering.
+
+@item @emph{Standard}:
+Fortran 77 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = LGT(STRING_A, STRING_B)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{STRING_A} @tab Shall be of default @code{CHARACTER} type.
+@item @var{STRING_B} @tab Shall be of default @code{CHARACTER} type.
+@end multitable
+
+@item @emph{Return value}:
+Returns @code{.TRUE.} if @code{STRING_A > STRING_B}, and @code{.FALSE.}
+otherwise, based on the ASCII ordering.
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name                           @tab Argument          @tab Return type       @tab Standard
+@item @code{LGT(STRING_A, STRING_B)} @tab @code{CHARACTER}  @tab @code{LOGICAL}    @tab Fortran 77 and later
+@end multitable
+
+@item @emph{See also}:
+@ref{LGE}, @ref{LLE}, @ref{LLT}
+@end table
+
+
+
+@node LINK
+@section @code{LINK} --- Create a hard link
+@fnindex LINK
+@cindex file system, create link
+@cindex file system, hard link
+
+@table @asis
+@item @emph{Description}:
+Makes a (hard) link from file @var{PATH1} to @var{PATH2}. A null
+character (@code{CHAR(0)}) can be used to mark the end of the names in
+@var{PATH1} and @var{PATH2}; otherwise, trailing blanks in the file
+names are ignored.  If the @var{STATUS} argument is supplied, it
+contains 0 on success or a nonzero error code upon return; see
+@code{link(2)}.
+
+This intrinsic is provided in both subroutine and function forms;
+however, only one form can be used in any given program unit.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine, function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{CALL LINK(PATH1, PATH2 [, STATUS])}
+@item @code{STATUS = LINK(PATH1, PATH2)}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{PATH1} @tab Shall be of default @code{CHARACTER} type.
+@item @var{PATH2} @tab Shall be of default @code{CHARACTER} type.
+@item @var{STATUS} @tab (Optional) Shall be of default @code{INTEGER} type.
+@end multitable
+
+@item @emph{See also}:
+@ref{SYMLNK}, @ref{UNLINK}
+@end table
+
+
+
+@node LLE
+@section @code{LLE} --- Lexical less than or equal
+@fnindex LLE
+@cindex lexical comparison of strings
+@cindex string, comparison
+
+@table @asis
+@item @emph{Description}:
+Determines whether one string is lexically less than or equal to another
+string, where the two strings are interpreted as containing ASCII
+character codes.  If the String A and String B are not the same length,
+the shorter is compared as if spaces were appended to it to form a value
+that has the same length as the longer.
+
+In general, the lexical comparison intrinsics @code{LGE}, @code{LGT},
+@code{LLE}, and @code{LLT} differ from the corresponding intrinsic
+operators @code{.GE.}, @code{.GT.}, @code{.LE.}, and @code{.LT.}, in
+that the latter use the processor's character ordering (which is not
+ASCII on some targets), whereas the former always use the ASCII
+ordering.
+
+@item @emph{Standard}:
+Fortran 77 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = LLE(STRING_A, STRING_B)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{STRING_A} @tab Shall be of default @code{CHARACTER} type.
+@item @var{STRING_B} @tab Shall be of default @code{CHARACTER} type.
+@end multitable
+
+@item @emph{Return value}:
+Returns @code{.TRUE.} if @code{STRING_A <= STRING_B}, and @code{.FALSE.}
+otherwise, based on the ASCII ordering.
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name                           @tab Argument          @tab Return type       @tab Standard
+@item @code{LLE(STRING_A, STRING_B)} @tab @code{CHARACTER}  @tab @code{LOGICAL}    @tab Fortran 77 and later
+@end multitable
+
+@item @emph{See also}:
+@ref{LGE}, @ref{LGT}, @ref{LLT}
+@end table
+
+
+
+@node LLT
+@section @code{LLT} --- Lexical less than
+@fnindex LLT
+@cindex lexical comparison of strings
+@cindex string, comparison
+
+@table @asis
+@item @emph{Description}:
+Determines whether one string is lexically less than another string,
+where the two strings are interpreted as containing ASCII character
+codes.  If the String A and String B are not the same length, the
+shorter is compared as if spaces were appended to it to form a value
+that has the same length as the longer.
+
+In general, the lexical comparison intrinsics @code{LGE}, @code{LGT},
+@code{LLE}, and @code{LLT} differ from the corresponding intrinsic
+operators @code{.GE.}, @code{.GT.}, @code{.LE.}, and @code{.LT.}, in
+that the latter use the processor's character ordering (which is not
+ASCII on some targets), whereas the former always use the ASCII
+ordering.
+
+@item @emph{Standard}:
+Fortran 77 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = LLT(STRING_A, STRING_B)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{STRING_A} @tab Shall be of default @code{CHARACTER} type.
+@item @var{STRING_B} @tab Shall be of default @code{CHARACTER} type.
+@end multitable
+
+@item @emph{Return value}:
+Returns @code{.TRUE.} if @code{STRING_A < STRING_B}, and @code{.FALSE.}
+otherwise, based on the ASCII ordering.
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name                           @tab Argument          @tab Return type       @tab Standard
+@item @code{LLT(STRING_A, STRING_B)} @tab @code{CHARACTER}  @tab @code{LOGICAL}    @tab Fortran 77 and later
+@end multitable
+
+@item @emph{See also}:
+@ref{LGE}, @ref{LGT}, @ref{LLE}
+@end table
+
+
+
+@node LNBLNK
+@section @code{LNBLNK} --- Index of the last non-blank character in a string
+@fnindex LNBLNK
+@cindex string, find non-blank character
+
+@table @asis
+@item @emph{Description}:
+Returns the length of a character string, ignoring any trailing blanks.
+This is identical to the standard @code{LEN_TRIM} intrinsic, and is only
+included for backwards compatibility.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = LNBLNK(STRING)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{STRING} @tab Shall be a scalar of type @code{CHARACTER},
+with @code{INTENT(IN)}
+@end multitable
+
+@item @emph{Return value}:
+The return value is of @code{INTEGER(kind=4)} type.
+
+@item @emph{See also}:
+@ref{INDEX intrinsic}, @ref{LEN_TRIM}
+@end table
+
+
+
+@node LOC
+@section @code{LOC} --- Returns the address of a variable
+@fnindex LOC
+@cindex location of a variable in memory
+
+@table @asis
+@item @emph{Description}:
+@code{LOC(X)} returns the address of @var{X} as an integer.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{RESULT = LOC(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab Variable of any type.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER}, with a @code{KIND}
+corresponding to the size (in bytes) of a memory address on the target
+machine.
+
+@item @emph{Example}:
+@smallexample
+program test_loc
+  integer :: i
+  real :: r
+  i = loc(r)
+  print *, i
+end program test_loc
+@end smallexample
+@end table
+
+
+
+@node LOG
+@section @code{LOG} --- Natural logarithm function
+@fnindex LOG
+@fnindex ALOG
+@fnindex DLOG
+@fnindex CLOG
+@fnindex ZLOG
+@fnindex CDLOG
+@cindex exponential function, inverse
+@cindex logarithm function
+@cindex natural logarithm function
+
+@table @asis
+@item @emph{Description}:
+@code{LOG(X)} computes the natural logarithm of @var{X}, i.e. the
+logarithm to the base @math{e}.
+
+@item @emph{Standard}:
+Fortran 77 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = LOG(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be @code{REAL} or
+@code{COMPLEX}.
+@end multitable
+
+@item @emph{Return value}:
+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}.
+
+@item @emph{Example}:
+@smallexample
+program test_log
+  real(8) :: x = 2.7182818284590451_8
+  complex :: z = (1.0, 2.0)
+  x = log(x)    ! will yield (approximately) 1
+  z = log(z)
+end program test_log
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name            @tab Argument          @tab Return type       @tab Standard
+@item @code{ALOG(X)}  @tab @code{REAL(4) X}  @tab @code{REAL(4)}    @tab f95, gnu
+@item @code{DLOG(X)}  @tab @code{REAL(8) X}  @tab @code{REAL(8)}    @tab f95, gnu
+@item @code{CLOG(X)}  @tab @code{COMPLEX(4) X}  @tab @code{COMPLEX(4)}    @tab f95, gnu
+@item @code{ZLOG(X)}  @tab @code{COMPLEX(8) X}  @tab @code{COMPLEX(8)}    @tab f95, gnu
+@item @code{CDLOG(X)} @tab @code{COMPLEX(8) X}  @tab @code{COMPLEX(8)}    @tab f95, gnu
+@end multitable
+@end table
+
+
+
+@node LOG10
+@section @code{LOG10} --- Base 10 logarithm function
+@fnindex LOG10
+@fnindex ALOG10
+@fnindex DLOG10
+@cindex exponential function, inverse
+@cindex logarithm function with base 10
+@cindex base 10 logarithm function
+
+@table @asis
+@item @emph{Description}:
+@code{LOG10(X)} computes the base 10 logarithm of @var{X}.
+
+@item @emph{Standard}:
+Fortran 77 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = LOG10(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be @code{REAL}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{REAL} or @code{COMPLEX}.
+The kind type parameter is the same as @var{X}.
+
+@item @emph{Example}:
+@smallexample
+program test_log10
+  real(8) :: x = 10.0_8
+  x = log10(x)
+end program test_log10
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name            @tab Argument          @tab Return type       @tab Standard
+@item @code{ALOG10(X)}  @tab @code{REAL(4) X}  @tab @code{REAL(4)}    @tab Fortran 95 and later
+@item @code{DLOG10(X)}  @tab @code{REAL(8) X}  @tab @code{REAL(8)}    @tab Fortran 95 and later
+@end multitable
+@end table
+
+
+
+@node LOG_GAMMA
+@section @code{LOG_GAMMA} --- Logarithm of the Gamma function
+@fnindex LOG_GAMMA
+@fnindex LGAMMA
+@fnindex ALGAMA
+@fnindex DLGAMA
+@cindex Gamma function, logarithm of
+
+@table @asis
+@item @emph{Description}:
+@code{LOG_GAMMA(X)} computes the natural logarithm of the absolute value
+of the Gamma (@math{\Gamma}) function.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{X = LOG_GAMMA(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab Shall be of type @code{REAL} and neither zero
+nor a negative integer.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{REAL} of the same kind as @var{X}.
+
+@item @emph{Example}:
+@smallexample
+program test_log_gamma
+  real :: x = 1.0
+  x = lgamma(x) ! returns 0.0
+end program test_log_gamma
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name             @tab Argument         @tab Return type       @tab Standard
+@item @code{LGAMMA(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)}    @tab GNU Extension
+@item @code{ALGAMA(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)}    @tab GNU Extension
+@item @code{DLGAMA(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)}    @tab GNU Extension
+@end multitable
+
+@item @emph{See also}:
+Gamma function: @ref{GAMMA}
+
+@end table
+
+
+
+@node LOGICAL
+@section @code{LOGICAL} --- Convert to logical type
+@fnindex LOGICAL
+@cindex conversion, to logical
+
+@table @asis
+@item @emph{Description}:
+Converts one kind of @code{LOGICAL} variable to another.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = LOGICAL(L [, KIND])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{L}    @tab The type shall be @code{LOGICAL}.
+@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
+expression indicating the kind parameter of the result.
+@end multitable
+
+@item @emph{Return value}:
+The return value is a @code{LOGICAL} value equal to @var{L}, with a
+kind corresponding to @var{KIND}, or of the default logical kind if
+@var{KIND} is not given.
+
+@item @emph{See also}:
+@ref{INT}, @ref{REAL}, @ref{CMPLX}
+@end table
+
+
+
+@node LONG
+@section @code{LONG} --- Convert to integer type
+@fnindex LONG
+@cindex conversion, to integer
+
+@table @asis
+@item @emph{Description}:
+Convert to a @code{KIND=4} integer type, which is the same size as a C
+@code{long} integer.  This is equivalent to the standard @code{INT}
+intrinsic with an optional argument of @code{KIND=4}, and is only
+included for backwards compatibility.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = LONG(A)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{A}    @tab Shall be of type @code{INTEGER},
+@code{REAL}, or @code{COMPLEX}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is a @code{INTEGER(4)} variable.
+
+@item @emph{See also}:
+@ref{INT}, @ref{INT2}, @ref{INT8}
+@end table
+
+
+
+@node LSHIFT
+@section @code{LSHIFT} --- Left shift bits
+@fnindex LSHIFT
+@cindex bits, shift left
+
+@table @asis
+@item @emph{Description}:
+@code{LSHIFT} returns a value corresponding to @var{I} with all of the
+bits shifted left by @var{SHIFT} places.  If the absolute value of
+@var{SHIFT} is greater than @code{BIT_SIZE(I)}, the value is undefined. 
+Bits shifted out from the left end are lost; zeros are shifted in from
+the opposite end.
+
+This function has been superseded by the @code{ISHFT} intrinsic, which
+is standard in Fortran 95 and later, and the @code{SHIFTL} intrinsic,
+which is standard in Fortran 2008 and later.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = LSHIFT(I, SHIFT)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab The type shall be @code{INTEGER}.
+@item @var{SHIFT} @tab The type shall be @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of the same kind as
+@var{I}.
+
+@item @emph{See also}:
+@ref{ISHFT}, @ref{ISHFTC}, @ref{RSHIFT}, @ref{SHIFTA}, @ref{SHIFTL},
+@ref{SHIFTR}
+
+@end table
+
+
+
+@node LSTAT
+@section @code{LSTAT} --- Get file status
+@fnindex LSTAT
+@cindex file system, file status
+
+@table @asis
+@item @emph{Description}:
+@code{LSTAT} is identical to @ref{STAT}, except that if path is a
+symbolic link, then the link itself is statted, not the file that it
+refers to.
+
+The elements in @code{VALUES} are the same as described by @ref{STAT}.
+
+This intrinsic is provided in both subroutine and function forms;
+however, only one form can be used in any given program unit.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine, function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{CALL LSTAT(NAME, VALUES [, STATUS])}
+@item @code{STATUS = LSTAT(NAME, VALUES)}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{NAME}   @tab The type shall be @code{CHARACTER} of the default
+kind, a valid path within the file system.
+@item @var{VALUES} @tab The type shall be @code{INTEGER(4), DIMENSION(13)}.
+@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER(4)}.
+Returns 0 on success and a system specific error code otherwise.
+@end multitable
+
+@item @emph{Example}:
+See @ref{STAT} for an example.
+
+@item @emph{See also}:
+To stat an open file: @ref{FSTAT}, to stat a file: @ref{STAT}
+@end table
+
+
+
+@node LTIME
+@section @code{LTIME} --- Convert time to local time info
+@fnindex LTIME
+@cindex time, conversion to local time info
+
+@table @asis
+@item @emph{Description}:
+Given a system time value @var{TIME} (as provided by the @code{TIME8}
+intrinsic), fills @var{VALUES} with values extracted from it appropriate
+to the local time zone using @code{localtime(3)}.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine
+
+@item @emph{Syntax}:
+@code{CALL LTIME(TIME, VALUES)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{TIME}  @tab An @code{INTEGER} scalar expression
+corresponding to a system time, with @code{INTENT(IN)}.
+@item @var{VALUES} @tab A default @code{INTEGER} array with 9 elements,
+with @code{INTENT(OUT)}.
+@end multitable
+
+@item @emph{Return value}:
+The elements of @var{VALUES} are assigned as follows:
+@enumerate
+@item Seconds after the minute, range 0--59 or 0--61 to allow for leap
+seconds
+@item Minutes after the hour, range 0--59
+@item Hours past midnight, range 0--23
+@item Day of month, range 0--31
+@item Number of months since January, range 0--12
+@item Years since 1900
+@item Number of days since Sunday, range 0--6
+@item Days since January 1
+@item Daylight savings indicator: positive if daylight savings is in
+effect, zero if not, and negative if the information is not available.
+@end enumerate
+
+@item @emph{See also}:
+@ref{CTIME}, @ref{GMTIME}, @ref{TIME}, @ref{TIME8}
+
+@end table
+
+
+
+@node MALLOC
+@section @code{MALLOC} --- Allocate dynamic memory
+@fnindex MALLOC
+@cindex pointer, cray
+
+@table @asis
+@item @emph{Description}:
+@code{MALLOC(SIZE)} allocates @var{SIZE} bytes of dynamic memory and
+returns the address of the allocated memory. The @code{MALLOC} intrinsic
+is an extension intended to be used with Cray pointers, and is provided
+in GNU Fortran to allow the user to compile legacy code. For new code
+using Fortran 95 pointers, the memory allocation intrinsic is
+@code{ALLOCATE}.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Function
+
+@item @emph{Syntax}:
+@code{PTR = MALLOC(SIZE)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{SIZE} @tab The type shall be @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER(K)}, with @var{K} such that
+variables of type @code{INTEGER(K)} have the same size as
+C pointers (@code{sizeof(void *)}).
+
+@item @emph{Example}:
+The following example demonstrates the use of @code{MALLOC} and
+@code{FREE} with Cray pointers.
+
+@smallexample
+program test_malloc
+  implicit none
+  integer i
+  real*8 x(*), z
+  pointer(ptr_x,x)
+
+  ptr_x = malloc(20*8)
+  do i = 1, 20
+    x(i) = sqrt(1.0d0 / i)
+  end do
+  z = 0
+  do i = 1, 20
+    z = z + x(i)
+    print *, z
+  end do
+  call free(ptr_x)
+end program test_malloc
+@end smallexample
+
+@item @emph{See also}:
+@ref{FREE}
+@end table
+
+
+
+@node MASKL
+@section @code{MASKL} --- Left justified mask
+@fnindex MASKL
+@cindex mask, left justified
+
+@table @asis
+@item @emph{Description}:
+@code{MASKL(I[, KIND])} has its leftmost @var{I} bits set to 1, and the
+remaining bits set to 0.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = MASKL(I[, KIND])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab Shall be of type @code{INTEGER}.
+@item @var{KIND} @tab Shall be a scalar constant expression of type
+@code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER}. If @var{KIND} is present, it
+specifies the kind value of the return type; otherwise, it is of the
+default integer kind.
+
+@item @emph{See also}:
+@ref{MASKR}
+@end table
+
+
+
+@node MASKR
+@section @code{MASKR} --- Right justified mask
+@fnindex MASKR
+@cindex mask, right justified
+
+@table @asis
+@item @emph{Description}:
+@code{MASKL(I[, KIND])} has its rightmost @var{I} bits set to 1, and the
+remaining bits set to 0.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = MASKR(I[, KIND])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab Shall be of type @code{INTEGER}.
+@item @var{KIND} @tab Shall be a scalar constant expression of type
+@code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER}. If @var{KIND} is present, it
+specifies the kind value of the return type; otherwise, it is of the
+default integer kind.
+
+@item @emph{See also}:
+@ref{MASKL}
+@end table
+
+
+
+@node MATMUL
+@section @code{MATMUL} --- matrix multiplication
+@fnindex MATMUL
+@cindex matrix multiplication
+@cindex product, matrix
+
+@table @asis
+@item @emph{Description}:
+Performs a matrix multiplication on numeric or logical arguments.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@code{RESULT = MATMUL(MATRIX_A, MATRIX_B)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{MATRIX_A} @tab An array of @code{INTEGER},
+@code{REAL}, @code{COMPLEX}, or @code{LOGICAL} type, with a rank of
+one or two.
+@item @var{MATRIX_B} @tab An array of @code{INTEGER},
+@code{REAL}, or @code{COMPLEX} type if @var{MATRIX_A} is of a numeric
+type; otherwise, an array of @code{LOGICAL} type. The rank shall be one
+or two, and the first (or only) dimension of @var{MATRIX_B} shall be
+equal to the last (or only) dimension of @var{MATRIX_A}.
+@end multitable
+
+@item @emph{Return value}:
+The matrix product of @var{MATRIX_A} and @var{MATRIX_B}.  The type and
+kind of the result follow the usual type and kind promotion rules, as
+for the @code{*} or @code{.AND.} operators.
+
+@item @emph{See also}:
+@end table
+
+
+
+@node MAX
+@section @code{MAX} --- Maximum value of an argument list
+@fnindex MAX
+@fnindex MAX0
+@fnindex AMAX0
+@fnindex MAX1
+@fnindex AMAX1
+@fnindex DMAX1
+@cindex maximum value
+
+@table @asis
+@item @emph{Description}:
+Returns the argument with the largest (most positive) value.
+
+@item @emph{Standard}:
+Fortran 77 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = MAX(A1, A2 [, A3 [, ...]])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{A1}          @tab The type shall be @code{INTEGER} or
+@code{REAL}.
+@item @var{A2}, @var{A3}, ... @tab An expression of the same type and kind
+as @var{A1}.  (As a GNU extension, arguments of different kinds are
+permitted.)
+@end multitable
+
+@item @emph{Return value}:
+The return value corresponds to the maximum value among the arguments,
+and has the same type and kind as the first argument.
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name             @tab Argument             @tab Return type         @tab Standard
+@item @code{MAX0(A1)}  @tab @code{INTEGER(4) A1} @tab @code{INTEGER(4)}   @tab Fortran 77 and later
+@item @code{AMAX0(A1)} @tab @code{INTEGER(4) A1} @tab @code{REAL(MAX(X))} @tab Fortran 77 and later
+@item @code{MAX1(A1)}  @tab @code{REAL A1}       @tab @code{INT(MAX(X))}  @tab Fortran 77 and later
+@item @code{AMAX1(A1)} @tab @code{REAL(4) A1}    @tab @code{REAL(4)}      @tab Fortran 77 and later
+@item @code{DMAX1(A1)} @tab @code{REAL(8) A1}    @tab @code{REAL(8)}      @tab Fortran 77 and later
+@end multitable
+
+@item @emph{See also}:
+@ref{MAXLOC} @ref{MAXVAL}, @ref{MIN}
+
+@end table
+
+
+
+@node MAXEXPONENT
+@section @code{MAXEXPONENT} --- Maximum exponent of a real kind
+@fnindex MAXEXPONENT
+@cindex model representation, maximum exponent
+
+@table @asis
+@item @emph{Description}:
+@code{MAXEXPONENT(X)} returns the maximum exponent in the model of the
+type of @code{X}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{RESULT = MAXEXPONENT(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab Shall be of type @code{REAL}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of the default integer
+kind.
+
+@item @emph{Example}:
+@smallexample
+program exponents
+  real(kind=4) :: x
+  real(kind=8) :: y
+
+  print *, minexponent(x), maxexponent(x)
+  print *, minexponent(y), maxexponent(y)
+end program exponents
+@end smallexample
+@end table
+
+
+
+@node MAXLOC
+@section @code{MAXLOC} --- Location of the maximum value within an array
+@fnindex MAXLOC
+@cindex array, location of maximum element
+
+@table @asis
+@item @emph{Description}:
+Determines the location of the element in the array with the maximum
+value, or, if the @var{DIM} argument is supplied, determines the
+locations of the maximum element along each row of the array in the
+@var{DIM} direction.  If @var{MASK} is present, only the elements for
+which @var{MASK} is @code{.TRUE.} are considered.  If more than one
+element in the array has the maximum value, the location returned is
+that of the first such element in array element order.  If the array has
+zero size, or all of the elements of @var{MASK} are @code{.FALSE.}, then
+the result is an array of zeroes.  Similarly, if @var{DIM} is supplied
+and all of the elements of @var{MASK} along a given row are zero, the
+result value for that row is zero.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{RESULT = MAXLOC(ARRAY, DIM [, MASK])}
+@item @code{RESULT = MAXLOC(ARRAY [, MASK])}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ARRAY} @tab Shall be an array of type @code{INTEGER} or
+@code{REAL}.
+@item @var{DIM}   @tab (Optional) Shall be a scalar of type
+@code{INTEGER}, with a value between one and the rank of @var{ARRAY},
+inclusive.  It may not be an optional dummy argument.
+@item @var{MASK}  @tab Shall be an array of type @code{LOGICAL},
+and conformable with @var{ARRAY}.
+@end multitable
+
+@item @emph{Return value}:
+If @var{DIM} is absent, the result is a rank-one array with a length
+equal to the rank of @var{ARRAY}.  If @var{DIM} is present, the result
+is an array with a rank one less than the rank of @var{ARRAY}, and a
+size corresponding to the size of @var{ARRAY} with the @var{DIM}
+dimension removed.  If @var{DIM} is present and @var{ARRAY} has a rank
+of one, the result is a scalar.  In all cases, the result is of default
+@code{INTEGER} type.
+
+@item @emph{See also}:
+@ref{MAX}, @ref{MAXVAL}
+
+@end table
+
+
+
+@node MAXVAL
+@section @code{MAXVAL} --- Maximum value of an array
+@fnindex MAXVAL
+@cindex array, maximum value
+@cindex maximum value
+
+@table @asis
+@item @emph{Description}:
+Determines the maximum value of the elements in an array value, or, if
+the @var{DIM} argument is supplied, determines the maximum value along
+each row of the array in the @var{DIM} direction.  If @var{MASK} is
+present, only the elements for which @var{MASK} is @code{.TRUE.} are
+considered.  If the array has zero size, or all of the elements of
+@var{MASK} are @code{.FALSE.}, then the result is @code{-HUGE(ARRAY)}
+if @var{ARRAY} is numeric, or a string of nulls if @var{ARRAY} is of character
+type.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{RESULT = MAXVAL(ARRAY, DIM [, MASK])}
+@item @code{RESULT = MAXVAL(ARRAY [, MASK])}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ARRAY} @tab Shall be an array of type @code{INTEGER} or
+@code{REAL}.
+@item @var{DIM}   @tab (Optional) Shall be a scalar of type
+@code{INTEGER}, with a value between one and the rank of @var{ARRAY},
+inclusive.  It may not be an optional dummy argument.
+@item @var{MASK}  @tab Shall be an array of type @code{LOGICAL},
+and conformable with @var{ARRAY}.
+@end multitable
+
+@item @emph{Return value}:
+If @var{DIM} is absent, or if @var{ARRAY} has a rank of one, the result
+is a scalar.  If @var{DIM} is present, the result is an array with a
+rank one less than the rank of @var{ARRAY}, and a size corresponding to
+the size of @var{ARRAY} with the @var{DIM} dimension removed.  In all
+cases, the result is of the same type and kind as @var{ARRAY}.
+
+@item @emph{See also}:
+@ref{MAX}, @ref{MAXLOC}
+@end table
+
+
+
+@node MCLOCK
+@section @code{MCLOCK} --- Time function
+@fnindex MCLOCK
+@cindex time, clock ticks
+@cindex clock ticks
+
+@table @asis
+@item @emph{Description}:
+Returns the number of clock ticks since the start of the process, based
+on the function @code{clock(3)} in the C standard library.
+
+This intrinsic is not fully portable, such as to systems with 32-bit
+@code{INTEGER} types but supporting times wider than 32 bits. Therefore,
+the values returned by this intrinsic might be, or become, negative, or
+numerically less than previous values, during a single run of the
+compiled program.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Function
+
+@item @emph{Syntax}:
+@code{RESULT = MCLOCK()}
+
+@item @emph{Return value}:
+The return value is a scalar of type @code{INTEGER(4)}, equal to the
+number of clock ticks since the start of the process, or @code{-1} if
+the system does not support @code{clock(3)}.
+
+@item @emph{See also}:
+@ref{CTIME}, @ref{GMTIME}, @ref{LTIME}, @ref{MCLOCK}, @ref{TIME}
+
+@end table
+
+
+
+@node MCLOCK8
+@section @code{MCLOCK8} --- Time function (64-bit)
+@fnindex MCLOCK8
+@cindex time, clock ticks
+@cindex clock ticks
+
+@table @asis
+@item @emph{Description}:
+Returns the number of clock ticks since the start of the process, based
+on the function @code{clock(3)} in the C standard library.
+
+@emph{Warning:} this intrinsic does not increase the range of the timing
+values over that returned by @code{clock(3)}. On a system with a 32-bit
+@code{clock(3)}, @code{MCLOCK8} will return a 32-bit value, even though
+it is converted to a 64-bit @code{INTEGER(8)} value. That means
+overflows of the 32-bit value can still occur. Therefore, the values
+returned by this intrinsic might be or become negative or numerically
+less than previous values during a single run of the compiled program.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Function
+
+@item @emph{Syntax}:
+@code{RESULT = MCLOCK8()}
+
+@item @emph{Return value}:
+The return value is a scalar of type @code{INTEGER(8)}, equal to the
+number of clock ticks since the start of the process, or @code{-1} if
+the system does not support @code{clock(3)}.
+
+@item @emph{See also}:
+@ref{CTIME}, @ref{GMTIME}, @ref{LTIME}, @ref{MCLOCK}, @ref{TIME8}
+
+@end table
+
+
+
+@node MERGE
+@section @code{MERGE} --- Merge variables
+@fnindex MERGE
+@cindex array, merge arrays
+@cindex array, combine arrays
+
+@table @asis
+@item @emph{Description}:
+Select values from two arrays according to a logical mask.  The result
+is equal to @var{TSOURCE} if @var{MASK} is @code{.TRUE.}, or equal to
+@var{FSOURCE} if it is @code{.FALSE.}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = MERGE(TSOURCE, FSOURCE, MASK)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{TSOURCE} @tab May be of any type.
+@item @var{FSOURCE} @tab Shall be of the same type and type parameters
+as @var{TSOURCE}.
+@item @var{MASK}    @tab Shall be of type @code{LOGICAL}.
+@end multitable
+
+@item @emph{Return value}:
+The result is of the same type and type parameters as @var{TSOURCE}.
+
+@end table
+
+
+
+@node MERGE_BITS
+@section @code{MERGE_BITS} --- Merge of bits under mask
+@fnindex MERGE_BITS
+@cindex bits, merge
+
+@table @asis
+@item @emph{Description}:
+@code{MERGE_BITS(I, J, MASK)} merges the bits of @var{I} and @var{J}
+as determined by the mask.  The i-th bit of the result is equal to the 
+i-th bit of @var{I} if the i-th bit of @var{MASK} is 1; it is equal to
+the i-th bit of @var{J} otherwise.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = MERGE_BITS(I, J, MASK)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I}    @tab Shall be of type @code{INTEGER}.
+@item @var{J}    @tab Shall be of type @code{INTEGER} and of the same
+kind as @var{I}.
+@item @var{MASK} @tab Shall be of type @code{INTEGER} and of the same
+kind as @var{I}.
+@end multitable
+
+@item @emph{Return value}:
+The result is of the same type and kind as @var{I}.
+
+@end table
+
+
+
+@node MIN
+@section @code{MIN} --- Minimum value of an argument list
+@fnindex MIN
+@fnindex MIN0
+@fnindex AMIN0
+@fnindex MIN1
+@fnindex AMIN1
+@fnindex DMIN1
+@cindex minimum value
+
+@table @asis
+@item @emph{Description}:
+Returns the argument with the smallest (most negative) value.
+
+@item @emph{Standard}:
+Fortran 77 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = MIN(A1, A2 [, A3, ...])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{A1}          @tab The type shall be @code{INTEGER} or
+@code{REAL}.
+@item @var{A2}, @var{A3}, ... @tab An expression of the same type and kind
+as @var{A1}.  (As a GNU extension, arguments of different kinds are
+permitted.)
+@end multitable
+
+@item @emph{Return value}:
+The return value corresponds to the maximum value among the arguments,
+and has the same type and kind as the first argument.
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name              @tab Argument             @tab Return type        @tab Standard
+@item @code{MIN0(A1)}   @tab @code{INTEGER(4) A1} @tab @code{INTEGER(4)}  @tab Fortran 77 and later
+@item @code{AMIN0(A1)}  @tab @code{INTEGER(4) A1} @tab @code{REAL(4)}     @tab Fortran 77 and later
+@item @code{MIN1(A1)}   @tab @code{REAL A1}       @tab @code{INTEGER(4)}  @tab Fortran 77 and later
+@item @code{AMIN1(A1)}  @tab @code{REAL(4) A1}    @tab @code{REAL(4)}     @tab Fortran 77 and later
+@item @code{DMIN1(A1)}  @tab @code{REAL(8) A1}    @tab @code{REAL(8)}     @tab Fortran 77 and later
+@end multitable
+
+@item @emph{See also}:
+@ref{MAX}, @ref{MINLOC}, @ref{MINVAL}
+@end table
+
+
+
+@node MINEXPONENT
+@section @code{MINEXPONENT} --- Minimum exponent of a real kind
+@fnindex MINEXPONENT
+@cindex model representation, minimum exponent
+
+@table @asis
+@item @emph{Description}:
+@code{MINEXPONENT(X)} returns the minimum exponent in the model of the
+type of @code{X}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{RESULT = MINEXPONENT(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab Shall be of type @code{REAL}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of the default integer
+kind.
+
+@item @emph{Example}:
+See @code{MAXEXPONENT} for an example.
+@end table
+
+
+
+@node MINLOC
+@section @code{MINLOC} --- Location of the minimum value within an array
+@fnindex MINLOC
+@cindex array, location of minimum element
+
+@table @asis
+@item @emph{Description}:
+Determines the location of the element in the array with the minimum
+value, or, if the @var{DIM} argument is supplied, determines the
+locations of the minimum element along each row of the array in the
+@var{DIM} direction.  If @var{MASK} is present, only the elements for
+which @var{MASK} is @code{.TRUE.} are considered.  If more than one
+element in the array has the minimum value, the location returned is
+that of the first such element in array element order.  If the array has
+zero size, or all of the elements of @var{MASK} are @code{.FALSE.}, then
+the result is an array of zeroes.  Similarly, if @var{DIM} is supplied
+and all of the elements of @var{MASK} along a given row are zero, the
+result value for that row is zero.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{RESULT = MINLOC(ARRAY, DIM [, MASK])}
+@item @code{RESULT = MINLOC(ARRAY [, MASK])}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ARRAY} @tab Shall be an array of type @code{INTEGER} or
+@code{REAL}.
+@item @var{DIM}   @tab (Optional) Shall be a scalar of type
+@code{INTEGER}, with a value between one and the rank of @var{ARRAY},
+inclusive.  It may not be an optional dummy argument.
+@item @var{MASK}  @tab Shall be an array of type @code{LOGICAL},
+and conformable with @var{ARRAY}.
+@end multitable
+
+@item @emph{Return value}:
+If @var{DIM} is absent, the result is a rank-one array with a length
+equal to the rank of @var{ARRAY}.  If @var{DIM} is present, the result
+is an array with a rank one less than the rank of @var{ARRAY}, and a
+size corresponding to the size of @var{ARRAY} with the @var{DIM}
+dimension removed.  If @var{DIM} is present and @var{ARRAY} has a rank
+of one, the result is a scalar.  In all cases, the result is of default
+@code{INTEGER} type.
+
+@item @emph{See also}:
+@ref{MIN}, @ref{MINVAL}
+
+@end table
+
+
+
+@node MINVAL
+@section @code{MINVAL} --- Minimum value of an array
+@fnindex MINVAL
+@cindex array, minimum value
+@cindex minimum value
+
+@table @asis
+@item @emph{Description}:
+Determines the minimum value of the elements in an array value, or, if
+the @var{DIM} argument is supplied, determines the minimum value along
+each row of the array in the @var{DIM} direction.  If @var{MASK} is
+present, only the elements for which @var{MASK} is @code{.TRUE.} are
+considered.  If the array has zero size, or all of the elements of
+@var{MASK} are @code{.FALSE.}, then the result is @code{HUGE(ARRAY)} if
+@var{ARRAY} is numeric, or a string of @code{CHAR(255)} characters if
+@var{ARRAY} is of character type.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{RESULT = MINVAL(ARRAY, DIM [, MASK])}
+@item @code{RESULT = MINVAL(ARRAY [, MASK])}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ARRAY} @tab Shall be an array of type @code{INTEGER} or
+@code{REAL}.
+@item @var{DIM}   @tab (Optional) Shall be a scalar of type
+@code{INTEGER}, with a value between one and the rank of @var{ARRAY},
+inclusive.  It may not be an optional dummy argument.
+@item @var{MASK}  @tab Shall be an array of type @code{LOGICAL},
+and conformable with @var{ARRAY}.
+@end multitable
+
+@item @emph{Return value}:
+If @var{DIM} is absent, or if @var{ARRAY} has a rank of one, the result
+is a scalar.  If @var{DIM} is present, the result is an array with a
+rank one less than the rank of @var{ARRAY}, and a size corresponding to
+the size of @var{ARRAY} with the @var{DIM} dimension removed.  In all
+cases, the result is of the same type and kind as @var{ARRAY}.
+
+@item @emph{See also}:
+@ref{MIN}, @ref{MINLOC}
+
+@end table
+
+
+
+@node MOD
+@section @code{MOD} --- Remainder function
+@fnindex MOD
+@fnindex AMOD
+@fnindex DMOD
+@cindex remainder
+@cindex division, remainder
+
+@table @asis
+@item @emph{Description}:
+@code{MOD(A,P)} computes the remainder of the division of A by P@. 
+
+@item @emph{Standard}:
+Fortran 77 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = MOD(A, P)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{A} @tab Shall be a scalar of type @code{INTEGER} or @code{REAL}.
+@item @var{P} @tab Shall be a scalar of the same type and kind as @var{A} 
+and not equal to zero.
+@end multitable
+
+@item @emph{Return value}:
+The return value is the result of @code{A - (INT(A/P) * P)}. The type
+and kind of the return value is the same as that of the arguments. The
+returned value has the same sign as A and a magnitude less than the
+magnitude of P.
+
+@item @emph{Example}:
+@smallexample
+program test_mod
+  print *, mod(17,3)
+  print *, mod(17.5,5.5)
+  print *, mod(17.5d0,5.5)
+  print *, mod(17.5,5.5d0)
+
+  print *, mod(-17,3)
+  print *, mod(-17.5,5.5)
+  print *, mod(-17.5d0,5.5)
+  print *, mod(-17.5,5.5d0)
+
+  print *, mod(17,-3)
+  print *, mod(17.5,-5.5)
+  print *, mod(17.5d0,-5.5)
+  print *, mod(17.5,-5.5d0)
+end program test_mod
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name             @tab Arguments          @tab Return type    @tab Standard
+@item @code{MOD(A,P)}  @tab @code{INTEGER A,P} @tab @code{INTEGER} @tab Fortran 95 and later
+@item @code{AMOD(A,P)} @tab @code{REAL(4) A,P} @tab @code{REAL(4)} @tab Fortran 95 and later
+@item @code{DMOD(A,P)} @tab @code{REAL(8) A,P} @tab @code{REAL(8)} @tab Fortran 95 and later
+@end multitable
+
+@item @emph{See also}:
+@ref{MODULO}
+
+@end table
+
+
+
+@node MODULO
+@section @code{MODULO} --- Modulo function
+@fnindex MODULO
+@cindex modulo
+@cindex division, modulo
+
+@table @asis
+@item @emph{Description}:
+@code{MODULO(A,P)} computes the @var{A} modulo @var{P}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = MODULO(A, P)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{A} @tab Shall be a scalar of type @code{INTEGER} or @code{REAL}.
+@item @var{P} @tab Shall be a scalar of the same type and kind as @var{A}. 
+It shall not be zero.
+@end multitable
+
+@item @emph{Return value}:
+The type and kind of the result are those of the arguments.
+@table @asis
+@item If @var{A} and @var{P} are of type @code{INTEGER}:
+@code{MODULO(A,P)} has the value @var{R} such that @code{A=Q*P+R}, where
+@var{Q} is an integer and @var{R} is between 0 (inclusive) and @var{P}
+(exclusive).
+@item If @var{A} and @var{P} are of type @code{REAL}:
+@code{MODULO(A,P)} has the value of @code{A - FLOOR (A / P) * P}.
+@end table
+The returned value has the same sign as P and a magnitude less than
+the magnitude of P.
+
+@item @emph{Example}:
+@smallexample
+program test_modulo
+  print *, modulo(17,3)
+  print *, modulo(17.5,5.5)
+
+  print *, modulo(-17,3)
+  print *, modulo(-17.5,5.5)
+
+  print *, modulo(17,-3)
+  print *, modulo(17.5,-5.5)
+end program
+@end smallexample
+
+@item @emph{See also}:
+@ref{MOD}
+
+@end table
+
+
+
+@node MOVE_ALLOC
+@section @code{MOVE_ALLOC} --- Move allocation from one object to another
+@fnindex MOVE_ALLOC
+@cindex moving allocation
+@cindex allocation, moving
+
+@table @asis
+@item @emph{Description}:
+@code{MOVE_ALLOC(FROM, TO)} moves the allocation from @var{FROM} to
+@var{TO}.  @var{FROM} will become deallocated in the process.
+
+@item @emph{Standard}:
+Fortran 2003 and later
+
+@item @emph{Class}:
+Pure subroutine
+
+@item @emph{Syntax}:
+@code{CALL MOVE_ALLOC(FROM, TO)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{FROM}  @tab @code{ALLOCATABLE}, @code{INTENT(INOUT)}, may be
+of any type and kind.
+@item @var{TO} @tab @code{ALLOCATABLE}, @code{INTENT(OUT)}, shall be
+of the same type, kind and rank as @var{FROM}.
+@end multitable
+
+@item @emph{Return value}:
+None
+
+@item @emph{Example}:
+@smallexample
+program test_move_alloc
+    integer, allocatable :: a(:), b(:)
+
+    allocate(a(3))
+    a = [ 1, 2, 3 ]
+    call move_alloc(a, b)
+    print *, allocated(a), allocated(b)
+    print *, b
+end program test_move_alloc
+@end smallexample
+@end table
+
+
+
+@node MVBITS
+@section @code{MVBITS} --- Move bits from one integer to another
+@fnindex MVBITS
+@cindex bits, move
+
+@table @asis
+@item @emph{Description}:
+Moves @var{LEN} bits from positions @var{FROMPOS} through
+@code{FROMPOS+LEN-1} of @var{FROM} to positions @var{TOPOS} through
+@code{TOPOS+LEN-1} of @var{TO}. The portion of argument @var{TO} not
+affected by the movement of bits is unchanged. The values of
+@code{FROMPOS+LEN-1} and @code{TOPOS+LEN-1} must be less than
+@code{BIT_SIZE(FROM)}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Elemental subroutine
+
+@item @emph{Syntax}:
+@code{CALL MVBITS(FROM, FROMPOS, LEN, TO, TOPOS)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{FROM}    @tab The type shall be @code{INTEGER}.
+@item @var{FROMPOS} @tab The type shall be @code{INTEGER}.
+@item @var{LEN}     @tab The type shall be @code{INTEGER}.
+@item @var{TO}      @tab The type shall be @code{INTEGER}, of the
+same kind as @var{FROM}.
+@item @var{TOPOS}   @tab The type shall be @code{INTEGER}.
+@end multitable
+
+@item @emph{See also}:
+@ref{IBCLR}, @ref{IBSET}, @ref{IBITS}, @ref{IAND}, @ref{IOR}, @ref{IEOR}
+@end table
+
+
+
+@node NEAREST
+@section @code{NEAREST} --- Nearest representable number
+@fnindex NEAREST
+@cindex real number, nearest different
+@cindex floating point, nearest different
+
+@table @asis
+@item @emph{Description}:
+@code{NEAREST(X, S)} returns the processor-representable number nearest
+to @code{X} in the direction indicated by the sign of @code{S}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = NEAREST(X, S)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab Shall be of type @code{REAL}.
+@item @var{S} @tab Shall be of type @code{REAL} and
+not equal to zero.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of the same type as @code{X}. If @code{S} is
+positive, @code{NEAREST} returns the processor-representable number
+greater than @code{X} and nearest to it. If @code{S} is negative,
+@code{NEAREST} returns the processor-representable number smaller than
+@code{X} and nearest to it.
+
+@item @emph{Example}:
+@smallexample
+program test_nearest
+  real :: x, y
+  x = nearest(42.0, 1.0)
+  y = nearest(42.0, -1.0)
+  write (*,"(3(G20.15))") x, y, x - y
+end program test_nearest
+@end smallexample
+@end table
+
+
+
+@node NEW_LINE
+@section @code{NEW_LINE} --- New line character
+@fnindex NEW_LINE
+@cindex newline
+@cindex output, newline
+
+@table @asis
+@item @emph{Description}:
+@code{NEW_LINE(C)} returns the new-line character.
+
+@item @emph{Standard}:
+Fortran 2003 and later
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{RESULT = NEW_LINE(C)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{C}    @tab The argument shall be a scalar or array of the
+type @code{CHARACTER}.
+@end multitable
+
+@item @emph{Return value}:
+Returns a @var{CHARACTER} scalar of length one with the new-line character of
+the same kind as parameter @var{C}.
+
+@item @emph{Example}:
+@smallexample
+program newline
+  implicit none
+  write(*,'(A)') 'This is record 1.'//NEW_LINE('A')//'This is record 2.'
+end program newline
+@end smallexample
+@end table
+
+
+
+@node NINT
+@section @code{NINT} --- Nearest whole number
+@fnindex NINT
+@fnindex IDNINT
+@cindex rounding, nearest whole number
+
+@table @asis
+@item @emph{Description}:
+@code{NINT(A)} rounds its argument to the nearest whole number.
+
+@item @emph{Standard}:
+Fortran 77 and later, with @var{KIND} argument Fortran 90 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = NINT(A [, KIND])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{A}    @tab The type of the argument shall be @code{REAL}.
+@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
+expression indicating the kind parameter of the result.
+@end multitable
+
+@item @emph{Return value}:
+Returns @var{A} with the fractional portion of its magnitude eliminated by
+rounding to the nearest whole number and with its sign preserved,
+converted to an @code{INTEGER} of the default kind.
+
+@item @emph{Example}:
+@smallexample
+program test_nint
+  real(4) x4
+  real(8) x8
+  x4 = 1.234E0_4
+  x8 = 4.321_8
+  print *, nint(x4), idnint(x8)
+end program test_nint
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name             @tab Argument           @tab Return Type     @tab Standard
+@item @code{NINT(A)}   @tab @code{REAL(4) A}   @tab  @code{INTEGER} @tab Fortran 95 and later
+@item @code{IDNINT(A)} @tab @code{REAL(8) A}   @tab  @code{INTEGER} @tab Fortran 95 and later
+@end multitable
+
+@item @emph{See also}:
+@ref{CEILING}, @ref{FLOOR}
+
+@end table
+
+
+
+@node NORM2
+@section @code{NORM2} --- Euclidean vector norms
+@fnindex NORM2
+@cindex Euclidean vector norm
+@cindex L2 vector norm
+@cindex norm, Euclidean
+
+@table @asis
+@item @emph{Description}:
+Calculates the Euclidean vector norm (@math{L_2} norm) of
+of @var{ARRAY} along dimension @var{DIM}.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{RESULT = NORM2(ARRAY[, DIM])}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ARRAY} @tab Shall be an array of type @code{REAL}
+@item @var{DIM}   @tab (Optional) shall be a scalar of type 
+@code{INTEGER} with a value in the range from 1 to n, where n 
+equals the rank of @var{ARRAY}.
+@end multitable
+
+@item @emph{Return value}:
+The result is of the same type as @var{ARRAY}.
+
+If @var{DIM} is absent, a scalar with the square root of the sum of all
+elements in @var{ARRAY} squared  is returned. Otherwise, an array of
+rank @math{n-1}, where @math{n} equals the rank of @var{ARRAY}, and a
+shape similar to that of @var{ARRAY} with dimension @var{DIM} dropped
+is returned.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_sum
+  REAL :: x(5) = [ real :: 1, 2, 3, 4, 5 ]
+  print *, NORM2(x)  ! = sqrt(55.) ~ 7.416
+END PROGRAM
+@end smallexample
+@end table
+
+
+
+@node NOT
+@section @code{NOT} --- Logical negation
+@fnindex NOT
+@cindex bits, negate
+@cindex bitwise logical not
+@cindex logical not, bitwise
+
+@table @asis
+@item @emph{Description}:
+@code{NOT} returns the bitwise Boolean inverse of @var{I}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = NOT(I)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab The type shall be @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The return type is @code{INTEGER}, of the same kind as the
+argument.
+
+@item @emph{See also}:
+@ref{IAND}, @ref{IEOR}, @ref{IOR}, @ref{IBITS}, @ref{IBSET}, @ref{IBCLR}
+
+@end table
+
+
+
+@node NULL
+@section @code{NULL} --- Function that returns an disassociated pointer
+@fnindex NULL
+@cindex pointer, status
+@cindex pointer, disassociated
+
+@table @asis
+@item @emph{Description}:
+Returns a disassociated pointer.
+
+If @var{MOLD} is present, a disassociated pointer of the same type is
+returned, otherwise the type is determined by context.
+
+In Fortran 95, @var{MOLD} is optional. Please note that Fortran 2003
+includes cases where it is required.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@code{PTR => NULL([MOLD])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{MOLD} @tab (Optional) shall be a pointer of any association
+status and of any type.
+@end multitable
+
+@item @emph{Return value}:
+A disassociated pointer.
+
+@item @emph{Example}:
+@smallexample
+REAL, POINTER, DIMENSION(:) :: VEC => NULL ()
+@end smallexample
+
+@item @emph{See also}:
+@ref{ASSOCIATED}
+@end table
+
+
+
+@node NUM_IMAGES
+@section @code{NUM_IMAGES} --- Function that returns the number of images
+@fnindex NUM_IMAGES
+@cindex coarray, @code{NUM_IMAGES}
+@cindex images, number of
+
+@table @asis
+@item @emph{Description}:
+Returns the number of images.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@code{RESULT = NUM_IMAGES()}
+
+@item @emph{Arguments}: None.
+
+@item @emph{Return value}:
+Scalar default-kind integer.
+
+@item @emph{Example}:
+@smallexample
+INTEGER :: value[*]
+INTEGER :: i
+value = THIS_IMAGE()
+SYNC ALL
+IF (THIS_IMAGE() == 1) THEN
+  DO i = 1, NUM_IMAGES()
+    WRITE(*,'(2(a,i0))') 'value[', i, '] is ', value[i]
+  END DO
+END IF
+@end smallexample
+
+@item @emph{See also}:
+@ref{THIS_IMAGE}, @ref{IMAGE_INDEX}
+@end table
+
+
+
+@node OR
+@section @code{OR} --- Bitwise logical OR
+@fnindex OR
+@cindex bitwise logical or
+@cindex logical or, bitwise
+
+@table @asis
+@item @emph{Description}:
+Bitwise logical @code{OR}.
+
+This intrinsic routine is provided for backwards compatibility with 
+GNU Fortran 77.  For integer arguments, programmers should consider
+the use of the @ref{IOR} intrinsic defined by the Fortran standard.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Function
+
+@item @emph{Syntax}:
+@code{RESULT = OR(I, J)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab The type shall be either a scalar @code{INTEGER}
+type or a scalar @code{LOGICAL} type.
+@item @var{J} @tab The type shall be the same as the type of @var{J}.
+@end multitable
+
+@item @emph{Return value}:
+The return type is either a scalar @code{INTEGER} or a scalar
+@code{LOGICAL}.  If the kind type parameters differ, then the
+smaller kind type is implicitly converted to larger kind, and the 
+return has the larger kind.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_or
+  LOGICAL :: T = .TRUE., F = .FALSE.
+  INTEGER :: a, b
+  DATA a / Z'F' /, b / Z'3' /
+
+  WRITE (*,*) OR(T, T), OR(T, F), OR(F, T), OR(F, F)
+  WRITE (*,*) OR(a, b)
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+Fortran 95 elemental function: @ref{IOR}
+@end table
+
+
+
+@node PACK
+@section @code{PACK} --- Pack an array into an array of rank one
+@fnindex PACK
+@cindex array, packing
+@cindex array, reduce dimension
+@cindex array, gather elements
+
+@table @asis
+@item @emph{Description}:
+Stores the elements of @var{ARRAY} in an array of rank one.
+
+The beginning of the resulting array is made up of elements whose @var{MASK} 
+equals @code{TRUE}. Afterwards, positions are filled with elements taken from
+@var{VECTOR}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@code{RESULT = PACK(ARRAY, MASK[,VECTOR])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ARRAY}  @tab Shall be an array of any type.
+@item @var{MASK}   @tab Shall be an array of type @code{LOGICAL} and 
+of the same size as @var{ARRAY}. Alternatively, it may be a @code{LOGICAL} 
+scalar.
+@item @var{VECTOR} @tab (Optional) shall be an array of the same type 
+as @var{ARRAY} and of rank one. If present, the number of elements in 
+@var{VECTOR} shall be equal to or greater than the number of true elements 
+in @var{MASK}. If @var{MASK} is scalar, the number of elements in 
+@var{VECTOR} shall be equal to or greater than the number of elements in
+@var{ARRAY}.
+@end multitable
+
+@item @emph{Return value}:
+The result is an array of rank one and the same type as that of @var{ARRAY}.
+If @var{VECTOR} is present, the result size is that of @var{VECTOR}, the
+number of @code{TRUE} values in @var{MASK} otherwise.
+
+@item @emph{Example}:
+Gathering nonzero elements from an array:
+@smallexample
+PROGRAM test_pack_1
+  INTEGER :: m(6)
+  m = (/ 1, 0, 0, 0, 5, 0 /)
+  WRITE(*, FMT="(6(I0, ' '))") pack(m, m /= 0)  ! "1 5"
+END PROGRAM
+@end smallexample
+
+Gathering nonzero elements from an array and appending elements from @var{VECTOR}:
+@smallexample
+PROGRAM test_pack_2
+  INTEGER :: m(4)
+  m = (/ 1, 0, 0, 2 /)
+  WRITE(*, FMT="(4(I0, ' '))") pack(m, m /= 0, (/ 0, 0, 3, 4 /))  ! "1 2 3 4"
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{UNPACK}
+@end table
+
+
+
+@node PARITY
+@section @code{PARITY} --- Reduction with exclusive OR
+@fnindex PARITY
+@cindex Parity
+@cindex Reduction, XOR
+@cindex XOR reduction
+
+@table @asis
+@item @emph{Description}:
+Calculates the parity, i.e. the reduction using @code{.XOR.},
+of @var{MASK} along dimension @var{DIM}.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{RESULT = PARITY(MASK[, DIM])}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{LOGICAL} @tab Shall be an array of type @code{LOGICAL}
+@item @var{DIM}   @tab (Optional) shall be a scalar of type 
+@code{INTEGER} with a value in the range from 1 to n, where n 
+equals the rank of @var{MASK}.
+@end multitable
+
+@item @emph{Return value}:
+The result is of the same type as @var{MASK}.
+
+If @var{DIM} is absent, a scalar with the parity of all elements in
+@var{MASK} is returned, i.e. true if an odd number of elements is
+@code{.true.} and false otherwise.  If @var{DIM} is present, an array
+of rank @math{n-1}, where @math{n} equals the rank of @var{ARRAY},
+and a shape similar to that of @var{MASK} with dimension @var{DIM}
+dropped is returned.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_sum
+  LOGICAL :: x(2) = [ .true., .false. ]
+  print *, PARITY(x) ! prints "T" (true).
+END PROGRAM
+@end smallexample
+@end table
+
+
+
+@node PERROR
+@section @code{PERROR} --- Print system error message
+@fnindex PERROR
+@cindex system, error handling
+
+@table @asis
+@item @emph{Description}:
+Prints (on the C @code{stderr} stream) a newline-terminated error
+message corresponding to the last system error. This is prefixed by
+@var{STRING}, a colon and a space. See @code{perror(3)}.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine
+
+@item @emph{Syntax}:
+@code{CALL PERROR(STRING)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{STRING} @tab A scalar of type @code{CHARACTER} and of the
+default kind.
+@end multitable
+
+@item @emph{See also}:
+@ref{IERRNO}
+@end table
+
+
+
+@node POPCNT
+@section @code{POPCNT} --- Number of bits set
+@fnindex POPCNT
+@cindex binary representation
+@cindex bits set
+
+@table @asis
+@item @emph{Description}:
+@code{POPCNT(I)} returns the number of bits set ('1' bits) in the binary
+representation of @code{I}.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = POPCNT(I)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab Shall be of type @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of the default integer
+kind.
+
+@item @emph{See also}:
+@ref{POPPAR}, @ref{LEADZ}, @ref{TRAILZ}
+
+@item @emph{Example}:
+@smallexample
+program test_population
+  print *, popcnt(127),       poppar(127)
+  print *, popcnt(huge(0_4)), poppar(huge(0_4))
+  print *, popcnt(huge(0_8)), poppar(huge(0_8))
+end program test_population
+@end smallexample
+@end table
+
+
+@node POPPAR
+@section @code{POPPAR} --- Parity of the number of bits set
+@fnindex POPPAR
+@cindex binary representation
+@cindex parity
+
+@table @asis
+@item @emph{Description}:
+@code{POPPAR(I)} returns parity of the integer @code{I}, i.e. the parity
+of the number of bits set ('1' bits) in the binary representation of
+@code{I}. It is equal to 0 if @code{I} has an even number of bits set,
+and 1 for an odd number of '1' bits.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = POPPAR(I)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab Shall be of type @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of the default integer
+kind.
+
+@item @emph{See also}:
+@ref{POPCNT}, @ref{LEADZ}, @ref{TRAILZ}
+
+@item @emph{Example}:
+@smallexample
+program test_population
+  print *, popcnt(127),       poppar(127)
+  print *, popcnt(huge(0_4)), poppar(huge(0_4))
+  print *, popcnt(huge(0_8)), poppar(huge(0_8))
+end program test_population
+@end smallexample
+@end table
+
+
+
+@node PRECISION
+@section @code{PRECISION} --- Decimal precision of a real kind
+@fnindex PRECISION
+@cindex model representation, precision
+
+@table @asis
+@item @emph{Description}:
+@code{PRECISION(X)} returns the decimal precision in the model of the
+type of @code{X}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{RESULT = PRECISION(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab Shall be of type @code{REAL} or @code{COMPLEX}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of the default integer
+kind.
+
+@item @emph{See also}:
+@ref{SELECTED_REAL_KIND}, @ref{RANGE}
+
+@item @emph{Example}:
+@smallexample
+program prec_and_range
+  real(kind=4) :: x(2)
+  complex(kind=8) :: y
+
+  print *, precision(x), range(x)
+  print *, precision(y), range(y)
+end program prec_and_range
+@end smallexample
+@end table
+
+
+
+@node PRESENT
+@section @code{PRESENT} --- Determine whether an optional dummy argument is specified
+@fnindex PRESENT
+
+@table @asis
+@item @emph{Description}:
+Determines whether an optional dummy argument is present.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{RESULT = PRESENT(A)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{A} @tab May be of any type and may be a pointer, scalar or array
+value, or a dummy procedure. It shall be the name of an optional dummy argument
+accessible within the current subroutine or function.
+@end multitable
+
+@item @emph{Return value}:
+Returns either @code{TRUE} if the optional argument @var{A} is present, or
+@code{FALSE} otherwise.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_present
+  WRITE(*,*) f(), f(42)      ! "F T"
+CONTAINS
+  LOGICAL FUNCTION f(x)
+    INTEGER, INTENT(IN), OPTIONAL :: x
+    f = PRESENT(x)
+  END FUNCTION
+END PROGRAM
+@end smallexample
+@end table
+
+
+
+@node PRODUCT
+@section @code{PRODUCT} --- Product of array elements
+@fnindex PRODUCT
+@cindex array, product
+@cindex array, multiply elements
+@cindex array, conditionally multiply elements
+@cindex multiply array elements
+
+@table @asis
+@item @emph{Description}:
+Multiplies the elements of @var{ARRAY} along dimension @var{DIM} if
+the corresponding element in @var{MASK} is @code{TRUE}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{RESULT = PRODUCT(ARRAY[, MASK])}
+@item @code{RESULT = PRODUCT(ARRAY, DIM[, MASK])}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ARRAY} @tab Shall be an array of type @code{INTEGER}, 
+@code{REAL} or @code{COMPLEX}.
+@item @var{DIM}   @tab (Optional) shall be a scalar of type 
+@code{INTEGER} with a value in the range from 1 to n, where n 
+equals the rank of @var{ARRAY}.
+@item @var{MASK}  @tab (Optional) shall be of type @code{LOGICAL} 
+and either be a scalar or an array of the same shape as @var{ARRAY}.
+@end multitable
+
+@item @emph{Return value}:
+The result is of the same type as @var{ARRAY}.
+
+If @var{DIM} is absent, a scalar with the product of all elements in 
+@var{ARRAY} is returned. Otherwise, an array of rank n-1, where n equals 
+the rank of @var{ARRAY}, and a shape similar to that of @var{ARRAY} with 
+dimension @var{DIM} dropped is returned.
+
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_product
+  INTEGER :: x(5) = (/ 1, 2, 3, 4 ,5 /)
+  print *, PRODUCT(x)                    ! all elements, product = 120
+  print *, PRODUCT(x, MASK=MOD(x, 2)==1) ! odd elements, product = 15
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{SUM}
+@end table
+
+
+
+@node RADIX
+@section @code{RADIX} --- Base of a model number
+@fnindex RADIX
+@cindex model representation, base
+@cindex model representation, radix
+
+@table @asis
+@item @emph{Description}:
+@code{RADIX(X)} returns the base of the model representing the entity @var{X}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{RESULT = RADIX(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab Shall be of type @code{INTEGER} or @code{REAL}
+@end multitable
+
+@item @emph{Return value}:
+The return value is a scalar of type @code{INTEGER} and of the default
+integer kind.
+
+@item @emph{See also}:
+@ref{SELECTED_REAL_KIND}
+
+@item @emph{Example}:
+@smallexample
+program test_radix
+  print *, "The radix for the default integer kind is", radix(0)
+  print *, "The radix for the default real kind is", radix(0.0)
+end program test_radix
+@end smallexample
+
+@end table
+
+
+
+@node RAN
+@section @code{RAN} --- Real pseudo-random number
+@fnindex RAN
+@cindex random number generation
+
+@table @asis
+@item @emph{Description}:
+For compatibility with HP FORTRAN 77/iX, the @code{RAN} intrinsic is
+provided as an alias for @code{RAND}.  See @ref{RAND} for complete
+documentation.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Function
+
+@item @emph{See also}:
+@ref{RAND}, @ref{RANDOM_NUMBER}
+@end table
+
+
+
+@node RAND
+@section @code{RAND} --- Real pseudo-random number
+@fnindex RAND
+@cindex random number generation
+
+@table @asis
+@item @emph{Description}:
+@code{RAND(FLAG)} returns a pseudo-random number from a uniform
+distribution between 0 and 1. If @var{FLAG} is 0, the next number
+in the current sequence is returned; if @var{FLAG} is 1, the generator
+is restarted by @code{CALL SRAND(0)}; if @var{FLAG} has any other value,
+it is used as a new seed with @code{SRAND}.
+
+This intrinsic routine is provided for backwards compatibility with
+GNU Fortran 77. It implements a simple modulo generator as provided 
+by @command{g77}. For new code, one should consider the use of 
+@ref{RANDOM_NUMBER} as it implements a superior algorithm.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Function
+
+@item @emph{Syntax}:
+@code{RESULT = RAND(I)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab Shall be a scalar @code{INTEGER} of kind 4.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of @code{REAL} type and the default kind.
+
+@item @emph{Example}:
+@smallexample
+program test_rand
+  integer,parameter :: seed = 86456
+  
+  call srand(seed)
+  print *, rand(), rand(), rand(), rand()
+  print *, rand(seed), rand(), rand(), rand()
+end program test_rand
+@end smallexample
+
+@item @emph{See also}:
+@ref{SRAND}, @ref{RANDOM_NUMBER}
+
+@end table
+
+
+
+@node RANDOM_NUMBER
+@section @code{RANDOM_NUMBER} --- Pseudo-random number
+@fnindex RANDOM_NUMBER
+@cindex random number generation
+
+@table @asis
+@item @emph{Description}:
+Returns a single pseudorandom number or an array of pseudorandom numbers
+from the uniform distribution over the range @math{ 0 \leq x < 1}.
+
+The runtime-library implements George Marsaglia's KISS (Keep It Simple 
+Stupid) random number generator (RNG). This RNG combines:
+@enumerate
+@item The congruential generator @math{x(n) = 69069 \cdot x(n-1) + 1327217885}
+with a period of @math{2^{32}},
+@item A 3-shift shift-register generator with a period of @math{2^{32} - 1},
+@item  Two 16-bit multiply-with-carry generators with a period of
+@math{597273182964842497 > 2^{59}}.
+@end enumerate
+The overall period exceeds @math{2^{123}}.
+
+Please note, this RNG is thread safe if used within OpenMP directives,
+i.e., its state will be consistent while called from multiple threads.
+However, the KISS generator does not create random numbers in parallel 
+from multiple sources, but in sequence from a single source. If an
+OpenMP-enabled application heavily relies on random numbers, one should 
+consider employing a dedicated parallel random number generator instead.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Subroutine
+
+@item @emph{Syntax}:
+@code{RANDOM_NUMBER(HARVEST)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{HARVEST} @tab Shall be a scalar or an array of type @code{REAL}.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+program test_random_number
+  REAL :: r(5,5)
+  CALL init_random_seed()         ! see example of RANDOM_SEED
+  CALL RANDOM_NUMBER(r)
+end program
+@end smallexample
+
+@item @emph{See also}:
+@ref{RANDOM_SEED}
+@end table
+
+
+
+@node RANDOM_SEED
+@section @code{RANDOM_SEED} --- Initialize a pseudo-random number sequence
+@fnindex RANDOM_SEED
+@cindex random number generation, seeding
+@cindex seeding a random number generator
+
+@table @asis
+@item @emph{Description}:
+Restarts or queries the state of the pseudorandom number generator used by 
+@code{RANDOM_NUMBER}.
+
+If @code{RANDOM_SEED} is called without arguments, it is initialized
+to a default state. The example below shows how to initialize the
+random seed with a varying seed in order to ensure a different random
+number sequence for each invocation of the program. Note that setting
+any of the seed values to zero should be avoided as it can result in
+poor quality random numbers being generated.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Subroutine
+
+@item @emph{Syntax}:
+@code{CALL RANDOM_SEED([SIZE, PUT, GET])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{SIZE} @tab (Optional) Shall be a scalar and of type default 
+@code{INTEGER}, with @code{INTENT(OUT)}. It specifies the minimum size 
+of the arrays used with the @var{PUT} and @var{GET} arguments.
+@item @var{PUT}  @tab (Optional) Shall be an array of type default 
+@code{INTEGER} and rank one. It is @code{INTENT(IN)} and the size of 
+the array must be larger than or equal to the number returned by the 
+@var{SIZE} argument.
+@item @var{GET}  @tab (Optional) Shall be an array of type default 
+@code{INTEGER} and rank one. It is @code{INTENT(OUT)} and the size 
+of the array must be larger than or equal to the number returned by 
+the @var{SIZE} argument.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+subroutine init_random_seed()
+  implicit none
+  integer, allocatable :: seed(:)
+  integer :: i, n, un, istat, dt(8), pid, t(2), s
+  integer(8) :: count, tms
+  
+  call random_seed(size = n)
+  allocate(seed(n))
+  ! First try if the OS provides a random number generator
+  open(newunit=un, file="/dev/urandom", access="stream", &
+       form="unformatted", action="read", status="old", iostat=istat)
+  if (istat == 0) then
+     read(un) seed
+     close(un)
+  else
+     ! Fallback to XOR:ing the current time and pid. The PID is
+     ! useful in case one launches multiple instances of the same
+     ! program in parallel.
+     call system_clock(count)
+     if (count /= 0) then
+        t = transfer(count, t)
+     else
+        call date_and_time(values=dt)
+        tms = (dt(1) - 1970) * 365_8 * 24 * 60 * 60 * 1000 &
+             + dt(2) * 31_8 * 24 * 60 * 60 * 1000 &
+             + dt(3) * 24 * 60 * 60 * 60 * 1000 &
+             + dt(5) * 60 * 60 * 1000 &
+             + dt(6) * 60 * 1000 + dt(7) * 1000 &
+             + dt(8)
+        t = transfer(tms, t)
+     end if
+     s = ieor(t(1), t(2))
+     pid = getpid() + 1099279 ! Add a prime
+     s = ieor(s, pid)
+     if (n >= 3) then
+        seed(1) = t(1) + 36269
+        seed(2) = t(2) + 72551
+        seed(3) = pid
+        if (n > 3) then
+           seed(4:) = s + 37 * (/ (i, i = 0, n - 4) /)
+        end if
+     else 
+        seed = s + 37 * (/ (i, i = 0, n - 1 ) /)
+     end if
+  end if
+  call random_seed(put=seed)
+end subroutine init_random_seed
+@end smallexample
+
+@item @emph{See also}:
+@ref{RANDOM_NUMBER}
+@end table
+
+
+
+@node RANGE
+@section @code{RANGE} --- Decimal exponent range
+@fnindex RANGE
+@cindex model representation, range
+
+@table @asis
+@item @emph{Description}:
+@code{RANGE(X)} returns the decimal exponent range in the model of the
+type of @code{X}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{RESULT = RANGE(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab Shall be of type @code{INTEGER}, @code{REAL}
+or @code{COMPLEX}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of the default integer
+kind.
+
+@item @emph{See also}:
+@ref{SELECTED_REAL_KIND}, @ref{PRECISION}
+
+@item @emph{Example}:
+See @code{PRECISION} for an example.
+@end table
+
+
+
+@node RANK
+@section @code{RANK} --- Rank of a data object
+@fnindex RANK
+@cindex rank
+
+@table @asis
+@item @emph{Description}:
+@code{RANK(A)} returns the rank of a scalar or array data object.
+
+@item @emph{Standard}:
+Technical Specification (TS) 29113
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{RESULT = RANK(A)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{A} @tab can be of any type
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of the default integer
+kind. For arrays, their rank is returned; for scalars zero is returned.
+
+@item @emph{Example}:
+@smallexample
+program test_rank
+  integer :: a
+  real, allocatable :: b(:,:)
+
+  print *, rank(a), rank(b) ! Prints:  0  2
+end program test_rank
+@end smallexample
+
+@end table
+
+
+
+@node REAL
+@section @code{REAL} --- Convert to real type 
+@fnindex REAL
+@fnindex REALPART
+@fnindex FLOAT
+@fnindex DFLOAT
+@fnindex SNGL
+@cindex conversion, to real
+@cindex complex numbers, real part
+
+@table @asis
+@item @emph{Description}:
+@code{REAL(A [, KIND])} converts its argument @var{A} to a real type.  The
+@code{REALPART} function is provided for compatibility with @command{g77},
+and its use is strongly discouraged.
+
+@item @emph{Standard}:
+Fortran 77 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{RESULT = REAL(A [, KIND])}
+@item @code{RESULT = REALPART(Z)}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{A}    @tab Shall be @code{INTEGER}, @code{REAL}, or
+@code{COMPLEX}.
+@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
+expression indicating the kind parameter of the result.
+@end multitable
+
+@item @emph{Return value}:
+These functions return a @code{REAL} variable or array under
+the following rules: 
+
+@table @asis
+@item (A)
+@code{REAL(A)} is converted to a default real type if @var{A} is an 
+integer or real variable.
+@item (B)
+@code{REAL(A)} is converted to a real type with the kind type parameter
+of @var{A} if @var{A} is a complex variable.
+@item (C)
+@code{REAL(A, KIND)} is converted to a real type with kind type
+parameter @var{KIND} if @var{A} is a complex, integer, or real
+variable.
+@end table
+
+@item @emph{Example}:
+@smallexample
+program test_real
+  complex :: x = (1.0, 2.0)
+  print *, real(x), real(x,8), realpart(x)
+end program test_real
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name             @tab Argument           @tab Return type     @tab Standard
+@item @code{FLOAT(A)}  @tab @code{INTEGER(4)}  @tab @code{REAL(4)}  @tab Fortran 77 and later
+@item @code{DFLOAT(A)} @tab @code{INTEGER(4)}  @tab @code{REAL(8)}  @tab GNU extension
+@item @code{SNGL(A)}   @tab @code{INTEGER(8)}  @tab @code{REAL(4)}  @tab Fortran 77 and later
+@end multitable
+
+
+@item @emph{See also}:
+@ref{DBLE}
+
+@end table
+
+
+
+@node RENAME
+@section @code{RENAME} --- Rename a file
+@fnindex RENAME
+@cindex file system, rename file
+
+@table @asis
+@item @emph{Description}:
+Renames a file from file @var{PATH1} to @var{PATH2}. A null
+character (@code{CHAR(0)}) can be used to mark the end of the names in
+@var{PATH1} and @var{PATH2}; otherwise, trailing blanks in the file
+names are ignored.  If the @var{STATUS} argument is supplied, it
+contains 0 on success or a nonzero error code upon return; see
+@code{rename(2)}.
+
+This intrinsic is provided in both subroutine and function forms;
+however, only one form can be used in any given program unit.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine, function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{CALL RENAME(PATH1, PATH2 [, STATUS])}
+@item @code{STATUS = RENAME(PATH1, PATH2)}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{PATH1} @tab Shall be of default @code{CHARACTER} type.
+@item @var{PATH2} @tab Shall be of default @code{CHARACTER} type.
+@item @var{STATUS} @tab (Optional) Shall be of default @code{INTEGER} type.
+@end multitable
+
+@item @emph{See also}:
+@ref{LINK}
+
+@end table
+
+
+
+@node REPEAT
+@section @code{REPEAT} --- Repeated string concatenation 
+@fnindex REPEAT
+@cindex string, repeat
+@cindex string, concatenate
+
+@table @asis
+@item @emph{Description}:
+Concatenates @var{NCOPIES} copies of a string.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@code{RESULT = REPEAT(STRING, NCOPIES)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{STRING}  @tab Shall be scalar and of type @code{CHARACTER}.
+@item @var{NCOPIES} @tab Shall be scalar and of type @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+A new scalar of type @code{CHARACTER} built up from @var{NCOPIES} copies 
+of @var{STRING}.
+
+@item @emph{Example}:
+@smallexample
+program test_repeat
+  write(*,*) repeat("x", 5)   ! "xxxxx"
+end program
+@end smallexample
+@end table
+
+
+
+@node RESHAPE
+@section @code{RESHAPE} --- Function to reshape an array
+@fnindex RESHAPE
+@cindex array, change dimensions
+@cindex array, transmogrify
+
+@table @asis
+@item @emph{Description}:
+Reshapes @var{SOURCE} to correspond to @var{SHAPE}. If necessary,
+the new array may be padded with elements from @var{PAD} or permuted
+as defined by @var{ORDER}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@code{RESULT = RESHAPE(SOURCE, SHAPE[, PAD, ORDER])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{SOURCE} @tab Shall be an array of any type.
+@item @var{SHAPE}  @tab Shall be of type @code{INTEGER} and an 
+array of rank one. Its values must be positive or zero.
+@item @var{PAD}    @tab (Optional) shall be an array of the same 
+type as @var{SOURCE}.
+@item @var{ORDER}  @tab (Optional) shall be of type @code{INTEGER}
+and an array of the same shape as @var{SHAPE}. Its values shall
+be a permutation of the numbers from 1 to n, where n is the size of 
+@var{SHAPE}. If @var{ORDER} is absent, the natural ordering shall
+be assumed.
+@end multitable
+
+@item @emph{Return value}:
+The result is an array of shape @var{SHAPE} with the same type as 
+@var{SOURCE}. 
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_reshape
+  INTEGER, DIMENSION(4) :: x
+  WRITE(*,*) SHAPE(x)                       ! prints "4"
+  WRITE(*,*) SHAPE(RESHAPE(x, (/2, 2/)))    ! prints "2 2"
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{SHAPE}
+@end table
+
+
+
+@node RRSPACING
+@section @code{RRSPACING} --- Reciprocal of the relative spacing
+@fnindex RRSPACING
+@cindex real number, relative spacing
+@cindex floating point, relative spacing
+
+
+@table @asis
+@item @emph{Description}:
+@code{RRSPACING(X)} returns the  reciprocal of the relative spacing of
+model numbers near @var{X}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = RRSPACING(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab Shall be of type @code{REAL}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of the same type and kind as @var{X}.
+The value returned is equal to
+@code{ABS(FRACTION(X)) * FLOAT(RADIX(X))**DIGITS(X)}.
+
+@item @emph{See also}:
+@ref{SPACING}
+@end table
+
+
+
+@node RSHIFT
+@section @code{RSHIFT} --- Right shift bits
+@fnindex RSHIFT
+@cindex bits, shift right
+
+@table @asis
+@item @emph{Description}:
+@code{RSHIFT} returns a value corresponding to @var{I} with all of the
+bits shifted right by @var{SHIFT} places.  If the absolute value of
+@var{SHIFT} is greater than @code{BIT_SIZE(I)}, the value is undefined.
+Bits shifted out from the right end are lost. The fill is arithmetic: the
+bits shifted in from the left end are equal to the leftmost bit, which in
+two's complement representation is the sign bit.
+
+This function has been superseded by the @code{SHIFTA} intrinsic, which
+is standard in Fortran 2008 and later.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = RSHIFT(I, SHIFT)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab The type shall be @code{INTEGER}.
+@item @var{SHIFT} @tab The type shall be @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of the same kind as
+@var{I}.
+
+@item @emph{See also}:
+@ref{ISHFT}, @ref{ISHFTC}, @ref{LSHIFT}, @ref{SHIFTA}, @ref{SHIFTR},
+@ref{SHIFTL}
+
+@end table
+
+
+
+@node SAME_TYPE_AS
+@section @code{SAME_TYPE_AS} ---  Query dynamic types for equality
+@fnindex SAME_TYPE_AS
+
+@table @asis
+@item @emph{Description}:
+Query dynamic types for equality.
+
+@item @emph{Standard}:
+Fortran 2003 and later
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{RESULT = SAME_TYPE_AS(A, B)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{A} @tab Shall be an object of extensible declared type or
+unlimited polymorphic.
+@item @var{B} @tab Shall be an object of extensible declared type or
+unlimited polymorphic.
+@end multitable
+
+@item @emph{Return value}:
+The return value is a scalar of type default logical. It is true if and
+only if the dynamic type of A is the same as the dynamic type of B.
+
+@item @emph{See also}:
+@ref{EXTENDS_TYPE_OF}
+
+@end table
+
+
+
+@node SCALE
+@section @code{SCALE} --- Scale a real value
+@fnindex SCALE
+@cindex real number, scale
+@cindex floating point, scale
+
+@table @asis
+@item @emph{Description}:
+@code{SCALE(X,I)} returns @code{X * RADIX(X)**I}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = SCALE(X, I)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type of the argument shall be a @code{REAL}.
+@item @var{I} @tab The type of the argument shall be a @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of the same type and kind as @var{X}.
+Its value is @code{X * RADIX(X)**I}.
+
+@item @emph{Example}:
+@smallexample
+program test_scale
+  real :: x = 178.1387e-4
+  integer :: i = 5
+  print *, scale(x,i), x*radix(x)**i
+end program test_scale
+@end smallexample
+
+@end table
+
+
+
+@node SCAN
+@section @code{SCAN} --- Scan a string for the presence of a set of characters
+@fnindex SCAN
+@cindex string, find subset
+
+@table @asis
+@item @emph{Description}:
+Scans a @var{STRING} for any of the characters in a @var{SET} 
+of characters.
+
+If @var{BACK} is either absent or equals @code{FALSE}, this function
+returns the position of the leftmost character of @var{STRING} that is
+in @var{SET}. If @var{BACK} equals @code{TRUE}, the rightmost position
+is returned. If no character of @var{SET} is found in @var{STRING}, the 
+result is zero.
+
+@item @emph{Standard}:
+Fortran 95 and later, with @var{KIND} argument Fortran 2003 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = SCAN(STRING, SET[, BACK [, KIND]])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{STRING} @tab Shall be of type @code{CHARACTER}.
+@item @var{SET}    @tab Shall be of type @code{CHARACTER}.
+@item @var{BACK}   @tab (Optional) shall be of type @code{LOGICAL}.
+@item @var{KIND}   @tab (Optional) An @code{INTEGER} initialization
+expression indicating the kind parameter of the result.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of kind @var{KIND}. If
+@var{KIND} is absent, the return value is of default integer kind.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_scan
+  WRITE(*,*) SCAN("FORTRAN", "AO")          ! 2, found 'O'
+  WRITE(*,*) SCAN("FORTRAN", "AO", .TRUE.)  ! 6, found 'A'
+  WRITE(*,*) SCAN("FORTRAN", "C++")         ! 0, found none
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{INDEX intrinsic}, @ref{VERIFY}
+@end table
+
+
+
+@node SECNDS
+@section @code{SECNDS} --- Time function
+@fnindex SECNDS
+@cindex time, elapsed
+@cindex elapsed time
+
+@table @asis
+@item @emph{Description}:
+@code{SECNDS(X)} gets the time in seconds from the real-time system clock.
+@var{X} is a reference time, also in seconds. If this is zero, the time in
+seconds from midnight is returned. This function is non-standard and its
+use is discouraged.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Function
+
+@item @emph{Syntax}:
+@code{RESULT = SECNDS (X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{T}     @tab Shall be of type @code{REAL(4)}.
+@item @var{X}     @tab Shall be of type @code{REAL(4)}.
+@end multitable
+
+@item @emph{Return value}:
+None
+
+@item @emph{Example}:
+@smallexample
+program test_secnds
+    integer :: i
+    real(4) :: t1, t2
+    print *, secnds (0.0)   ! seconds since midnight
+    t1 = secnds (0.0)       ! reference time
+    do i = 1, 10000000      ! do something
+    end do
+    t2 = secnds (t1)        ! elapsed time
+    print *, "Something took ", t2, " seconds."
+end program test_secnds
+@end smallexample
+@end table
+
+
+
+@node SECOND
+@section @code{SECOND} --- CPU time function
+@fnindex SECOND
+@cindex time, elapsed
+@cindex elapsed time
+
+@table @asis
+@item @emph{Description}:
+Returns a @code{REAL(4)} value representing the elapsed CPU time in
+seconds.  This provides the same functionality as the standard
+@code{CPU_TIME} intrinsic, and is only included for backwards
+compatibility.
+
+This intrinsic is provided in both subroutine and function forms;
+however, only one form can be used in any given program unit.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine, function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{CALL SECOND(TIME)}
+@item @code{TIME = SECOND()}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{TIME}  @tab Shall be of type @code{REAL(4)}.
+@end multitable
+
+@item @emph{Return value}:
+In either syntax, @var{TIME} is set to the process's current runtime in
+seconds.
+
+@item @emph{See also}:
+@ref{CPU_TIME}
+
+@end table
+
+
+
+@node SELECTED_CHAR_KIND
+@section @code{SELECTED_CHAR_KIND} --- Choose character kind
+@fnindex SELECTED_CHAR_KIND
+@cindex character kind
+@cindex kind, character
+
+@table @asis
+@item @emph{Description}:
+
+@code{SELECTED_CHAR_KIND(NAME)} returns the kind value for the character
+set named @var{NAME}, if a character set with such a name is supported,
+or @math{-1} otherwise. Currently, supported character sets include
+``ASCII'' and ``DEFAULT'', which are equivalent, and ``ISO_10646''
+(Universal Character Set, UCS-4) which is commonly known as Unicode.
+
+@item @emph{Standard}:
+Fortran 2003 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@code{RESULT = SELECTED_CHAR_KIND(NAME)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{NAME} @tab Shall be a scalar and of the default character type.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+program character_kind
+  use iso_fortran_env
+  implicit none
+  integer, parameter :: ascii = selected_char_kind ("ascii")
+  integer, parameter :: ucs4  = selected_char_kind ('ISO_10646')
+
+  character(kind=ascii, len=26) :: alphabet
+  character(kind=ucs4,  len=30) :: hello_world
+
+  alphabet = ascii_"abcdefghijklmnopqrstuvwxyz"
+  hello_world = ucs4_'Hello World and Ni Hao -- ' &
+                // char (int (z'4F60'), ucs4)     &
+                // char (int (z'597D'), ucs4)
+
+  write (*,*) alphabet
+
+  open (output_unit, encoding='UTF-8')
+  write (*,*) trim (hello_world)
+end program character_kind
+@end smallexample
+@end table
+
+
+
+@node SELECTED_INT_KIND
+@section @code{SELECTED_INT_KIND} --- Choose integer kind
+@fnindex SELECTED_INT_KIND
+@cindex integer kind
+@cindex kind, integer
+
+@table @asis
+@item @emph{Description}:
+@code{SELECTED_INT_KIND(R)} return the kind value of the smallest integer
+type that can represent all values ranging from @math{-10^R} (exclusive)
+to @math{10^R} (exclusive). If there is no integer kind that accommodates
+this range, @code{SELECTED_INT_KIND} returns @math{-1}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@code{RESULT = SELECTED_INT_KIND(R)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{R} @tab Shall be a scalar and of type @code{INTEGER}.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+program large_integers
+  integer,parameter :: k5 = selected_int_kind(5)
+  integer,parameter :: k15 = selected_int_kind(15)
+  integer(kind=k5) :: i5
+  integer(kind=k15) :: i15
+
+  print *, huge(i5), huge(i15)
+
+  ! The following inequalities are always true
+  print *, huge(i5) >= 10_k5**5-1
+  print *, huge(i15) >= 10_k15**15-1
+end program large_integers
+@end smallexample
+@end table
+
+
+
+@node SELECTED_REAL_KIND
+@section @code{SELECTED_REAL_KIND} --- Choose real kind
+@fnindex SELECTED_REAL_KIND
+@cindex real kind
+@cindex kind, real
+@cindex radix, real
+
+@table @asis
+@item @emph{Description}:
+@code{SELECTED_REAL_KIND(P,R)} returns the kind value of a real data type
+with decimal precision of at least @code{P} digits, exponent range of
+at least @code{R}, and with a radix of @code{RADIX}.
+
+@item @emph{Standard}:
+Fortran 95 and later, with @code{RADIX} Fortran 2008 or later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@code{RESULT = SELECTED_REAL_KIND([P, R, RADIX])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{P} @tab (Optional) shall be a scalar and of type @code{INTEGER}.
+@item @var{R} @tab (Optional) shall be a scalar and of type @code{INTEGER}.
+@item @var{RADIX} @tab (Optional) shall be a scalar and of type @code{INTEGER}.
+@end multitable
+Before Fortran 2008, at least one of the arguments @var{R} or @var{P} shall
+be present; since Fortran 2008, they are assumed to be zero if absent.
+
+@item @emph{Return value}:
+
+@code{SELECTED_REAL_KIND} returns the value of the kind type parameter of
+a real data type with decimal precision of at least @code{P} digits, a
+decimal exponent range of at least @code{R}, and with the requested
+@code{RADIX}. If the @code{RADIX} parameter is absent, real kinds with
+any radix can be returned. If more than one real data type meet the
+criteria, the kind of the data type with the smallest decimal precision
+is returned. If no real data type matches the criteria, the result is
+@table @asis
+@item -1 if the processor does not support a real data type with a
+precision greater than or equal to @code{P}, but the @code{R} and
+@code{RADIX} requirements can be fulfilled
+@item -2 if the processor does not support a real type with an exponent
+range greater than or equal to @code{R}, but @code{P} and @code{RADIX}
+are fulfillable
+@item -3 if @code{RADIX} but not @code{P} and @code{R} requirements
+are fulfillable
+@item -4 if @code{RADIX} and either @code{P} or @code{R} requirements
+are fulfillable
+@item -5 if there is no real type with the given @code{RADIX}
+@end table
+
+@item @emph{See also}:
+@ref{PRECISION}, @ref{RANGE}, @ref{RADIX}
+
+@item @emph{Example}:
+@smallexample
+program real_kinds
+  integer,parameter :: p6 = selected_real_kind(6)
+  integer,parameter :: p10r100 = selected_real_kind(10,100)
+  integer,parameter :: r400 = selected_real_kind(r=400)
+  real(kind=p6) :: x
+  real(kind=p10r100) :: y
+  real(kind=r400) :: z
+
+  print *, precision(x), range(x)
+  print *, precision(y), range(y)
+  print *, precision(z), range(z)
+end program real_kinds
+@end smallexample
+@end table
+
+
+
+@node SET_EXPONENT
+@section @code{SET_EXPONENT} --- Set the exponent of the model
+@fnindex SET_EXPONENT
+@cindex real number, set exponent
+@cindex floating point, set exponent
+
+@table @asis
+@item @emph{Description}:
+@code{SET_EXPONENT(X, I)} returns the real number whose fractional part
+is that that of @var{X} and whose exponent part is @var{I}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = SET_EXPONENT(X, I)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab Shall be of type @code{REAL}.
+@item @var{I} @tab Shall be of type @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of the same type and kind as @var{X}.
+The real number whose fractional part
+is that that of @var{X} and whose exponent part if @var{I} is returned;
+it is @code{FRACTION(X) * RADIX(X)**I}.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_setexp
+  REAL :: x = 178.1387e-4
+  INTEGER :: i = 17
+  PRINT *, SET_EXPONENT(x, i), FRACTION(x) * RADIX(x)**i
+END PROGRAM
+@end smallexample
+
+@end table
+
+
+
+@node SHAPE
+@section @code{SHAPE} --- Determine the shape of an array
+@fnindex SHAPE
+@cindex array, shape
+
+@table @asis
+@item @emph{Description}:
+Determines the shape of an array.
+
+@item @emph{Standard}:
+Fortran 95 and later, with @var{KIND} argument Fortran 2003 and later
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{RESULT = SHAPE(SOURCE [, KIND])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{SOURCE} @tab Shall be an array or scalar of any type. 
+If @var{SOURCE} is a pointer it must be associated and allocatable 
+arrays must be allocated.
+@item @var{KIND}   @tab (Optional) An @code{INTEGER} initialization
+expression indicating the kind parameter of the result.
+@end multitable
+
+@item @emph{Return value}:
+An @code{INTEGER} array of rank one with as many elements as @var{SOURCE} 
+has dimensions. The elements of the resulting array correspond to the extend
+of @var{SOURCE} along the respective dimensions. If @var{SOURCE} is a scalar,
+the result is the rank one array of size zero. If @var{KIND} is absent, the
+return value has the default integer kind otherwise the specified kind.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_shape
+  INTEGER, DIMENSION(-1:1, -1:2) :: A
+  WRITE(*,*) SHAPE(A)             ! (/ 3, 4 /)
+  WRITE(*,*) SIZE(SHAPE(42))      ! (/ /)
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{RESHAPE}, @ref{SIZE}
+@end table
+
+
+
+@node SHIFTA
+@section @code{SHIFTA} --- Right shift with fill
+@fnindex SHIFTA
+@cindex bits, shift right
+@cindex shift, right with fill
+
+@table @asis
+@item @emph{Description}:
+@code{SHIFTA} returns a value corresponding to @var{I} with all of the
+bits shifted right by @var{SHIFT} places.  If the absolute value of
+@var{SHIFT} is greater than @code{BIT_SIZE(I)}, the value is undefined.
+Bits shifted out from the right end are lost. The fill is arithmetic: the
+bits shifted in from the left end are equal to the leftmost bit, which in
+two's complement representation is the sign bit.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = SHIFTA(I, SHIFT)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab The type shall be @code{INTEGER}.
+@item @var{SHIFT} @tab The type shall be @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of the same kind as
+@var{I}.
+
+@item @emph{See also}:
+@ref{SHIFTL}, @ref{SHIFTR}
+@end table
+
+
+
+@node SHIFTL
+@section @code{SHIFTL} --- Left shift
+@fnindex SHIFTL
+@cindex bits, shift left
+@cindex shift, left
+
+@table @asis
+@item @emph{Description}:
+@code{SHIFTL} returns a value corresponding to @var{I} with all of the
+bits shifted left by @var{SHIFT} places.  If the absolute value of
+@var{SHIFT} is greater than @code{BIT_SIZE(I)}, the value is undefined.
+Bits shifted out from the left end are lost, and bits shifted in from
+the right end are set to 0.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = SHIFTL(I, SHIFT)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab The type shall be @code{INTEGER}.
+@item @var{SHIFT} @tab The type shall be @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of the same kind as
+@var{I}.
+
+@item @emph{See also}:
+@ref{SHIFTA}, @ref{SHIFTR}
+@end table
+
+
+
+@node SHIFTR
+@section @code{SHIFTR} --- Right shift
+@fnindex SHIFTR
+@cindex bits, shift right
+@cindex shift, right
+
+@table @asis
+@item @emph{Description}:
+@code{SHIFTR} returns a value corresponding to @var{I} with all of the
+bits shifted right by @var{SHIFT} places.  If the absolute value of
+@var{SHIFT} is greater than @code{BIT_SIZE(I)}, the value is undefined.
+Bits shifted out from the right end are lost, and bits shifted in from
+the left end are set to 0.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = SHIFTR(I, SHIFT)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab The type shall be @code{INTEGER}.
+@item @var{SHIFT} @tab The type shall be @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of the same kind as
+@var{I}.
+
+@item @emph{See also}:
+@ref{SHIFTA}, @ref{SHIFTL}
+@end table
+
+
+
+@node SIGN
+@section @code{SIGN} --- Sign copying function
+@fnindex SIGN
+@fnindex ISIGN
+@fnindex DSIGN
+@cindex sign copying
+
+@table @asis
+@item @emph{Description}:
+@code{SIGN(A,B)} returns the value of @var{A} with the sign of @var{B}.
+
+@item @emph{Standard}:
+Fortran 77 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = SIGN(A, B)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{A} @tab Shall be of type @code{INTEGER} or @code{REAL}
+@item @var{B} @tab Shall be of the same type and kind as @var{A}
+@end multitable
+
+@item @emph{Return value}:
+The kind of the return value is that of @var{A} and @var{B}.
+If @math{B\ge 0} then the result is @code{ABS(A)}, else
+it is @code{-ABS(A)}.
+
+@item @emph{Example}:
+@smallexample
+program test_sign
+  print *, sign(-12,1)
+  print *, sign(-12,0)
+  print *, sign(-12,-1)
+
+  print *, sign(-12.,1.)
+  print *, sign(-12.,0.)
+  print *, sign(-12.,-1.)
+end program test_sign
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name              @tab Arguments              @tab Return type       @tab Standard
+@item @code{SIGN(A,B)}  @tab @code{REAL(4) A, B}    @tab @code{REAL(4)}    @tab f77, gnu
+@item @code{ISIGN(A,B)} @tab @code{INTEGER(4) A, B} @tab @code{INTEGER(4)} @tab f77, gnu
+@item @code{DSIGN(A,B)} @tab @code{REAL(8) A, B}    @tab @code{REAL(8)}    @tab f77, gnu
+@end multitable
+@end table
+
+
+
+@node SIGNAL
+@section @code{SIGNAL} --- Signal handling subroutine (or function)
+@fnindex SIGNAL
+@cindex system, signal handling
+
+@table @asis
+@item @emph{Description}:
+@code{SIGNAL(NUMBER, HANDLER [, STATUS])} causes external subroutine
+@var{HANDLER} to be executed with a single integer argument when signal
+@var{NUMBER} occurs.  If @var{HANDLER} is an integer, it can be used to
+turn off handling of signal @var{NUMBER} or revert to its default
+action.  See @code{signal(2)}.
+
+If @code{SIGNAL} is called as a subroutine and the @var{STATUS} argument
+is supplied, it is set to the value returned by @code{signal(2)}.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine, function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{CALL SIGNAL(NUMBER, HANDLER [, STATUS])}
+@item @code{STATUS = SIGNAL(NUMBER, HANDLER)}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{NUMBER} @tab Shall be a scalar integer, with @code{INTENT(IN)}
+@item @var{HANDLER}@tab Signal handler (@code{INTEGER FUNCTION} or
+@code{SUBROUTINE}) or dummy/global @code{INTEGER} scalar.
+@code{INTEGER}. It is @code{INTENT(IN)}.
+@item @var{STATUS} @tab (Optional) @var{STATUS} shall be a scalar
+integer. It has @code{INTENT(OUT)}.
+@end multitable
+@c TODO: What should the interface of the handler be?  Does it take arguments?
+
+@item @emph{Return value}:
+The @code{SIGNAL} function returns the value returned by @code{signal(2)}.
+
+@item @emph{Example}:
+@smallexample
+program test_signal
+  intrinsic signal
+  external handler_print
+
+  call signal (12, handler_print)
+  call signal (10, 1)
+
+  call sleep (30)
+end program test_signal
+@end smallexample
+@end table
+
+
+
+@node SIN
+@section @code{SIN} --- Sine function 
+@fnindex SIN
+@fnindex DSIN
+@fnindex CSIN
+@fnindex ZSIN
+@fnindex CDSIN
+@cindex trigonometric function, sine
+@cindex sine
+
+@table @asis
+@item @emph{Description}:
+@code{SIN(X)} computes the sine of @var{X}.
+
+@item @emph{Standard}:
+Fortran 77 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = SIN(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be @code{REAL} or
+@code{COMPLEX}.
+@end multitable
+
+@item @emph{Return value}:
+The return value has same type and kind as @var{X}.
+
+@item @emph{Example}:
+@smallexample
+program test_sin
+  real :: x = 0.0
+  x = sin(x)
+end program test_sin
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name            @tab Argument             @tab Return type       @tab Standard
+@item @code{SIN(X)}   @tab @code{REAL(4) X}     @tab @code{REAL(4)}    @tab f77, gnu
+@item @code{DSIN(X)}  @tab @code{REAL(8) X}     @tab @code{REAL(8)}    @tab f95, gnu
+@item @code{CSIN(X)}  @tab @code{COMPLEX(4) X}  @tab @code{COMPLEX(4)} @tab f95, gnu
+@item @code{ZSIN(X)}  @tab @code{COMPLEX(8) X}  @tab @code{COMPLEX(8)} @tab f95, gnu
+@item @code{CDSIN(X)} @tab @code{COMPLEX(8) X}  @tab @code{COMPLEX(8)} @tab f95, gnu
+@end multitable
+
+@item @emph{See also}:
+@ref{ASIN}
+@end table
+
+
+
+@node SINH
+@section @code{SINH} --- Hyperbolic sine function 
+@fnindex SINH
+@fnindex DSINH
+@cindex hyperbolic sine
+@cindex hyperbolic function, sine
+@cindex sine, hyperbolic
+
+@table @asis
+@item @emph{Description}:
+@code{SINH(X)} computes the hyperbolic sine of @var{X}.
+
+@item @emph{Standard}:
+Fortran 95 and later, for a complex argument Fortran 2008 or later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = SINH(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be @code{REAL} or @code{COMPLEX}.
+@end multitable
+
+@item @emph{Return value}:
+The return value has same type and kind as @var{X}.
+
+@item @emph{Example}:
+@smallexample
+program test_sinh
+  real(8) :: x = - 1.0_8
+  x = sinh(x)
+end program test_sinh
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name            @tab Argument          @tab Return type       @tab Standard
+@item @code{SINH(X)}  @tab @code{REAL(4) X}  @tab @code{REAL(4)}    @tab Fortran 95 and later
+@item @code{DSINH(X)} @tab @code{REAL(8) X}  @tab @code{REAL(8)}    @tab Fortran 95 and later
+@end multitable
+
+@item @emph{See also}:
+@ref{ASINH}
+@end table
+
+
+
+@node SIZE
+@section @code{SIZE} --- Determine the size of an array
+@fnindex SIZE
+@cindex array, size
+@cindex array, number of elements
+@cindex array, count elements
+
+@table @asis
+@item @emph{Description}:
+Determine the extent of @var{ARRAY} along a specified dimension @var{DIM},
+or the total number of elements in @var{ARRAY} if @var{DIM} is absent.
+
+@item @emph{Standard}:
+Fortran 95 and later, with @var{KIND} argument Fortran 2003 and later
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{RESULT = SIZE(ARRAY[, DIM [, KIND]])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ARRAY} @tab Shall be an array of any type. If @var{ARRAY} is
+a pointer it must be associated and allocatable arrays must be allocated.
+@item @var{DIM}   @tab (Optional) shall be a scalar of type @code{INTEGER} 
+and its value shall be in the range from 1 to n, where n equals the rank 
+of @var{ARRAY}.
+@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
+expression indicating the kind parameter of the result.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of kind @var{KIND}. If
+@var{KIND} is absent, the return value is of default integer kind.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_size
+  WRITE(*,*) SIZE((/ 1, 2 /))    ! 2
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{SHAPE}, @ref{RESHAPE}
+@end table
+
+
+@node SIZEOF
+@section @code{SIZEOF} --- Size in bytes of an expression
+@fnindex SIZEOF
+@cindex expression size
+@cindex size of an expression
+
+@table @asis
+@item @emph{Description}:
+@code{SIZEOF(X)} calculates the number of bytes of storage the
+expression @code{X} occupies.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{N = SIZEOF(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The argument shall be of any type, rank or shape.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type integer and of the system-dependent kind
+@var{C_SIZE_T} (from the @var{ISO_C_BINDING} module). Its value is the
+number of bytes occupied by the argument.  If the argument has the
+@code{POINTER} attribute, the number of bytes of the storage area pointed
+to is returned.  If the argument is of a derived type with @code{POINTER}
+or @code{ALLOCATABLE} components, the return value does not account for
+the sizes of the data pointed to by these components. If the argument is
+polymorphic, the size according to the declared type is returned. The argument
+may not be a procedure or procedure pointer.
+
+@item @emph{Example}:
+@smallexample
+   integer :: i
+   real :: r, s(5)
+   print *, (sizeof(s)/sizeof(r) == 5)
+   end
+@end smallexample
+The example will print @code{.TRUE.} unless you are using a platform
+where default @code{REAL} variables are unusually padded.
+
+@item @emph{See also}:
+@ref{C_SIZEOF}, @ref{STORAGE_SIZE}
+@end table
+
+
+@node SLEEP
+@section @code{SLEEP} --- Sleep for the specified number of seconds
+@fnindex SLEEP
+@cindex delayed execution
+
+@table @asis
+@item @emph{Description}:
+Calling this subroutine causes the process to pause for @var{SECONDS} seconds.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine
+
+@item @emph{Syntax}:
+@code{CALL SLEEP(SECONDS)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{SECONDS} @tab The type shall be of default @code{INTEGER}.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+program test_sleep
+  call sleep(5)
+end
+@end smallexample
+@end table
+
+
+
+@node SPACING
+@section @code{SPACING} --- Smallest distance between two numbers of a given type
+@fnindex SPACING
+@cindex real number, relative spacing
+@cindex floating point, relative spacing
+
+@table @asis
+@item @emph{Description}:
+Determines the distance between the argument @var{X} and the nearest 
+adjacent number of the same type.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = SPACING(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab Shall be of type @code{REAL}.
+@end multitable
+
+@item @emph{Return value}:
+The result is of the same type as the input argument @var{X}.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_spacing
+  INTEGER, PARAMETER :: SGL = SELECTED_REAL_KIND(p=6, r=37)
+  INTEGER, PARAMETER :: DBL = SELECTED_REAL_KIND(p=13, r=200)
+
+  WRITE(*,*) spacing(1.0_SGL)      ! "1.1920929E-07"          on i686
+  WRITE(*,*) spacing(1.0_DBL)      ! "2.220446049250313E-016" on i686
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{RRSPACING}
+@end table
+
+
+
+@node SPREAD
+@section @code{SPREAD} --- Add a dimension to an array
+@fnindex SPREAD
+@cindex array, increase dimension
+@cindex array, duplicate elements
+@cindex array, duplicate dimensions
+
+@table @asis
+@item @emph{Description}:
+Replicates a @var{SOURCE} array @var{NCOPIES} times along a specified 
+dimension @var{DIM}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@code{RESULT = SPREAD(SOURCE, DIM, NCOPIES)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{SOURCE}  @tab Shall be a scalar or an array of any type and 
+a rank less than seven.
+@item @var{DIM}     @tab Shall be a scalar of type @code{INTEGER} with a 
+value in the range from 1 to n+1, where n equals the rank of @var{SOURCE}.
+@item @var{NCOPIES} @tab Shall be a scalar of type @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The result is an array of the same type as @var{SOURCE} and has rank n+1
+where n equals the rank of @var{SOURCE}.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_spread
+  INTEGER :: a = 1, b(2) = (/ 1, 2 /)
+  WRITE(*,*) SPREAD(A, 1, 2)            ! "1 1"
+  WRITE(*,*) SPREAD(B, 1, 2)            ! "1 1 2 2"
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{UNPACK}
+@end table
+
+
+
+@node SQRT
+@section @code{SQRT} --- Square-root function
+@fnindex SQRT
+@fnindex DSQRT
+@fnindex CSQRT
+@fnindex ZSQRT
+@fnindex CDSQRT
+@cindex root
+@cindex square-root
+
+@table @asis
+@item @emph{Description}:
+@code{SQRT(X)} computes the square root of @var{X}.
+
+@item @emph{Standard}:
+Fortran 77 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = SQRT(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be @code{REAL} or
+@code{COMPLEX}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{REAL} or @code{COMPLEX}.
+The kind type parameter is the same as @var{X}.
+
+@item @emph{Example}:
+@smallexample
+program test_sqrt
+  real(8) :: x = 2.0_8
+  complex :: z = (1.0, 2.0)
+  x = sqrt(x)
+  z = sqrt(z)
+end program test_sqrt
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name             @tab Argument             @tab Return type          @tab Standard
+@item @code{SQRT(X)}   @tab @code{REAL(4) X}     @tab @code{REAL(4)}       @tab Fortran 95 and later
+@item @code{DSQRT(X)}  @tab @code{REAL(8) X}     @tab @code{REAL(8)}       @tab Fortran 95 and later
+@item @code{CSQRT(X)}  @tab @code{COMPLEX(4) X}  @tab @code{COMPLEX(4)}    @tab Fortran 95 and later
+@item @code{ZSQRT(X)}  @tab @code{COMPLEX(8) X}  @tab @code{COMPLEX(8)}    @tab GNU extension
+@item @code{CDSQRT(X)} @tab @code{COMPLEX(8) X}  @tab @code{COMPLEX(8)}    @tab GNU extension
+@end multitable
+@end table
+
+
+
+@node SRAND
+@section @code{SRAND} --- Reinitialize the random number generator
+@fnindex SRAND
+@cindex random number generation, seeding
+@cindex seeding a random number generator
+
+@table @asis
+@item @emph{Description}:
+@code{SRAND} reinitializes the pseudo-random number generator
+called by @code{RAND} and @code{IRAND}. The new seed used by the
+generator is specified by the required argument @var{SEED}.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine
+
+@item @emph{Syntax}:
+@code{CALL SRAND(SEED)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{SEED} @tab Shall be a scalar @code{INTEGER(kind=4)}.
+@end multitable
+
+@item @emph{Return value}:
+Does not return anything.
+
+@item @emph{Example}:
+See @code{RAND} and @code{IRAND} for examples.
+
+@item @emph{Notes}:
+The Fortran 2003 standard specifies the intrinsic @code{RANDOM_SEED} to
+initialize the pseudo-random numbers generator and @code{RANDOM_NUMBER}
+to generate pseudo-random numbers. Please note that in
+GNU Fortran, these two sets of intrinsics (@code{RAND},
+@code{IRAND} and @code{SRAND} on the one hand, @code{RANDOM_NUMBER} and
+@code{RANDOM_SEED} on the other hand) access two independent
+pseudo-random number generators.
+
+@item @emph{See also}:
+@ref{RAND}, @ref{RANDOM_SEED}, @ref{RANDOM_NUMBER}
+
+@end table
+
+
+
+@node STAT
+@section @code{STAT} --- Get file status
+@fnindex STAT
+@cindex file system, file status
+
+@table @asis
+@item @emph{Description}:
+This function returns information about a file. No permissions are required on 
+the file itself, but execute (search) permission is required on all of the 
+directories in path that lead to the file.
+
+The elements that are obtained and stored in the array @code{VALUES}:
+@multitable @columnfractions .15 .70
+@item @code{VALUES(1)}   @tab  Device ID 
+@item @code{VALUES(2)}   @tab  Inode number 
+@item @code{VALUES(3)}   @tab  File mode 
+@item @code{VALUES(4)}   @tab  Number of links 
+@item @code{VALUES(5)}   @tab  Owner's uid 
+@item @code{VALUES(6)}   @tab  Owner's gid 
+@item @code{VALUES(7)}   @tab  ID of device containing directory entry for file (0 if not available) 
+@item @code{VALUES(8)}   @tab  File size (bytes) 
+@item @code{VALUES(9)}   @tab  Last access time 
+@item @code{VALUES(10)}  @tab  Last modification time 
+@item @code{VALUES(11)}  @tab  Last file status change time 
+@item @code{VALUES(12)}  @tab  Preferred I/O block size (-1 if not available) 
+@item @code{VALUES(13)}  @tab  Number of blocks allocated (-1 if not available)
+@end multitable
+
+Not all these elements are relevant on all systems. 
+If an element is not relevant, it is returned as 0.
+
+This intrinsic is provided in both subroutine and function forms; however,
+only one form can be used in any given program unit.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine, function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{CALL STAT(NAME, VALUES [, STATUS])}
+@item @code{STATUS = STAT(NAME, VALUES)}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{NAME}   @tab The type shall be @code{CHARACTER}, of the
+default kind and a valid path within the file system.
+@item @var{VALUES} @tab The type shall be @code{INTEGER(4), DIMENSION(13)}.
+@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER(4)}. Returns 0 
+on success and a system specific error code otherwise.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_stat
+  INTEGER, DIMENSION(13) :: buff
+  INTEGER :: status
+
+  CALL STAT("/etc/passwd", buff, status)
+
+  IF (status == 0) THEN
+    WRITE (*, FMT="('Device ID:',               T30, I19)") buff(1)
+    WRITE (*, FMT="('Inode number:',            T30, I19)") buff(2)
+    WRITE (*, FMT="('File mode (octal):',       T30, O19)") buff(3)
+    WRITE (*, FMT="('Number of links:',         T30, I19)") buff(4)
+    WRITE (*, FMT="('Owner''s uid:',            T30, I19)") buff(5)
+    WRITE (*, FMT="('Owner''s gid:',            T30, I19)") buff(6)
+    WRITE (*, FMT="('Device where located:',    T30, I19)") buff(7)
+    WRITE (*, FMT="('File size:',               T30, I19)") buff(8)
+    WRITE (*, FMT="('Last access time:',        T30, A19)") CTIME(buff(9))
+    WRITE (*, FMT="('Last modification time',   T30, A19)") CTIME(buff(10))
+    WRITE (*, FMT="('Last status change time:', T30, A19)") CTIME(buff(11))
+    WRITE (*, FMT="('Preferred block size:',    T30, I19)") buff(12)
+    WRITE (*, FMT="('No. of blocks allocated:', T30, I19)") buff(13)
+  END IF
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+To stat an open file: @ref{FSTAT}, to stat a link: @ref{LSTAT}
+@end table
+
+
+
+@node STORAGE_SIZE
+@section @code{STORAGE_SIZE} --- Storage size in bits
+@fnindex STORAGE_SIZE
+@cindex storage size
+
+@table @asis
+@item @emph{Description}:
+Returns the storage size of argument @var{A} in bits.
+@item @emph{Standard}:
+Fortran 2008 and later
+@item @emph{Class}:
+Inquiry function
+@item @emph{Syntax}:
+@code{RESULT = STORAGE_SIZE(A [, KIND])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{A} @tab Shall be a scalar or array of any type.
+@item @var{KIND} @tab (Optional) shall be a scalar integer constant expression.
+@end multitable
+
+@item @emph{Return Value}:
+The result is a scalar integer with the kind type parameter specified by KIND
+(or default integer type if KIND is missing). The result value is the size
+expressed in bits for an element of an array that has the dynamic type and type
+parameters of A.
+
+@item @emph{See also}:
+@ref{C_SIZEOF}, @ref{SIZEOF}
+@end table
+
+
+
+@node SUM
+@section @code{SUM} --- Sum of array elements
+@fnindex SUM
+@cindex array, sum
+@cindex array, add elements
+@cindex array, conditionally add elements
+@cindex sum array elements
+
+@table @asis
+@item @emph{Description}:
+Adds the elements of @var{ARRAY} along dimension @var{DIM} if
+the corresponding element in @var{MASK} is @code{TRUE}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{RESULT = SUM(ARRAY[, MASK])}
+@item @code{RESULT = SUM(ARRAY, DIM[, MASK])}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ARRAY} @tab Shall be an array of type @code{INTEGER}, 
+@code{REAL} or @code{COMPLEX}.
+@item @var{DIM}   @tab (Optional) shall be a scalar of type 
+@code{INTEGER} with a value in the range from 1 to n, where n 
+equals the rank of @var{ARRAY}.
+@item @var{MASK}  @tab (Optional) shall be of type @code{LOGICAL} 
+and either be a scalar or an array of the same shape as @var{ARRAY}.
+@end multitable
+
+@item @emph{Return value}:
+The result is of the same type as @var{ARRAY}.
+
+If @var{DIM} is absent, a scalar with the sum of all elements in @var{ARRAY}
+is returned. Otherwise, an array of rank n-1, where n equals the rank of 
+@var{ARRAY}, and a shape similar to that of @var{ARRAY} with dimension @var{DIM} 
+dropped is returned.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_sum
+  INTEGER :: x(5) = (/ 1, 2, 3, 4 ,5 /)
+  print *, SUM(x)                        ! all elements, sum = 15
+  print *, SUM(x, MASK=MOD(x, 2)==1)     ! odd elements, sum = 9
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{PRODUCT}
+@end table
+
+
+
+@node SYMLNK
+@section @code{SYMLNK} --- Create a symbolic link
+@fnindex SYMLNK
+@cindex file system, create link
+@cindex file system, soft link
+
+@table @asis
+@item @emph{Description}:
+Makes a symbolic link from file @var{PATH1} to @var{PATH2}. A null
+character (@code{CHAR(0)}) can be used to mark the end of the names in
+@var{PATH1} and @var{PATH2}; otherwise, trailing blanks in the file
+names are ignored.  If the @var{STATUS} argument is supplied, it
+contains 0 on success or a nonzero error code upon return; see
+@code{symlink(2)}.  If the system does not supply @code{symlink(2)}, 
+@code{ENOSYS} is returned.
+
+This intrinsic is provided in both subroutine and function forms;
+however, only one form can be used in any given program unit.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine, function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{CALL SYMLNK(PATH1, PATH2 [, STATUS])}
+@item @code{STATUS = SYMLNK(PATH1, PATH2)}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{PATH1} @tab Shall be of default @code{CHARACTER} type.
+@item @var{PATH2} @tab Shall be of default @code{CHARACTER} type.
+@item @var{STATUS} @tab (Optional) Shall be of default @code{INTEGER} type.
+@end multitable
+
+@item @emph{See also}:
+@ref{LINK}, @ref{UNLINK}
+
+@end table
+
+
+
+@node SYSTEM
+@section @code{SYSTEM} --- Execute a shell command
+@fnindex SYSTEM
+@cindex system, system call
+
+@table @asis
+@item @emph{Description}:
+Passes the command @var{COMMAND} to a shell (see @code{system(3)}). If
+argument @var{STATUS} is present, it contains the value returned by
+@code{system(3)}, which is presumably 0 if the shell command succeeded.
+Note that which shell is used to invoke the command is system-dependent
+and environment-dependent.
+
+This intrinsic is provided in both subroutine and function forms;
+however, only one form can be used in any given program unit.
+
+Note that the @code{system} function need not be thread-safe. It is
+the responsibility of the user to ensure that @code{system} is not
+called concurrently.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine, function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{CALL SYSTEM(COMMAND [, STATUS])}
+@item @code{STATUS = SYSTEM(COMMAND)}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{COMMAND} @tab Shall be of default @code{CHARACTER} type.
+@item @var{STATUS}  @tab (Optional) Shall be of default @code{INTEGER} type.
+@end multitable
+
+@item @emph{See also}:
+@ref{EXECUTE_COMMAND_LINE}, which is part of the Fortran 2008 standard
+and should considered in new code for future portability.
+@end table
+
+
+
+@node SYSTEM_CLOCK
+@section @code{SYSTEM_CLOCK} --- Time function
+@fnindex SYSTEM_CLOCK
+@cindex time, clock ticks
+@cindex clock ticks
+
+@table @asis
+@item @emph{Description}:
+Determines the @var{COUNT} of a processor clock since an unspecified
+time in the past modulo @var{COUNT_MAX}, @var{COUNT_RATE} determines
+the number of clock ticks per second.  If the platform supports a
+monotonic clock, that clock is used and can, depending on the platform
+clock implementation, provide up to nanosecond resolution.  If a
+monotonic clock is not available, the implementation falls back to a
+realtime clock.
+
+@var{COUNT_RATE} is system dependent and can vary depending on the
+kind of the arguments. For @var{kind=4} arguments, @var{COUNT}
+represents milliseconds, while for @var{kind=8} arguments, @var{COUNT}
+typically represents micro- or nanoseconds depending on resolution of
+the underlying platform clock. @var{COUNT_MAX} usually equals
+@code{HUGE(COUNT_MAX)}. Note that the millisecond resolution of the
+@var{kind=4} version implies that the @var{COUNT} will wrap around in
+roughly 25 days. In order to avoid issues with the wrap around and for
+more precise timing, please use the @var{kind=8} version.
+
+If there is no clock, or querying the clock fails, @var{COUNT} is set
+to @code{-HUGE(COUNT)}, and @var{COUNT_RATE} and @var{COUNT_MAX} are
+set to zero.
+
+When running on a platform using the GNU C library (glibc) version
+2.16 or older, or a derivative thereof, the high resolution monotonic
+clock is available only when linking with the @var{rt} library.  This
+can be done explicitly by adding the @code{-lrt} flag when linking the
+application, but is also done implicitly when using OpenMP.
+
+On the Windows platform, the version with @var{kind=4} arguments uses
+the @code{GetTickCount} function, whereas the @var{kind=8} version
+uses @code{QueryPerformanceCounter} and
+@code{QueryPerformanceCounterFrequency}. For more information, and
+potential caveats, please see the platform documentation.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Subroutine
+
+@item @emph{Syntax}:
+@code{CALL SYSTEM_CLOCK([COUNT, COUNT_RATE, COUNT_MAX])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{COUNT}      @tab (Optional) shall be a scalar of type 
+@code{INTEGER} with @code{INTENT(OUT)}.
+@item @var{COUNT_RATE} @tab (Optional) shall be a scalar of type 
+@code{INTEGER} with @code{INTENT(OUT)}.
+@item @var{COUNT_MAX}  @tab (Optional) shall be a scalar of type 
+@code{INTEGER} with @code{INTENT(OUT)}.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_system_clock
+  INTEGER :: count, count_rate, count_max
+  CALL SYSTEM_CLOCK(count, count_rate, count_max)
+  WRITE(*,*) count, count_rate, count_max
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{DATE_AND_TIME}, @ref{CPU_TIME}
+@end table
+
+
+
+@node TAN
+@section @code{TAN} --- Tangent function
+@fnindex TAN
+@fnindex DTAN
+@cindex trigonometric function, tangent
+@cindex tangent
+
+@table @asis
+@item @emph{Description}:
+@code{TAN(X)} computes the tangent of @var{X}.
+
+@item @emph{Standard}:
+Fortran 77 and later, for a complex argument Fortran 2008 or later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = TAN(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be @code{REAL} or @code{COMPLEX}.
+@end multitable
+
+@item @emph{Return value}:
+The return value has same type and kind as @var{X}.
+
+@item @emph{Example}:
+@smallexample
+program test_tan
+  real(8) :: x = 0.165_8
+  x = tan(x)
+end program test_tan
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name            @tab Argument          @tab Return type     @tab Standard
+@item @code{TAN(X)}   @tab @code{REAL(4) X}  @tab @code{REAL(4)}  @tab Fortran 95 and later
+@item @code{DTAN(X)}  @tab @code{REAL(8) X}  @tab @code{REAL(8)}  @tab Fortran 95 and later
+@end multitable
+
+@item @emph{See also}:
+@ref{ATAN}
+@end table
+
+
+
+@node TANH
+@section @code{TANH} --- Hyperbolic tangent function 
+@fnindex TANH
+@fnindex DTANH
+@cindex hyperbolic tangent
+@cindex hyperbolic function, tangent
+@cindex tangent, hyperbolic
+
+@table @asis
+@item @emph{Description}:
+@code{TANH(X)} computes the hyperbolic tangent of @var{X}.
+
+@item @emph{Standard}:
+Fortran 77 and later, for a complex argument Fortran 2008 or later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{X = TANH(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be @code{REAL} or @code{COMPLEX}.
+@end multitable
+
+@item @emph{Return value}:
+The return value has same type and kind as @var{X}. If @var{X} is
+complex, the imaginary part of the result is in radians. If @var{X}
+is @code{REAL}, the return value lies in the range
+@math{ - 1 \leq tanh(x) \leq 1 }.
+
+@item @emph{Example}:
+@smallexample
+program test_tanh
+  real(8) :: x = 2.1_8
+  x = tanh(x)
+end program test_tanh
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .20 .20 .20 .25
+@item Name            @tab Argument          @tab Return type       @tab Standard
+@item @code{TANH(X)}  @tab @code{REAL(4) X}  @tab @code{REAL(4)}    @tab Fortran 95 and later
+@item @code{DTANH(X)} @tab @code{REAL(8) X}  @tab @code{REAL(8)}    @tab Fortran 95 and later
+@end multitable
+
+@item @emph{See also}:
+@ref{ATANH}
+@end table
+
+
+
+@node THIS_IMAGE
+@section @code{THIS_IMAGE} --- Function that returns the cosubscript index of this image
+@fnindex THIS_IMAGE
+@cindex coarray, @code{THIS_IMAGE}
+@cindex images, index of this image
+
+@table @asis
+@item @emph{Description}:
+Returns the cosubscript for this image.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{RESULT = THIS_IMAGE()}
+@item @code{RESULT = THIS_IMAGE(COARRAY [, DIM])}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{COARRAY} @tab Coarray of any type  (optional; if @var{DIM}
+present, required).
+@item @var{DIM}     @tab default integer scalar (optional). If present,
+@var{DIM} shall be between one and the corank of @var{COARRAY}.
+@end multitable
+
+
+@item @emph{Return value}:
+Default integer. If @var{COARRAY} is not present, it is scalar and its value
+is the index of the invoking image. Otherwise, if @var{DIM} is not present,
+a rank-1 array with corank elements is returned, containing the cosubscripts
+for @var{COARRAY} specifying the invoking image. If @var{DIM} is present,
+a scalar is returned, with the value of the @var{DIM} element of
+@code{THIS_IMAGE(COARRAY)}.
+
+@item @emph{Example}:
+@smallexample
+INTEGER :: value[*]
+INTEGER :: i
+value = THIS_IMAGE()
+SYNC ALL
+IF (THIS_IMAGE() == 1) THEN
+  DO i = 1, NUM_IMAGES()
+    WRITE(*,'(2(a,i0))') 'value[', i, '] is ', value[i]
+  END DO
+END IF
+@end smallexample
+
+@item @emph{See also}:
+@ref{NUM_IMAGES}, @ref{IMAGE_INDEX}
+@end table
+
+
+
+@node TIME
+@section @code{TIME} --- Time function
+@fnindex TIME
+@cindex time, current
+@cindex current time
+
+@table @asis
+@item @emph{Description}:
+Returns the current time encoded as an integer (in the manner of the
+function @code{time(3)} in the C standard library). This value is
+suitable for passing to @code{CTIME}, @code{GMTIME}, and @code{LTIME}.
+
+This intrinsic is not fully portable, such as to systems with 32-bit
+@code{INTEGER} types but supporting times wider than 32 bits. Therefore,
+the values returned by this intrinsic might be, or become, negative, or
+numerically less than previous values, during a single run of the
+compiled program.
+
+See @ref{TIME8}, for information on a similar intrinsic that might be
+portable to more GNU Fortran implementations, though to fewer Fortran
+compilers.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Function
+
+@item @emph{Syntax}:
+@code{RESULT = TIME()}
+
+@item @emph{Return value}:
+The return value is a scalar of type @code{INTEGER(4)}.
+
+@item @emph{See also}:
+@ref{CTIME}, @ref{GMTIME}, @ref{LTIME}, @ref{MCLOCK}, @ref{TIME8}
+
+@end table
+
+
+
+@node TIME8
+@section @code{TIME8} --- Time function (64-bit)
+@fnindex TIME8
+@cindex time, current
+@cindex current time
+
+@table @asis
+@item @emph{Description}:
+Returns the current time encoded as an integer (in the manner of the
+function @code{time(3)} in the C standard library). This value is
+suitable for passing to @code{CTIME}, @code{GMTIME}, and @code{LTIME}.
+
+@emph{Warning:} this intrinsic does not increase the range of the timing
+values over that returned by @code{time(3)}. On a system with a 32-bit
+@code{time(3)}, @code{TIME8} will return a 32-bit value, even though
+it is converted to a 64-bit @code{INTEGER(8)} value. That means
+overflows of the 32-bit value can still occur. Therefore, the values
+returned by this intrinsic might be or become negative or numerically
+less than previous values during a single run of the compiled program.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Function
+
+@item @emph{Syntax}:
+@code{RESULT = TIME8()}
+
+@item @emph{Return value}:
+The return value is a scalar of type @code{INTEGER(8)}.
+
+@item @emph{See also}:
+@ref{CTIME}, @ref{GMTIME}, @ref{LTIME}, @ref{MCLOCK8}, @ref{TIME}
+
+@end table
+
+
+
+@node TINY
+@section @code{TINY} --- Smallest positive number of a real kind
+@fnindex TINY
+@cindex limits, smallest number
+@cindex model representation, smallest number
+
+@table @asis
+@item @emph{Description}:
+@code{TINY(X)} returns the smallest positive (non zero) number
+in the model of the type of @code{X}.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{RESULT = TINY(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab Shall be of type @code{REAL}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of the same type and kind as @var{X}
+
+@item @emph{Example}:
+See @code{HUGE} for an example.
+@end table
+
+
+
+@node TRAILZ
+@section @code{TRAILZ} --- Number of trailing zero bits of an integer
+@fnindex TRAILZ
+@cindex zero bits
+
+@table @asis
+@item @emph{Description}:
+@code{TRAILZ} returns the number of trailing zero bits of an integer.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = TRAILZ(I)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab Shall be of type @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The type of the return value is the default @code{INTEGER}.
+If all the bits of @code{I} are zero, the result value is @code{BIT_SIZE(I)}.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_trailz
+  WRITE (*,*) TRAILZ(8)  ! prints 3
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{BIT_SIZE}, @ref{LEADZ}, @ref{POPPAR}, @ref{POPCNT}
+@end table
+
+
+
+@node TRANSFER
+@section @code{TRANSFER} --- Transfer bit patterns
+@fnindex TRANSFER
+@cindex bits, move
+@cindex type cast
+
+@table @asis
+@item @emph{Description}:
+Interprets the bitwise representation of @var{SOURCE} in memory as if it
+is the representation of a variable or array of the same type and type
+parameters as @var{MOLD}.
+
+This is approximately equivalent to the C concept of @emph{casting} one
+type to another.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@code{RESULT = TRANSFER(SOURCE, MOLD[, SIZE])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{SOURCE} @tab Shall be a scalar or an array of any type.
+@item @var{MOLD}   @tab Shall be a scalar or an array of any type.
+@item @var{SIZE}   @tab (Optional) shall be a scalar of type 
+@code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The result has the same type as @var{MOLD}, with the bit level
+representation of @var{SOURCE}.  If @var{SIZE} is present, the result is
+a one-dimensional array of length @var{SIZE}.  If @var{SIZE} is absent
+but @var{MOLD} is an array (of any size or shape), the result is a one-
+dimensional array of the minimum length needed to contain the entirety
+of the bitwise representation of @var{SOURCE}.   If @var{SIZE} is absent
+and @var{MOLD} is a scalar, the result is a scalar.
+
+If the bitwise representation of the result is longer than that of
+@var{SOURCE}, then the leading bits of the result correspond to those of
+@var{SOURCE} and any trailing bits are filled arbitrarily.
+
+When the resulting bit representation does not correspond to a valid
+representation of a variable of the same type as @var{MOLD}, the results
+are undefined, and subsequent operations on the result cannot be
+guaranteed to produce sensible behavior.  For example, it is possible to
+create @code{LOGICAL} variables for which @code{@var{VAR}} and
+@code{.NOT.@var{VAR}} both appear to be true.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_transfer
+  integer :: x = 2143289344
+  print *, transfer(x, 1.0)    ! prints "NaN" on i686
+END PROGRAM
+@end smallexample
+@end table
+
+
+
+@node TRANSPOSE
+@section @code{TRANSPOSE} --- Transpose an array of rank two
+@fnindex TRANSPOSE
+@cindex array, transpose
+@cindex matrix, transpose
+@cindex transpose
+
+@table @asis
+@item @emph{Description}:
+Transpose an array of rank two. Element (i, j) of the result has the value 
+@code{MATRIX(j, i)}, for all i, j.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@code{RESULT = TRANSPOSE(MATRIX)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{MATRIX} @tab Shall be an array of any type and have a rank of two.
+@end multitable
+
+@item @emph{Return value}:
+The result has the same type as @var{MATRIX}, and has shape 
+@code{(/ m, n /)} if @var{MATRIX} has shape @code{(/ n, m /)}.
+@end table
+
+
+
+@node TRIM
+@section @code{TRIM} --- Remove trailing blank characters of a string
+@fnindex TRIM
+@cindex string, remove trailing whitespace
+
+@table @asis
+@item @emph{Description}:
+Removes trailing blank characters of a string.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@code{RESULT = TRIM(STRING)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{STRING} @tab Shall be a scalar of type @code{CHARACTER}.
+@end multitable
+
+@item @emph{Return value}:
+A scalar of type @code{CHARACTER} which length is that of @var{STRING}
+less the number of trailing blanks.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_trim
+  CHARACTER(len=10), PARAMETER :: s = "GFORTRAN  "
+  WRITE(*,*) LEN(s), LEN(TRIM(s))  ! "10 8", with/without trailing blanks
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{ADJUSTL}, @ref{ADJUSTR}
+@end table
+
+
+
+@node TTYNAM
+@section @code{TTYNAM} --- Get the name of a terminal device.
+@fnindex TTYNAM
+@cindex system, terminal
+
+@table @asis
+@item @emph{Description}:
+Get the name of a terminal device. For more information, 
+see @code{ttyname(3)}.
+
+This intrinsic is provided in both subroutine and function forms; 
+however, only one form can be used in any given program unit. 
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine, function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{CALL TTYNAM(UNIT, NAME)}
+@item @code{NAME = TTYNAM(UNIT)}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{UNIT} @tab Shall be a scalar @code{INTEGER}.
+@item @var{NAME} @tab Shall be of type @code{CHARACTER}.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_ttynam
+  INTEGER :: unit
+  DO unit = 1, 10
+    IF (isatty(unit=unit)) write(*,*) ttynam(unit)
+  END DO
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{ISATTY}
+@end table
+
+
+
+@node UBOUND
+@section @code{UBOUND} --- Upper dimension bounds of an array
+@fnindex UBOUND
+@cindex array, upper bound
+
+@table @asis
+@item @emph{Description}:
+Returns the upper bounds of an array, or a single upper bound
+along the @var{DIM} dimension.
+@item @emph{Standard}:
+Fortran 95 and later, with @var{KIND} argument Fortran 2003 and later
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{RESULT = UBOUND(ARRAY [, DIM [, KIND]])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ARRAY} @tab Shall be an array, of any type.
+@item @var{DIM} @tab (Optional) Shall be a scalar @code{INTEGER}.
+@item @var{KIND}@tab (Optional) An @code{INTEGER} initialization
+expression indicating the kind parameter of the result.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of kind @var{KIND}. If
+@var{KIND} is absent, the return value is of default integer kind.
+If @var{DIM} is absent, the result is an array of the upper bounds of
+@var{ARRAY}.  If @var{DIM} is present, the result is a scalar
+corresponding to the upper bound of the array along that dimension.  If
+@var{ARRAY} is an expression rather than a whole array or array
+structure component, or if it has a zero extent along the relevant
+dimension, the upper bound is taken to be the number of elements along
+the relevant dimension.
+
+@item @emph{See also}:
+@ref{LBOUND}, @ref{LCOBOUND}
+@end table
+
+
+
+@node UCOBOUND
+@section @code{UCOBOUND} --- Upper codimension bounds of an array
+@fnindex UCOBOUND
+@cindex coarray, upper bound
+
+@table @asis
+@item @emph{Description}:
+Returns the upper cobounds of a coarray, or a single upper cobound
+along the @var{DIM} codimension.
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{RESULT = UCOBOUND(COARRAY [, DIM [, KIND]])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ARRAY} @tab Shall be an coarray, of any type.
+@item @var{DIM} @tab (Optional) Shall be a scalar @code{INTEGER}.
+@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
+expression indicating the kind parameter of the result.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of kind @var{KIND}. If
+@var{KIND} is absent, the return value is of default integer kind.
+If @var{DIM} is absent, the result is an array of the lower cobounds of
+@var{COARRAY}.  If @var{DIM} is present, the result is a scalar
+corresponding to the lower cobound of the array along that codimension.
+
+@item @emph{See also}:
+@ref{LCOBOUND}, @ref{LBOUND}
+@end table
+
+
+
+@node UMASK
+@section @code{UMASK} --- Set the file creation mask
+@fnindex UMASK
+@cindex file system, file creation mask
+
+@table @asis
+@item @emph{Description}:
+Sets the file creation mask to @var{MASK}. If called as a function, it
+returns the old value. If called as a subroutine and argument @var{OLD}
+if it is supplied, it is set to the old value. See @code{umask(2)}.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine, function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{CALL UMASK(MASK [, OLD])}
+@item @code{OLD = UMASK(MASK)}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{MASK} @tab Shall be a scalar of type @code{INTEGER}.
+@item @var{OLD} @tab (Optional) Shall be a scalar of type
+@code{INTEGER}.
+@end multitable
+
+@end table
+
+
+
+@node UNLINK
+@section @code{UNLINK} --- Remove a file from the file system
+@fnindex UNLINK
+@cindex file system, remove file
+
+@table @asis
+@item @emph{Description}:
+Unlinks the file @var{PATH}. A null character (@code{CHAR(0)}) can be
+used to mark the end of the name in @var{PATH}; otherwise, trailing
+blanks in the file name are ignored.  If the @var{STATUS} argument is
+supplied, it contains 0 on success or a nonzero error code upon return;
+see @code{unlink(2)}.
+
+This intrinsic is provided in both subroutine and function forms;
+however, only one form can be used in any given program unit.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Subroutine, function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{CALL UNLINK(PATH [, STATUS])}
+@item @code{STATUS = UNLINK(PATH)}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{PATH} @tab Shall be of default @code{CHARACTER} type.
+@item @var{STATUS} @tab (Optional) Shall be of default @code{INTEGER} type.
+@end multitable
+
+@item @emph{See also}:
+@ref{LINK}, @ref{SYMLNK}
+@end table
+
+
+
+@node UNPACK
+@section @code{UNPACK} --- Unpack an array of rank one into an array
+@fnindex UNPACK
+@cindex array, unpacking
+@cindex array, increase dimension
+@cindex array, scatter elements
+
+@table @asis
+@item @emph{Description}:
+Store the elements of @var{VECTOR} in an array of higher rank.
+
+@item @emph{Standard}:
+Fortran 95 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@code{RESULT = UNPACK(VECTOR, MASK, FIELD)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{VECTOR} @tab Shall be an array of any type and rank one. It 
+shall have at least as many elements as @var{MASK} has @code{TRUE} values.
+@item @var{MASK}   @tab Shall be an array of type @code{LOGICAL}.
+@item @var{FIELD}  @tab Shall be of the same type as @var{VECTOR} and have
+the same shape as @var{MASK}.
+@end multitable
+
+@item @emph{Return value}:
+The resulting array corresponds to @var{FIELD} with @code{TRUE} elements
+of @var{MASK} replaced by values from @var{VECTOR} in array element order.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_unpack
+  integer :: vector(2)  = (/1,1/)
+  logical :: mask(4)  = (/ .TRUE., .FALSE., .FALSE., .TRUE. /)
+  integer :: field(2,2) = 0, unity(2,2)
+
+  ! result: unity matrix
+  unity = unpack(vector, reshape(mask, (/2,2/)), field)
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{PACK}, @ref{SPREAD}
+@end table
+
+
+
+@node VERIFY
+@section @code{VERIFY} --- Scan a string for characters not a given set
+@fnindex VERIFY
+@cindex string, find missing set
+
+@table @asis
+@item @emph{Description}:
+Verifies that all the characters in @var{STRING} belong to the set of
+characters in @var{SET}.
+
+If @var{BACK} is either absent or equals @code{FALSE}, this function
+returns the position of the leftmost character of @var{STRING} that is
+not in @var{SET}. If @var{BACK} equals @code{TRUE}, the rightmost
+position is returned. If all characters of @var{STRING} are found in
+@var{SET}, the result is zero.
+
+@item @emph{Standard}:
+Fortran 95 and later, with @var{KIND} argument Fortran 2003 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = VERIFY(STRING, SET[, BACK [, KIND]])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{STRING} @tab Shall be of type @code{CHARACTER}.
+@item @var{SET}    @tab Shall be of type @code{CHARACTER}.
+@item @var{BACK}   @tab (Optional) shall be of type @code{LOGICAL}.
+@item @var{KIND}   @tab (Optional) An @code{INTEGER} initialization
+expression indicating the kind parameter of the result.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of kind @var{KIND}. If
+@var{KIND} is absent, the return value is of default integer kind.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_verify
+  WRITE(*,*) VERIFY("FORTRAN", "AO")           ! 1, found 'F'
+  WRITE(*,*) VERIFY("FORTRAN", "FOO")          ! 3, found 'R'
+  WRITE(*,*) VERIFY("FORTRAN", "C++")          ! 1, found 'F'
+  WRITE(*,*) VERIFY("FORTRAN", "C++", .TRUE.)  ! 7, found 'N'
+  WRITE(*,*) VERIFY("FORTRAN", "FORTRAN")      ! 0' found none
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{SCAN}, @ref{INDEX intrinsic}
+@end table
+
+
+
+@node XOR
+@section @code{XOR} --- Bitwise logical exclusive OR
+@fnindex XOR
+@cindex bitwise logical exclusive or
+@cindex logical exclusive or, bitwise
+
+@table @asis
+@item @emph{Description}:
+Bitwise logical exclusive or. 
+
+This intrinsic routine is provided for backwards compatibility with 
+GNU Fortran 77.  For integer arguments, programmers should consider
+the use of the @ref{IEOR} intrinsic and for logical arguments the
+@code{.NEQV.} operator, which are both defined by the Fortran standard.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Function
+
+@item @emph{Syntax}:
+@code{RESULT = XOR(I, J)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab The type shall be either  a scalar @code{INTEGER}
+type or a scalar @code{LOGICAL} type.
+@item @var{J} @tab The type shall be the same as the type of @var{I}.
+@end multitable
+
+@item @emph{Return value}:
+The return type is either a scalar @code{INTEGER} or a scalar
+@code{LOGICAL}.  If the kind type parameters differ, then the
+smaller kind type is implicitly converted to larger kind, and the 
+return has the larger kind.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_xor
+  LOGICAL :: T = .TRUE., F = .FALSE.
+  INTEGER :: a, b
+  DATA a / Z'F' /, b / Z'3' /
+
+  WRITE (*,*) XOR(T, T), XOR(T, F), XOR(F, T), XOR(F, F)
+  WRITE (*,*) XOR(a, b)
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+Fortran 95 elemental function: @ref{IEOR}
+@end table
+
+
+
+@node Intrinsic Modules
+@chapter Intrinsic Modules
+@cindex intrinsic Modules
+
+@menu
+* ISO_FORTRAN_ENV::
+* ISO_C_BINDING::
+* OpenMP Modules OMP_LIB and OMP_LIB_KINDS::
+@end menu
+
+@node ISO_FORTRAN_ENV
+@section @code{ISO_FORTRAN_ENV}
+@table @asis
+@item @emph{Standard}:
+Fortran 2003 and later, except when otherwise noted
+@end table
+
+The @code{ISO_FORTRAN_ENV} module provides the following scalar default-integer
+named constants:
+
+@table @asis
+@item @code{ATOMIC_INT_KIND}:
+Default-kind integer constant to be used as kind parameter when defining
+integer variables used in atomic operations. (Fortran 2008 or later.)
+
+@item @code{ATOMIC_LOGICAL_KIND}:
+Default-kind integer constant to be used as kind parameter when defining
+logical variables used in atomic operations. (Fortran 2008 or later.)
+
+@item @code{CHARACTER_KINDS}:
+Default-kind integer constant array of rank one containing the supported kind
+parameters of the @code{CHARACTER} type. (Fortran 2008 or later.)
+
+@item @code{CHARACTER_STORAGE_SIZE}:
+Size in bits of the character storage unit.
+
+@item @code{ERROR_UNIT}:
+Identifies the preconnected unit used for error reporting.
+
+@item @code{FILE_STORAGE_SIZE}:
+Size in bits of the file-storage unit.
+
+@item @code{INPUT_UNIT}:
+Identifies the preconnected unit identified by the asterisk
+(@code{*}) in @code{READ} statement.
+
+@item @code{INT8}, @code{INT16}, @code{INT32}, @code{INT64}:
+Kind type parameters to specify an INTEGER type with a storage
+size of 16, 32, and 64 bits. It is negative if a target platform
+does not support the particular kind. (Fortran 2008 or later.)
+
+@item @code{INTEGER_KINDS}:
+Default-kind integer constant array of rank one containing the supported kind
+parameters of the @code{INTEGER} type. (Fortran 2008 or later.)
+
+@item @code{IOSTAT_END}:
+The value assigned to the variable passed to the @code{IOSTAT=} specifier of
+an input/output statement if an end-of-file condition occurred.
+
+@item @code{IOSTAT_EOR}:
+The value assigned to the variable passed to the @code{IOSTAT=} specifier of
+an input/output statement if an end-of-record condition occurred.
+
+@item @code{IOSTAT_INQUIRE_INTERNAL_UNIT}:
+Scalar default-integer constant, used by @code{INQUIRE} for the
+@code{IOSTAT=} specifier to denote an that a unit number identifies an
+internal unit. (Fortran 2008 or later.)
+
+@item @code{NUMERIC_STORAGE_SIZE}:
+The size in bits of the numeric storage unit.
+
+@item @code{LOGICAL_KINDS}:
+Default-kind integer constant array of rank one containing the supported kind
+parameters of the @code{LOGICAL} type. (Fortran 2008 or later.)
+
+@item @code{OUTPUT_UNIT}:
+Identifies the preconnected unit identified by the asterisk
+(@code{*}) in @code{WRITE} statement.
+
+@item @code{REAL32}, @code{REAL64}, @code{REAL128}:
+Kind type parameters to specify a REAL type with a storage
+size of 32, 64, and 128 bits. It is negative if a target platform
+does not support the particular kind. (Fortran 2008 or later.)
+
+@item @code{REAL_KINDS}:
+Default-kind integer constant array of rank one containing the supported kind
+parameters of the @code{REAL} type. (Fortran 2008 or later.)
+
+@item @code{STAT_LOCKED}:
+Scalar default-integer constant used as STAT= return value by @code{LOCK} to
+denote that the lock variable is locked by the executing image. (Fortran 2008
+or later.)
+
+@item @code{STAT_LOCKED_OTHER_IMAGE}:
+Scalar default-integer constant used as STAT= return value by @code{UNLOCK} to
+denote that the lock variable is locked by another image. (Fortran 2008 or
+later.)
+
+@item @code{STAT_STOPPED_IMAGE}:
+Positive, scalar default-integer constant used as STAT= return value if the
+argument in the statement requires synchronisation with an image, which has
+initiated the termination of the execution. (Fortran 2008 or later.)
+
+@item @code{STAT_UNLOCKED}:
+Scalar default-integer constant used as STAT= return value by @code{UNLOCK} to
+denote that the lock variable is unlocked. (Fortran 2008 or later.)
+@end table
+
+The module provides the following derived type:
+
+@table @asis
+@item @code{LOCK_TYPE}:
+Derived type with private components to be use with the @code{LOCK} and
+@code{UNLOCK} statement. A variable of its type has to be always declared
+as coarray and may not appear in a variable-definition context.
+(Fortran 2008 or later.)
+@end table
+
+The module also provides the following intrinsic procedures:
+@ref{COMPILER_OPTIONS} and @ref{COMPILER_VERSION}.
+
+
+
+@node ISO_C_BINDING
+@section @code{ISO_C_BINDING}
+@table @asis
+@item @emph{Standard}:
+Fortran 2003 and later, GNU extensions
+@end table
+
+The following intrinsic procedures are provided by the module; their
+definition can be found in the section Intrinsic Procedures of this
+manual.
+
+@table @asis
+@item @code{C_ASSOCIATED}
+@item @code{C_F_POINTER}
+@item @code{C_F_PROCPOINTER}
+@item @code{C_FUNLOC}
+@item @code{C_LOC}
+@item @code{C_SIZEOF}
+@end table
+@c TODO: Vertical spacing between C_FUNLOC and C_LOC wrong in PDF,
+@c don't really know why.
+
+The @code{ISO_C_BINDING} module provides the following named constants of
+type default integer, which can be used as KIND type parameters.
+
+In addition to the integer named constants required by the Fortran 2003 
+standard and @code{C_PTRDIFF_T} of TS 29113, GNU Fortran provides as an
+extension named constants for the 128-bit integer types supported by the
+C compiler: @code{C_INT128_T, C_INT_LEAST128_T, C_INT_FAST128_T}.
+Furthermore, if @code{__float128} is supported in C, the named constants
+@code{C_FLOAT128, C_FLOAT128_COMPLEX} are defined.
+
+@multitable @columnfractions .15 .35 .35 .35
+@item Fortran Type  @tab Named constant         @tab C type                                @tab Extension
+@item @code{INTEGER}@tab @code{C_INT}           @tab @code{int}
+@item @code{INTEGER}@tab @code{C_SHORT}         @tab @code{short int}
+@item @code{INTEGER}@tab @code{C_LONG}          @tab @code{long int}
+@item @code{INTEGER}@tab @code{C_LONG_LONG}     @tab @code{long long int}
+@item @code{INTEGER}@tab @code{C_SIGNED_CHAR}   @tab @code{signed char}/@code{unsigned char}
+@item @code{INTEGER}@tab @code{C_SIZE_T}        @tab @code{size_t}
+@item @code{INTEGER}@tab @code{C_INT8_T}        @tab @code{int8_t}
+@item @code{INTEGER}@tab @code{C_INT16_T}       @tab @code{int16_t}
+@item @code{INTEGER}@tab @code{C_INT32_T}       @tab @code{int32_t}
+@item @code{INTEGER}@tab @code{C_INT64_T}       @tab @code{int64_t}
+@item @code{INTEGER}@tab @code{C_INT128_T}      @tab @code{int128_t}                      @tab Ext.
+@item @code{INTEGER}@tab @code{C_INT_LEAST8_T}  @tab @code{int_least8_t}
+@item @code{INTEGER}@tab @code{C_INT_LEAST16_T} @tab @code{int_least16_t}
+@item @code{INTEGER}@tab @code{C_INT_LEAST32_T} @tab @code{int_least32_t}
+@item @code{INTEGER}@tab @code{C_INT_LEAST64_T} @tab @code{int_least64_t}
+@item @code{INTEGER}@tab @code{C_INT_LEAST128_T}@tab @code{int_least128_t}                @tab Ext.
+@item @code{INTEGER}@tab @code{C_INT_FAST8_T}   @tab @code{int_fast8_t}
+@item @code{INTEGER}@tab @code{C_INT_FAST16_T}  @tab @code{int_fast16_t}
+@item @code{INTEGER}@tab @code{C_INT_FAST32_T}  @tab @code{int_fast32_t}
+@item @code{INTEGER}@tab @code{C_INT_FAST64_T}  @tab @code{int_fast64_t}
+@item @code{INTEGER}@tab @code{C_INT_FAST128_T} @tab @code{int_fast128_t}                 @tab Ext.
+@item @code{INTEGER}@tab @code{C_INTMAX_T}      @tab @code{intmax_t}
+@item @code{INTEGER}@tab @code{C_INTPTR_T}      @tab @code{intptr_t}
+@item @code{INTEGER}@tab @code{C_PTRDIFF_T}     @tab @code{intptr_t}                      @tab TS 29113
+@item @code{REAL}   @tab @code{C_FLOAT}         @tab @code{float}
+@item @code{REAL}   @tab @code{C_DOUBLE}        @tab @code{double}
+@item @code{REAL}   @tab @code{C_LONG_DOUBLE}   @tab @code{long double}
+@item @code{REAL}   @tab @code{C_FLOAT128}      @tab @code{__float128}                    @tab Ext.
+@item @code{COMPLEX}@tab @code{C_FLOAT_COMPLEX} @tab @code{float _Complex}
+@item @code{COMPLEX}@tab @code{C_DOUBLE_COMPLEX}@tab @code{double _Complex}
+@item @code{COMPLEX}@tab @code{C_LONG_DOUBLE_COMPLEX}@tab @code{long double _Complex}
+@item @code{REAL}   @tab @code{C_FLOAT128_COMPLEX}   @tab @code{__float128 _Complex}      @tab Ext.
+@item @code{LOGICAL}@tab @code{C_BOOL}          @tab @code{_Bool}
+@item @code{CHARACTER}@tab @code{C_CHAR}        @tab @code{char}
+@end multitable
+
+Additionally, the following parameters of type @code{CHARACTER(KIND=C_CHAR)}
+are defined.
+
+@multitable @columnfractions .20 .45 .15
+@item Name                     @tab C definition    @tab Value
+@item @code{C_NULL_CHAR}       @tab null character  @tab @code{'\0'}
+@item @code{C_ALERT}           @tab alert           @tab @code{'\a'}
+@item @code{C_BACKSPACE}       @tab backspace       @tab @code{'\b'}
+@item @code{C_FORM_FEED}       @tab form feed       @tab @code{'\f'}
+@item @code{C_NEW_LINE}        @tab new line        @tab @code{'\n'}
+@item @code{C_CARRIAGE_RETURN} @tab carriage return @tab @code{'\r'}
+@item @code{C_HORIZONTAL_TAB}  @tab horizontal tab  @tab @code{'\t'}
+@item @code{C_VERTICAL_TAB}    @tab vertical tab    @tab @code{'\v'}
+@end multitable
+
+Moreover, the following two named constants are defined:
+
+@multitable @columnfractions .20 .80
+@item Name                 @tab Type
+@item @code{C_NULL_PTR}    @tab @code{C_PTR}
+@item @code{C_NULL_FUNPTR} @tab @code{C_FUNPTR}
+@end multitable
+
+Both are equivalent to the value @code{NULL} in C.
+
+@node OpenMP Modules OMP_LIB and OMP_LIB_KINDS
+@section OpenMP Modules @code{OMP_LIB} and @code{OMP_LIB_KINDS}
+@table @asis
+@item @emph{Standard}:
+OpenMP Application Program Interface v4.0
+@end table
+
+
+The OpenMP Fortran runtime library routines are provided both in
+a form of two Fortran 90 modules, named @code{OMP_LIB} and 
+@code{OMP_LIB_KINDS}, and in a form of a Fortran @code{include} file named
+@file{omp_lib.h}. The procedures provided by @code{OMP_LIB} can be found
+in the @ref{Top,,Introduction,libgomp,GNU OpenMP runtime library} manual,
+the named constants defined in the modules are listed
+below.
+
+For details refer to the actual
+@uref{http://www.openmp.org/mp-documents/OpenMP4.0.0.pdf,
+OpenMP Application Program Interface v4.0}.
+
+@code{OMP_LIB_KINDS} provides the following scalar default-integer
+named constants:
+
+@table @asis
+@item @code{omp_lock_kind}
+@item @code{omp_nest_lock_kind}
+@item @code{omp_proc_bind_kind}
+@item @code{omp_sched_kind}
+@end table
+
+@code{OMP_LIB} provides the scalar default-integer
+named constant @code{openmp_version} with a value of the form
+@var{yyyymm}, where @code{yyyy} is the year and @var{mm} the month
+of the OpenMP version; for OpenMP v3.1 the value is @code{201107}
+and for OpenMP v4.0 the value is @code{201307}.
+
+The following scalar integer named constants of the
+kind @code{omp_sched_kind}:
+
+@table @asis
+@item @code{omp_sched_static}
+@item @code{omp_sched_dynamic}
+@item @code{omp_sched_guided}
+@item @code{omp_sched_auto}
+@end table
+
+And the following scalar integer named constants of the 
+kind @code{omp_proc_bind_kind}:
+
+@table @asis
+@item @code{omp_proc_bind_false}
+@item @code{omp_proc_bind_true}
+@item @code{omp_proc_bind_master}
+@item @code{omp_proc_bind_close}
+@item @code{omp_proc_bind_spread}
+@end table
diff --git a/gcc-4.9/gcc/fortran/invoke.texi b/gcc-4.9/gcc/fortran/invoke.texi
new file mode 100644
index 000000000..b92abfc2f
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/invoke.texi
@@ -0,0 +1,1641 @@
+@c Copyright (C) 2004-2014 Free Software Foundation, Inc.
+@c This is part of the GNU Fortran manual.   
+@c For copying conditions, see the file gfortran.texi.
+
+@ignore
+@c man begin COPYRIGHT
+Copyright @copyright{} 2004-2014 Free Software Foundation, Inc.
+
+Permission is granted to copy, distribute and/or modify this document
+under the terms of the GNU Free Documentation License, Version 1.3 or
+any later version published by the Free Software Foundation; with the
+Invariant Sections being ``Funding Free Software'', the Front-Cover
+Texts being (a) (see below), and with the Back-Cover Texts being (b)
+(see below).  A copy of the license is included in the gfdl(7) man page.
+
+(a) The FSF's Front-Cover Text is:
+
+     A GNU Manual
+
+(b) The FSF's Back-Cover Text is:
+
+     You have freedom to copy and modify this GNU Manual, like GNU
+     software.  Copies published by the Free Software Foundation raise
+     funds for GNU development.
+@c man end
+@c Set file name and title for the man page.
+@setfilename gfortran
+@settitle GNU Fortran compiler.
+@c man begin SYNOPSIS
+gfortran [@option{-c}|@option{-S}|@option{-E}]
+         [@option{-g}] [@option{-pg}] [@option{-O}@var{level}]
+         [@option{-W}@var{warn}@dots{}] [@option{-pedantic}]
+         [@option{-I}@var{dir}@dots{}] [@option{-L}@var{dir}@dots{}]
+         [@option{-D}@var{macro}[=@var{defn}]@dots{}] [@option{-U}@var{macro}]
+         [@option{-f}@var{option}@dots{}]
+         [@option{-m}@var{machine-option}@dots{}]
+         [@option{-o} @var{outfile}] @var{infile}@dots{}
+
+Only the most useful options are listed here; see below for the
+remainder.
+@c man end
+@c man begin SEEALSO
+gpl(7), gfdl(7), fsf-funding(7),
+cpp(1), gcov(1), gcc(1), as(1), ld(1), gdb(1), adb(1), dbx(1), sdb(1)
+and the Info entries for @file{gcc}, @file{cpp}, @file{gfortran}, @file{as},
+@file{ld}, @file{binutils} and @file{gdb}.
+@c man end
+@c man begin BUGS
+For instructions on reporting bugs, see
+@w{@value{BUGURL}}.
+@c man end
+@c man begin AUTHOR
+See the Info entry for @command{gfortran} for contributors to GCC and
+GNU Fortran.
+@c man end
+@end ignore
+
+@node Invoking GNU Fortran
+@chapter GNU Fortran Command Options
+@cindex GNU Fortran command options
+@cindex command options
+@cindex options, @command{gfortran} command
+
+@c man begin DESCRIPTION
+
+The @command{gfortran} command supports all the options supported by the
+@command{gcc} command.  Only options specific to GNU Fortran are documented
+here.
+
+@xref{Invoking GCC,,GCC Command Options,gcc,Using the GNU Compiler
+Collection (GCC)}, for information
+on the non-Fortran-specific aspects of the @command{gcc} command (and,
+therefore, the @command{gfortran} command).
+
+@cindex options, negative forms
+All GCC and GNU Fortran options
+are accepted both by @command{gfortran} and by @command{gcc}
+(as well as any other drivers built at the same time,
+such as @command{g++}),
+since adding GNU Fortran to the GCC distribution
+enables acceptance of GNU Fortran options
+by all of the relevant drivers.
+
+In some cases, options have positive and negative forms;
+the negative form of @option{-ffoo} would be @option{-fno-foo}.
+This manual documents only one of these two forms, whichever
+one is not the default.
+@c man end
+
+@menu
+* Option Summary::      Brief list of all @command{gfortran} options,
+                        without explanations.
+* Fortran Dialect Options::  Controlling the variant of Fortran language
+                             compiled.
+* Preprocessing Options::  Enable and customize preprocessing.
+* Error and Warning Options::     How picky should the compiler be?
+* Debugging Options::   Symbol tables, measurements, and debugging dumps.
+* Directory Options::   Where to find module files
+* Link Options ::       Influencing the linking step
+* Runtime Options::     Influencing runtime behavior
+* Code Gen Options::    Specifying conventions for function calls, data layout
+                        and register usage.
+* Environment Variables:: Environment variables that affect @command{gfortran}.
+@end menu
+
+@node Option Summary
+@section Option summary
+
+@c man begin OPTIONS
+
+Here is a summary of all the options specific to GNU Fortran, grouped
+by type.  Explanations are in the following sections.
+
+@table @emph
+@item Fortran Language Options
+@xref{Fortran Dialect Options,,Options controlling Fortran dialect}.
+@gccoptlist{-fall-intrinsics -fbackslash -fcray-pointer -fd-lines-as-code @gol
+-fd-lines-as-comments -fdefault-double-8 -fdefault-integer-8 @gol
+-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
+-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}
+}
+
+@item Preprocessing Options
+@xref{Preprocessing Options,,Enable and customize preprocessing}.
+@gccoptlist{-A-@var{question}@r{[}=@var{answer}@r{]}
+-A@var{question}=@var{answer} -C -CC -D@var{macro}@r{[}=@var{defn}@r{]}
+-H -P @gol
+-U@var{macro} -cpp -dD -dI -dM -dN -dU -fworking-directory
+-imultilib @var{dir} @gol
+-iprefix @var{file} -iquote -isysroot @var{dir} -isystem @var{dir} -nocpp 
+-nostdinc @gol
+-undef
+}
+
+@item Error and Warning Options
+@xref{Error and Warning Options,,Options to request or suppress errors
+and warnings}.
+@gccoptlist{-Waliasing -Wall -Wampersand -Warray-bounds
+-Wc-binding-type -Wcharacter-truncation @gol
+-Wconversion -Wfunction-elimination -Wimplicit-interface @gol
+-Wimplicit-procedure -Wintrinsic-shadow -Wintrinsics-std @gol
+-Wline-truncation -Wno-align-commons -Wno-tabs -Wreal-q-constant @gol
+-Wsurprising -Wunderflow -Wunused-parameter -Wrealloc-lhs -Wrealloc-lhs-all @gol
+-Wtarget-lifetime -fmax-errors=@var{n} -fsyntax-only -pedantic -pedantic-errors
+}
+
+@item Debugging Options
+@xref{Debugging Options,,Options for debugging your program or GNU Fortran}.
+@gccoptlist{-fbacktrace -fdump-fortran-optimized -fdump-fortran-original @gol
+-fdump-parse-tree -ffpe-trap=@var{list} -ffpe-summary=@var{list}
+}
+
+@item Directory Options
+@xref{Directory Options,,Options for directory search}.
+@gccoptlist{-I@var{dir}  -J@var{dir} -fintrinsic-modules-path @var{dir}}
+
+@item Link Options
+@xref{Link Options,,Options for influencing the linking step}.
+@gccoptlist{-static-libgfortran}
+
+@item Runtime Options
+@xref{Runtime Options,,Options for influencing runtime behavior}.
+@gccoptlist{-fconvert=@var{conversion} -fmax-subrecord-length=@var{length} @gol
+-frecord-marker=@var{length} -fsign-zero
+}
+
+@item Code Generation Options
+@xref{Code Gen Options,,Options for code generation conventions}.
+@gccoptlist{-faggressive-function-elimination -fblas-matmul-limit=@var{n} @gol
+-fbounds-check -fcheck-array-temporaries @gol
+-fcheck=@var{<all|array-temps|bounds|do|mem|pointer|recursion>} @gol
+-fcoarray=@var{<none|single|lib>} -fexternal-blas -ff2c
+-ffrontend-optimize @gol
+-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
+-fmax-array-constructor=@var{n} -fmax-stack-var-size=@var{n}
+-fno-align-commons @gol
+-fno-automatic -fno-protect-parens -fno-underscoring @gol
+-fsecond-underscore -fpack-derived -frealloc-lhs -frecursive @gol
+-frepack-arrays -fshort-enums -fstack-arrays
+}
+@end table
+
+@node Fortran Dialect Options
+@section Options controlling Fortran dialect
+@cindex dialect options
+@cindex language, dialect options
+@cindex options, dialect
+
+The following options control the details of the Fortran dialect
+accepted by the compiler:
+
+@table @gcctabopt
+@item -ffree-form
+@itemx -ffixed-form
+@opindex @code{ffree-form}
+@opindex @code{fno-fixed-form}
+@cindex options, Fortran dialect
+@cindex file format, free
+@cindex file format, fixed
+Specify the layout used by the source file.  The free form layout
+was introduced in Fortran 90.  Fixed form was traditionally used in
+older Fortran programs.  When neither option is specified, the source
+form is determined by the file extension.
+
+@item -fall-intrinsics
+@opindex @code{fall-intrinsics}
+This option causes all intrinsic procedures (including the GNU-specific
+extensions) to be accepted.  This can be useful with @option{-std=f95} to
+force standard-compliance but get access to the full range of intrinsics
+available with @command{gfortran}.  As a consequence, @option{-Wintrinsics-std}
+will be ignored and no user-defined procedure with the same name as any
+intrinsic will be called except when it is explicitly declared @code{EXTERNAL}.
+
+@item -fd-lines-as-code
+@itemx -fd-lines-as-comments
+@opindex @code{fd-lines-as-code}
+@opindex @code{fd-lines-as-comments}
+Enable special treatment for lines beginning with @code{d} or @code{D}
+in fixed form sources.  If the @option{-fd-lines-as-code} option is
+given they are treated as if the first column contained a blank.  If the
+@option{-fd-lines-as-comments} option is given, they are treated as
+comment lines.
+
+@item -fdollar-ok
+@opindex @code{fdollar-ok}
+@cindex @code{$}
+@cindex symbol names
+@cindex character set
+Allow @samp{$} as a valid non-first character in a symbol name. Symbols 
+that start with @samp{$} are rejected since it is unclear which rules to
+apply to implicit typing as different vendors implement different rules.
+Using @samp{$} in @code{IMPLICIT} statements is also rejected.
+
+@item -fbackslash
+@opindex @code{backslash}
+@cindex backslash
+@cindex escape characters
+Change the interpretation of backslashes in string literals from a single
+backslash character to ``C-style'' escape characters. The following
+combinations are expanded @code{\a}, @code{\b}, @code{\f}, @code{\n},
+@code{\r}, @code{\t}, @code{\v}, @code{\\}, and @code{\0} to the ASCII
+characters alert, backspace, form feed, newline, carriage return,
+horizontal tab, vertical tab, backslash, and NUL, respectively.
+Additionally, @code{\x}@var{nn}, @code{\u}@var{nnnn} and
+@code{\U}@var{nnnnnnnn} (where each @var{n} is a hexadecimal digit) are
+translated into the Unicode characters corresponding to the specified code
+points. All other combinations of a character preceded by \ are
+unexpanded.
+
+@item -fmodule-private
+@opindex @code{fmodule-private}
+@cindex module entities
+@cindex private
+Set the default accessibility of module entities to @code{PRIVATE}.
+Use-associated entities will not be accessible unless they are explicitly
+declared as @code{PUBLIC}.
+
+@item -ffixed-line-length-@var{n}
+@opindex @code{ffixed-line-length-}@var{n}
+@cindex file format, fixed
+Set column after which characters are ignored in typical fixed-form
+lines in the source file, and through which spaces are assumed (as
+if padded to that length) after the ends of short fixed-form lines.
+
+Popular values for @var{n} include 72 (the
+standard and the default), 80 (card image), and 132 (corresponding
+to ``extended-source'' options in some popular compilers).
+@var{n} may also be @samp{none}, meaning that the entire line is meaningful
+and that continued character constants never have implicit spaces appended
+to them to fill out the line.
+@option{-ffixed-line-length-0} means the same thing as
+@option{-ffixed-line-length-none}.
+
+@item -ffree-line-length-@var{n}
+@opindex @code{ffree-line-length-}@var{n}
+@cindex file format, free
+Set column after which characters are ignored in typical free-form
+lines in the source file. The default value is 132.
+@var{n} may be @samp{none}, meaning that the entire line is meaningful.
+@option{-ffree-line-length-0} means the same thing as
+@option{-ffree-line-length-none}.
+
+@item -fmax-identifier-length=@var{n}
+@opindex @code{fmax-identifier-length=}@var{n}
+Specify the maximum allowed identifier length. Typical values are
+31 (Fortran 95) and 63 (Fortran 2003 and Fortran 2008).
+
+@item -fimplicit-none
+@opindex @code{fimplicit-none}
+Specify that no implicit typing is allowed, unless overridden by explicit
+@code{IMPLICIT} statements.  This is the equivalent of adding
+@code{implicit none} to the start of every procedure.
+
+@item -fcray-pointer
+@opindex @code{fcray-pointer}
+Enable the Cray pointer extension, which provides C-like pointer
+functionality.
+
+@item -fopenmp
+@opindex @code{fopenmp}
+@cindex OpenMP
+Enable the OpenMP extensions.  This includes OpenMP @code{!$omp} directives
+in free form
+and @code{c$omp}, @code{*$omp} and @code{!$omp} directives in fixed form,
+@code{!$} conditional compilation sentinels in free form
+and @code{c$}, @code{*$} and @code{!$} sentinels in fixed form, 
+and when linking arranges for the OpenMP runtime library to be linked
+in.  The option @option{-fopenmp} implies @option{-frecursive}.
+
+@item -fno-range-check
+@opindex @code{frange-check}
+Disable range checking on results of simplification of constant
+expressions during compilation.  For example, GNU Fortran will give
+an error at compile time when simplifying @code{a = 1. / 0}.
+With this option, no error will be given and @code{a} will be assigned
+the value @code{+Infinity}.  If an expression evaluates to a value
+outside of the relevant range of [@code{-HUGE()}:@code{HUGE()}],
+then the expression will be replaced by @code{-Inf} or @code{+Inf}
+as appropriate.
+Similarly, @code{DATA i/Z'FFFFFFFF'/} will result in an integer overflow
+on most systems, but with @option{-fno-range-check} the value will
+``wrap around'' and @code{i} will be initialized to @math{-1} instead.
+
+@item -fdefault-integer-8
+@opindex @code{fdefault-integer-8}
+Set the default integer and logical types to an 8 byte wide type.  This option
+also affects the kind of integer constants like @code{42}. Unlike
+@option{-finteger-4-integer-8}, it does not promote variables with explicit
+kind declaration.
+
+@item -fdefault-real-8
+@opindex @code{fdefault-real-8}
+Set the default real type to an 8 byte wide type. This option also affects
+the kind of non-double real constants like @code{1.0}, and does promote
+the default width of @code{DOUBLE PRECISION} to 16 bytes if possible, unless
+@code{-fdefault-double-8} is given, too. Unlike @option{-freal-4-real-8},
+it does not promote variables with explicit kind declaration.
+
+@item -fdefault-double-8
+@opindex @code{fdefault-double-8}
+Set the @code{DOUBLE PRECISION} type to an 8 byte wide type.  Do nothing if this
+is already the default.  If @option{-fdefault-real-8} is given,
+@code{DOUBLE PRECISION} would instead be promoted to 16 bytes if possible, and
+@option{-fdefault-double-8} can be used to prevent this.  The kind of real
+constants like @code{1.d0} will not be changed by @option{-fdefault-real-8}
+though, so also @option{-fdefault-double-8} does not affect it.
+
+@item -finteger-4-integer-8
+@opindex @code{finteger-4-integer-8}
+Promote all @code{INTEGER(KIND=4)} entities to an @code{INTEGER(KIND=8)}
+entities.  If @code{KIND=8} is unavailable, then an error will be issued.
+This option should be used with care and may not be suitable for your codes.
+Areas of possible concern include calls to external procedures,
+alignment in @code{EQUIVALENCE} and/or @code{COMMON}, generic interfaces,
+BOZ literal constant conversion, and I/O.  Inspection of the intermediate
+representation of the translated Fortran code, produced by
+@option{-fdump-tree-original}, is suggested.
+
+@item  -freal-4-real-8
+@itemx -freal-4-real-10
+@itemx -freal-4-real-16
+@itemx -freal-8-real-4
+@itemx -freal-8-real-10
+@itemx -freal-8-real-16
+@opindex @code{freal-4-real-8}
+@opindex @code{freal-4-real-10}
+@opindex @code{freal-4-real-16}
+@opindex @code{freal-8-real-4}
+@opindex @code{freal-8-real-10}
+@opindex @code{freal-8-real-16}
+@cindex options, real kind type promotion
+Promote all @code{REAL(KIND=M)} entities to @code{REAL(KIND=N)} entities.
+If @code{REAL(KIND=N)} is unavailable, then an error will be issued.
+All other real kind types are unaffected by this option.
+These options should be used with care and may not be suitable for your
+codes.  Areas of possible concern include calls to external procedures,
+alignment in @code{EQUIVALENCE} and/or @code{COMMON}, generic interfaces,
+BOZ literal constant conversion, and I/O.  Inspection of the intermediate
+representation of the translated Fortran code, produced by
+@option{-fdump-tree-original}, is suggested.
+
+@item -std=@var{std}
+@opindex @code{std=}@var{std} option
+Specify the standard to which the program is expected to conform, which
+may be one of @samp{f95}, @samp{f2003}, @samp{f2008}, @samp{gnu}, or
+@samp{legacy}.  The default value for @var{std} is @samp{gnu}, which
+specifies a superset of the Fortran 95 standard that includes all of the
+extensions supported by GNU Fortran, although warnings will be given for
+obsolete extensions not recommended for use in new code.  The
+@samp{legacy} value is equivalent but without the warnings for obsolete
+extensions, and may be useful for old non-standard programs.  The
+@samp{f95}, @samp{f2003} and @samp{f2008} values specify strict
+conformance to the Fortran 95, Fortran 2003 and Fortran 2008 standards,
+respectively; errors are given for all extensions beyond the relevant
+language standard, and warnings are given for the Fortran 77 features
+that are permitted but obsolescent in later standards. @samp{-std=f2008ts}
+allows the Fortran 2008 standard including the additions of the 
+Technical Specification (TS) 29113 on Further Interoperability of Fortran
+with C.
+
+@end table
+
+@node Preprocessing Options
+@section Enable and customize preprocessing
+@cindex preprocessor
+@cindex options, preprocessor
+@cindex CPP
+
+Preprocessor related options. See section 
+@ref{Preprocessing and conditional compilation} for more detailed
+information on preprocessing in @command{gfortran}.
+
+@table @gcctabopt
+@item -cpp
+@itemx -nocpp
+@opindex @code{cpp}
+@opindex @code{fpp}
+@cindex preprocessor, enable
+@cindex preprocessor, disable
+Enable preprocessing. The preprocessor is automatically invoked if
+the file extension is @file{.fpp}, @file{.FPP},  @file{.F}, @file{.FOR},
+@file{.FTN}, @file{.F90}, @file{.F95}, @file{.F03} or @file{.F08}. Use
+this option to manually enable preprocessing of any kind of Fortran file.
+
+To disable preprocessing of files with any of the above listed extensions,
+use the negative form: @option{-nocpp}.
+
+The preprocessor is run in traditional mode. Any restrictions of the
+file-format, especially the limits on line length, apply for
+preprocessed output as well, so it might be advisable to use the
+@option{-ffree-line-length-none} or @option{-ffixed-line-length-none}
+options.
+
+@item -dM
+@opindex @code{dM}
+@cindex preprocessor, debugging
+@cindex debugging, preprocessor
+Instead of the normal output, generate a list of @code{'#define'}
+directives for all the macros defined during the execution of the
+preprocessor, including predefined macros. This gives you a way
+of finding out what is predefined in your version of the preprocessor.
+Assuming you have no file @file{foo.f90}, the command
+@smallexample
+  touch foo.f90; gfortran -cpp -E -dM foo.f90
+@end smallexample
+will show all the predefined macros.
+
+@item -dD
+@opindex @code{dD}
+@cindex preprocessor, debugging
+@cindex debugging, preprocessor
+Like @option{-dM} except in two respects: it does not include the
+predefined macros, and it outputs both the @code{#define} directives
+and the result of preprocessing. Both kinds of output go to the
+standard output file.
+
+@item -dN
+@opindex @code{dN}
+@cindex preprocessor, debugging
+@cindex debugging, preprocessor
+Like @option{-dD}, but emit only the macro names, not their expansions.
+
+@item -dU
+@opindex @code{dU}
+@cindex preprocessor, debugging
+@cindex debugging, preprocessor
+Like @option{dD} except that only macros that are expanded, or whose
+definedness is tested in preprocessor directives, are output; the 
+output is delayed until the use or test of the macro; and @code{'#undef'}
+directives are also output for macros tested but undefined at the time.
+
+@item -dI
+@opindex @code{dI}
+@cindex preprocessor, debugging
+@cindex debugging, preprocessor
+Output @code{'#include'} directives in addition to the result
+of preprocessing.
+
+@item -fworking-directory
+@opindex @code{fworking-directory}
+@cindex preprocessor, working directory
+Enable generation of linemarkers in the preprocessor output that will
+let the compiler know the current working directory at the time of
+preprocessing. When this option is enabled, the preprocessor will emit,
+after the initial linemarker, a second linemarker with the current
+working directory followed by two slashes. GCC will use this directory,
+when it is present in the preprocessed input, as the directory emitted
+as the current working directory in some debugging information formats.
+This option is implicitly enabled if debugging information is enabled,
+but this can be inhibited with the negated form
+@option{-fno-working-directory}. If the @option{-P} flag is present
+in the command line, this option has no effect, since no @code{#line}
+directives are emitted whatsoever.
+
+@item -idirafter @var{dir}
+@opindex @code{idirafter @var{dir}}
+@cindex preprocessing, include path
+Search @var{dir} for include files, but do it after all directories
+specified with @option{-I} and the standard system directories have
+been exhausted. @var{dir} is treated as a system include directory.
+If dir begins with @code{=}, then the @code{=} will be replaced by
+the sysroot prefix; see @option{--sysroot} and @option{-isysroot}.
+
+@item -imultilib @var{dir}
+@opindex @code{imultilib @var{dir}}
+@cindex preprocessing, include path
+Use @var{dir} as a subdirectory of the directory containing target-specific
+C++ headers.
+
+@item -iprefix @var{prefix}
+@opindex @code{iprefix @var{prefix}}
+@cindex preprocessing, include path
+Specify @var{prefix} as the prefix for subsequent @option{-iwithprefix}
+options. If the @var{prefix} represents a directory, you should include
+the final @code{'/'}.
+
+@item -isysroot @var{dir}
+@opindex @code{isysroot @var{dir}}
+@cindex preprocessing, include path
+This option is like the @option{--sysroot} option, but applies only to
+header files. See the @option{--sysroot} option for more information.
+
+@item -iquote @var{dir}
+@opindex @code{iquote @var{dir}}
+@cindex preprocessing, include path
+Search @var{dir} only for header files requested with @code{#include "file"};
+they are not searched for @code{#include <file>}, before all directories
+specified by @option{-I} and before the standard system directories. If
+@var{dir} begins with @code{=}, then the @code{=} will be replaced by the
+sysroot prefix; see @option{--sysroot} and @option{-isysroot}.
+
+@item -isystem @var{dir}
+@opindex @code{isystem @var{dir}}
+@cindex preprocessing, include path
+Search @var{dir} for header files, after all directories specified by
+@option{-I} but before the standard system directories. Mark it as a
+system directory, so that it gets the same special treatment as is
+applied to the standard system directories. If @var{dir} begins with
+@code{=}, then the @code{=} will be replaced by the sysroot prefix;
+see @option{--sysroot} and @option{-isysroot}.
+
+@item -nostdinc
+@opindex @code{nostdinc}
+Do not search the standard system directories for header files. Only
+the directories you have specified with @option{-I} options (and the
+directory of the current file, if appropriate) are searched.
+
+@item -undef
+@opindex @code{undef}
+Do not predefine any system-specific or GCC-specific macros.
+The standard predefined macros remain defined.
+
+@item -A@var{predicate}=@var{answer}
+@opindex @code{A@var{predicate}=@var{answer}}
+@cindex preprocessing, assertion
+Make an assertion with the predicate @var{predicate} and answer @var{answer}.
+This form is preferred to the older form -A predicate(answer), which is still
+supported, because it does not use shell special characters.
+
+@item -A-@var{predicate}=@var{answer}
+@opindex @code{A-@var{predicate}=@var{answer}}
+@cindex preprocessing, assertion
+Cancel an assertion with the predicate @var{predicate} and answer @var{answer}.
+
+@item -C
+@opindex @code{C}
+@cindex preprocessing, keep comments
+Do not discard comments. All comments are passed through to the output
+file, except for comments in processed directives, which are deleted
+along with the directive.
+
+You should be prepared for side effects when using @option{-C}; it causes
+the preprocessor to treat comments as tokens in their own right. For example,
+comments appearing at the start of what would be a directive line have the
+effect of turning that line into an ordinary source line, since the first
+token on the line is no longer a @code{'#'}.
+
+Warning: this currently handles C-Style comments only. The preprocessor
+does not yet recognize Fortran-style comments.
+
+@item -CC
+@opindex @code{CC}
+@cindex preprocessing, keep comments
+Do not discard comments, including during macro expansion. This is like
+@option{-C}, except that comments contained within macros are also passed
+through to the output file where the macro is expanded.
+
+In addition to the side-effects of the @option{-C} option, the @option{-CC}
+option causes all C++-style comments inside a macro to be converted to C-style
+comments. This is to prevent later use of that macro from inadvertently
+commenting out the remainder of the source line. The @option{-CC} option
+is generally used to support lint comments.
+
+Warning: this currently handles C- and C++-Style comments only. The
+preprocessor does not yet recognize Fortran-style comments.
+
+@item -D@var{name}
+@opindex @code{D@var{name}}
+@cindex preprocessing, define macros
+Predefine name as a macro, with definition @code{1}.
+
+@item -D@var{name}=@var{definition}
+@opindex @code{D@var{name}=@var{definition}}
+@cindex preprocessing, define macros
+The contents of @var{definition} are tokenized and processed as if they
+appeared during translation phase three in a @code{'#define'} directive.
+In particular, the definition will be truncated by embedded newline
+characters.
+
+If you are invoking the preprocessor from a shell or shell-like program
+you may need to use the shell's quoting syntax to protect characters such
+as spaces that have a meaning in the shell syntax.
+
+If you wish to define a function-like macro on the command line, write
+its argument list with surrounding parentheses before the equals sign
+(if any). Parentheses are meaningful to most shells, so you will need
+to quote the option. With sh and csh, @code{-D'name(args...)=definition'}
+works.
+
+@option{-D} and @option{-U} options are processed in the order they are
+given on the command line. All -imacros file and -include file options
+are processed after all -D and -U options.
+
+@item -H
+@opindex @code{H}
+Print the name of each header file used, in addition to other normal
+activities. Each name is indented to show how deep in the @code{'#include'}
+stack it is.
+
+@item -P
+@opindex @code{P}
+@cindex preprocessing, no linemarkers
+Inhibit generation of linemarkers in the output from the preprocessor.
+This might be useful when running the preprocessor on something that
+is not C code, and will be sent to a program which might be confused
+by the linemarkers.
+
+@item -U@var{name}
+@opindex @code{U@var{name}}
+@cindex preprocessing, undefine macros
+Cancel any previous definition of @var{name}, either built in or provided
+with a @option{-D} option.
+@end table
+
+
+@node Error and Warning Options
+@section Options to request or suppress errors and warnings
+@cindex options, warnings
+@cindex options, errors
+@cindex warnings, suppressing
+@cindex messages, error
+@cindex messages, warning
+@cindex suppressing warnings
+
+Errors are diagnostic messages that report that the GNU Fortran compiler
+cannot compile the relevant piece of source code.  The compiler will
+continue to process the program in an attempt to report further errors
+to aid in debugging, but will not produce any compiled output.  
+
+Warnings are diagnostic messages that report constructions which
+are not inherently erroneous but which are risky or suggest there is
+likely to be a bug in the program.  Unless @option{-Werror} is specified,
+they do not prevent compilation of the program.
+
+You can request many specific warnings with options beginning @option{-W},
+for example @option{-Wimplicit} to request warnings on implicit
+declarations.  Each of these specific warning options also has a
+negative form beginning @option{-Wno-} to turn off warnings;
+for example, @option{-Wno-implicit}.  This manual lists only one of the
+two forms, whichever is not the default.
+
+These options control the amount and kinds of errors and warnings produced
+by GNU Fortran:
+
+@table @gcctabopt
+@item -fmax-errors=@var{n}
+@opindex @code{fmax-errors=}@var{n}
+@cindex errors, limiting
+Limits the maximum number of error messages to @var{n}, at which point
+GNU Fortran bails out rather than attempting to continue processing the
+source code.  If @var{n} is 0, there is no limit on the number of error
+messages produced.
+
+@item -fsyntax-only
+@opindex @code{fsyntax-only}
+@cindex syntax checking
+Check the code for syntax errors, but do not actually compile it.  This
+will generate module files for each module present in the code, but no
+other output file.
+
+@item -pedantic
+@opindex @code{pedantic}
+Issue warnings for uses of extensions to Fortran 95.
+@option{-pedantic} also applies to C-language constructs where they
+occur in GNU Fortran source files, such as use of @samp{\e} in a
+character constant within a directive like @code{#include}.
+
+Valid Fortran 95 programs should compile properly with or without
+this option.
+However, without this option, certain GNU extensions and traditional
+Fortran features are supported as well.
+With this option, many of them are rejected.
+
+Some users try to use @option{-pedantic} to check programs for conformance.
+They soon find that it does not do quite what they want---it finds some
+nonstandard practices, but not all.
+However, improvements to GNU Fortran in this area are welcome.
+
+This should be used in conjunction with @option{-std=f95},
+@option{-std=f2003} or @option{-std=f2008}.
+
+@item -pedantic-errors
+@opindex @code{pedantic-errors}
+Like @option{-pedantic}, except that errors are produced rather than
+warnings.
+
+@item -Wall
+@opindex @code{Wall}
+@cindex all warnings
+@cindex warnings, all
+Enables commonly used warning options pertaining to usage that
+we recommend avoiding and that we believe are easy to avoid.
+This currently includes @option{-Waliasing}, @option{-Wampersand},
+@option{-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}.
+
+@item -Waliasing
+@opindex @code{Waliasing}
+@cindex aliasing
+@cindex warnings, aliasing
+Warn about possible aliasing of dummy arguments. Specifically, it warns
+if the same actual argument is associated with a dummy argument with
+@code{INTENT(IN)} and a dummy argument with @code{INTENT(OUT)} in a call
+with an explicit interface.
+
+The following example will trigger the warning.
+@smallexample
+  interface
+    subroutine bar(a,b)
+      integer, intent(in) :: a
+      integer, intent(out) :: b
+    end subroutine
+  end interface
+  integer :: a
+
+  call bar(a,a)
+@end smallexample
+
+@item -Wampersand
+@opindex @code{Wampersand}
+@cindex warnings, ampersand
+@cindex @code{&}
+Warn about missing ampersand in continued character constants. The warning is
+given with @option{-Wampersand}, @option{-pedantic}, @option{-std=f95},
+@option{-std=f2003} and @option{-std=f2008}. Note: With no ampersand
+given in a continued character constant, GNU Fortran assumes continuation
+at the first non-comment, non-whitespace character after the ampersand
+that initiated the continuation.
+
+@item -Warray-temporaries
+@opindex @code{Warray-temporaries}
+@cindex warnings, array temporaries
+Warn about array temporaries generated by the compiler.  The information
+generated by this warning is sometimes useful in optimization, in order to
+avoid such temporaries.
+
+@item -Wc-binding-type
+@opindex @code{Wc-binding-type}
+@cindex warning, C binding type
+Warn if the a variable might not be C interoperable.  In particular, warn if 
+the variable has been declared using an intrinsic type with default kind
+instead of using a kind parameter defined for C interoperability in the
+intrinsic @code{ISO_C_Binding} module.  This option is implied by
+@option{-Wall}.
+
+@item -Wcharacter-truncation
+@opindex @code{Wcharacter-truncation}
+@cindex warnings, character truncation
+Warn when a character assignment will truncate the assigned string.
+
+@item -Wline-truncation
+@opindex @code{Wline-truncation}
+@cindex warnings, line truncation
+Warn when a source code line will be truncated.  This option is
+implied by @option{-Wall}.
+
+@item -Wconversion
+@opindex @code{Wconversion}
+@cindex warnings, conversion
+@cindex conversion
+Warn about implicit conversions that are likely to change the value of 
+the expression after conversion. Implied by @option{-Wall}.
+
+@item -Wconversion-extra
+@opindex @code{Wconversion-extra}
+@cindex warnings, conversion
+@cindex conversion
+Warn about implicit conversions between different types and kinds.
+
+@item -Wextra
+@opindex @code{Wextra}
+@cindex extra warnings
+@cindex warnings, extra
+Enables some warning options for usages of language features which
+may be problematic. This currently includes @option{-Wcompare-reals}
+and @option{-Wunused-parameter}.
+
+@item -Wimplicit-interface
+@opindex @code{Wimplicit-interface}
+@cindex warnings, implicit interface
+Warn if a procedure is called without an explicit interface.
+Note this only checks that an explicit interface is present.  It does not
+check that the declared interfaces are consistent across program units.
+
+@item -Wimplicit-procedure
+@opindex @code{Wimplicit-procedure}
+@cindex warnings, implicit procedure
+Warn if a procedure is called that has neither an explicit interface
+nor has been declared as @code{EXTERNAL}.
+
+@item -Wintrinsics-std
+@opindex @code{Wintrinsics-std}
+@cindex warnings, non-standard intrinsics
+@cindex warnings, intrinsics of other standards
+Warn if @command{gfortran} finds a procedure named like an intrinsic not
+available in the currently selected standard (with @option{-std}) and treats
+it as @code{EXTERNAL} procedure because of this.  @option{-fall-intrinsics} can
+be used to never trigger this behavior and always link to the intrinsic
+regardless of the selected standard.
+
+@item -Wreal-q-constant
+@opindex @code{Wreal-q-constant}
+@cindex warnings, @code{q} exponent-letter
+Produce a warning if a real-literal-constant contains a @code{q}
+exponent-letter.
+
+@item -Wsurprising
+@opindex @code{Wsurprising}
+@cindex warnings, suspicious code
+Produce a warning when ``suspicious'' code constructs are encountered.
+While technically legal these usually indicate that an error has been made.
+
+This currently produces a warning under the following circumstances:
+
+@itemize @bullet
+@item
+An INTEGER SELECT construct has a CASE that can never be matched as its
+lower value is greater than its upper value.
+
+@item
+A LOGICAL SELECT construct has three CASE statements.
+
+@item
+A TRANSFER specifies a source that is shorter than the destination.
+
+@item
+The type of a function result is declared more than once with the same type.  If
+@option{-pedantic} or standard-conforming mode is enabled, this is an error.
+
+@item
+A @code{CHARACTER} variable is declared with negative length.
+@end itemize
+
+@item -Wtabs
+@opindex @code{Wtabs}
+@cindex warnings, tabs
+@cindex tabulators
+By default, tabs are accepted as whitespace, but tabs are not members
+of the Fortran Character Set.  For continuation lines, a tab followed
+by a digit between 1 and 9 is supported.  @option{-Wno-tabs} will cause
+a warning to be issued if a tab is encountered. Note, @option{-Wno-tabs}
+is active for @option{-pedantic}, @option{-std=f95}, @option{-std=f2003},
+@option{-std=f2008} and @option{-Wall}.
+
+@item -Wunderflow
+@opindex @code{Wunderflow}
+@cindex warnings, underflow
+@cindex underflow
+Produce a warning when numerical constant expressions are
+encountered, which yield an UNDERFLOW during compilation.
+
+@item -Wintrinsic-shadow
+@opindex @code{Wintrinsic-shadow}
+@cindex warnings, intrinsic
+@cindex intrinsic
+Warn if a user-defined procedure or module procedure has the same name as an
+intrinsic; in this case, an explicit interface or @code{EXTERNAL} or
+@code{INTRINSIC} declaration might be needed to get calls later resolved to
+the desired intrinsic/procedure.  This option is implied by @option{-Wall}.
+
+@item -Wunused-dummy-argument
+@opindex @code{Wunused-dummy-argument}
+@cindex warnings, unused dummy argument
+@cindex unused dummy argument
+@cindex dummy argument, unused
+Warn about unused dummy arguments. This option is implied by @option{-Wall}.
+
+@item -Wunused-parameter
+@opindex @code{Wunused-parameter}
+@cindex warnings, unused parameter
+@cindex unused parameter
+Contrary to @command{gcc}'s meaning of @option{-Wunused-parameter},
+@command{gfortran}'s implementation of this option does not warn
+about unused dummy arguments (see @option{-Wunused-dummy-argument}),
+but about unused @code{PARAMETER} values. @option{-Wunused-parameter}
+is not included in @option{-Wall} but is implied by @option{-Wall -Wextra}.
+
+@item -Walign-commons
+@opindex @code{Walign-commons}
+@cindex warnings, alignment of @code{COMMON} blocks
+@cindex alignment of @code{COMMON} blocks
+By default, @command{gfortran} warns about any occasion of variables being
+padded for proper alignment inside a @code{COMMON} block. This warning can be turned
+off via @option{-Wno-align-commons}. See also @option{-falign-commons}.
+
+@item -Wfunction-elimination
+@opindex @code{Wfunction-elimination}
+@cindex function elimination
+@cindex warnings, function elimination
+Warn if any calls to functions are eliminated by the optimizations
+enabled by the @option{-ffrontend-optimize} option.
+
+@item -Wrealloc-lhs
+@opindex @code{Wrealloc-lhs}
+@cindex Reallocate the LHS in assignments, notification
+Warn when the compiler might insert code to for allocation or reallocation of
+an allocatable array variable of intrinsic type in intrinsic assignments.  In
+hot loops, the Fortran 2003 reallocation feature may reduce the performance.
+If the array is already allocated with the correct shape, consider using a
+whole-array array-spec (e.g. @code{(:,:,:)}) for the variable on the left-hand
+side to prevent the reallocation check. Note that in some cases the warning
+is shown, even if the compiler will optimize reallocation checks away.  For
+instance, when the right-hand side contains the same variable multiplied by
+a scalar.  See also @option{-frealloc-lhs}.
+
+@item -Wrealloc-lhs-all
+@opindex @code{Wrealloc-lhs-all}
+Warn when the compiler inserts code to for allocation or reallocation of an
+allocatable variable; this includes scalars and derived types.
+
+@item -Wcompare-reals
+@opindex @code{Wcompare-reals}
+Warn when comparing real or complex types for equality or inequality.
+This option is implied by @option{-Wextra}.
+
+@item -Wtarget-lifetime
+@opindex @code{Wtargt-lifetime}
+Warn if the pointer in a pointer assignment might be longer than the its
+target. This option is implied by @option{-Wall}.
+
+@item -Wzerotrip
+@opindex @code{Wzerotrip}
+Warn if a @code{DO} loop is known to execute zero times at compile
+time.  This option is implied by @option{-Wall}.
+
+@item -Werror
+@opindex @code{Werror}
+@cindex warnings, to errors
+Turns all warnings into errors.
+@end table
+
+@xref{Warning Options,,Options to Request or Suppress Errors and
+Warnings, gcc,Using the GNU Compiler Collection (GCC)}, for information on
+more options offered by the GBE shared by @command{gfortran}, @command{gcc}
+and other GNU compilers.
+
+Some of these have no effect when compiling programs written in Fortran.
+
+@node Debugging Options
+@section Options for debugging your program or GNU Fortran
+@cindex options, debugging
+@cindex debugging information options
+
+GNU Fortran has various special options that are used for debugging
+either your program or the GNU Fortran compiler.
+
+@table @gcctabopt
+@item -fdump-fortran-original
+@opindex @code{fdump-fortran-original}
+Output the internal parse tree after translating the source program
+into internal representation.  Only really useful for debugging the
+GNU Fortran compiler itself.
+
+@item -fdump-fortran-optimized
+@opindex @code{fdump-fortran-optimized}
+Output the parse tree after front-end optimization.  Only really
+useful for debugging the GNU Fortran compiler itself.
+
+@item -fdump-parse-tree
+@opindex @code{fdump-parse-tree}
+Output the internal parse tree after translating the source program
+into internal representation.  Only really useful for debugging the
+GNU Fortran compiler itself.  This option is deprecated; use
+@code{-fdump-fortran-original} instead.
+
+@item -ffpe-trap=@var{list}
+@opindex @code{ffpe-trap=}@var{list}
+Specify a list of floating point exception traps to enable.  On most
+systems, if a floating point exception occurs and the trap for that
+exception is enabled, a SIGFPE signal will be sent and the program
+being aborted, producing a core file useful for debugging.  @var{list}
+is a (possibly empty) comma-separated list of the following
+exceptions: @samp{invalid} (invalid floating point operation, such as
+@code{SQRT(-1.0)}), @samp{zero} (division by zero), @samp{overflow}
+(overflow in a floating point operation), @samp{underflow} (underflow
+in a floating point operation), @samp{inexact} (loss of precision
+during operation), and @samp{denormal} (operation performed on a
+denormal value).  The first five exceptions correspond to the five
+IEEE 754 exceptions, whereas the last one (@samp{denormal}) is not
+part of the IEEE 754 standard but is available on some common
+architectures such as x86.
+
+The first three exceptions (@samp{invalid}, @samp{zero}, and
+@samp{overflow}) often indicate serious errors, and unless the program
+has provisions for dealing with these exceptions, enabling traps for
+these three exceptions is probably a good idea.
+
+Many, if not most, floating point operations incur loss of precision
+due to rounding, and hence the @code{ffpe-trap=inexact} is likely to
+be uninteresting in practice.
+
+By default no exception traps are enabled.
+
+@item -ffpe-summary=@var{list}
+@opindex @code{ffpe-summary=}@var{list}
+Specify a list of floating-point exceptions, whose flag status is printed
+to @code{ERROR_UNIT} when invoking @code{STOP} and @code{ERROR STOP}.
+@var{list} can be either @samp{none}, @samp{all} or a comma-separated list
+of the following exceptions: @samp{invalid}, @samp{zero}, @samp{overflow},
+@samp{underflow}, @samp{inexact} and @samp{denormal}. (See
+@option{-ffpe-trap} for a description of the exceptions.)
+
+By default, a summary for all exceptions but @samp{inexact} is shown.
+
+@item -fno-backtrace
+@opindex @code{fno-backtrace}
+@cindex backtrace
+@cindex trace
+When a serious runtime error is encountered or a deadly signal is
+emitted (segmentation fault, illegal instruction, bus error,
+floating-point exception, and the other POSIX signals that have the
+action @samp{core}), the Fortran runtime library tries to output a
+backtrace of the error. @code{-fno-backtrace} disables the backtrace
+generation. This option only has influence for compilation of the
+Fortran main program.
+
+@end table
+
+@xref{Debugging Options,,Options for Debugging Your Program or GCC,
+gcc,Using the GNU Compiler Collection (GCC)}, for more information on
+debugging options.
+
+@node Directory Options
+@section Options for directory search
+@cindex directory, options
+@cindex options, directory search
+@cindex search path
+@cindex @code{INCLUDE} directive
+@cindex directive, @code{INCLUDE}
+These options affect how GNU Fortran searches
+for files specified by the @code{INCLUDE} directive and where it searches
+for previously compiled modules.
+
+It also affects the search paths used by @command{cpp} when used to preprocess
+Fortran source.
+
+@table @gcctabopt
+@item -I@var{dir}
+@opindex @code{I}@var{dir}
+@cindex directory, search paths for inclusion
+@cindex inclusion, directory search paths for
+@cindex search paths, for included files
+@cindex paths, search
+@cindex module search path
+These affect interpretation of the @code{INCLUDE} directive
+(as well as of the @code{#include} directive of the @command{cpp}
+preprocessor).
+
+Also note that the general behavior of @option{-I} and
+@code{INCLUDE} is pretty much the same as of @option{-I} with
+@code{#include} in the @command{cpp} preprocessor, with regard to
+looking for @file{header.gcc} files and other such things.
+
+This path is also used to search for @file{.mod} files when previously
+compiled modules are required by a @code{USE} statement.
+
+@xref{Directory Options,,Options for Directory Search,
+gcc,Using the GNU Compiler Collection (GCC)}, for information on the
+@option{-I} option.
+
+@item -J@var{dir}
+@opindex @code{J}@var{dir}
+@opindex @code{M}@var{dir}
+@cindex paths, search
+@cindex module search path
+This option specifies where to put @file{.mod} files for compiled modules.
+It is also added to the list of directories to searched by an @code{USE}
+statement.
+
+The default is the current directory.
+
+@item -fintrinsic-modules-path @var{dir}
+@opindex @code{fintrinsic-modules-path} @var{dir}
+@cindex paths, search
+@cindex module search path
+This option specifies the location of pre-compiled intrinsic modules, if
+they are not in the default location expected by the compiler.
+@end table
+
+@node Link Options
+@section Influencing the linking step
+@cindex options, linking
+@cindex linking, static
+
+These options come into play when the compiler links object files into an 
+executable output file. They are meaningless if the compiler is not doing 
+a link step.
+
+@table @gcctabopt
+@item -static-libgfortran
+@opindex @code{static-libgfortran}
+On systems that provide @file{libgfortran} as a shared and a static
+library, this option forces the use of the static version. If no
+shared version of @file{libgfortran} was built when the compiler was
+configured, this option has no effect.
+@end table
+
+
+@node Runtime Options
+@section Influencing runtime behavior
+@cindex options, runtime
+
+These options affect the runtime behavior of programs compiled with GNU Fortran.
+
+@table @gcctabopt
+@item -fconvert=@var{conversion}
+@opindex @code{fconvert=}@var{conversion}
+Specify the representation of data for unformatted files.  Valid
+values for conversion are: @samp{native}, the default; @samp{swap},
+swap between big- and little-endian; @samp{big-endian}, use big-endian
+representation for unformatted files; @samp{little-endian}, use little-endian
+representation for unformatted files.
+
+@emph{This option has an effect only when used in the main program.
+The @code{CONVERT} specifier and the GFORTRAN_CONVERT_UNIT environment
+variable override the default specified by @option{-fconvert}.}
+
+@item -frecord-marker=@var{length}
+@opindex @code{frecord-marker=}@var{length}
+Specify the length of record markers for unformatted files.
+Valid values for @var{length} are 4 and 8.  Default is 4.
+@emph{This is different from previous versions of @command{gfortran}},
+which specified a default record marker length of 8 on most
+systems.  If you want to read or write files compatible
+with earlier versions of @command{gfortran}, use @option{-frecord-marker=8}.
+
+@item -fmax-subrecord-length=@var{length}
+@opindex @code{fmax-subrecord-length=}@var{length}
+Specify the maximum length for a subrecord.  The maximum permitted
+value for length is 2147483639, which is also the default.  Only
+really useful for use by the gfortran testsuite.
+
+@item -fsign-zero
+@opindex @code{fsign-zero}
+When enabled, floating point numbers of value zero with the sign bit set
+are written as negative number in formatted output and treated as
+negative in the @code{SIGN} intrinsic.  @option{-fno-sign-zero} does not
+print the negative sign of zero values (or values rounded to zero for I/O)
+and regards zero as positive number in the @code{SIGN} intrinsic for
+compatibility with Fortran 77. The default is @option{-fsign-zero}.
+@end table
+
+@node Code Gen Options
+@section Options for code generation conventions
+@cindex code generation, conventions
+@cindex options, code generation
+@cindex options, run-time
+
+These machine-independent options control the interface conventions
+used in code generation.
+
+Most of them have both positive and negative forms; the negative form
+of @option{-ffoo} would be @option{-fno-foo}.  In the table below, only
+one of the forms is listed---the one which is not the default.  You
+can figure out the other form by either removing @option{no-} or adding
+it.
+
+@table @gcctabopt
+@item -fno-automatic
+@opindex @code{fno-automatic}
+@cindex @code{SAVE} statement
+@cindex statement, @code{SAVE}
+Treat each program unit (except those marked as RECURSIVE) as if the
+@code{SAVE} statement were specified for every local variable and array
+referenced in it. Does not affect common blocks. (Some Fortran compilers
+provide this option under the name @option{-static} or @option{-save}.)
+The default, which is @option{-fautomatic}, uses the stack for local
+variables smaller than the value given by @option{-fmax-stack-var-size}.
+Use the option @option{-frecursive} to use no static memory. 
+
+@item -ff2c
+@opindex ff2c
+@cindex calling convention
+@cindex @command{f2c} calling convention
+@cindex @command{g77} calling convention
+@cindex libf2c calling convention
+Generate code designed to be compatible with code generated
+by @command{g77} and @command{f2c}.
+
+The calling conventions used by @command{g77} (originally implemented
+in @command{f2c}) require functions that return type
+default @code{REAL} to actually return the C type @code{double}, and
+functions that return type @code{COMPLEX} to return the values via an
+extra argument in the calling sequence that points to where to
+store the return value.  Under the default GNU calling conventions, such
+functions simply return their results as they would in GNU
+C---default @code{REAL} functions return the C type @code{float}, and
+@code{COMPLEX} functions return the GNU C type @code{complex}.
+Additionally, this option implies the @option{-fsecond-underscore}
+option, unless @option{-fno-second-underscore} is explicitly requested.
+
+This does not affect the generation of code that interfaces with
+the @command{libgfortran} library.
+
+@emph{Caution:} It is not a good idea to mix Fortran code compiled with
+@option{-ff2c} with code compiled with the default @option{-fno-f2c}
+calling conventions as, calling @code{COMPLEX} or default @code{REAL}
+functions between program parts which were compiled with different
+calling conventions will break at execution time.
+
+@emph{Caution:} This will break code which passes intrinsic functions
+of type default @code{REAL} or @code{COMPLEX} as actual arguments, as
+the library implementations use the @option{-fno-f2c} calling conventions.
+
+@item -fno-underscoring
+@opindex @code{fno-underscoring}
+@cindex underscore
+@cindex symbol names, underscores
+@cindex transforming symbol names
+@cindex symbol names, transforming
+Do not transform names of entities specified in the Fortran
+source file by appending underscores to them.
+
+With @option{-funderscoring} in effect, GNU Fortran appends one
+underscore to external names with no underscores.  This is done to ensure
+compatibility with code produced by many UNIX Fortran compilers.
+
+@emph{Caution}: The default behavior of GNU Fortran is
+incompatible with @command{f2c} and @command{g77}, please use the
+@option{-ff2c} option if you want object files compiled with
+GNU Fortran to be compatible with object code created with these
+tools.
+
+Use of @option{-fno-underscoring} is not recommended unless you are
+experimenting with issues such as integration of GNU Fortran into
+existing system environments (vis-@`{a}-vis existing libraries, tools,
+and so on).
+
+For example, with @option{-funderscoring}, and assuming other defaults like
+@option{-fcase-lower} and that @code{j()} and @code{max_count()} are
+external functions while @code{my_var} and @code{lvar} are local variables,
+a statement like
+@smallexample
+I = J() + MAX_COUNT (MY_VAR, LVAR)
+@end smallexample
+@noindent
+is implemented as something akin to:
+@smallexample
+i = j_() + max_count__(&my_var__, &lvar);
+@end smallexample
+
+With @option{-fno-underscoring}, the same statement is implemented as:
+
+@smallexample
+i = j() + max_count(&my_var, &lvar);
+@end smallexample
+
+Use of @option{-fno-underscoring} allows direct specification of
+user-defined names while debugging and when interfacing GNU Fortran
+code with other languages.
+
+Note that just because the names match does @emph{not} mean that the
+interface implemented by GNU Fortran for an external name matches the
+interface implemented by some other language for that same name.
+That is, getting code produced by GNU Fortran to link to code produced
+by some other compiler using this or any other method can be only a
+small part of the overall solution---getting the code generated by
+both compilers to agree on issues other than naming can require
+significant effort, and, unlike naming disagreements, linkers normally
+cannot detect disagreements in these other areas.
+
+Also, note that with @option{-fno-underscoring}, the lack of appended
+underscores introduces the very real possibility that a user-defined
+external name will conflict with a name in a system library, which
+could make finding unresolved-reference bugs quite difficult in some
+cases---they might occur at program run time, and show up only as
+buggy behavior at run time.
+
+In future versions of GNU Fortran we hope to improve naming and linking
+issues so that debugging always involves using the names as they appear
+in the source, even if the names as seen by the linker are mangled to
+prevent accidental linking between procedures with incompatible
+interfaces.
+
+@item -fsecond-underscore
+@opindex @code{fsecond-underscore}
+@cindex underscore
+@cindex symbol names, underscores
+@cindex transforming symbol names
+@cindex symbol names, transforming
+@cindex @command{f2c} calling convention
+@cindex @command{g77} calling convention
+@cindex libf2c calling convention
+By default, GNU Fortran appends an underscore to external
+names.  If this option is used GNU Fortran appends two
+underscores to names with underscores and one underscore to external names
+with no underscores.  GNU Fortran also appends two underscores to
+internal names with underscores to avoid naming collisions with external
+names.
+
+This option has no effect if @option{-fno-underscoring} is
+in effect.  It is implied by the @option{-ff2c} option.
+
+Otherwise, with this option, an external name such as @code{MAX_COUNT}
+is implemented as a reference to the link-time external symbol
+@code{max_count__}, instead of @code{max_count_}.  This is required
+for compatibility with @command{g77} and @command{f2c}, and is implied
+by use of the @option{-ff2c} option.
+
+@item -fcoarray=@var{<keyword>}
+@opindex @code{fcoarray}
+@cindex coarrays
+
+@table @asis
+@item @samp{none}
+Disable coarray support; using coarray declarations and image-control
+statements will produce a compile-time error. (Default)
+
+@item @samp{single}
+Single-image mode, i.e. @code{num_images()} is always one.
+
+@item @samp{lib}
+Library-based coarray parallelization; a suitable GNU Fortran coarray
+library needs to be linked.
+@end table
+
+
+@item -fcheck=@var{<keyword>}
+@opindex @code{fcheck}
+@cindex array, bounds checking
+@cindex bounds checking
+@cindex pointer checking
+@cindex memory checking
+@cindex range checking
+@cindex subscript checking
+@cindex checking subscripts
+@cindex run-time checking
+@cindex checking array temporaries
+
+Enable the generation of run-time checks; the argument shall be
+a comma-delimited list of the following keywords.
+
+@table @asis
+@item @samp{all}
+Enable all run-time test of @option{-fcheck}.
+
+@item @samp{array-temps}
+Warns at run time when for passing an actual argument a temporary array
+had to be generated. The information generated by this warning is
+sometimes useful in optimization, in order to avoid such temporaries.
+
+Note: The warning is only printed once per location.
+
+@item @samp{bounds}
+Enable generation of run-time checks for array subscripts
+and against the declared minimum and maximum values.  It also
+checks array indices for assumed and deferred
+shape arrays against the actual allocated bounds and ensures that all string
+lengths are equal for character array constructors without an explicit
+typespec.
+
+Some checks require that @option{-fcheck=bounds} is set for
+the compilation of the main program.
+
+Note: In the future this may also include other forms of checking, e.g.,
+checking substring references.
+
+@item @samp{do}
+Enable generation of run-time checks for invalid modification of loop
+iteration variables.
+
+@item @samp{mem}
+Enable generation of run-time checks for memory allocation.
+Note: This option does not affect explicit allocations using the
+@code{ALLOCATE} statement, which will be always checked.
+
+@item @samp{pointer}
+Enable generation of run-time checks for pointers and allocatables.
+
+@item @samp{recursion}
+Enable generation of run-time checks for recursively called subroutines and
+functions which are not marked as recursive. See also @option{-frecursive}.
+Note: This check does not work for OpenMP programs and is disabled if used
+together with @option{-frecursive} and @option{-fopenmp}.
+@end table
+
+
+@item -fbounds-check
+@opindex @code{fbounds-check}
+@c Note: This option is also referred in gcc's manpage
+Deprecated alias for @option{-fcheck=bounds}.
+
+@item -fcheck-array-temporaries
+@opindex @code{fcheck-array-temporaries}
+Deprecated alias for @option{-fcheck=array-temps}.
+
+@item -fmax-array-constructor=@var{n}
+@opindex @code{fmax-array-constructor}
+This option can be used to increase the upper limit permitted in 
+array constructors.  The code below requires this option to expand
+the array at compile time.
+
+@smallexample
+program test
+implicit none
+integer j
+integer, parameter :: n = 100000
+integer, parameter :: i(n) = (/ (2*j, j = 1, n) /)
+print '(10(I0,1X))', i
+end program test
+@end smallexample
+
+@emph{Caution:  This option can lead to long compile times and excessively
+large object files.}
+
+The default value for @var{n} is 65535.
+
+
+@item -fmax-stack-var-size=@var{n}
+@opindex @code{fmax-stack-var-size}
+This option specifies the size in bytes of the largest array that will be put
+on the stack; if the size is exceeded static memory is used (except in
+procedures marked as RECURSIVE). Use the option @option{-frecursive} to
+allow for recursive procedures which do not have a RECURSIVE attribute or
+for parallel programs. Use @option{-fno-automatic} to never use the stack.
+
+This option currently only affects local arrays declared with constant
+bounds, and may not apply to all character variables.
+Future versions of GNU Fortran may improve this behavior.
+
+The default value for @var{n} is 32768.
+
+@item -fstack-arrays
+@opindex @code{fstack-arrays}
+Adding this option will make the Fortran compiler put all local arrays,
+even those of unknown size onto stack memory.  If your program uses very
+large local arrays it is possible that you will have to extend your runtime
+limits for stack memory on some operating systems. This flag is enabled
+by default at optimization level @option{-Ofast}.
+
+
+@item -fpack-derived
+@opindex @code{fpack-derived}
+@cindex structure packing
+This option tells GNU Fortran to pack derived type members as closely as
+possible.  Code compiled with this option is likely to be incompatible
+with code compiled without this option, and may execute slower.
+
+@item -frepack-arrays
+@opindex @code{frepack-arrays}
+@cindex repacking arrays
+In some circumstances GNU Fortran may pass assumed shape array
+sections via a descriptor describing a noncontiguous area of memory.
+This option adds code to the function prologue to repack the data into
+a contiguous block at runtime.
+
+This should result in faster accesses to the array.  However it can introduce
+significant overhead to the function call, especially  when the passed data
+is noncontiguous.
+
+@item -fshort-enums
+@opindex @code{fshort-enums}
+This option is provided for interoperability with C code that was
+compiled with the @option{-fshort-enums} option.  It will make
+GNU Fortran choose the smallest @code{INTEGER} kind a given
+enumerator set will fit in, and give all its enumerators this kind.
+
+@item -fexternal-blas
+@opindex @code{fexternal-blas}
+This option will make @command{gfortran} generate calls to BLAS functions
+for some matrix operations like @code{MATMUL}, instead of using our own
+algorithms, if the size of the matrices involved is larger than a given
+limit (see @option{-fblas-matmul-limit}).  This may be profitable if an
+optimized vendor BLAS library is available.  The BLAS library will have
+to be specified at link time.
+
+@item -fblas-matmul-limit=@var{n}
+@opindex @code{fblas-matmul-limit}
+Only significant when @option{-fexternal-blas} is in effect.
+Matrix multiplication of matrices with size larger than (or equal to) @var{n}
+will be performed by calls to BLAS functions, while others will be
+handled by @command{gfortran} internal algorithms. 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 30.
+
+@item -frecursive
+@opindex @code{frecursive}
+Allow indirect recursion by forcing all local arrays to be allocated
+on the stack. This flag cannot be used together with
+@option{-fmax-stack-var-size=} or @option{-fno-automatic}.
+
+@item -finit-local-zero
+@itemx -finit-integer=@var{n}
+@itemx -finit-real=@var{<zero|inf|-inf|nan|snan>}
+@itemx -finit-logical=@var{<true|false>}
+@itemx -finit-character=@var{n}
+@opindex @code{finit-local-zero}
+@opindex @code{finit-integer}
+@opindex @code{finit-real}
+@opindex @code{finit-logical}
+@opindex @code{finit-character}
+The @option{-finit-local-zero} option instructs the compiler to
+initialize local @code{INTEGER}, @code{REAL}, and @code{COMPLEX}
+variables to zero, @code{LOGICAL} variables to false, and
+@code{CHARACTER} variables to a string of null bytes.  Finer-grained
+initialization options are provided by the
+@option{-finit-integer=@var{n}},
+@option{-finit-real=@var{<zero|inf|-inf|nan|snan>}} (which also initializes
+the real and imaginary parts of local @code{COMPLEX} variables),
+@option{-finit-logical=@var{<true|false>}}, and
+@option{-finit-character=@var{n}} (where @var{n} is an ASCII character
+value) options.  These options do not initialize
+@itemize @bullet
+@item
+allocatable arrays
+@item
+components of derived type variables
+@item
+variables that appear in an @code{EQUIVALENCE} statement.
+@end itemize
+(These limitations may be removed in future releases).
+
+Note that the @option{-finit-real=nan} option initializes @code{REAL}
+and @code{COMPLEX} variables with a quiet NaN. For a signalling NaN
+use @option{-finit-real=snan}; note, however, that compile-time
+optimizations may convert them into quiet NaN and that trapping
+needs to be enabled (e.g. via @option{-ffpe-trap}).
+
+Finally, note that enabling any of the @option{-finit-*} options will
+silence warnings that would have been emitted by @option{-Wuninitialized}
+for the affected local variables.
+
+@item -falign-commons
+@opindex @code{falign-commons}
+@cindex alignment of @code{COMMON} blocks
+By default, @command{gfortran} enforces proper alignment of all variables in a
+@code{COMMON} block by padding them as needed. On certain platforms this is mandatory,
+on others it increases performance. If a @code{COMMON} block is not declared with
+consistent data types everywhere, this padding can cause trouble, and
+@option{-fno-align-commons} can be used to disable automatic alignment. The
+same form of this option should be used for all files that share a @code{COMMON} block.
+To avoid potential alignment issues in @code{COMMON} blocks, it is recommended to order
+objects from largest to smallest.
+
+@item -fno-protect-parens
+@opindex @code{fno-protect-parens}
+@cindex re-association of parenthesized expressions
+By default the parentheses in expression are honored for all optimization
+levels such that the compiler does not do any re-association. Using
+@option{-fno-protect-parens} allows the compiler to reorder @code{REAL} and
+@code{COMPLEX} expressions to produce faster code. Note that for the re-association
+optimization @option{-fno-signed-zeros} and @option{-fno-trapping-math}
+need to be in effect. The parentheses protection is enabled by default, unless
+@option{-Ofast} is given.
+
+@item -frealloc-lhs
+@opindex @code{frealloc-lhs}
+@cindex Reallocate the LHS in assignments
+An allocatable left-hand side of an intrinsic assignment is automatically
+(re)allocated if it is either unallocated or has a different shape. The
+option is enabled by default except when @option{-std=f95} is given. See
+also @option{-Wrealloc-lhs}.
+
+@item -faggressive-function-elimination
+@opindex @code{faggressive-function-elimination}
+@cindex Elimination of functions with identical argument lists
+Functions with identical argument lists are eliminated within
+statements, regardless of whether these functions are marked
+@code{PURE} or not. For example, in
+@smallexample
+  a = f(b,c) + f(b,c)
+@end smallexample
+there will only be a single call to @code{f}.  This option only works
+if @option{-ffrontend-optimize} is in effect.
+
+@item -ffrontend-optimize
+@opindex @code{frontend-optimize}
+@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}.
+@end table
+
+@xref{Code Gen Options,,Options for Code Generation Conventions,
+gcc,Using the GNU Compiler Collection (GCC)}, for information on more options
+offered by the GBE
+shared by @command{gfortran}, @command{gcc}, and other GNU compilers.
+
+@c man end
+
+@node Environment Variables
+@section Environment variables affecting @command{gfortran}
+@cindex environment variable
+
+@c man begin ENVIRONMENT
+
+The @command{gfortran} compiler currently does not make use of any environment
+variables to control its operation above and beyond those
+that affect the operation of @command{gcc}.
+
+@xref{Environment Variables,,Environment Variables Affecting GCC,
+gcc,Using the GNU Compiler Collection (GCC)}, for information on environment
+variables.
+
+@xref{Runtime}, for environment variables that affect the
+run-time behavior of programs compiled with GNU Fortran.
+@c man end
diff --git a/gcc-4.9/gcc/fortran/io.c b/gcc-4.9/gcc/fortran/io.c
new file mode 100644
index 000000000..84d0db818
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/io.c
@@ -0,0 +1,4205 @@
+/* Deal with I/O statements & related stuff.
+   Copyright (C) 2000-2014 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "flags.h"
+#include "gfortran.h"
+#include "match.h"
+#include "parse.h"
+
+gfc_st_label
+format_asterisk = {0, NULL, NULL, -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL,
+		   0, {NULL, NULL}};
+
+typedef struct
+{
+  const char *name, *spec, *value;
+  bt type;
+}
+io_tag;
+
+static const io_tag
+	tag_file	= {"FILE", " file =", " %e", BT_CHARACTER },
+	tag_status	= {"STATUS", " status =", " %e", BT_CHARACTER},
+	tag_e_access	= {"ACCESS", " access =", " %e", BT_CHARACTER},
+	tag_e_form	= {"FORM", " form =", " %e", BT_CHARACTER},
+	tag_e_recl	= {"RECL", " recl =", " %e", BT_INTEGER},
+	tag_e_blank	= {"BLANK", " blank =", " %e", BT_CHARACTER},
+	tag_e_position	= {"POSITION", " position =", " %e", BT_CHARACTER},
+	tag_e_action	= {"ACTION", " action =", " %e", BT_CHARACTER},
+	tag_e_delim	= {"DELIM", " delim =", " %e", BT_CHARACTER},
+	tag_e_pad	= {"PAD", " pad =", " %e", BT_CHARACTER},
+	tag_e_decimal	= {"DECIMAL", " decimal =", " %e", BT_CHARACTER},
+	tag_e_encoding	= {"ENCODING", " encoding =", " %e", BT_CHARACTER},
+	tag_e_async	= {"ASYNCHRONOUS", " asynchronous =", " %e", BT_CHARACTER},
+	tag_e_round	= {"ROUND", " round =", " %e", BT_CHARACTER},
+	tag_e_sign	= {"SIGN", " sign =", " %e", BT_CHARACTER},
+	tag_unit	= {"UNIT", " unit =", " %e", BT_INTEGER},
+	tag_advance	= {"ADVANCE", " advance =", " %e", BT_CHARACTER},
+	tag_rec		= {"REC", " rec =", " %e", BT_INTEGER},
+	tag_spos	= {"POSITION", " pos =", " %e", BT_INTEGER},
+	tag_format	= {"FORMAT", NULL, NULL, BT_CHARACTER},
+	tag_iomsg	= {"IOMSG", " iomsg =", " %e", BT_CHARACTER},
+	tag_iostat	= {"IOSTAT", " iostat =", " %v", BT_INTEGER},
+	tag_size	= {"SIZE", " size =", " %v", BT_INTEGER},
+	tag_exist	= {"EXIST", " exist =", " %v", BT_LOGICAL},
+	tag_opened	= {"OPENED", " opened =", " %v", BT_LOGICAL},
+	tag_named	= {"NAMED", " named =", " %v", BT_LOGICAL},
+	tag_name	= {"NAME", " name =", " %v", BT_CHARACTER},
+	tag_number	= {"NUMBER", " number =", " %v", BT_INTEGER},
+	tag_s_access	= {"ACCESS", " access =", " %v", BT_CHARACTER},
+	tag_sequential	= {"SEQUENTIAL", " sequential =", " %v", BT_CHARACTER},
+	tag_direct	= {"DIRECT", " direct =", " %v", BT_CHARACTER},
+	tag_s_form	= {"FORM", " form =", " %v", BT_CHARACTER},
+	tag_formatted	= {"FORMATTED", " formatted =", " %v", BT_CHARACTER},
+	tag_unformatted	= {"UNFORMATTED", " unformatted =", " %v", BT_CHARACTER},
+	tag_s_recl	= {"RECL", " recl =", " %v", BT_INTEGER},
+	tag_nextrec	= {"NEXTREC", " nextrec =", " %v", BT_INTEGER},
+	tag_s_blank	= {"BLANK", " blank =", " %v", BT_CHARACTER},
+	tag_s_position	= {"POSITION", " position =", " %v", BT_CHARACTER},
+	tag_s_action	= {"ACTION", " action =", " %v", BT_CHARACTER},
+	tag_read	= {"READ", " read =", " %v", BT_CHARACTER},
+	tag_write	= {"WRITE", " write =", " %v", BT_CHARACTER},
+	tag_readwrite	= {"READWRITE", " readwrite =", " %v", BT_CHARACTER},
+	tag_s_delim	= {"DELIM", " delim =", " %v", BT_CHARACTER},
+	tag_s_pad	= {"PAD", " pad =", " %v", BT_CHARACTER},
+	tag_s_decimal	= {"DECIMAL", " decimal =", " %v", BT_CHARACTER},
+	tag_s_encoding	= {"ENCODING", " encoding =", " %v", BT_CHARACTER},
+	tag_s_async	= {"ASYNCHRONOUS", " asynchronous =", " %v", BT_CHARACTER},
+	tag_s_round	= {"ROUND", " round =", " %v", BT_CHARACTER},
+	tag_s_sign	= {"SIGN", " sign =", " %v", BT_CHARACTER},
+	tag_iolength	= {"IOLENGTH", " iolength =", " %v", BT_INTEGER},
+	tag_convert     = {"CONVERT", " convert =", " %e", BT_CHARACTER},
+	tag_strm_out    = {"POS", " pos =", " %v", BT_INTEGER},
+	tag_err		= {"ERR", " err =", " %l", BT_UNKNOWN},
+	tag_end		= {"END", " end =", " %l", BT_UNKNOWN},
+	tag_eor		= {"EOR", " eor =", " %l", BT_UNKNOWN},
+	tag_id		= {"ID", " id =", " %v", BT_INTEGER},
+	tag_pending	= {"PENDING", " pending =", " %v", BT_LOGICAL},
+	tag_newunit	= {"NEWUNIT", " newunit =", " %v", BT_INTEGER},
+	tag_s_iqstream	= {"STREAM", " stream =", " %v", BT_CHARACTER};
+
+static gfc_dt *current_dt;
+
+#define RESOLVE_TAG(x, y) if (!resolve_tag (x, y)) return false;
+
+
+/**************** Fortran 95 FORMAT parser  *****************/
+
+/* FORMAT tokens returned by format_lex().  */
+typedef enum
+{
+  FMT_NONE, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD,
+  FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_LPAREN,
+  FMT_RPAREN, FMT_X, FMT_SIGN, FMT_BLANK, FMT_CHAR, FMT_P, FMT_IBOZ, FMT_F,
+  FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END,
+  FMT_ERROR, FMT_DC, FMT_DP, FMT_T, FMT_TR, FMT_TL, FMT_STAR, FMT_RC,
+  FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ
+}
+format_token;
+
+/* Local variables for checking format strings.  The saved_token is
+   used to back up by a single format token during the parsing
+   process.  */
+static gfc_char_t *format_string;
+static int format_string_pos;
+static int format_length, use_last_char;
+static char error_element;
+static locus format_locus;
+
+static format_token saved_token;
+
+static enum
+{ MODE_STRING, MODE_FORMAT, MODE_COPY }
+mode;
+
+
+/* Return the next character in the format string.  */
+
+static char
+next_char (gfc_instring in_string)
+{
+  static gfc_char_t c;
+
+  if (use_last_char)
+    {
+      use_last_char = 0;
+      return c;
+    }
+
+  format_length++;
+
+  if (mode == MODE_STRING)
+    c = *format_string++;
+  else
+    {
+      c = gfc_next_char_literal (in_string);
+      if (c == '\n')
+	c = '\0';
+    }
+
+  if (gfc_option.flag_backslash && c == '\\')
+    {
+      locus old_locus = gfc_current_locus;
+
+      if (gfc_match_special_char (&c) == MATCH_NO)
+	gfc_current_locus = old_locus;
+
+      if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
+	gfc_warning ("Extension: backslash character at %C");
+    }
+
+  if (mode == MODE_COPY)
+    *format_string++ = c;
+
+  if (mode != MODE_STRING)
+    format_locus = gfc_current_locus;
+
+  format_string_pos++;
+
+  c = gfc_wide_toupper (c);
+  return c;
+}
+
+
+/* Back up one character position.  Only works once.  */
+
+static void
+unget_char (void)
+{
+  use_last_char = 1;
+}
+
+/* Eat up the spaces and return a character.  */
+
+static char
+next_char_not_space (bool *error)
+{
+  char c;
+  do
+    {
+      error_element = c = next_char (NONSTRING);
+      if (c == '\t')
+	{
+	  if (gfc_option.allow_std & GFC_STD_GNU)
+	    gfc_warning ("Extension: Tab character in format at %C");
+	  else
+	    {
+	      gfc_error ("Extension: Tab character in format at %C");
+	      *error = true;
+	      return c;
+	    }
+	}
+    }
+  while (gfc_is_whitespace (c));
+  return c;
+}
+
+static int value = 0;
+
+/* Simple lexical analyzer for getting the next token in a FORMAT
+   statement.  */
+
+static format_token
+format_lex (void)
+{
+  format_token token;
+  char c, delim;
+  int zflag;
+  int negative_flag;
+  bool error = false;
+
+  if (saved_token != FMT_NONE)
+    {
+      token = saved_token;
+      saved_token = FMT_NONE;
+      return token;
+    }
+
+  c = next_char_not_space (&error);
+  
+  negative_flag = 0;
+  switch (c)
+    {
+    case '-':
+      negative_flag = 1;
+      /* Falls through.  */
+
+    case '+':
+      c = next_char_not_space (&error);
+      if (!ISDIGIT (c))
+	{
+	  token = FMT_UNKNOWN;
+	  break;
+	}
+
+      value = c - '0';
+
+      do
+	{
+	  c = next_char_not_space (&error);
+	  if (ISDIGIT (c))
+	    value = 10 * value + c - '0';
+	}
+      while (ISDIGIT (c));
+
+      unget_char ();
+
+      if (negative_flag)
+	value = -value;
+
+      token = FMT_SIGNED_INT;
+      break;
+
+    case '0':
+    case '1':
+    case '2':
+    case '3':
+    case '4':
+    case '5':
+    case '6':
+    case '7':
+    case '8':
+    case '9':
+      zflag = (c == '0');
+
+      value = c - '0';
+
+      do
+	{
+	  c = next_char_not_space (&error);
+	  if (ISDIGIT (c))
+	    {
+	      value = 10 * value + c - '0';
+	      if (c != '0')
+		zflag = 0;
+	    }
+	}
+      while (ISDIGIT (c));
+
+      unget_char ();
+      token = zflag ? FMT_ZERO : FMT_POSINT;
+      break;
+
+    case '.':
+      token = FMT_PERIOD;
+      break;
+
+    case ',':
+      token = FMT_COMMA;
+      break;
+
+    case ':':
+      token = FMT_COLON;
+      break;
+
+    case '/':
+      token = FMT_SLASH;
+      break;
+
+    case '$':
+      token = FMT_DOLLAR;
+      break;
+
+    case 'T':
+      c = next_char_not_space (&error);
+      switch (c)
+	{
+	case 'L':
+	  token = FMT_TL;
+	  break;
+	case 'R':
+	  token = FMT_TR;
+	  break;
+	default:
+	  token = FMT_T;
+	  unget_char ();
+	}
+      break;
+
+    case '(':
+      token = FMT_LPAREN;
+      break;
+
+    case ')':
+      token = FMT_RPAREN;
+      break;
+
+    case 'X':
+      token = FMT_X;
+      break;
+
+    case 'S':
+      c = next_char_not_space (&error);
+      if (c != 'P' && c != 'S')
+	unget_char ();
+
+      token = FMT_SIGN;
+      break;
+
+    case 'B':
+      c = next_char_not_space (&error);
+      if (c == 'N' || c == 'Z')
+	token = FMT_BLANK;
+      else
+	{
+	  unget_char ();
+	  token = FMT_IBOZ;
+	}
+
+      break;
+
+    case '\'':
+    case '"':
+      delim = c;
+
+      value = 0;
+
+      for (;;)
+	{
+	  c = next_char (INSTRING_WARN);
+	  if (c == '\0')
+	    {
+	      token = FMT_END;
+	      break;
+	    }
+
+	  if (c == delim)
+	    {
+	      c = next_char (INSTRING_NOWARN);
+
+	      if (c == '\0')
+		{
+		  token = FMT_END;
+		  break;
+		}
+
+	      if (c != delim)
+		{
+		  unget_char ();
+		  token = FMT_CHAR;
+		  break;
+		}
+	    }
+	  value++;
+	}
+      break;
+
+    case 'P':
+      token = FMT_P;
+      break;
+
+    case 'I':
+    case 'O':
+    case 'Z':
+      token = FMT_IBOZ;
+      break;
+
+    case 'F':
+      token = FMT_F;
+      break;
+
+    case 'E':
+      c = next_char_not_space (&error);
+      if (c == 'N' )
+	token = FMT_EN;
+      else if (c == 'S')
+        token = FMT_ES;
+      else
+	{
+	  token = FMT_E;
+	  unget_char ();
+	}
+
+      break;
+
+    case 'G':
+      token = FMT_G;
+      break;
+
+    case 'H':
+      token = FMT_H;
+      break;
+
+    case 'L':
+      token = FMT_L;
+      break;
+
+    case 'A':
+      token = FMT_A;
+      break;
+
+    case 'D':
+      c = next_char_not_space (&error);
+      if (c == 'P')
+	{
+	  if (!gfc_notify_std (GFC_STD_F2003, "DP format "
+			       "specifier not allowed at %C"))
+	    return FMT_ERROR;
+	  token = FMT_DP;
+	}
+      else if (c == 'C')
+	{
+	  if (!gfc_notify_std (GFC_STD_F2003, "DC format "
+			       "specifier not allowed at %C"))
+	    return FMT_ERROR;
+	  token = FMT_DC;
+	}
+      else
+	{
+	  token = FMT_D;
+	  unget_char ();
+	}
+      break;
+
+    case 'R':
+      c = next_char_not_space (&error);
+      switch (c)
+	{
+	case 'C':
+	  token = FMT_RC;
+	  break;
+	case 'D':
+	  token = FMT_RD;
+	  break;
+	case 'N':
+	  token = FMT_RN;
+	  break;
+	case 'P':
+	  token = FMT_RP;
+	  break;
+	case 'U':
+	  token = FMT_RU;
+	  break;
+	case 'Z':
+	  token = FMT_RZ;
+	  break;
+	default:
+	  token = FMT_UNKNOWN;
+	  unget_char ();
+	  break;
+	}
+      break;
+
+    case '\0':
+      token = FMT_END;
+      break;
+
+    case '*':
+      token = FMT_STAR;
+      break;
+
+    default:
+      token = FMT_UNKNOWN;
+      break;
+    }
+
+  if (error)
+    return FMT_ERROR;
+
+  return token;
+}
+
+
+static const char *
+token_to_string (format_token t)
+{
+  switch (t)
+    {
+      case FMT_D:
+	return "D";
+      case FMT_G:
+	return "G";
+      case FMT_E:
+	return "E";
+      case FMT_EN:
+	return "EN";
+      case FMT_ES:
+	return "ES";
+      default:
+        return "";
+    }
+}
+
+/* Check a format statement.  The format string, either from a FORMAT
+   statement or a constant in an I/O statement has already been parsed
+   by itself, and we are checking it for validity.  The dual origin
+   means that the warning message is a little less than great.  */
+
+static bool
+check_format (bool is_input)
+{
+  const char *posint_required	  = _("Positive width required");
+  const char *nonneg_required	  = _("Nonnegative width required");
+  const char *unexpected_element  = _("Unexpected element '%c' in format string"
+				      " at %L");
+  const char *unexpected_end	  = _("Unexpected end of format string");
+  const char *zero_width	  = _("Zero width in format descriptor");
+
+  const char *error;
+  format_token t, u;
+  int level;
+  int repeat;
+  bool rv;
+
+  use_last_char = 0;
+  saved_token = FMT_NONE;
+  level = 0;
+  repeat = 0;
+  rv = true;
+  format_string_pos = 0;
+
+  t = format_lex ();
+  if (t == FMT_ERROR)
+    goto fail;
+  if (t != FMT_LPAREN)
+    {
+      error = _("Missing leading left parenthesis");
+      goto syntax;
+    }
+
+  t = format_lex ();
+  if (t == FMT_ERROR)
+    goto fail;
+  if (t == FMT_RPAREN)
+    goto finished;		/* Empty format is legal */
+  saved_token = t;
+
+format_item:
+  /* In this state, the next thing has to be a format item.  */
+  t = format_lex ();
+  if (t == FMT_ERROR)
+    goto fail;
+format_item_1:
+  switch (t)
+    {
+    case FMT_STAR:
+      repeat = -1;
+      t = format_lex ();
+      if (t == FMT_ERROR)
+	goto fail;
+      if (t == FMT_LPAREN)
+	{
+	  level++;
+	  goto format_item;
+	}
+      error = _("Left parenthesis required after '*'");
+      goto syntax;
+
+    case FMT_POSINT:
+      repeat = value;
+      t = format_lex ();
+      if (t == FMT_ERROR)
+	goto fail;
+      if (t == FMT_LPAREN)
+	{
+	  level++;
+	  goto format_item;
+	}
+
+      if (t == FMT_SLASH)
+	goto optional_comma;
+
+      goto data_desc;
+
+    case FMT_LPAREN:
+      level++;
+      goto format_item;
+
+    case FMT_SIGNED_INT:
+    case FMT_ZERO:
+      /* Signed integer can only precede a P format.  */
+      t = format_lex ();
+      if (t == FMT_ERROR)
+	goto fail;
+      if (t != FMT_P)
+	{
+	  error = _("Expected P edit descriptor");
+	  goto syntax;
+	}
+
+      goto data_desc;
+
+    case FMT_P:
+      /* P requires a prior number.  */
+      error = _("P descriptor requires leading scale factor");
+      goto syntax;
+
+    case FMT_X:
+      /* X requires a prior number if we're being pedantic.  */
+      if (mode != MODE_FORMAT)
+	format_locus.nextc += format_string_pos;
+      if (!gfc_notify_std (GFC_STD_GNU, "X descriptor requires leading "
+			   "space count at %L", &format_locus))
+	return false;
+      goto between_desc;
+
+    case FMT_SIGN:
+    case FMT_BLANK:
+    case FMT_DP:
+    case FMT_DC:
+    case FMT_RC:
+    case FMT_RD:
+    case FMT_RN:
+    case FMT_RP:
+    case FMT_RU:
+    case FMT_RZ:
+      goto between_desc;
+
+    case FMT_CHAR:
+      goto extension_optional_comma;
+
+    case FMT_COLON:
+    case FMT_SLASH:
+      goto optional_comma;
+
+    case FMT_DOLLAR:
+      t = format_lex ();
+      if (t == FMT_ERROR)
+	goto fail;
+
+      if (!gfc_notify_std (GFC_STD_GNU, "$ descriptor at %L", &format_locus))
+	return false;
+      if (t != FMT_RPAREN || level > 0)
+	{
+	  gfc_warning ("$ should be the last specifier in format at %L",
+		       &format_locus);
+	  goto optional_comma_1;
+	}
+
+      goto finished;
+
+    case FMT_T:
+    case FMT_TL:
+    case FMT_TR:
+    case FMT_IBOZ:
+    case FMT_F:
+    case FMT_E:
+    case FMT_EN:
+    case FMT_ES:
+    case FMT_G:
+    case FMT_L:
+    case FMT_A:
+    case FMT_D:
+    case FMT_H:
+      goto data_desc;
+
+    case FMT_END:
+      error = unexpected_end;
+      goto syntax;
+
+    default:
+      error = unexpected_element;
+      goto syntax;
+    }
+
+data_desc:
+  /* In this state, t must currently be a data descriptor.
+     Deal with things that can/must follow the descriptor.  */
+  switch (t)
+    {
+    case FMT_SIGN:
+    case FMT_BLANK:
+    case FMT_DP:
+    case FMT_DC:
+    case FMT_X:
+      break;
+
+    case FMT_P:
+      /* No comma after P allowed only for F, E, EN, ES, D, or G.
+	 10.1.1 (1).  */
+      t = format_lex ();
+      if (t == FMT_ERROR)
+	goto fail;
+      if (!(gfc_option.allow_std & GFC_STD_F2003) && t != FMT_COMMA
+	  && t != FMT_F && t != FMT_E && t != FMT_EN && t != FMT_ES
+	  && t != FMT_D && t != FMT_G && t != FMT_RPAREN && t != FMT_SLASH)
+	{
+	  error = _("Comma required after P descriptor");
+	  goto syntax;
+	}
+      if (t != FMT_COMMA)
+	{
+	  if (t == FMT_POSINT)
+	    {
+	      t = format_lex ();
+	      if (t == FMT_ERROR)
+		goto fail;
+	    }
+          if (t != FMT_F && t != FMT_E && t != FMT_EN && t != FMT_ES && t != FMT_D
+	      && t != FMT_G && t != FMT_RPAREN && t != FMT_SLASH)
+	    {
+	      error = _("Comma required after P descriptor");
+	      goto syntax;
+	    }
+	}
+
+      saved_token = t;
+      goto optional_comma;
+
+    case FMT_T:
+    case FMT_TL:
+    case FMT_TR:
+      t = format_lex ();
+      if (t != FMT_POSINT)
+	{
+	  error = _("Positive width required with T descriptor");
+	  goto syntax;
+	}
+      break;
+
+    case FMT_L:
+      t = format_lex ();
+      if (t == FMT_ERROR)
+	goto fail;
+      if (t == FMT_POSINT)
+	break;
+
+      switch (gfc_notification_std (GFC_STD_GNU))
+	{
+	  case WARNING:
+	    if (mode != MODE_FORMAT)
+	      format_locus.nextc += format_string_pos;
+	    gfc_warning ("Extension: Missing positive width after L "
+			 "descriptor at %L", &format_locus);
+	    saved_token = t;
+	    break;
+
+	  case ERROR:
+	    error = posint_required;
+	    goto syntax;
+
+	  case SILENT:
+	    saved_token = t;
+	    break;
+
+	  default:
+	    gcc_unreachable ();
+	}
+      break;
+
+    case FMT_A:
+      t = format_lex ();
+      if (t == FMT_ERROR)
+	goto fail;
+      if (t == FMT_ZERO)
+	{
+	  error = zero_width;
+	  goto syntax;
+	}
+      if (t != FMT_POSINT)
+	saved_token = t;
+      break;
+
+    case FMT_D:
+    case FMT_E:
+    case FMT_G:
+    case FMT_EN:
+    case FMT_ES:
+      u = format_lex ();
+      if (t == FMT_G && u == FMT_ZERO)
+	{
+	  if (is_input)
+	    {
+	      error = zero_width;
+	      goto syntax;
+	    }
+	  if (!gfc_notify_std (GFC_STD_F2008, "'G0' in format at %L", 
+			       &format_locus))
+	    return false;
+	  u = format_lex ();
+	  if (u != FMT_PERIOD)
+	    {
+	      saved_token = u;
+	      break;
+	    }
+	  u = format_lex ();
+	  if (u != FMT_POSINT)
+	    {
+	      error = posint_required;
+	      goto syntax;
+	    }
+	  u = format_lex ();
+	  if (u == FMT_E)
+	    {
+	      error = _("E specifier not allowed with g0 descriptor");
+	      goto syntax;
+	    }
+	  saved_token = u;
+	  break;
+	}
+
+      if (u != FMT_POSINT)
+	{
+	  format_locus.nextc += format_string_pos;
+	  gfc_error ("Positive width required in format "
+			 "specifier %s at %L", token_to_string (t),
+			 &format_locus);
+	  saved_token = u;
+	  goto fail;
+	}
+
+      u = format_lex ();
+      if (u == FMT_ERROR)
+	goto fail;
+      if (u != FMT_PERIOD)
+	{
+	  /* Warn if -std=legacy, otherwise error.  */
+	  format_locus.nextc += format_string_pos;
+	  if (gfc_option.warn_std != 0)
+	    {
+	      gfc_error ("Period required in format "
+			     "specifier %s at %L", token_to_string (t),
+			     &format_locus);
+	      saved_token = u;
+              goto fail;
+	    }
+	  else
+	    gfc_warning ("Period required in format "
+			 "specifier %s at %L", token_to_string (t),
+			  &format_locus);
+	  /* If we go to finished, we need to unwind this
+	     before the next round.  */
+	  format_locus.nextc -= format_string_pos;
+	  saved_token = u;
+	  break;
+	}
+
+      u = format_lex ();
+      if (u == FMT_ERROR)
+	goto fail;
+      if (u != FMT_ZERO && u != FMT_POSINT)
+	{
+	  error = nonneg_required;
+	  goto syntax;
+	}
+
+      if (t == FMT_D)
+	break;
+
+      /* Look for optional exponent.  */
+      u = format_lex ();
+      if (u == FMT_ERROR)
+	goto fail;
+      if (u != FMT_E)
+	{
+	  saved_token = u;
+	}
+      else
+	{
+	  u = format_lex ();
+	  if (u == FMT_ERROR)
+	    goto fail;
+	  if (u != FMT_POSINT)
+	    {
+	      error = _("Positive exponent width required");
+	      goto syntax;
+	    }
+	}
+
+      break;
+
+    case FMT_F:
+      t = format_lex ();
+      if (t == FMT_ERROR)
+	goto fail;
+      if (t != FMT_ZERO && t != FMT_POSINT)
+	{
+	  error = nonneg_required;
+	  goto syntax;
+	}
+      else if (is_input && t == FMT_ZERO)
+	{
+	  error = posint_required;
+	  goto syntax;
+	}
+
+      t = format_lex ();
+      if (t == FMT_ERROR)
+	goto fail;
+      if (t != FMT_PERIOD)
+	{
+	  /* Warn if -std=legacy, otherwise error.  */
+	  if (gfc_option.warn_std != 0)
+	    {
+	      error = _("Period required in format specifier");
+	      goto syntax;
+	    }
+	  if (mode != MODE_FORMAT)
+	    format_locus.nextc += format_string_pos;
+	  gfc_warning ("Period required in format specifier at %L",
+		       &format_locus);
+	  saved_token = t;
+	  break;
+	}
+
+      t = format_lex ();
+      if (t == FMT_ERROR)
+	goto fail;
+      if (t != FMT_ZERO && t != FMT_POSINT)
+	{
+	  error = nonneg_required;
+	  goto syntax;
+	}
+
+      break;
+
+    case FMT_H:
+      if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
+	{
+	  if (mode != MODE_FORMAT)
+	    format_locus.nextc += format_string_pos;
+	  gfc_warning ("The H format specifier at %L is"
+		       " a Fortran 95 deleted feature", &format_locus);
+	}
+      if (mode == MODE_STRING)
+	{
+	  format_string += value;
+	  format_length -= value;
+          format_string_pos += repeat;
+	}
+      else
+	{
+	  while (repeat >0)
+	   {
+	     next_char (INSTRING_WARN);
+	     repeat -- ;
+	   }
+	}
+     break;
+
+    case FMT_IBOZ:
+      t = format_lex ();
+      if (t == FMT_ERROR)
+	goto fail;
+      if (t != FMT_ZERO && t != FMT_POSINT)
+	{
+	  error = nonneg_required;
+	  goto syntax;
+	}
+      else if (is_input && t == FMT_ZERO)
+	{
+	  error = posint_required;
+	  goto syntax;
+	}
+
+      t = format_lex ();
+      if (t == FMT_ERROR)
+	goto fail;
+      if (t != FMT_PERIOD)
+	{
+	  saved_token = t;
+	}
+      else
+	{
+	  t = format_lex ();
+	  if (t == FMT_ERROR)
+	    goto fail;
+	  if (t != FMT_ZERO && t != FMT_POSINT)
+	    {
+	      error = nonneg_required;
+	      goto syntax;
+	    }
+	}
+
+      break;
+
+    default:
+      error = unexpected_element;
+      goto syntax;
+    }
+
+between_desc:
+  /* Between a descriptor and what comes next.  */
+  t = format_lex ();
+  if (t == FMT_ERROR)
+    goto fail;
+  switch (t)
+    {
+
+    case FMT_COMMA:
+      goto format_item;
+
+    case FMT_RPAREN:
+      level--;
+      if (level < 0)
+	goto finished;
+      goto between_desc;
+
+    case FMT_COLON:
+    case FMT_SLASH:
+      goto optional_comma;
+
+    case FMT_END:
+      error = unexpected_end;
+      goto syntax;
+
+    default:
+      if (mode != MODE_FORMAT)
+	format_locus.nextc += format_string_pos - 1;
+      if (!gfc_notify_std (GFC_STD_GNU, "Missing comma at %L", &format_locus))
+	return false;
+      /* If we do not actually return a failure, we need to unwind this
+         before the next round.  */
+      if (mode != MODE_FORMAT)
+	format_locus.nextc -= format_string_pos;
+      goto format_item_1;
+    }
+
+optional_comma:
+  /* Optional comma is a weird between state where we've just finished
+     reading a colon, slash, dollar or P descriptor.  */
+  t = format_lex ();
+  if (t == FMT_ERROR)
+    goto fail;
+optional_comma_1:
+  switch (t)
+    {
+    case FMT_COMMA:
+      break;
+
+    case FMT_RPAREN:
+      level--;
+      if (level < 0)
+	goto finished;
+      goto between_desc;
+
+    default:
+      /* Assume that we have another format item.  */
+      saved_token = t;
+      break;
+    }
+
+  goto format_item;
+
+extension_optional_comma:
+  /* As a GNU extension, permit a missing comma after a string literal.  */
+  t = format_lex ();
+  if (t == FMT_ERROR)
+    goto fail;
+  switch (t)
+    {
+    case FMT_COMMA:
+      break;
+
+    case FMT_RPAREN:
+      level--;
+      if (level < 0)
+	goto finished;
+      goto between_desc;
+
+    case FMT_COLON:
+    case FMT_SLASH:
+      goto optional_comma;
+
+    case FMT_END:
+      error = unexpected_end;
+      goto syntax;
+
+    default:
+      if (mode != MODE_FORMAT)
+	format_locus.nextc += format_string_pos;
+      if (!gfc_notify_std (GFC_STD_GNU, "Missing comma at %L", &format_locus))
+	return false;
+      /* If we do not actually return a failure, we need to unwind this
+         before the next round.  */
+      if (mode != MODE_FORMAT)
+	format_locus.nextc -= format_string_pos;
+      saved_token = t;
+      break;
+    }
+
+  goto format_item;
+  
+syntax:
+  if (mode != MODE_FORMAT)
+    format_locus.nextc += format_string_pos;
+  if (error == unexpected_element)
+    gfc_error (error, error_element, &format_locus);
+  else
+    gfc_error ("%s in format string at %L", error, &format_locus);
+fail:
+  rv = false;
+
+finished:
+  return rv;
+}
+
+
+/* Given an expression node that is a constant string, see if it looks
+   like a format string.  */
+
+static bool
+check_format_string (gfc_expr *e, bool is_input)
+{
+  bool rv;
+  int i;
+  if (!e || e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
+    return true;
+
+  mode = MODE_STRING;
+  format_string = e->value.character.string;
+
+  /* More elaborate measures are needed to show where a problem is within a
+     format string that has been calculated, but that's probably not worth the
+     effort.  */
+  format_locus = e->where;
+  rv = check_format (is_input);
+  /* check for extraneous characters at the end of an otherwise valid format
+     string, like '(A10,I3)F5'
+     start at the end and move back to the last character processed,
+     spaces are OK */
+  if (rv && e->value.character.length > format_string_pos)
+    for (i=e->value.character.length-1;i>format_string_pos-1;i--)
+      if (e->value.character.string[i] != ' ')
+        {
+          format_locus.nextc += format_length + 1; 
+          gfc_warning ("Extraneous characters in format at %L", &format_locus); 
+          break;
+        }
+  return rv;
+}
+
+
+/************ Fortran 95 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
+   format string.  */
+
+match
+gfc_match_format (void)
+{
+  gfc_expr *e;
+  locus start;
+
+  if (gfc_current_ns->proc_name
+      && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
+    {
+      gfc_error ("Format statement in module main block at %C");
+      return MATCH_ERROR;
+    }
+
+  if (gfc_statement_label == NULL)
+    {
+      gfc_error ("Missing format label at %C");
+      return MATCH_ERROR;
+    }
+  gfc_gobble_whitespace ();
+
+  mode = MODE_FORMAT;
+  format_length = 0;
+
+  start = gfc_current_locus;
+
+  if (!check_format (false))
+    return MATCH_ERROR;
+
+  if (gfc_match_eos () != MATCH_YES)
+    {
+      gfc_syntax_error (ST_FORMAT);
+      return MATCH_ERROR;
+    }
+
+  /* The label doesn't get created until after the statement is done
+     being matched, so we have to leave the string for later.  */
+
+  gfc_current_locus = start;	/* Back to the beginning */
+
+  new_st.loc = start;
+  new_st.op = EXEC_NOP;
+
+  e = gfc_get_character_expr (gfc_default_character_kind, &start,
+			      NULL, format_length);
+  format_string = e->value.character.string;
+  gfc_statement_label->format = e;
+
+  mode = MODE_COPY;
+  check_format (false);		/* Guaranteed to succeed */
+  gfc_match_eos ();		/* Guaranteed to succeed */
+
+  return MATCH_YES;
+}
+
+
+/* Match an expression I/O tag of some sort.  */
+
+static match
+match_etag (const io_tag *tag, gfc_expr **v)
+{
+  gfc_expr *result;
+  match m;
+
+  m = gfc_match (tag->spec);
+  if (m != MATCH_YES)
+    return m;
+
+  m = gfc_match (tag->value, &result);
+  if (m != MATCH_YES)
+    {
+      gfc_error ("Invalid value for %s specification at %C", tag->name);
+      return MATCH_ERROR;
+    }
+
+  if (*v != NULL)
+    {
+      gfc_error ("Duplicate %s specification at %C", tag->name);
+      gfc_free_expr (result);
+      return MATCH_ERROR;
+    }
+
+  *v = result;
+  return MATCH_YES;
+}
+
+
+/* Match a variable I/O tag of some sort.  */
+
+static match
+match_vtag (const io_tag *tag, gfc_expr **v)
+{
+  gfc_expr *result;
+  match m;
+
+  m = gfc_match (tag->spec);
+  if (m != MATCH_YES)
+    return m;
+
+  m = gfc_match (tag->value, &result);
+  if (m != MATCH_YES)
+    {
+      gfc_error ("Invalid value for %s specification at %C", tag->name);
+      return MATCH_ERROR;
+    }
+
+  if (*v != NULL)
+    {
+      gfc_error ("Duplicate %s specification at %C", tag->name);
+      gfc_free_expr (result);
+      return MATCH_ERROR;
+    }
+
+  if (result->symtree->n.sym->attr.intent == INTENT_IN)
+    {
+      gfc_error ("Variable %s cannot be INTENT(IN) at %C", tag->name);
+      gfc_free_expr (result);
+      return MATCH_ERROR;
+    }
+
+  bool impure = gfc_impure_variable (result->symtree->n.sym);
+  if (impure && gfc_pure (NULL))
+    {
+      gfc_error ("Variable %s cannot be assigned in PURE procedure at %C",
+		 tag->name);
+      gfc_free_expr (result);
+      return MATCH_ERROR;
+    }
+
+  if (impure)
+    gfc_unset_implicit_pure (NULL);
+
+  *v = result;
+  return MATCH_YES;
+}
+
+
+/* Match I/O tags that cause variables to become redefined.  */
+
+static match
+match_out_tag (const io_tag *tag, gfc_expr **result)
+{
+  match m;
+
+  m = match_vtag (tag, result);
+  if (m == MATCH_YES)
+    gfc_check_do_variable ((*result)->symtree);
+
+  return m;
+}
+
+
+/* Match a label I/O tag.  */
+
+static match
+match_ltag (const io_tag *tag, gfc_st_label ** label)
+{
+  match m;
+  gfc_st_label *old;
+
+  old = *label;
+  m = gfc_match (tag->spec);
+  if (m != MATCH_YES)
+    return m;
+
+  m = gfc_match (tag->value, label);
+  if (m != MATCH_YES)
+    {
+      gfc_error ("Invalid value for %s specification at %C", tag->name);
+      return MATCH_ERROR;
+    }
+
+  if (old)
+    {
+      gfc_error ("Duplicate %s label specification at %C", tag->name);
+      return MATCH_ERROR;
+    }
+
+  if (!gfc_reference_st_label (*label, ST_LABEL_TARGET))
+    return MATCH_ERROR;
+
+  return m;
+}
+
+
+/* Resolution of the FORMAT tag, to be called from resolve_tag.  */
+
+static bool
+resolve_tag_format (const gfc_expr *e)
+{
+  if (e->expr_type == EXPR_CONSTANT
+      && (e->ts.type != BT_CHARACTER
+	  || e->ts.kind != gfc_default_character_kind))
+    {
+      gfc_error ("Constant expression in FORMAT tag at %L must be "
+		 "of type default CHARACTER", &e->where);
+      return false;
+    }
+
+  /* If e's rank is zero and e is not an element of an array, it should be
+     of integer or character type.  The integer variable should be
+     ASSIGNED.  */
+  if (e->rank == 0
+      && (e->expr_type != EXPR_VARIABLE
+	  || e->symtree == NULL
+	  || e->symtree->n.sym->as == NULL
+	  || e->symtree->n.sym->as->rank == 0))
+    {
+      if ((e->ts.type != BT_CHARACTER
+	   || e->ts.kind != gfc_default_character_kind)
+	  && e->ts.type != BT_INTEGER)
+	{
+	  gfc_error ("FORMAT tag at %L must be of type default-kind CHARACTER "
+		     "or of INTEGER", &e->where);
+	  return false;
+	}
+      else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE)
+	{
+	  if (!gfc_notify_std (GFC_STD_F95_DEL, "ASSIGNED variable in "
+			       "FORMAT tag at %L", &e->where))
+	    return false;
+	  if (e->symtree->n.sym->attr.assign != 1)
+	    {
+	      gfc_error ("Variable '%s' at %L has not been assigned a "
+			 "format label", e->symtree->n.sym->name, &e->where);
+	      return false;
+	    }
+	}
+      else if (e->ts.type == BT_INTEGER)
+	{
+	  gfc_error ("Scalar '%s' in FORMAT tag at %L is not an ASSIGNED "
+		     "variable", gfc_basic_typename (e->ts.type), &e->where);
+	  return false;
+	}
+
+      return true;
+    }
+
+  /* If rank is nonzero and type is not character, we allow it under GFC_STD_LEGACY.
+     It may be assigned an Hollerith constant.  */
+  if (e->ts.type != BT_CHARACTER)
+    {
+      if (!gfc_notify_std (GFC_STD_LEGACY, "Non-character in FORMAT tag "
+			   "at %L", &e->where))
+	return false;
+
+      if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE)
+	{
+	  gfc_error ("Non-character assumed shape array element in FORMAT"
+		     " tag at %L", &e->where);
+	  return false;
+	}
+
+      if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
+	{
+	  gfc_error ("Non-character assumed size array element in FORMAT"
+		     " tag at %L", &e->where);
+	  return false;
+	}
+
+      if (e->rank == 0 && e->symtree->n.sym->attr.pointer)
+	{
+	  gfc_error ("Non-character pointer array element in FORMAT tag at %L",
+		     &e->where);
+	  return false;
+	}
+    }
+
+  return true;
+}
+
+
+/* Do expression resolution and type-checking on an expression tag.  */
+
+static bool
+resolve_tag (const io_tag *tag, gfc_expr *e)
+{
+  if (e == NULL)
+    return true;
+
+  if (!gfc_resolve_expr (e))
+    return false;
+
+  if (tag == &tag_format)
+    return resolve_tag_format (e);
+
+  if (e->ts.type != tag->type)
+    {
+      gfc_error ("%s tag at %L must be of type %s", tag->name,
+		 &e->where, gfc_basic_typename (tag->type));
+      return false;
+    }
+
+  if (e->ts.type == BT_CHARACTER && e->ts.kind != gfc_default_character_kind)
+    {
+      gfc_error ("%s tag at %L must be a character string of default kind",
+		 tag->name, &e->where);
+      return false;
+    }
+
+  if (e->rank != 0)
+    {
+      gfc_error ("%s tag at %L must be scalar", tag->name, &e->where);
+      return false;
+    }
+
+  if (tag == &tag_iomsg)
+    {
+      if (!gfc_notify_std (GFC_STD_F2003, "IOMSG tag at %L", &e->where))
+	return false;
+    }
+
+  if ((tag == &tag_iostat || tag == &tag_size || tag == &tag_iolength)
+      && e->ts.kind != gfc_default_integer_kind)
+    {
+      if (!gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default "
+			   "INTEGER in %s tag at %L", tag->name, &e->where))
+	return false;
+    }
+
+  if (tag == &tag_exist && e->ts.kind != gfc_default_logical_kind)
+    {
+      if (!gfc_notify_std (GFC_STD_F2008, "Nondefault LOGICAL "
+			   "in %s tag at %L", tag->name, &e->where))
+	return false;
+    }
+
+  if (tag == &tag_newunit)
+    {
+      if (!gfc_notify_std (GFC_STD_F2008, "NEWUNIT specifier at %L", 
+			   &e->where))
+	return false;
+    }
+
+  /* NEWUNIT, IOSTAT, SIZE and IOMSG are variable definition contexts.  */
+  if (tag == &tag_newunit || tag == &tag_iostat
+      || tag == &tag_size || tag == &tag_iomsg)
+    {
+      char context[64];
+
+      sprintf (context, _("%s tag"), tag->name);
+      if (!gfc_check_vardef_context (e, false, false, false, context))
+	return false;
+    }
+  
+  if (tag == &tag_convert)
+    {
+      if (!gfc_notify_std (GFC_STD_GNU, "CONVERT tag at %L", &e->where))
+	return false;
+    }
+
+  return true;
+}
+
+
+/* Match a single tag of an OPEN statement.  */
+
+static match
+match_open_element (gfc_open *open)
+{
+  match m;
+
+  m = match_etag (&tag_e_async, &open->asynchronous);
+  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);
+  if (m != MATCH_NO)
+    return m;
+  m = match_out_tag (&tag_iostat, &open->iostat);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_file, &open->file);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_status, &open->status);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_e_access, &open->access);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_e_form, &open->form);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_e_recl, &open->recl);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_e_blank, &open->blank);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_e_position, &open->position);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_e_action, &open->action);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_e_delim, &open->delim);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_e_pad, &open->pad);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_e_decimal, &open->decimal);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_e_encoding, &open->encoding);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_e_round, &open->round);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_e_sign, &open->sign);
+  if (m != MATCH_NO)
+    return m;
+  m = match_ltag (&tag_err, &open->err);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_convert, &open->convert);
+  if (m != MATCH_NO)
+    return m;
+  m = match_out_tag (&tag_newunit, &open->newunit);
+  if (m != MATCH_NO)
+    return m;
+
+  return MATCH_NO;
+}
+
+
+/* Free the gfc_open structure and all the expressions it contains.  */
+
+void
+gfc_free_open (gfc_open *open)
+{
+  if (open == NULL)
+    return;
+
+  gfc_free_expr (open->unit);
+  gfc_free_expr (open->iomsg);
+  gfc_free_expr (open->iostat);
+  gfc_free_expr (open->file);
+  gfc_free_expr (open->status);
+  gfc_free_expr (open->access);
+  gfc_free_expr (open->form);
+  gfc_free_expr (open->recl);
+  gfc_free_expr (open->blank);
+  gfc_free_expr (open->position);
+  gfc_free_expr (open->action);
+  gfc_free_expr (open->delim);
+  gfc_free_expr (open->pad);
+  gfc_free_expr (open->decimal);
+  gfc_free_expr (open->encoding);
+  gfc_free_expr (open->round);
+  gfc_free_expr (open->sign);
+  gfc_free_expr (open->convert);
+  gfc_free_expr (open->asynchronous);
+  gfc_free_expr (open->newunit);
+  free (open);
+}
+
+
+/* Resolve everything in a gfc_open structure.  */
+
+bool
+gfc_resolve_open (gfc_open *open)
+{
+
+  RESOLVE_TAG (&tag_unit, open->unit);
+  RESOLVE_TAG (&tag_iomsg, open->iomsg);
+  RESOLVE_TAG (&tag_iostat, open->iostat);
+  RESOLVE_TAG (&tag_file, open->file);
+  RESOLVE_TAG (&tag_status, open->status);
+  RESOLVE_TAG (&tag_e_access, open->access);
+  RESOLVE_TAG (&tag_e_form, open->form);
+  RESOLVE_TAG (&tag_e_recl, open->recl);
+  RESOLVE_TAG (&tag_e_blank, open->blank);
+  RESOLVE_TAG (&tag_e_position, open->position);
+  RESOLVE_TAG (&tag_e_action, open->action);
+  RESOLVE_TAG (&tag_e_delim, open->delim);
+  RESOLVE_TAG (&tag_e_pad, open->pad);
+  RESOLVE_TAG (&tag_e_decimal, open->decimal);
+  RESOLVE_TAG (&tag_e_encoding, open->encoding);
+  RESOLVE_TAG (&tag_e_async, open->asynchronous);
+  RESOLVE_TAG (&tag_e_round, open->round);
+  RESOLVE_TAG (&tag_e_sign, open->sign);
+  RESOLVE_TAG (&tag_convert, open->convert);
+  RESOLVE_TAG (&tag_newunit, open->newunit);
+
+  if (!gfc_reference_st_label (open->err, ST_LABEL_TARGET))
+    return false;
+
+  return true;
+}
+
+
+/* Check if a given value for a SPECIFIER is either in the list of values
+   allowed in F95 or F2003, issuing an error message and returning a zero
+   value if it is not allowed.  */
+
+static int
+compare_to_allowed_values (const char *specifier, const char *allowed[],
+			   const char *allowed_f2003[], 
+			   const char *allowed_gnu[], gfc_char_t *value,
+			   const char *statement, bool warn)
+{
+  int i;
+  unsigned int len;
+
+  len = gfc_wide_strlen (value);
+  if (len > 0)
+  {
+    for (len--; len > 0; len--)
+      if (value[len] != ' ')
+	break;
+    len++;
+  }
+
+  for (i = 0; allowed[i]; i++)
+    if (len == strlen (allowed[i])
+	&& gfc_wide_strncasecmp (value, allowed[i], strlen (allowed[i])) == 0)
+      return 1;
+
+  for (i = 0; allowed_f2003 && allowed_f2003[i]; i++)
+    if (len == strlen (allowed_f2003[i])
+	&& gfc_wide_strncasecmp (value, allowed_f2003[i],
+				 strlen (allowed_f2003[i])) == 0)
+      {
+	notification n = gfc_notification_std (GFC_STD_F2003);
+
+	if (n == WARNING || (warn && n == ERROR))
+	  {
+	    gfc_warning ("Fortran 2003: %s specifier in %s statement at %C "
+			 "has value '%s'", specifier, statement,
+			 allowed_f2003[i]);
+	    return 1;
+	  }
+	else
+	  if (n == ERROR)
+	    {
+	      gfc_notify_std (GFC_STD_F2003, "%s specifier in "
+			      "%s statement at %C has value '%s'", specifier,
+			      statement, allowed_f2003[i]);
+	      return 0;
+	    }
+
+	/* n == SILENT */
+	return 1;
+      }
+
+  for (i = 0; allowed_gnu && allowed_gnu[i]; i++)
+    if (len == strlen (allowed_gnu[i])
+	&& gfc_wide_strncasecmp (value, allowed_gnu[i],
+				 strlen (allowed_gnu[i])) == 0)
+      {
+	notification n = gfc_notification_std (GFC_STD_GNU);
+
+	if (n == WARNING || (warn && n == ERROR))
+	  {
+	    gfc_warning ("Extension: %s specifier in %s statement at %C "
+			 "has value '%s'", specifier, statement,
+			 allowed_gnu[i]);
+	    return 1;
+	  }
+	else
+	  if (n == ERROR)
+	    {
+	      gfc_notify_std (GFC_STD_GNU, "%s specifier in "
+			      "%s statement at %C has value '%s'", specifier,
+			      statement, allowed_gnu[i]);
+	      return 0;
+	    }
+
+	/* n == SILENT */
+	return 1;
+      }
+
+  if (warn)
+    {
+      char *s = gfc_widechar_to_char (value, -1);
+      gfc_warning ("%s specifier in %s statement at %C has invalid value '%s'",
+		   specifier, statement, s);
+      free (s);
+      return 1;
+    }
+  else
+    {
+      char *s = gfc_widechar_to_char (value, -1);
+      gfc_error ("%s specifier in %s statement at %C has invalid value '%s'",
+		 specifier, statement, s);
+      free (s);
+      return 0;
+    }
+}
+
+
+/* Match an OPEN statement.  */
+
+match
+gfc_match_open (void)
+{
+  gfc_open *open;
+  match m;
+  bool warn;
+
+  m = gfc_match_char ('(');
+  if (m == MATCH_NO)
+    return m;
+
+  open = XCNEW (gfc_open);
+
+  m = match_open_element (open);
+
+  if (m == MATCH_ERROR)
+    goto cleanup;
+  if (m == MATCH_NO)
+    {
+      m = gfc_match_expr (&open->unit);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+    }
+
+  for (;;)
+    {
+      if (gfc_match_char (')') == MATCH_YES)
+	break;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+
+      m = match_open_element (open);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_NO)
+	goto syntax;
+    }
+
+  if (gfc_match_eos () == MATCH_NO)
+    goto syntax;
+
+  if (gfc_pure (NULL))
+    {
+      gfc_error ("OPEN statement not allowed in PURE procedure at %C");
+      goto cleanup;
+    }
+
+  gfc_unset_implicit_pure (NULL);
+
+  warn = (open->err || open->iostat) ? true : false;
+
+  /* Checks on NEWUNIT specifier.  */
+  if (open->newunit)
+    {
+      if (open->unit)
+	{
+	  gfc_error ("UNIT specifier not allowed with NEWUNIT at %C");
+	  goto cleanup;
+	}
+
+      if (!(open->file || (open->status
+          && gfc_wide_strncasecmp (open->status->value.character.string,
+				   "scratch", 7) == 0)))
+	{
+	  gfc_error ("NEWUNIT specifier must have FILE= "
+		     "or STATUS='scratch' at %C");
+	  goto cleanup;
+	}
+    }
+  else if (!open->unit)
+    {
+      gfc_error ("OPEN statement at %C must have UNIT or NEWUNIT specified");
+      goto cleanup;
+    }
+
+  /* Checks on the ACCESS specifier.  */
+  if (open->access && open->access->expr_type == EXPR_CONSTANT)
+    {
+      static const char *access_f95[] = { "SEQUENTIAL", "DIRECT", NULL };
+      static const char *access_f2003[] = { "STREAM", NULL };
+      static const char *access_gnu[] = { "APPEND", NULL };
+
+      if (!compare_to_allowed_values ("ACCESS", access_f95, access_f2003,
+				      access_gnu,
+				      open->access->value.character.string,
+				      "OPEN", warn))
+	goto cleanup;
+    }
+
+  /* Checks on the ACTION specifier.  */
+  if (open->action && open->action->expr_type == EXPR_CONSTANT)
+    {
+      static const char *action[] = { "READ", "WRITE", "READWRITE", NULL };
+
+      if (!compare_to_allowed_values ("ACTION", action, NULL, NULL,
+				      open->action->value.character.string,
+				      "OPEN", warn))
+	goto cleanup;
+    }
+
+  /* Checks on the ASYNCHRONOUS specifier.  */
+  if (open->asynchronous)
+    {
+      if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS= at %C "
+			   "not allowed in Fortran 95"))
+	goto cleanup;
+
+      if (open->asynchronous->expr_type == EXPR_CONSTANT)
+	{
+	  static const char * asynchronous[] = { "YES", "NO", NULL };
+
+	  if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous,
+			NULL, NULL, open->asynchronous->value.character.string,
+			"OPEN", warn))
+	    goto cleanup;
+	}
+    }
+
+  /* Checks on the BLANK specifier.  */
+  if (open->blank)
+    {
+      if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %C "
+			   "not allowed in Fortran 95"))
+	goto cleanup;
+
+      if (open->blank->expr_type == EXPR_CONSTANT)
+	{
+	  static const char *blank[] = { "ZERO", "NULL", NULL };
+
+	  if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
+					  open->blank->value.character.string,
+					  "OPEN", warn))
+	    goto cleanup;
+	}
+    }
+
+  /* Checks on the DECIMAL specifier.  */
+  if (open->decimal)
+    {
+      if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %C "
+			   "not allowed in Fortran 95"))
+	goto cleanup;
+
+      if (open->decimal->expr_type == EXPR_CONSTANT)
+	{
+	  static const char * decimal[] = { "COMMA", "POINT", NULL };
+
+	  if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
+					  open->decimal->value.character.string,
+					  "OPEN", warn))
+	    goto cleanup;
+	}
+    }
+
+  /* Checks on the DELIM specifier.  */
+  if (open->delim)
+    {
+      if (open->delim->expr_type == EXPR_CONSTANT)
+	{
+	  static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
+
+	  if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
+					  open->delim->value.character.string,
+					  "OPEN", warn))
+	  goto cleanup;
+	}
+    }
+
+  /* Checks on the ENCODING specifier.  */
+  if (open->encoding)
+    {
+      if (!gfc_notify_std (GFC_STD_F2003, "ENCODING= at %C "
+			   "not allowed in Fortran 95"))
+	goto cleanup;
+    
+      if (open->encoding->expr_type == EXPR_CONSTANT)
+	{
+	  static const char * encoding[] = { "DEFAULT", "UTF-8", NULL };
+
+	  if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL,
+					  open->encoding->value.character.string,
+					  "OPEN", warn))
+	  goto cleanup;
+	}
+    }
+
+  /* Checks on the FORM specifier.  */
+  if (open->form && open->form->expr_type == EXPR_CONSTANT)
+    {
+      static const char *form[] = { "FORMATTED", "UNFORMATTED", NULL };
+
+      if (!compare_to_allowed_values ("FORM", form, NULL, NULL,
+				      open->form->value.character.string,
+				      "OPEN", warn))
+	goto cleanup;
+    }
+
+  /* Checks on the PAD specifier.  */
+  if (open->pad && open->pad->expr_type == EXPR_CONSTANT)
+    {
+      static const char *pad[] = { "YES", "NO", NULL };
+
+      if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
+				      open->pad->value.character.string,
+				      "OPEN", warn))
+	goto cleanup;
+    }
+
+  /* Checks on the POSITION specifier.  */
+  if (open->position && open->position->expr_type == EXPR_CONSTANT)
+    {
+      static const char *position[] = { "ASIS", "REWIND", "APPEND", NULL };
+
+      if (!compare_to_allowed_values ("POSITION", position, NULL, NULL,
+				      open->position->value.character.string,
+				      "OPEN", warn))
+	goto cleanup;
+    }
+
+  /* Checks on the ROUND specifier.  */
+  if (open->round)
+    {
+      if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %C "
+			   "not allowed in Fortran 95"))
+      goto cleanup;
+
+      if (open->round->expr_type == EXPR_CONSTANT)
+	{
+	  static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
+					  "COMPATIBLE", "PROCESSOR_DEFINED",
+					   NULL };
+
+	  if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
+					  open->round->value.character.string,
+					  "OPEN", warn))
+	  goto cleanup;
+	}
+    }
+
+  /* Checks on the SIGN specifier.  */
+  if (open->sign) 
+    {
+      if (!gfc_notify_std (GFC_STD_F2003, "SIGN= at %C "
+			   "not allowed in Fortran 95"))
+	goto cleanup;
+
+      if (open->sign->expr_type == EXPR_CONSTANT)
+	{
+	  static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
+					  NULL };
+
+	  if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
+					  open->sign->value.character.string,
+					  "OPEN", warn))
+	  goto cleanup;
+	}
+    }
+
+#define warn_or_error(...) \
+{ \
+  if (warn) \
+    gfc_warning (__VA_ARGS__); \
+  else \
+    { \
+      gfc_error (__VA_ARGS__); \
+      goto cleanup; \
+    } \
+}
+
+  /* Checks on the RECL specifier.  */
+  if (open->recl && open->recl->expr_type == EXPR_CONSTANT
+      && open->recl->ts.type == BT_INTEGER
+      && mpz_sgn (open->recl->value.integer) != 1)
+    {
+      warn_or_error ("RECL in OPEN statement at %C must be positive");
+    }
+
+  /* Checks on the STATUS specifier.  */
+  if (open->status && open->status->expr_type == EXPR_CONSTANT)
+    {
+      static const char *status[] = { "OLD", "NEW", "SCRATCH",
+	"REPLACE", "UNKNOWN", NULL };
+
+      if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
+				      open->status->value.character.string,
+				      "OPEN", warn))
+	goto cleanup;
+
+      /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
+	 the FILE= specifier shall appear.  */
+      if (open->file == NULL
+	  && (gfc_wide_strncasecmp (open->status->value.character.string,
+				    "replace", 7) == 0
+	      || gfc_wide_strncasecmp (open->status->value.character.string,
+				       "new", 3) == 0))
+	{
+	  char *s = gfc_widechar_to_char (open->status->value.character.string,
+					  -1);
+	  warn_or_error ("The STATUS specified in OPEN statement at %C is "
+			 "'%s' and no FILE specifier is present", s);
+	  free (s);
+	}
+
+      /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
+	 the FILE= specifier shall not appear.  */
+      if (gfc_wide_strncasecmp (open->status->value.character.string,
+				"scratch", 7) == 0 && open->file)
+	{
+	  warn_or_error ("The STATUS specified in OPEN statement at %C "
+			 "cannot have the value SCRATCH if a FILE specifier "
+			 "is present");
+	}
+    }
+
+  /* Things that are not allowed for unformatted I/O.  */
+  if (open->form && open->form->expr_type == EXPR_CONSTANT
+      && (open->delim || open->decimal || open->encoding || open->round
+	  || open->sign || open->pad || open->blank)
+      && gfc_wide_strncasecmp (open->form->value.character.string,
+			       "unformatted", 11) == 0)
+    {
+      const char *spec = (open->delim ? "DELIM "
+				      : (open->pad ? "PAD " : open->blank
+							    ? "BLANK " : ""));
+
+      warn_or_error ("%s specifier at %C not allowed in OPEN statement for "
+		     "unformatted I/O", spec);
+    }
+
+  if (open->recl && open->access && open->access->expr_type == EXPR_CONSTANT
+      && gfc_wide_strncasecmp (open->access->value.character.string,
+			       "stream", 6) == 0)
+    {
+      warn_or_error ("RECL specifier not allowed in OPEN statement at %C for "
+		     "stream I/O");
+    }
+
+  if (open->position
+      && open->access && open->access->expr_type == EXPR_CONSTANT
+      && !(gfc_wide_strncasecmp (open->access->value.character.string,
+				 "sequential", 10) == 0
+	   || gfc_wide_strncasecmp (open->access->value.character.string,
+				    "stream", 6) == 0
+	   || gfc_wide_strncasecmp (open->access->value.character.string,
+				    "append", 6) == 0))
+    {
+      warn_or_error ("POSITION specifier in OPEN statement at %C only allowed "
+		     "for stream or sequential ACCESS");
+    }
+
+#undef warn_or_error
+
+  new_st.op = EXEC_OPEN;
+  new_st.ext.open = open;
+  return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (ST_OPEN);
+
+cleanup:
+  gfc_free_open (open);
+  return MATCH_ERROR;
+}
+
+
+/* Free a gfc_close structure an all its expressions.  */
+
+void
+gfc_free_close (gfc_close *close)
+{
+  if (close == NULL)
+    return;
+
+  gfc_free_expr (close->unit);
+  gfc_free_expr (close->iomsg);
+  gfc_free_expr (close->iostat);
+  gfc_free_expr (close->status);
+  free (close);
+}
+
+
+/* Match elements of a CLOSE statement.  */
+
+static match
+match_close_element (gfc_close *close)
+{
+  match m;
+
+  m = match_etag (&tag_unit, &close->unit);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_status, &close->status);
+  if (m != MATCH_NO)
+    return m;
+  m = match_out_tag (&tag_iomsg, &close->iomsg);
+  if (m != MATCH_NO)
+    return m;
+  m = match_out_tag (&tag_iostat, &close->iostat);
+  if (m != MATCH_NO)
+    return m;
+  m = match_ltag (&tag_err, &close->err);
+  if (m != MATCH_NO)
+    return m;
+
+  return MATCH_NO;
+}
+
+
+/* Match a CLOSE statement.  */
+
+match
+gfc_match_close (void)
+{
+  gfc_close *close;
+  match m;
+  bool warn;
+
+  m = gfc_match_char ('(');
+  if (m == MATCH_NO)
+    return m;
+
+  close = XCNEW (gfc_close);
+
+  m = match_close_element (close);
+
+  if (m == MATCH_ERROR)
+    goto cleanup;
+  if (m == MATCH_NO)
+    {
+      m = gfc_match_expr (&close->unit);
+      if (m == MATCH_NO)
+	goto syntax;
+      if (m == MATCH_ERROR)
+	goto cleanup;
+    }
+
+  for (;;)
+    {
+      if (gfc_match_char (')') == MATCH_YES)
+	break;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+
+      m = match_close_element (close);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_NO)
+	goto syntax;
+    }
+
+  if (gfc_match_eos () == MATCH_NO)
+    goto syntax;
+
+  if (gfc_pure (NULL))
+    {
+      gfc_error ("CLOSE statement not allowed in PURE procedure at %C");
+      goto cleanup;
+    }
+
+  gfc_unset_implicit_pure (NULL);
+
+  warn = (close->iostat || close->err) ? true : false;
+
+  /* Checks on the STATUS specifier.  */
+  if (close->status && close->status->expr_type == EXPR_CONSTANT)
+    {
+      static const char *status[] = { "KEEP", "DELETE", NULL };
+
+      if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
+				      close->status->value.character.string,
+				      "CLOSE", warn))
+	goto cleanup;
+    }
+
+  new_st.op = EXEC_CLOSE;
+  new_st.ext.close = close;
+  return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (ST_CLOSE);
+
+cleanup:
+  gfc_free_close (close);
+  return MATCH_ERROR;
+}
+
+
+/* Resolve everything in a gfc_close structure.  */
+
+bool
+gfc_resolve_close (gfc_close *close)
+{
+  RESOLVE_TAG (&tag_unit, close->unit);
+  RESOLVE_TAG (&tag_iomsg, close->iomsg);
+  RESOLVE_TAG (&tag_iostat, close->iostat);
+  RESOLVE_TAG (&tag_status, close->status);
+
+  if (!gfc_reference_st_label (close->err, ST_LABEL_TARGET))
+    return false;
+
+  if (close->unit == NULL)
+    {
+      /* Find a locus from one of the arguments to close, when UNIT is
+	 not specified.  */
+      locus loc = gfc_current_locus;
+      if (close->status)
+	loc = close->status->where;
+      else if (close->iostat)
+	loc = close->iostat->where;
+      else if (close->iomsg)
+	loc = close->iomsg->where;
+      else if (close->err)
+	loc = close->err->where;
+
+      gfc_error ("CLOSE statement at %L requires a UNIT number", &loc);
+      return false;
+    }
+
+  if (close->unit->expr_type == EXPR_CONSTANT
+      && close->unit->ts.type == BT_INTEGER
+      && mpz_sgn (close->unit->value.integer) < 0)
+    {
+      gfc_error ("UNIT number in CLOSE statement at %L must be non-negative",
+		 &close->unit->where);
+    }
+
+  return true;
+}
+
+
+/* Free a gfc_filepos structure.  */
+
+void
+gfc_free_filepos (gfc_filepos *fp)
+{
+  gfc_free_expr (fp->unit);
+  gfc_free_expr (fp->iomsg);
+  gfc_free_expr (fp->iostat);
+  free (fp);
+}
+
+
+/* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement.  */
+
+static match
+match_file_element (gfc_filepos *fp)
+{
+  match m;
+
+  m = match_etag (&tag_unit, &fp->unit);
+  if (m != MATCH_NO)
+    return m;
+  m = match_out_tag (&tag_iomsg, &fp->iomsg);
+  if (m != MATCH_NO)
+    return m;
+  m = match_out_tag (&tag_iostat, &fp->iostat);
+  if (m != MATCH_NO)
+    return m;
+  m = match_ltag (&tag_err, &fp->err);
+  if (m != MATCH_NO)
+    return m;
+
+  return MATCH_NO;
+}
+
+
+/* Match the second half of the file-positioning statements, REWIND,
+   BACKSPACE, ENDFILE, or the FLUSH statement.  */
+
+static match
+match_filepos (gfc_statement st, gfc_exec_op op)
+{
+  gfc_filepos *fp;
+  match m;
+
+  fp = XCNEW (gfc_filepos);
+
+  if (gfc_match_char ('(') == MATCH_NO)
+    {
+      m = gfc_match_expr (&fp->unit);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_NO)
+	goto syntax;
+
+      goto done;
+    }
+
+  m = match_file_element (fp);
+  if (m == MATCH_ERROR)
+    goto done;
+  if (m == MATCH_NO)
+    {
+      m = gfc_match_expr (&fp->unit);
+      if (m == MATCH_ERROR)
+	goto done;
+      if (m == MATCH_NO)
+	goto syntax;
+    }
+
+  for (;;)
+    {
+      if (gfc_match_char (')') == MATCH_YES)
+	break;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+
+      m = match_file_element (fp);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_NO)
+	goto syntax;
+    }
+
+done:
+  if (gfc_match_eos () != MATCH_YES)
+    goto syntax;
+
+  if (gfc_pure (NULL))
+    {
+      gfc_error ("%s statement not allowed in PURE procedure at %C",
+		 gfc_ascii_statement (st));
+
+      goto cleanup;
+    }
+
+  gfc_unset_implicit_pure (NULL);
+
+  new_st.op = op;
+  new_st.ext.filepos = fp;
+  return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (st);
+
+cleanup:
+  gfc_free_filepos (fp);
+  return MATCH_ERROR;
+}
+
+
+bool
+gfc_resolve_filepos (gfc_filepos *fp)
+{
+  RESOLVE_TAG (&tag_unit, fp->unit);
+  RESOLVE_TAG (&tag_iostat, fp->iostat);
+  RESOLVE_TAG (&tag_iomsg, fp->iomsg);
+  if (!gfc_reference_st_label (fp->err, ST_LABEL_TARGET))
+    return false;
+
+  if (fp->unit->expr_type == EXPR_CONSTANT
+      && fp->unit->ts.type == BT_INTEGER
+      && mpz_sgn (fp->unit->value.integer) < 0)
+    {
+      gfc_error ("UNIT number in statement at %L must be non-negative",
+		 &fp->unit->where);
+    }
+
+  return true;
+}
+
+
+/* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND,
+   and the FLUSH statement.  */
+
+match
+gfc_match_endfile (void)
+{
+  return match_filepos (ST_END_FILE, EXEC_ENDFILE);
+}
+
+match
+gfc_match_backspace (void)
+{
+  return match_filepos (ST_BACKSPACE, EXEC_BACKSPACE);
+}
+
+match
+gfc_match_rewind (void)
+{
+  return match_filepos (ST_REWIND, EXEC_REWIND);
+}
+
+match
+gfc_match_flush (void)
+{
+  if (!gfc_notify_std (GFC_STD_F2003, "FLUSH statement at %C"))
+    return MATCH_ERROR;
+
+  return match_filepos (ST_FLUSH, EXEC_FLUSH);
+}
+
+/******************** Data Transfer Statements *********************/
+
+/* Return a default unit number.  */
+
+static gfc_expr *
+default_unit (io_kind k)
+{
+  int unit;
+
+  if (k == M_READ)
+    unit = 5;
+  else
+    unit = 6;
+
+  return gfc_get_int_expr (gfc_default_integer_kind, NULL, unit);
+}
+
+
+/* Match a unit specification for a data transfer statement.  */
+
+static match
+match_dt_unit (io_kind k, gfc_dt *dt)
+{
+  gfc_expr *e;
+
+  if (gfc_match_char ('*') == MATCH_YES)
+    {
+      if (dt->io_unit != NULL)
+	goto conflict;
+
+      dt->io_unit = default_unit (k);
+      return MATCH_YES;
+    }
+
+  if (gfc_match_expr (&e) == MATCH_YES)
+    {
+      if (dt->io_unit != NULL)
+	{
+	  gfc_free_expr (e);
+	  goto conflict;
+	}
+
+      dt->io_unit = e;
+      return MATCH_YES;
+    }
+
+  return MATCH_NO;
+
+conflict:
+  gfc_error ("Duplicate UNIT specification at %C");
+  return MATCH_ERROR;
+}
+
+
+/* Match a format specification.  */
+
+static match
+match_dt_format (gfc_dt *dt)
+{
+  locus where;
+  gfc_expr *e;
+  gfc_st_label *label;
+  match m;
+
+  where = gfc_current_locus;
+
+  if (gfc_match_char ('*') == MATCH_YES)
+    {
+      if (dt->format_expr != NULL || dt->format_label != NULL)
+	goto conflict;
+
+      dt->format_label = &format_asterisk;
+      return MATCH_YES;
+    }
+
+  if ((m = gfc_match_st_label (&label)) == MATCH_YES)
+    {
+      char c;
+
+      /* Need to check if the format label is actually either an operand
+	 to a user-defined operator or is a kind type parameter.  That is,
+	 print 2.ip.8      ! .ip. is a user-defined operator return CHARACTER.
+	 print 1_'(I0)', i ! 1_'(I0)' is a default character string.  */
+
+      gfc_gobble_whitespace ();
+      c = gfc_peek_ascii_char ();
+      if (c == '.' || c == '_')
+	gfc_current_locus = where;
+      else
+	{
+	  if (dt->format_expr != NULL || dt->format_label != NULL)
+	    {
+	      gfc_free_st_label (label);
+	      goto conflict;
+	    }
+
+	  if (!gfc_reference_st_label (label, ST_LABEL_FORMAT))
+	    return MATCH_ERROR;
+
+	  dt->format_label = label;
+	  return MATCH_YES;
+	}
+    }
+  else if (m == MATCH_ERROR)
+    /* The label was zero or too large.  Emit the correct diagnosis.  */
+    return MATCH_ERROR;
+
+  if (gfc_match_expr (&e) == MATCH_YES)
+    {
+      if (dt->format_expr != NULL || dt->format_label != NULL)
+	{
+	  gfc_free_expr (e);
+	  goto conflict;
+	}
+      dt->format_expr = e;
+      return MATCH_YES;
+    }
+
+  gfc_current_locus = where;	/* The only case where we have to restore */
+
+  return MATCH_NO;
+
+conflict:
+  gfc_error ("Duplicate format specification at %C");
+  return MATCH_ERROR;
+}
+
+
+/* Traverse a namelist that is part of a READ statement to make sure
+   that none of the variables in the namelist are INTENT(IN).  Returns
+   nonzero if we find such a variable.  */
+
+static int
+check_namelist (gfc_symbol *sym)
+{
+  gfc_namelist *p;
+
+  for (p = sym->namelist; p; p = p->next)
+    if (p->sym->attr.intent == INTENT_IN)
+      {
+	gfc_error ("Symbol '%s' in namelist '%s' is INTENT(IN) at %C",
+		   p->sym->name, sym->name);
+	return 1;
+      }
+
+  return 0;
+}
+
+
+/* Match a single data transfer element.  */
+
+static match
+match_dt_element (io_kind k, gfc_dt *dt)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_symbol *sym;
+  match m;
+
+  if (gfc_match (" unit =") == MATCH_YES)
+    {
+      m = match_dt_unit (k, dt);
+      if (m != MATCH_NO)
+	return m;
+    }
+
+  if (gfc_match (" fmt =") == MATCH_YES)
+    {
+      m = match_dt_format (dt);
+      if (m != MATCH_NO)
+	return m;
+    }
+
+  if (gfc_match (" nml = %n", name) == MATCH_YES)
+    {
+      if (dt->namelist != NULL)
+	{
+	  gfc_error ("Duplicate NML specification at %C");
+	  return MATCH_ERROR;
+	}
+
+      if (gfc_find_symbol (name, NULL, 1, &sym))
+	return MATCH_ERROR;
+
+      if (sym == NULL || sym->attr.flavor != FL_NAMELIST)
+	{
+	  gfc_error ("Symbol '%s' at %C must be a NAMELIST group name",
+		     sym != NULL ? sym->name : name);
+	  return MATCH_ERROR;
+	}
+
+      dt->namelist = sym;
+      if (k == M_READ && check_namelist (sym))
+	return MATCH_ERROR;
+
+      return MATCH_YES;
+    }
+
+  m = match_etag (&tag_e_async, &dt->asynchronous);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_e_blank, &dt->blank);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_e_delim, &dt->delim);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_e_pad, &dt->pad);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_e_sign, &dt->sign);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_e_round, &dt->round);
+  if (m != MATCH_NO)
+    return m;
+  m = match_out_tag (&tag_id, &dt->id);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_e_decimal, &dt->decimal);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_rec, &dt->rec);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_spos, &dt->pos);
+  if (m != MATCH_NO)
+    return m;
+  m = match_out_tag (&tag_iomsg, &dt->iomsg);
+  if (m != MATCH_NO)
+    return m;
+  m = match_out_tag (&tag_iostat, &dt->iostat);
+  if (m != MATCH_NO)
+    return m;
+  m = match_ltag (&tag_err, &dt->err);
+  if (m == MATCH_YES)
+    dt->err_where = gfc_current_locus;
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_advance, &dt->advance);
+  if (m != MATCH_NO)
+    return m;
+  m = match_out_tag (&tag_size, &dt->size);
+  if (m != MATCH_NO)
+    return m;
+
+  m = match_ltag (&tag_end, &dt->end);
+  if (m == MATCH_YES)
+    {
+      if (k == M_WRITE)
+       {
+	 gfc_error ("END tag at %C not allowed in output statement");
+	 return MATCH_ERROR;
+       }
+      dt->end_where = gfc_current_locus;
+    }
+  if (m != MATCH_NO)
+    return m;
+
+  m = match_ltag (&tag_eor, &dt->eor);
+  if (m == MATCH_YES)
+    dt->eor_where = gfc_current_locus;
+  if (m != MATCH_NO)
+    return m;
+
+  return MATCH_NO;
+}
+
+
+/* Free a data transfer structure and everything below it.  */
+
+void
+gfc_free_dt (gfc_dt *dt)
+{
+  if (dt == NULL)
+    return;
+
+  gfc_free_expr (dt->io_unit);
+  gfc_free_expr (dt->format_expr);
+  gfc_free_expr (dt->rec);
+  gfc_free_expr (dt->advance);
+  gfc_free_expr (dt->iomsg);
+  gfc_free_expr (dt->iostat);
+  gfc_free_expr (dt->size);
+  gfc_free_expr (dt->pad);
+  gfc_free_expr (dt->delim);
+  gfc_free_expr (dt->sign);
+  gfc_free_expr (dt->round);
+  gfc_free_expr (dt->blank);
+  gfc_free_expr (dt->decimal);
+  gfc_free_expr (dt->pos);
+  gfc_free_expr (dt->dt_io_kind);
+  /* dt->extra_comma is a link to dt_io_kind if it is set.  */
+  free (dt);
+}
+
+
+/* Resolve everything in a gfc_dt structure.  */
+
+bool
+gfc_resolve_dt (gfc_dt *dt, locus *loc)
+{
+  gfc_expr *e;
+  io_kind k;
+
+  /* This is set in any case.  */
+  gcc_assert (dt->dt_io_kind);
+  k = dt->dt_io_kind->value.iokind;
+
+  RESOLVE_TAG (&tag_format, dt->format_expr);
+  RESOLVE_TAG (&tag_rec, dt->rec);
+  RESOLVE_TAG (&tag_spos, dt->pos);
+  RESOLVE_TAG (&tag_advance, dt->advance);
+  RESOLVE_TAG (&tag_id, dt->id);
+  RESOLVE_TAG (&tag_iomsg, dt->iomsg);
+  RESOLVE_TAG (&tag_iostat, dt->iostat);
+  RESOLVE_TAG (&tag_size, dt->size);
+  RESOLVE_TAG (&tag_e_pad, dt->pad);
+  RESOLVE_TAG (&tag_e_delim, dt->delim);
+  RESOLVE_TAG (&tag_e_sign, dt->sign);
+  RESOLVE_TAG (&tag_e_round, dt->round);
+  RESOLVE_TAG (&tag_e_blank, dt->blank);
+  RESOLVE_TAG (&tag_e_decimal, dt->decimal);
+  RESOLVE_TAG (&tag_e_async, dt->asynchronous);
+
+  e = dt->io_unit;
+  if (e == NULL)
+    {
+      gfc_error ("UNIT not specified at %L", loc);
+      return false;
+    }
+
+  if (gfc_resolve_expr (e)
+      && (e->ts.type != BT_INTEGER
+	  && (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_VARIABLE)))
+    {
+      /* If there is no extra comma signifying the "format" form of the IO
+	 statement, then this must be an error.  */
+      if (!dt->extra_comma)
+	{
+	  gfc_error ("UNIT specification at %L must be an INTEGER expression "
+		     "or a CHARACTER variable", &e->where);
+	  return false;
+	}
+      else
+	{
+	  /* At this point, we have an extra comma.  If io_unit has arrived as
+	     type character, we assume its really the "format" form of the I/O
+	     statement.  We set the io_unit to the default unit and format to
+	     the character expression.  See F95 Standard section 9.4.  */
+	  if (e->ts.type == BT_CHARACTER && (k == M_READ || k == M_PRINT))
+	    {
+	      dt->format_expr = dt->io_unit;
+	      dt->io_unit = default_unit (k);
+
+	      /* Nullify this pointer now so that a warning/error is not
+		 triggered below for the "Extension".  */
+	      dt->extra_comma = NULL;
+	    }
+
+	  if (k == M_WRITE)
+	    {
+	      gfc_error ("Invalid form of WRITE statement at %L, UNIT required",
+			 &dt->extra_comma->where);
+	      return false;
+	    }
+	}
+    }
+
+  if (e->ts.type == BT_CHARACTER)
+    {
+      if (gfc_has_vector_index (e))
+	{
+	  gfc_error ("Internal unit with vector subscript at %L", &e->where);
+	  return false;
+	}
+
+      /* If we are writing, make sure the internal unit can be changed.  */
+      gcc_assert (k != M_PRINT);
+      if (k == M_WRITE
+	  && !gfc_check_vardef_context (e, false, false, false, 
+					_("internal unit in WRITE")))
+	return false;
+    }
+
+  if (e->rank && e->ts.type != BT_CHARACTER)
+    {
+      gfc_error ("External IO UNIT cannot be an array at %L", &e->where);
+      return false;
+    }
+
+  if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_INTEGER
+      && mpz_sgn (e->value.integer) < 0)
+    {
+      gfc_error ("UNIT number in statement at %L must be non-negative",
+		 &e->where);
+      return false;
+    }
+
+  /* If we are reading and have a namelist, check that all namelist symbols
+     can appear in a variable definition context.  */
+  if (k == M_READ && dt->namelist)
+    {
+      gfc_namelist* n;
+      for (n = dt->namelist->namelist; n; n = n->next)
+	{
+	  gfc_expr* e;
+	  bool t;
+
+	  e = gfc_get_variable_expr (gfc_find_sym_in_symtree (n->sym));
+	  t = gfc_check_vardef_context (e, false, false, false, NULL);
+	  gfc_free_expr (e);
+
+	  if (!t)
+	    {
+	      gfc_error ("NAMELIST '%s' in READ statement at %L contains"
+			 " the symbol '%s' which may not appear in a"
+			 " variable definition context",
+			 dt->namelist->name, loc, n->sym->name);
+	      return false;
+	    }
+	}
+    }
+
+  if (dt->extra_comma
+      && !gfc_notify_std (GFC_STD_GNU, "Comma before i/o item list at %L", 
+			  &dt->extra_comma->where))
+    return false;
+
+  if (dt->err)
+    {
+      if (!gfc_reference_st_label (dt->err, ST_LABEL_TARGET))
+	return false;
+      if (dt->err->defined == ST_LABEL_UNKNOWN)
+	{
+	  gfc_error ("ERR tag label %d at %L not defined",
+		      dt->err->value, &dt->err_where);
+	  return false;
+	}
+    }
+
+  if (dt->end)
+    {
+      if (!gfc_reference_st_label (dt->end, ST_LABEL_TARGET))
+	return false;
+      if (dt->end->defined == ST_LABEL_UNKNOWN)
+	{
+	  gfc_error ("END tag label %d at %L not defined",
+		      dt->end->value, &dt->end_where);
+	  return false;
+	}
+    }
+
+  if (dt->eor)
+    {
+      if (!gfc_reference_st_label (dt->eor, ST_LABEL_TARGET))
+	return false;
+      if (dt->eor->defined == ST_LABEL_UNKNOWN)
+	{
+	  gfc_error ("EOR tag label %d at %L not defined",
+		      dt->eor->value, &dt->eor_where);
+	  return false;
+	}
+    }
+
+  /* Check the format label actually exists.  */
+  if (dt->format_label && dt->format_label != &format_asterisk
+      && dt->format_label->defined == ST_LABEL_UNKNOWN)
+    {
+      gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value,
+		 &dt->format_label->where);
+      return false;
+    }
+
+  return true;
+}
+
+
+/* Given an io_kind, return its name.  */
+
+static const char *
+io_kind_name (io_kind k)
+{
+  const char *name;
+
+  switch (k)
+    {
+    case M_READ:
+      name = "READ";
+      break;
+    case M_WRITE:
+      name = "WRITE";
+      break;
+    case M_PRINT:
+      name = "PRINT";
+      break;
+    case M_INQUIRE:
+      name = "INQUIRE";
+      break;
+    default:
+      gfc_internal_error ("io_kind_name(): bad I/O-kind");
+    }
+
+  return name;
+}
+
+
+/* Match an IO iteration statement of the form:
+
+   ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] )
+
+   which is equivalent to a single IO element.  This function is
+   mutually recursive with match_io_element().  */
+
+static match match_io_element (io_kind, gfc_code **);
+
+static match
+match_io_iterator (io_kind k, gfc_code **result)
+{
+  gfc_code *head, *tail, *new_code;
+  gfc_iterator *iter;
+  locus old_loc;
+  match m;
+  int n;
+
+  iter = NULL;
+  head = NULL;
+  old_loc = gfc_current_locus;
+
+  if (gfc_match_char ('(') != MATCH_YES)
+    return MATCH_NO;
+
+  m = match_io_element (k, &head);
+  tail = head;
+
+  if (m != MATCH_YES || gfc_match_char (',') != MATCH_YES)
+    {
+      m = MATCH_NO;
+      goto cleanup;
+    }
+
+  /* Can't be anything but an IO iterator.  Build a list.  */
+  iter = gfc_get_iterator ();
+
+  for (n = 1;; n++)
+    {
+      m = gfc_match_iterator (iter, 0);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_YES)
+	{
+	  gfc_check_do_variable (iter->var->symtree);
+	  break;
+	}
+
+      m = match_io_element (k, &new_code);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_NO)
+	{
+	  if (n > 2)
+	    goto syntax;
+	  goto cleanup;
+	}
+
+      tail = gfc_append_code (tail, new_code);
+
+      if (gfc_match_char (',') != MATCH_YES)
+	{
+	  if (n > 2)
+	    goto syntax;
+	  m = MATCH_NO;
+	  goto cleanup;
+	}
+    }
+
+  if (gfc_match_char (')') != MATCH_YES)
+    goto syntax;
+
+  new_code = gfc_get_code (EXEC_DO);
+  new_code->ext.iterator = iter;
+
+  new_code->block = gfc_get_code (EXEC_DO);
+  new_code->block->next = head;
+
+  *result = new_code;
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in I/O iterator at %C");
+  m = MATCH_ERROR;
+
+cleanup:
+  gfc_free_iterator (iter, 1);
+  gfc_free_statements (head);
+  gfc_current_locus = old_loc;
+  return m;
+}
+
+
+/* Match a single element of an IO list, which is either a single
+   expression or an IO Iterator.  */
+
+static match
+match_io_element (io_kind k, gfc_code **cpp)
+{
+  gfc_expr *expr;
+  gfc_code *cp;
+  match m;
+
+  expr = NULL;
+
+  m = match_io_iterator (k, cpp);
+  if (m == MATCH_YES)
+    return MATCH_YES;
+
+  if (k == M_READ)
+    {
+      m = gfc_match_variable (&expr, 0);
+      if (m == MATCH_NO)
+	gfc_error ("Expected variable in READ statement at %C");
+    }
+  else
+    {
+      m = gfc_match_expr (&expr);
+      if (m == MATCH_NO)
+	gfc_error ("Expected expression in %s statement at %C",
+		   io_kind_name (k));
+    }
+
+  if (m == MATCH_YES && k == M_READ && gfc_check_do_variable (expr->symtree))
+    m = MATCH_ERROR;
+
+  if (m != MATCH_YES)
+    {
+      gfc_free_expr (expr);
+      return MATCH_ERROR;
+    }
+
+  cp = gfc_get_code (EXEC_TRANSFER);
+  cp->expr1 = expr;
+  if (k != M_INQUIRE)
+    cp->ext.dt = current_dt;
+
+  *cpp = cp;
+  return MATCH_YES;
+}
+
+
+/* Match an I/O list, building gfc_code structures as we go.  */
+
+static match
+match_io_list (io_kind k, gfc_code **head_p)
+{
+  gfc_code *head, *tail, *new_code;
+  match m;
+
+  *head_p = head = tail = NULL;
+  if (gfc_match_eos () == MATCH_YES)
+    return MATCH_YES;
+
+  for (;;)
+    {
+      m = match_io_element (k, &new_code);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_NO)
+	goto syntax;
+
+      tail = gfc_append_code (tail, new_code);
+      if (head == NULL)
+	head = new_code;
+
+      if (gfc_match_eos () == MATCH_YES)
+	break;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+    }
+
+  *head_p = head;
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
+
+cleanup:
+  gfc_free_statements (head);
+  return MATCH_ERROR;
+}
+
+
+/* Attach the data transfer end node.  */
+
+static void
+terminate_io (gfc_code *io_code)
+{
+  gfc_code *c;
+
+  if (io_code == NULL)
+    io_code = new_st.block;
+
+  c = gfc_get_code (EXEC_DT_END);
+
+  /* Point to structure that is already there */
+  c->ext.dt = new_st.ext.dt;
+  gfc_append_code (io_code, c);
+}
+
+
+/* Check the constraints for a data transfer statement.  The majority of the
+   constraints appearing in 9.4 of the standard appear here.  Some are handled
+   in resolve_tag and others in gfc_resolve_dt.  */
+
+static match
+check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code,
+		      locus *spec_end)
+{
+#define io_constraint(condition,msg,arg)\
+if (condition) \
+  {\
+    gfc_error(msg,arg);\
+    m = MATCH_ERROR;\
+  }
+
+  match m;
+  gfc_expr *expr;
+  gfc_symbol *sym = NULL;
+  bool warn, unformatted;
+
+  warn = (dt->err || dt->iostat) ? true : false;
+  unformatted = dt->format_expr == NULL && dt->format_label == NULL
+		&& dt->namelist == NULL;
+
+  m = MATCH_YES;
+
+  expr = dt->io_unit;
+  if (expr && expr->expr_type == EXPR_VARIABLE
+      && expr->ts.type == BT_CHARACTER)
+    {
+      sym = expr->symtree->n.sym;
+
+      io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN,
+		     "Internal file at %L must not be INTENT(IN)",
+		     &expr->where);
+
+      io_constraint (gfc_has_vector_index (dt->io_unit),
+		     "Internal file incompatible with vector subscript at %L",
+		     &expr->where);
+
+      io_constraint (dt->rec != NULL,
+		     "REC tag at %L is incompatible with internal file",
+		     &dt->rec->where);
+    
+      io_constraint (dt->pos != NULL,
+		     "POS tag at %L is incompatible with internal file",
+		     &dt->pos->where);
+
+      io_constraint (unformatted,
+		     "Unformatted I/O not allowed with internal unit at %L",
+		     &dt->io_unit->where);
+
+      io_constraint (dt->asynchronous != NULL,
+		     "ASYNCHRONOUS tag at %L not allowed with internal file",
+		     &dt->asynchronous->where);
+
+      if (dt->namelist != NULL)
+	{
+	  if (!gfc_notify_std (GFC_STD_F2003, "Internal file at %L with "
+			       "namelist", &expr->where))
+	    m = MATCH_ERROR;
+	}
+
+      io_constraint (dt->advance != NULL,
+		     "ADVANCE tag at %L is incompatible with internal file",
+		     &dt->advance->where);
+    }
+
+  if (expr && expr->ts.type != BT_CHARACTER)
+    {
+
+      io_constraint (gfc_pure (NULL) && (k == M_READ || k == M_WRITE),
+		     "IO UNIT in %s statement at %C must be "
+		     "an internal file in a PURE procedure",
+		     io_kind_name (k));
+
+      if (k == M_READ || k == M_WRITE)
+	gfc_unset_implicit_pure (NULL);
+    }
+
+  if (k != M_READ)
+    {
+      io_constraint (dt->end, "END tag not allowed with output at %L",
+		     &dt->end_where);
+
+      io_constraint (dt->eor, "EOR tag not allowed with output at %L",
+		     &dt->eor_where);
+
+      io_constraint (dt->blank, "BLANK= specifier not allowed with output at %L",
+		     &dt->blank->where);
+
+      io_constraint (dt->pad, "PAD= specifier not allowed with output at %L",
+		     &dt->pad->where);
+
+      io_constraint (dt->size, "SIZE= specifier not allowed with output at %L",
+		     &dt->size->where);
+    }
+  else
+    {
+      io_constraint (dt->size && dt->advance == NULL,
+		     "SIZE tag at %L requires an ADVANCE tag",
+		     &dt->size->where);
+
+      io_constraint (dt->eor && dt->advance == NULL,
+		     "EOR tag at %L requires an ADVANCE tag",
+		     &dt->eor_where);
+    }
+
+  if (dt->asynchronous) 
+    {
+      static const char * asynchronous[] = { "YES", "NO", NULL };
+
+      if (!gfc_reduce_init_expr (dt->asynchronous))
+	{
+	  gfc_error ("ASYNCHRONOUS= specifier at %L must be an initialization "
+		     "expression", &dt->asynchronous->where);
+	  return MATCH_ERROR;
+	}
+
+      if (!compare_to_allowed_values
+		("ASYNCHRONOUS", asynchronous, NULL, NULL,
+		 dt->asynchronous->value.character.string,
+		 io_kind_name (k), warn))
+	return MATCH_ERROR;
+    }
+
+  if (dt->id)
+    {
+      bool not_yes
+	= !dt->asynchronous
+	  || gfc_wide_strlen (dt->asynchronous->value.character.string) != 3
+	  || gfc_wide_strncasecmp (dt->asynchronous->value.character.string,
+				   "yes", 3) != 0;
+      io_constraint (not_yes,
+		     "ID= specifier at %L must be with ASYNCHRONOUS='yes' "
+		     "specifier", &dt->id->where);
+    }
+
+  if (dt->decimal)
+    {
+      if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %C "
+			   "not allowed in Fortran 95"))
+	return MATCH_ERROR;
+
+      if (dt->decimal->expr_type == EXPR_CONSTANT)
+	{
+	  static const char * decimal[] = { "COMMA", "POINT", NULL };
+
+	  if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
+					  dt->decimal->value.character.string,
+					  io_kind_name (k), warn))
+	    return MATCH_ERROR;
+
+	  io_constraint (unformatted,
+			 "the DECIMAL= specifier at %L must be with an "
+			 "explicit format expression", &dt->decimal->where);
+	}
+    }
+  
+  if (dt->blank)
+    {
+      if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %C "
+			   "not allowed in Fortran 95"))
+	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))
+	    return MATCH_ERROR;
+
+	  io_constraint (unformatted,
+			 "the BLANK= specifier at %L must be with an "
+			 "explicit format expression", &dt->blank->where);
+	}
+    }
+
+  if (dt->pad)
+    {
+      if (!gfc_notify_std (GFC_STD_F2003, "PAD= at %C "
+			   "not allowed in Fortran 95"))
+	return MATCH_ERROR;
+
+      if (dt->pad->expr_type == EXPR_CONSTANT)
+	{
+	  static const char * pad[] = { "YES", "NO", NULL };
+
+	  if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
+					  dt->pad->value.character.string,
+					  io_kind_name (k), warn))
+	    return MATCH_ERROR;
+
+	  io_constraint (unformatted,
+			 "the PAD= specifier at %L must be with an "
+			 "explicit format expression", &dt->pad->where);
+	}
+    }
+
+  if (dt->round)
+    {
+      if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %C "
+			   "not allowed in Fortran 95"))
+	return MATCH_ERROR;
+
+      if (dt->round->expr_type == EXPR_CONSTANT)
+	{
+	  static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
+					  "COMPATIBLE", "PROCESSOR_DEFINED",
+					  NULL };
+
+	  if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
+					  dt->round->value.character.string,
+					  io_kind_name (k), warn))
+	    return MATCH_ERROR;
+	}
+    }
+  
+  if (dt->sign)
+    {
+      /* When implemented, change the following to use gfc_notify_std F2003.
+      if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %C "
+	  "not allowed in Fortran 95") == false)
+	return MATCH_ERROR;  */
+      if (dt->sign->expr_type == EXPR_CONSTANT)
+	{
+	  static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
+					 NULL };
+
+	  if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
+				      dt->sign->value.character.string,
+				      io_kind_name (k), warn))
+	    return MATCH_ERROR;
+
+	  io_constraint (unformatted,
+			 "SIGN= specifier at %L must be with an "
+			 "explicit format expression", &dt->sign->where);
+
+	  io_constraint (k == M_READ,
+			 "SIGN= specifier at %L not allowed in a "
+			 "READ statement", &dt->sign->where);
+	}
+    }
+
+  if (dt->delim)
+    {
+      if (!gfc_notify_std (GFC_STD_F2003, "DELIM= at %C "
+			   "not allowed in Fortran 95"))
+	return MATCH_ERROR;
+
+      if (dt->delim->expr_type == EXPR_CONSTANT)
+	{
+	  static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
+
+	  if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
+					  dt->delim->value.character.string,
+					  io_kind_name (k), warn))
+	    return MATCH_ERROR;
+
+	  io_constraint (k == M_READ,
+			 "DELIM= specifier at %L not allowed in a "
+			 "READ statement", &dt->delim->where);
+      
+	  io_constraint (dt->format_label != &format_asterisk
+			 && dt->namelist == NULL,
+			 "DELIM= specifier at %L must have FMT=*",
+			 &dt->delim->where);
+
+	  io_constraint (unformatted && dt->namelist == NULL,
+			 "DELIM= specifier at %L must be with FMT=* or "
+			 "NML= specifier ", &dt->delim->where);
+	}
+    }
+  
+  if (dt->namelist)
+    {
+      io_constraint (io_code && dt->namelist,
+		     "NAMELIST cannot be followed by IO-list at %L",
+		     &io_code->loc);
+
+      io_constraint (dt->format_expr,
+		     "IO spec-list cannot contain both NAMELIST group name "
+		     "and format specification at %L",
+		     &dt->format_expr->where);
+
+      io_constraint (dt->format_label,
+		     "IO spec-list cannot contain both NAMELIST group name "
+		     "and format label at %L", spec_end);
+
+      io_constraint (dt->rec,
+		     "NAMELIST IO is not allowed with a REC= specifier "
+		     "at %L", &dt->rec->where);
+
+      io_constraint (dt->advance,
+		     "NAMELIST IO is not allowed with a ADVANCE= specifier "
+		     "at %L", &dt->advance->where);
+    }
+
+  if (dt->rec)
+    {
+      io_constraint (dt->end,
+		     "An END tag is not allowed with a "
+		     "REC= specifier at %L", &dt->end_where);
+
+      io_constraint (dt->format_label == &format_asterisk,
+		     "FMT=* is not allowed with a REC= specifier "
+		     "at %L", spec_end);
+
+      io_constraint (dt->pos,
+		     "POS= is not allowed with REC= specifier "
+		     "at %L", &dt->pos->where);
+    }
+
+  if (dt->advance)
+    {
+      int not_yes, not_no;
+      expr = dt->advance;
+
+      io_constraint (dt->format_label == &format_asterisk,
+		     "List directed format(*) is not allowed with a "
+		     "ADVANCE= specifier at %L.", &expr->where);
+
+      io_constraint (unformatted,
+		     "the ADVANCE= specifier at %L must appear with an "
+		     "explicit format expression", &expr->where);
+
+      if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER)
+	{
+	  const gfc_char_t *advance = expr->value.character.string;
+	  not_no = gfc_wide_strlen (advance) != 2
+		   || gfc_wide_strncasecmp (advance, "no", 2) != 0;
+	  not_yes = gfc_wide_strlen (advance) != 3
+		    || gfc_wide_strncasecmp (advance, "yes", 3) != 0;
+	}
+      else
+	{
+	  not_no = 0;
+	  not_yes = 0;
+	}
+
+      io_constraint (not_no && not_yes,
+		     "ADVANCE= specifier at %L must have value = "
+		     "YES or NO.", &expr->where);
+
+      io_constraint (dt->size && not_no && k == M_READ,
+		     "SIZE tag at %L requires an ADVANCE = 'NO'",
+		     &dt->size->where);
+
+      io_constraint (dt->eor && not_no && k == M_READ,
+		     "EOR tag at %L requires an ADVANCE = 'NO'",
+		     &dt->eor_where);      
+    }
+
+  expr = dt->format_expr;
+  if (!gfc_simplify_expr (expr, 0)
+      || !check_format_string (expr, k == M_READ))
+    return MATCH_ERROR;
+
+  return m;
+}
+#undef io_constraint
+
+
+/* Match a READ, WRITE or PRINT statement.  */
+
+static match
+match_io (io_kind k)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_code *io_code;
+  gfc_symbol *sym;
+  int comma_flag;
+  locus where;
+  locus spec_end;
+  gfc_dt *dt;
+  match m;
+
+  where = gfc_current_locus;
+  comma_flag = 0;
+  current_dt = dt = XCNEW (gfc_dt);
+  m = gfc_match_char ('(');
+  if (m == MATCH_NO)
+    {
+      where = gfc_current_locus;
+      if (k == M_WRITE)
+	goto syntax;
+      else if (k == M_PRINT)
+	{
+	  /* Treat the non-standard case of PRINT namelist.  */
+	  if ((gfc_current_form == FORM_FIXED || gfc_peek_ascii_char () == ' ')
+	      && gfc_match_name (name) == MATCH_YES)
+	    {
+	      gfc_find_symbol (name, NULL, 1, &sym);
+	      if (sym && sym->attr.flavor == FL_NAMELIST)
+		{
+		  if (!gfc_notify_std (GFC_STD_GNU, "PRINT namelist at "
+				       "%C is an extension"))
+		    {
+		      m = MATCH_ERROR;
+		      goto cleanup;
+		    }
+
+		  dt->io_unit = default_unit (k);
+		  dt->namelist = sym;
+		  goto get_io_list;
+		}
+	      else
+		gfc_current_locus = where;
+	    }
+	}
+
+      if (gfc_current_form == FORM_FREE)
+	{
+	  char c = gfc_peek_ascii_char ();
+	  if (c != ' ' && c != '*' && c != '\'' && c != '"')
+	    {
+	      m = MATCH_NO;
+	      goto cleanup;
+	    }
+	}
+
+      m = match_dt_format (dt);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_NO)
+	goto syntax;
+
+      comma_flag = 1;
+      dt->io_unit = default_unit (k);
+      goto get_io_list;
+    }
+  else
+    {
+      /* Before issuing an error for a malformed 'print (1,*)' type of
+	 error, check for a default-char-expr of the form ('(I0)').  */
+      if (k == M_PRINT && m == MATCH_YES)
+	{
+	  /* Reset current locus to get the initial '(' in an expression.  */
+	  gfc_current_locus = where;
+	  dt->format_expr = NULL;
+	  m = match_dt_format (dt);
+
+	  if (m == MATCH_ERROR)
+	    goto cleanup;
+	  if (m == MATCH_NO || dt->format_expr == NULL)
+	    goto syntax;
+
+	  comma_flag = 1;
+	  dt->io_unit = default_unit (k);
+	  goto get_io_list;
+	}
+    }
+
+  /* Match a control list */
+  if (match_dt_element (k, dt) == MATCH_YES)
+    goto next;
+  if (match_dt_unit (k, dt) != MATCH_YES)
+    goto loop;
+
+  if (gfc_match_char (')') == MATCH_YES)
+    goto get_io_list;
+  if (gfc_match_char (',') != MATCH_YES)
+    goto syntax;
+
+  m = match_dt_element (k, dt);
+  if (m == MATCH_YES)
+    goto next;
+  if (m == MATCH_ERROR)
+    goto cleanup;
+
+  m = match_dt_format (dt);
+  if (m == MATCH_YES)
+    goto next;
+  if (m == MATCH_ERROR)
+    goto cleanup;
+
+  where = gfc_current_locus;
+
+  m = gfc_match_name (name);
+  if (m == MATCH_YES)
+    {
+      gfc_find_symbol (name, NULL, 1, &sym);
+      if (sym && sym->attr.flavor == FL_NAMELIST)
+	{
+	  dt->namelist = sym;
+	  if (k == M_READ && check_namelist (sym))
+	    {
+	      m = MATCH_ERROR;
+	      goto cleanup;
+	    }
+	  goto next;
+	}
+    }
+
+  gfc_current_locus = where;
+
+  goto loop;			/* No matches, try regular elements */
+
+next:
+  if (gfc_match_char (')') == MATCH_YES)
+    goto get_io_list;
+  if (gfc_match_char (',') != MATCH_YES)
+    goto syntax;
+
+loop:
+  for (;;)
+    {
+      m = match_dt_element (k, dt);
+      if (m == MATCH_NO)
+	goto syntax;
+      if (m == MATCH_ERROR)
+	goto cleanup;
+
+      if (gfc_match_char (')') == MATCH_YES)
+	break;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+    }
+
+get_io_list:
+
+  /* Used in check_io_constraints, where no locus is available.  */
+  spec_end = gfc_current_locus;
+
+  /* Save the IO kind for later use.  */
+  dt->dt_io_kind = gfc_get_iokind_expr (&gfc_current_locus, k);
+
+  /* Optional leading comma (non-standard).  We use a gfc_expr structure here
+     to save the locus.  This is used later when resolving transfer statements
+     that might have a format expression without unit number.  */
+  if (!comma_flag && gfc_match_char (',') == MATCH_YES)
+    dt->extra_comma = dt->dt_io_kind;
+
+  io_code = NULL;
+  if (gfc_match_eos () != MATCH_YES)
+    {
+      if (comma_flag && gfc_match_char (',') != MATCH_YES)
+	{
+	  gfc_error ("Expected comma in I/O list at %C");
+	  m = MATCH_ERROR;
+	  goto cleanup;
+	}
+
+      m = match_io_list (k, &io_code);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_NO)
+	goto syntax;
+    }
+
+  /* A full IO statement has been matched.  Check the constraints.  spec_end is
+     supplied for cases where no locus is supplied.  */
+  m = check_io_constraints (k, dt, io_code, &spec_end);
+
+  if (m == MATCH_ERROR)
+    goto cleanup;
+
+  new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE;
+  new_st.ext.dt = dt;
+  new_st.block = gfc_get_code (new_st.op);
+  new_st.block->next = io_code;
+
+  terminate_io (io_code);
+
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
+  m = MATCH_ERROR;
+
+cleanup:
+  gfc_free_dt (dt);
+  return m;
+}
+
+
+match
+gfc_match_read (void)
+{
+  return match_io (M_READ);
+}
+
+
+match
+gfc_match_write (void)
+{
+  return match_io (M_WRITE);
+}
+
+
+match
+gfc_match_print (void)
+{
+  match m;
+
+  m = match_io (M_PRINT);
+  if (m != MATCH_YES)
+    return m;
+
+  if (gfc_pure (NULL))
+    {
+      gfc_error ("PRINT statement at %C not allowed within PURE procedure");
+      return MATCH_ERROR;
+    }
+
+  gfc_unset_implicit_pure (NULL);
+
+  return MATCH_YES;
+}
+
+
+/* Free a gfc_inquire structure.  */
+
+void
+gfc_free_inquire (gfc_inquire *inquire)
+{
+
+  if (inquire == NULL)
+    return;
+
+  gfc_free_expr (inquire->unit);
+  gfc_free_expr (inquire->file);
+  gfc_free_expr (inquire->iomsg);
+  gfc_free_expr (inquire->iostat);
+  gfc_free_expr (inquire->exist);
+  gfc_free_expr (inquire->opened);
+  gfc_free_expr (inquire->number);
+  gfc_free_expr (inquire->named);
+  gfc_free_expr (inquire->name);
+  gfc_free_expr (inquire->access);
+  gfc_free_expr (inquire->sequential);
+  gfc_free_expr (inquire->direct);
+  gfc_free_expr (inquire->form);
+  gfc_free_expr (inquire->formatted);
+  gfc_free_expr (inquire->unformatted);
+  gfc_free_expr (inquire->recl);
+  gfc_free_expr (inquire->nextrec);
+  gfc_free_expr (inquire->blank);
+  gfc_free_expr (inquire->position);
+  gfc_free_expr (inquire->action);
+  gfc_free_expr (inquire->read);
+  gfc_free_expr (inquire->write);
+  gfc_free_expr (inquire->readwrite);
+  gfc_free_expr (inquire->delim);
+  gfc_free_expr (inquire->encoding);
+  gfc_free_expr (inquire->pad);
+  gfc_free_expr (inquire->iolength);
+  gfc_free_expr (inquire->convert);
+  gfc_free_expr (inquire->strm_pos);
+  gfc_free_expr (inquire->asynchronous);
+  gfc_free_expr (inquire->decimal);
+  gfc_free_expr (inquire->pending);
+  gfc_free_expr (inquire->id);
+  gfc_free_expr (inquire->sign);
+  gfc_free_expr (inquire->size);
+  gfc_free_expr (inquire->round);
+  free (inquire);
+}
+
+
+/* Match an element of an INQUIRE statement.  */
+
+#define RETM   if (m != MATCH_NO) return m;
+
+static match
+match_inquire_element (gfc_inquire *inquire)
+{
+  match m;
+
+  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_out_tag (&tag_iostat, &inquire->iostat);
+  RETM m = match_vtag (&tag_exist, &inquire->exist);
+  RETM m = match_vtag (&tag_opened, &inquire->opened);
+  RETM m = match_vtag (&tag_named, &inquire->named);
+  RETM m = match_vtag (&tag_name, &inquire->name);
+  RETM m = match_out_tag (&tag_number, &inquire->number);
+  RETM m = match_vtag (&tag_s_access, &inquire->access);
+  RETM m = match_vtag (&tag_sequential, &inquire->sequential);
+  RETM m = match_vtag (&tag_direct, &inquire->direct);
+  RETM m = match_vtag (&tag_s_form, &inquire->form);
+  RETM m = match_vtag (&tag_formatted, &inquire->formatted);
+  RETM m = match_vtag (&tag_unformatted, &inquire->unformatted);
+  RETM m = match_out_tag (&tag_s_recl, &inquire->recl);
+  RETM m = match_out_tag (&tag_nextrec, &inquire->nextrec);
+  RETM m = match_vtag (&tag_s_blank, &inquire->blank);
+  RETM m = match_vtag (&tag_s_position, &inquire->position);
+  RETM m = match_vtag (&tag_s_action, &inquire->action);
+  RETM m = match_vtag (&tag_read, &inquire->read);
+  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);
+  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);
+  RETM m = match_vtag (&tag_s_encoding, &inquire->encoding);
+  RETM m = match_vtag (&tag_s_round, &inquire->round);
+  RETM m = match_vtag (&tag_s_sign, &inquire->sign);
+  RETM m = match_vtag (&tag_s_pad, &inquire->pad);
+  RETM m = match_out_tag (&tag_iolength, &inquire->iolength);
+  RETM m = match_vtag (&tag_convert, &inquire->convert);
+  RETM m = match_out_tag (&tag_strm_out, &inquire->strm_pos);
+  RETM m = match_vtag (&tag_pending, &inquire->pending);
+  RETM m = match_vtag (&tag_id, &inquire->id);
+  RETM m = match_vtag (&tag_s_iqstream, &inquire->iqstream);
+  RETM return MATCH_NO;
+}
+
+#undef RETM
+
+
+match
+gfc_match_inquire (void)
+{
+  gfc_inquire *inquire;
+  gfc_code *code;
+  match m;
+  locus loc;
+
+  m = gfc_match_char ('(');
+  if (m == MATCH_NO)
+    return m;
+
+  inquire = XCNEW (gfc_inquire);
+
+  loc = gfc_current_locus;
+
+  m = match_inquire_element (inquire);
+  if (m == MATCH_ERROR)
+    goto cleanup;
+  if (m == MATCH_NO)
+    {
+      m = gfc_match_expr (&inquire->unit);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_NO)
+	goto syntax;
+    }
+
+  /* See if we have the IOLENGTH form of the inquire statement.  */
+  if (inquire->iolength != NULL)
+    {
+      if (gfc_match_char (')') != MATCH_YES)
+	goto syntax;
+
+      m = match_io_list (M_INQUIRE, &code);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_NO)
+	goto syntax;
+
+      new_st.op = EXEC_IOLENGTH;
+      new_st.expr1 = inquire->iolength;
+      new_st.ext.inquire = inquire;
+
+      if (gfc_pure (NULL))
+	{
+	  gfc_free_statements (code);
+	  gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
+	  return MATCH_ERROR;
+	}
+
+      gfc_unset_implicit_pure (NULL);
+
+      new_st.block = gfc_get_code (EXEC_IOLENGTH);
+      terminate_io (code);
+      new_st.block->next = code;
+      return MATCH_YES;
+    }
+
+  /* At this point, we have the non-IOLENGTH inquire statement.  */
+  for (;;)
+    {
+      if (gfc_match_char (')') == MATCH_YES)
+	break;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+
+      m = match_inquire_element (inquire);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_NO)
+	goto syntax;
+
+      if (inquire->iolength != NULL)
+	{
+	  gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
+	  goto cleanup;
+	}
+    }
+
+  if (gfc_match_eos () != MATCH_YES)
+    goto syntax;
+
+  if (inquire->unit != NULL && inquire->file != NULL)
+    {
+      gfc_error ("INQUIRE statement at %L cannot contain both FILE and "
+		 "UNIT specifiers", &loc);
+      goto cleanup;
+    }
+
+  if (inquire->unit == NULL && inquire->file == NULL)
+    {
+      gfc_error ("INQUIRE statement at %L requires either FILE or "
+		 "UNIT specifier", &loc);
+      goto cleanup;
+    }
+
+  if (gfc_pure (NULL))
+    {
+      gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
+      goto cleanup;
+    }
+
+  gfc_unset_implicit_pure (NULL);
+  
+  if (inquire->id != NULL && inquire->pending == NULL)
+    {
+      gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with "
+		 "the ID= specifier", &loc);
+      goto cleanup;
+    }
+
+  new_st.op = EXEC_INQUIRE;
+  new_st.ext.inquire = inquire;
+  return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (ST_INQUIRE);
+
+cleanup:
+  gfc_free_inquire (inquire);
+  return MATCH_ERROR;
+}
+
+
+/* Resolve everything in a gfc_inquire structure.  */
+
+bool
+gfc_resolve_inquire (gfc_inquire *inquire)
+{
+  RESOLVE_TAG (&tag_unit, inquire->unit);
+  RESOLVE_TAG (&tag_file, inquire->file);
+  RESOLVE_TAG (&tag_id, inquire->id);
+
+  /* For INQUIRE, all tags except FILE, ID and UNIT are variable definition
+     contexts.  Thus, use an extended RESOLVE_TAG macro for that.  */
+#define INQUIRE_RESOLVE_TAG(tag, expr) \
+  RESOLVE_TAG (tag, expr); \
+  if (expr) \
+    { \
+      char context[64]; \
+      sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \
+      if (gfc_check_vardef_context ((expr), false, false, false, \
+				    context) == false) \
+	return false; \
+    }
+  INQUIRE_RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
+  INQUIRE_RESOLVE_TAG (&tag_iostat, inquire->iostat);
+  INQUIRE_RESOLVE_TAG (&tag_exist, inquire->exist);
+  INQUIRE_RESOLVE_TAG (&tag_opened, inquire->opened);
+  INQUIRE_RESOLVE_TAG (&tag_number, inquire->number);
+  INQUIRE_RESOLVE_TAG (&tag_named, inquire->named);
+  INQUIRE_RESOLVE_TAG (&tag_name, inquire->name);
+  INQUIRE_RESOLVE_TAG (&tag_s_access, inquire->access);
+  INQUIRE_RESOLVE_TAG (&tag_sequential, inquire->sequential);
+  INQUIRE_RESOLVE_TAG (&tag_direct, inquire->direct);
+  INQUIRE_RESOLVE_TAG (&tag_s_form, inquire->form);
+  INQUIRE_RESOLVE_TAG (&tag_formatted, inquire->formatted);
+  INQUIRE_RESOLVE_TAG (&tag_unformatted, inquire->unformatted);
+  INQUIRE_RESOLVE_TAG (&tag_s_recl, inquire->recl);
+  INQUIRE_RESOLVE_TAG (&tag_nextrec, inquire->nextrec);
+  INQUIRE_RESOLVE_TAG (&tag_s_blank, inquire->blank);
+  INQUIRE_RESOLVE_TAG (&tag_s_position, inquire->position);
+  INQUIRE_RESOLVE_TAG (&tag_s_action, inquire->action);
+  INQUIRE_RESOLVE_TAG (&tag_read, inquire->read);
+  INQUIRE_RESOLVE_TAG (&tag_write, inquire->write);
+  INQUIRE_RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
+  INQUIRE_RESOLVE_TAG (&tag_s_delim, inquire->delim);
+  INQUIRE_RESOLVE_TAG (&tag_s_pad, inquire->pad);
+  INQUIRE_RESOLVE_TAG (&tag_s_encoding, inquire->encoding);
+  INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round);
+  INQUIRE_RESOLVE_TAG (&tag_iolength, inquire->iolength);
+  INQUIRE_RESOLVE_TAG (&tag_convert, inquire->convert);
+  INQUIRE_RESOLVE_TAG (&tag_strm_out, inquire->strm_pos);
+  INQUIRE_RESOLVE_TAG (&tag_s_async, inquire->asynchronous);
+  INQUIRE_RESOLVE_TAG (&tag_s_sign, inquire->sign);
+  INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round);
+  INQUIRE_RESOLVE_TAG (&tag_pending, inquire->pending);
+  INQUIRE_RESOLVE_TAG (&tag_size, inquire->size);
+  INQUIRE_RESOLVE_TAG (&tag_s_decimal, inquire->decimal);
+  INQUIRE_RESOLVE_TAG (&tag_s_iqstream, inquire->iqstream);
+#undef INQUIRE_RESOLVE_TAG
+
+  if (!gfc_reference_st_label (inquire->err, ST_LABEL_TARGET))
+    return false;
+
+  return true;
+}
+
+
+void
+gfc_free_wait (gfc_wait *wait)
+{
+  if (wait == NULL)
+    return;
+
+  gfc_free_expr (wait->unit);
+  gfc_free_expr (wait->iostat);
+  gfc_free_expr (wait->iomsg);
+  gfc_free_expr (wait->id);
+  free (wait);
+}
+
+
+bool
+gfc_resolve_wait (gfc_wait *wait)
+{
+  RESOLVE_TAG (&tag_unit, wait->unit);
+  RESOLVE_TAG (&tag_iomsg, wait->iomsg);
+  RESOLVE_TAG (&tag_iostat, wait->iostat);
+  RESOLVE_TAG (&tag_id, wait->id);
+
+  if (!gfc_reference_st_label (wait->err, ST_LABEL_TARGET))
+    return false;
+  
+  if (!gfc_reference_st_label (wait->end, ST_LABEL_TARGET))
+    return false;
+
+  return true;
+}
+
+/* Match an element of a WAIT statement.  */
+
+#define RETM   if (m != MATCH_NO) return m;
+
+static match
+match_wait_element (gfc_wait *wait)
+{
+  match m;
+
+  m = match_etag (&tag_unit, &wait->unit);
+  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_out_tag (&tag_iostat, &wait->iostat);
+  RETM m = match_etag (&tag_id, &wait->id);
+  RETM return MATCH_NO;
+}
+
+#undef RETM
+
+
+match
+gfc_match_wait (void)
+{
+  gfc_wait *wait;
+  match m;
+
+  m = gfc_match_char ('(');
+  if (m == MATCH_NO)
+    return m;
+
+  wait = XCNEW (gfc_wait);
+
+  m = match_wait_element (wait);
+  if (m == MATCH_ERROR)
+    goto cleanup;
+  if (m == MATCH_NO)
+    {
+      m = gfc_match_expr (&wait->unit);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_NO)
+	goto syntax;
+    }
+
+  for (;;)
+    {
+      if (gfc_match_char (')') == MATCH_YES)
+	break;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+
+      m = match_wait_element (wait);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_NO)
+	goto syntax;
+    }
+
+  if (!gfc_notify_std (GFC_STD_F2003, "WAIT at %C "
+		       "not allowed in Fortran 95"))
+    goto cleanup;
+
+  if (gfc_pure (NULL))
+    {
+      gfc_error ("WAIT statement not allowed in PURE procedure at %C");
+      goto cleanup;
+    }
+
+  gfc_unset_implicit_pure (NULL);
+
+  new_st.op = EXEC_WAIT;
+  new_st.ext.wait = wait;
+
+  return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (ST_WAIT);
+
+cleanup:
+  gfc_free_wait (wait);
+  return MATCH_ERROR;
+}
diff --git a/gcc-4.9/gcc/fortran/ioparm.def b/gcc-4.9/gcc/fortran/ioparm.def
new file mode 100644
index 000000000..17b345864
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/ioparm.def
@@ -0,0 +1,115 @@
+/* Copyright (C) 2005-2014 Free Software Foundation, Inc.
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+#ifndef IOPARM_common_libreturn_mask
+#define IOPARM_common_libreturn_mask	3
+#define IOPARM_common_libreturn_ok	0
+#define IOPARM_common_libreturn_error	1
+#define IOPARM_common_libreturn_end	2
+#define IOPARM_common_libreturn_eor	3
+#define IOPARM_common_err		(1 << 2)
+#define IOPARM_common_end		(1 << 3)
+#define IOPARM_common_eor		(1 << 4)
+#endif
+IOPARM (common,  flags,		0,	 int4)
+IOPARM (common,  unit,		0,	 int4)
+IOPARM (common,  filename,	0,	 pchar)
+IOPARM (common,  line,		0,	 int4)
+IOPARM (common,  iomsg,		1 << 6,  char2)
+IOPARM (common,  iostat,	1 << 5,  pint4)
+IOPARM (open,    common,	0,	 common)
+IOPARM (open,    recl_in,	1 << 7,  int4)
+IOPARM (open,    file,		1 << 8,  char2)
+IOPARM (open,    status,	1 << 9,  char1)
+IOPARM (open,    access,	1 << 10, char2)
+IOPARM (open,    form,		1 << 11, char1)
+IOPARM (open,    blank,		1 << 12, char2)
+IOPARM (open,    position,	1 << 13, char1)
+IOPARM (open,    action,	1 << 14, char2)
+IOPARM (open,    delim,		1 << 15, char1)
+IOPARM (open,    pad,		1 << 16, char2)
+IOPARM (open,    convert,	1 << 17, char1)
+IOPARM (open,    decimal,	1 << 18, char2)
+IOPARM (open,    encoding,	1 << 19, char1)
+IOPARM (open,    round,		1 << 20, char2)
+IOPARM (open,    sign,		1 << 21, char1)
+IOPARM (open,    asynchronous,	1 << 22, char2)
+IOPARM (open,    newunit,	1 << 23, pint4)
+IOPARM (close,   common,	0,	 common)
+IOPARM (close,   status,	1 << 7,  char1)
+IOPARM (filepos, common,	0,	 common)
+IOPARM (inquire, common,	0,	 common)
+IOPARM (inquire, exist,		1 << 7,  pint4)
+IOPARM (inquire, opened,	1 << 8,  pint4)
+IOPARM (inquire, number,	1 << 9,  pint4)
+IOPARM (inquire, named,		1 << 10, pint4)
+IOPARM (inquire, nextrec,	1 << 11, pint4)
+IOPARM (inquire, recl_out,	1 << 12, pint4)
+IOPARM (inquire, strm_pos_out,	1 << 13, pintio)
+IOPARM (inquire, file,		1 << 14, char1)
+IOPARM (inquire, access,	1 << 15, char2)
+IOPARM (inquire, form,		1 << 16, char1)
+IOPARM (inquire, blank,		1 << 17, char2)
+IOPARM (inquire, position,	1 << 18, char1)
+IOPARM (inquire, action,	1 << 19, char2)
+IOPARM (inquire, delim,		1 << 20, char1)
+IOPARM (inquire, pad,		1 << 21, char2)
+IOPARM (inquire, name,		1 << 22, char1)
+IOPARM (inquire, sequential,	1 << 23, char2)
+IOPARM (inquire, direct,	1 << 24, char1)
+IOPARM (inquire, formatted,	1 << 25, char2)
+IOPARM (inquire, unformatted,	1 << 26, char1)
+IOPARM (inquire, read,		1 << 27, char2)
+IOPARM (inquire, write,		1 << 28, char1)
+IOPARM (inquire, readwrite,	1 << 29, char2)
+IOPARM (inquire, convert,	1 << 30, char1)
+IOPARM (inquire, flags2,	1 << 31, int4)
+IOPARM (inquire, asynchronous,	1 << 0,  char1)
+IOPARM (inquire, decimal,	1 << 1,  char2)
+IOPARM (inquire, encoding,	1 << 2,  char1)
+IOPARM (inquire, round,		1 << 3,  char2)
+IOPARM (inquire, sign,		1 << 4,  char1)
+IOPARM (inquire, pending,	1 << 5,  pint4)
+IOPARM (inquire, size,		1 << 6,  pintio)
+IOPARM (inquire, id,		1 << 7,  pint4)
+IOPARM (inquire, iqstream,	1 << 8,  char1)
+IOPARM (wait,    common,	0,	 common)
+IOPARM (wait,    id,		1 << 7,  pint4)
+#ifndef IOPARM_dt_list_format
+#define IOPARM_dt_list_format		(1 << 7)
+#define IOPARM_dt_namelist_read_mode	(1 << 8)
+#endif
+IOPARM (dt,      common,	0,	 common)
+IOPARM (dt,      rec,		1 << 9,  intio)
+IOPARM (dt,      size,		1 << 10, pintio)
+IOPARM (dt,      iolength,	1 << 11, pintio)
+IOPARM (dt,      internal_unit_desc, 0,  parray)
+IOPARM (dt,      format,	1 << 12, char1)
+IOPARM (dt,      advance,	1 << 13, char2)
+IOPARM (dt,      internal_unit,	1 << 14, char1)
+IOPARM (dt,      namelist_name,	1 << 15, char2)
+IOPARM (dt,      u,		0,	 pad)
+IOPARM (dt,      id,		1 << 16, pint4)
+IOPARM (dt,      pos,		1 << 17, intio)
+IOPARM (dt,      asynchronous, 	1 << 18, char1)
+IOPARM (dt,      blank,		1 << 19, char2)
+IOPARM (dt,      decimal,	1 << 20, char1)
+IOPARM (dt,      delim,		1 << 21, char2)
+IOPARM (dt,      pad,		1 << 22, char1)
+IOPARM (dt,      round,		1 << 23, char2)
+IOPARM (dt,      sign,		1 << 24, char1)
diff --git a/gcc-4.9/gcc/fortran/iresolve.c b/gcc-4.9/gcc/fortran/iresolve.c
new file mode 100644
index 000000000..630d725e1
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/iresolve.c
@@ -0,0 +1,3691 @@
+/* Intrinsic function resolution.
+   Copyright (C) 2000-2014 Free Software Foundation, Inc.
+   Contributed by Andy Vaught & Katherine Holcomb
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+
+/* Assign name and types to intrinsic procedures.  For functions, the
+   first argument to a resolution function is an expression pointer to
+   the original function node and the rest are pointers to the
+   arguments of the function call.  For subroutines, a pointer to the
+   code node is passed.  The result type and library subroutine name
+   are generally set according to the function arguments.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "tree.h"
+#include "stringpool.h"
+#include "gfortran.h"
+#include "intrinsic.h"
+#include "constructor.h"
+#include "arith.h"
+
+/* Given printf-like arguments, return a stable version of the result string. 
+
+   We already have a working, optimized string hashing table in the form of
+   the identifier table.  Reusing this table is likely not to be wasted, 
+   since if the function name makes it to the gimple output of the frontend,
+   we'll have to create the identifier anyway.  */
+
+const char *
+gfc_get_string (const char *format, ...)
+{
+  char temp_name[128];
+  va_list ap;
+  tree ident;
+
+  va_start (ap, format);
+  vsnprintf (temp_name, sizeof (temp_name), format, ap);
+  va_end (ap);
+  temp_name[sizeof (temp_name) - 1] = 0;
+
+  ident = get_identifier (temp_name);
+  return IDENTIFIER_POINTER (ident);
+}
+
+/* MERGE and SPREAD need to have source charlen's present for passing
+   to the result expression.  */
+static void
+check_charlen_present (gfc_expr *source)
+{
+  if (source->ts.u.cl == NULL)
+    source->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+
+  if (source->expr_type == EXPR_CONSTANT)
+    {
+      source->ts.u.cl->length
+		= gfc_get_int_expr (gfc_default_integer_kind, NULL,
+				    source->value.character.length);
+      source->rank = 0;
+    }
+  else if (source->expr_type == EXPR_ARRAY)
+    {
+      gfc_constructor *c = gfc_constructor_first (source->value.constructor);
+      source->ts.u.cl->length
+		= gfc_get_int_expr (gfc_default_integer_kind, NULL,
+				    c->expr->value.character.length);
+    }
+}
+
+/* Helper function for resolving the "mask" argument.  */
+
+static void
+resolve_mask_arg (gfc_expr *mask)
+{
+
+  gfc_typespec ts;
+  gfc_clear_ts (&ts);
+
+  if (mask->rank == 0)
+    {
+      /* For the scalar case, coerce the mask to kind=4 unconditionally
+	 (because this is the only kind we have a library function
+	 for).  */
+
+      if (mask->ts.kind != 4)
+	{
+	  ts.type = BT_LOGICAL;
+	  ts.kind = 4;
+	  gfc_convert_type (mask, &ts, 2);
+	}
+    }
+  else
+    {
+      /* In the library, we access the mask with a GFC_LOGICAL_1
+	 argument.  No need to waste memory if we are about to create
+	 a temporary array.  */
+      if (mask->expr_type == EXPR_OP && mask->ts.kind != 1)
+	{
+	  ts.type = BT_LOGICAL;
+	  ts.kind = 1;
+	  gfc_convert_type_warn (mask, &ts, 2, 0);
+	}
+    }
+}
+
+
+static void
+resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind,
+	       const char *name, bool coarray)
+{
+  f->ts.type = BT_INTEGER;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
+
+  if (dim == NULL)
+    {
+      f->rank = 1;
+      if (array->rank != -1)
+	{
+	  f->shape = gfc_get_shape (1);
+	  mpz_init_set_ui (f->shape[0], coarray ? gfc_get_corank (array)
+						: array->rank);
+	}
+    }
+
+  f->value.function.name = gfc_get_string (name);
+}
+
+
+static void
+resolve_transformational (const char *name, gfc_expr *f, gfc_expr *array,
+			  gfc_expr *dim, gfc_expr *mask)
+{
+  const char *prefix;
+
+  f->ts = array->ts;
+
+  if (mask)
+    {
+      if (mask->rank == 0)
+	prefix = "s";
+      else
+	prefix = "m";
+
+      resolve_mask_arg (mask);
+    }
+  else
+    prefix = "";
+
+  if (dim != NULL)
+    {
+      f->rank = array->rank - 1;
+      f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
+      gfc_resolve_dim_arg (dim);
+    }
+
+  f->value.function.name
+    = gfc_get_string (PREFIX ("%s%s_%c%d"), prefix, name,
+		    gfc_type_letter (array->ts.type), array->ts.kind);
+}
+
+
+/********************** Resolution functions **********************/
+
+
+void
+gfc_resolve_abs (gfc_expr *f, gfc_expr *a)
+{
+  f->ts = a->ts;
+  if (f->ts.type == BT_COMPLEX)
+    f->ts.type = BT_REAL;
+
+  f->value.function.name
+    = gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
+}
+
+
+void
+gfc_resolve_access (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
+		    gfc_expr *mode ATTRIBUTE_UNUSED)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_c_int_kind;
+  f->value.function.name = PREFIX ("access_func");
+}
+
+
+void
+gfc_resolve_adjustl (gfc_expr *f, gfc_expr *string)
+{
+  f->ts.type = BT_CHARACTER;
+  f->ts.kind = string->ts.kind;
+  f->value.function.name = gfc_get_string ("__adjustl_s%d", f->ts.kind);
+}
+
+
+void
+gfc_resolve_adjustr (gfc_expr *f, gfc_expr *string)
+{
+  f->ts.type = BT_CHARACTER;
+  f->ts.kind = string->ts.kind;
+  f->value.function.name = gfc_get_string ("__adjustr_s%d", f->ts.kind);
+}
+
+
+static void
+gfc_resolve_char_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind,
+			const char *name)
+{
+  f->ts.type = BT_CHARACTER;
+  f->ts.kind = (kind == NULL)
+	     ? gfc_default_character_kind : mpz_get_si (kind->value.integer);
+  f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+  f->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+
+  f->value.function.name = gfc_get_string (name, f->ts.kind,
+					   gfc_type_letter (x->ts.type),
+					   x->ts.kind);
+}
+
+
+void
+gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind)
+{
+  gfc_resolve_char_achar (f, x, kind, "__achar_%d_%c%d");
+}
+
+
+void
+gfc_resolve_acos (gfc_expr *f, gfc_expr *x)
+{
+  f->ts = x->ts;
+  f->value.function.name
+    = gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+}
+
+
+void
+gfc_resolve_acosh (gfc_expr *f, gfc_expr *x)
+{
+  f->ts = x->ts;
+  f->value.function.name
+    = gfc_get_string ("__acosh_%c%d", gfc_type_letter (x->ts.type),
+		      x->ts.kind);
+}
+
+
+void
+gfc_resolve_aimag (gfc_expr *f, gfc_expr *x)
+{
+  f->ts.type = BT_REAL;
+  f->ts.kind = x->ts.kind;
+  f->value.function.name
+    = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type),
+		      x->ts.kind);
+}
+
+
+void
+gfc_resolve_and (gfc_expr *f, gfc_expr *i, gfc_expr *j)
+{
+  f->ts.type = i->ts.type;
+  f->ts.kind = gfc_kind_max (i, j);
+
+  if (i->ts.kind != j->ts.kind)
+    {
+      if (i->ts.kind == gfc_kind_max (i, j))
+	gfc_convert_type (j, &i->ts, 2);
+      else
+	gfc_convert_type (i, &j->ts, 2);
+    }
+
+  f->value.function.name
+    = gfc_get_string ("__and_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
+}
+
+
+void
+gfc_resolve_aint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
+{
+  gfc_typespec ts;
+  gfc_clear_ts (&ts);
+  
+  f->ts.type = a->ts.type;
+  f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
+
+  if (a->ts.kind != f->ts.kind)
+    {
+      ts.type = f->ts.type;
+      ts.kind = f->ts.kind;
+      gfc_convert_type (a, &ts, 2);
+    }
+  /* The resolved name is only used for specific intrinsics where
+     the return kind is the same as the arg kind.  */
+  f->value.function.name
+    = gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
+}
+
+
+void
+gfc_resolve_dint (gfc_expr *f, gfc_expr *a)
+{
+  gfc_resolve_aint (f, a, NULL);
+}
+
+
+void
+gfc_resolve_all (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
+{
+  f->ts = mask->ts;
+
+  if (dim != NULL)
+    {
+      gfc_resolve_dim_arg (dim);
+      f->rank = mask->rank - 1;
+      f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
+    }
+
+  f->value.function.name
+    = gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask->ts.type),
+		      mask->ts.kind);
+}
+
+
+void
+gfc_resolve_anint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
+{
+  gfc_typespec ts;
+  gfc_clear_ts (&ts);
+  
+  f->ts.type = a->ts.type;
+  f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
+
+  if (a->ts.kind != f->ts.kind)
+    {
+      ts.type = f->ts.type;
+      ts.kind = f->ts.kind;
+      gfc_convert_type (a, &ts, 2);
+    }
+
+  /* The resolved name is only used for specific intrinsics where
+     the return kind is the same as the arg kind.  */
+  f->value.function.name
+    = gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type),
+		      a->ts.kind);
+}
+
+
+void
+gfc_resolve_dnint (gfc_expr *f, gfc_expr *a)
+{
+  gfc_resolve_anint (f, a, NULL);
+}
+
+
+void
+gfc_resolve_any (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
+{
+  f->ts = mask->ts;
+
+  if (dim != NULL)
+    {
+      gfc_resolve_dim_arg (dim);
+      f->rank = mask->rank - 1;
+      f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
+    }
+
+  f->value.function.name
+    = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask->ts.type),
+		      mask->ts.kind);
+}
+
+
+void
+gfc_resolve_asin (gfc_expr *f, gfc_expr *x)
+{
+  f->ts = x->ts;
+  f->value.function.name
+    = gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+}
+
+void
+gfc_resolve_asinh (gfc_expr *f, gfc_expr *x)
+{
+  f->ts = x->ts;
+  f->value.function.name
+    = gfc_get_string ("__asinh_%c%d", gfc_type_letter (x->ts.type),
+		      x->ts.kind);
+}
+
+void
+gfc_resolve_atan (gfc_expr *f, gfc_expr *x)
+{
+  f->ts = x->ts;
+  f->value.function.name
+    = gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+}
+
+void
+gfc_resolve_atanh (gfc_expr *f, gfc_expr *x)
+{
+  f->ts = x->ts;
+  f->value.function.name
+    = gfc_get_string ("__atanh_%c%d", gfc_type_letter (x->ts.type),
+		      x->ts.kind);
+}
+
+void
+gfc_resolve_atan2 (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
+{
+  f->ts = x->ts;
+  f->value.function.name
+    = gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type),
+		      x->ts.kind);
+}
+
+
+/* Resolve the BESYN and BESJN intrinsics.  */
+
+void
+gfc_resolve_besn (gfc_expr *f, gfc_expr *n, gfc_expr *x)
+{
+  gfc_typespec ts;
+  gfc_clear_ts (&ts);
+  
+  f->ts = x->ts;
+  if (n->ts.kind != gfc_c_int_kind)
+    {
+      ts.type = BT_INTEGER;
+      ts.kind = gfc_c_int_kind;
+      gfc_convert_type (n, &ts, 2);
+    }
+  f->value.function.name = gfc_get_string ("<intrinsic>");
+}
+
+
+void
+gfc_resolve_bessel_n2 (gfc_expr *f, gfc_expr *n1, gfc_expr *n2, gfc_expr *x)
+{
+  gfc_typespec ts;
+  gfc_clear_ts (&ts);
+  
+  f->ts = x->ts;
+  f->rank = 1;
+  if (n1->expr_type == EXPR_CONSTANT && n2->expr_type == EXPR_CONSTANT)
+    {
+      f->shape = gfc_get_shape (1);
+      mpz_init (f->shape[0]);
+      mpz_sub (f->shape[0], n2->value.integer, n1->value.integer);
+      mpz_add_ui (f->shape[0], f->shape[0], 1);
+    }
+
+  if (n1->ts.kind != gfc_c_int_kind)
+    {
+      ts.type = BT_INTEGER;
+      ts.kind = gfc_c_int_kind;
+      gfc_convert_type (n1, &ts, 2);
+    }
+
+  if (n2->ts.kind != gfc_c_int_kind)
+    {
+      ts.type = BT_INTEGER;
+      ts.kind = gfc_c_int_kind;
+      gfc_convert_type (n2, &ts, 2);
+    }
+
+  if (f->value.function.isym->id == GFC_ISYM_JN2)
+    f->value.function.name = gfc_get_string (PREFIX ("bessel_jn_r%d"),
+					     f->ts.kind);
+  else
+    f->value.function.name = gfc_get_string (PREFIX ("bessel_yn_r%d"),
+					     f->ts.kind);
+}
+
+
+void
+gfc_resolve_btest (gfc_expr *f, gfc_expr *i, gfc_expr *pos)
+{
+  f->ts.type = BT_LOGICAL;
+  f->ts.kind = gfc_default_logical_kind;
+  f->value.function.name
+    = gfc_get_string ("__btest_%d_%d", i->ts.kind, pos->ts.kind);
+}
+
+
+void
+gfc_resolve_c_loc (gfc_expr *f, gfc_expr *x ATTRIBUTE_UNUSED)
+{
+  f->ts = f->value.function.isym->ts;
+}
+
+
+void
+gfc_resolve_c_funloc (gfc_expr *f, gfc_expr *x ATTRIBUTE_UNUSED)
+{
+  f->ts = f->value.function.isym->ts;
+}
+
+
+void
+gfc_resolve_ceiling (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = (kind == NULL)
+	     ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
+  f->value.function.name
+    = gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind,
+		      gfc_type_letter (a->ts.type), a->ts.kind);
+}
+
+
+void
+gfc_resolve_char (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
+{
+  gfc_resolve_char_achar (f, a, kind, "__char_%d_%c%d");
+}
+
+
+void
+gfc_resolve_chdir (gfc_expr *f, gfc_expr *d ATTRIBUTE_UNUSED)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_default_integer_kind;
+  f->value.function.name = gfc_get_string (PREFIX ("chdir_i%d"), f->ts.kind);
+}
+
+
+void
+gfc_resolve_chdir_sub (gfc_code *c)
+{
+  const char *name;
+  int kind;
+
+  if (c->ext.actual->next->expr != NULL)
+    kind = c->ext.actual->next->expr->ts.kind;
+  else
+    kind = gfc_default_integer_kind;
+
+  name = gfc_get_string (PREFIX ("chdir_i%d_sub"), kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
+gfc_resolve_chmod (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
+		   gfc_expr *mode ATTRIBUTE_UNUSED)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_c_int_kind;
+  f->value.function.name = PREFIX ("chmod_func");
+}
+
+
+void
+gfc_resolve_chmod_sub (gfc_code *c)
+{
+  const char *name;
+  int kind;
+
+  if (c->ext.actual->next->next->expr != NULL)
+    kind = c->ext.actual->next->next->expr->ts.kind;
+  else
+    kind = gfc_default_integer_kind;
+
+  name = gfc_get_string (PREFIX ("chmod_i%d_sub"), kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
+gfc_resolve_cmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y, gfc_expr *kind)
+{
+  f->ts.type = BT_COMPLEX;
+  f->ts.kind = (kind == NULL)
+	     ? gfc_default_real_kind : mpz_get_si (kind->value.integer);
+
+  if (y == NULL)
+    f->value.function.name
+      = gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind,
+			gfc_type_letter (x->ts.type), x->ts.kind);
+  else
+    f->value.function.name
+      = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
+			gfc_type_letter (x->ts.type), x->ts.kind,
+			gfc_type_letter (y->ts.type), y->ts.kind);
+}
+
+
+void
+gfc_resolve_dcmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y)
+{
+  gfc_resolve_cmplx (f, x, y, gfc_get_int_expr (gfc_default_integer_kind, NULL,
+						gfc_default_double_kind));
+}
+
+
+void
+gfc_resolve_complex (gfc_expr *f, gfc_expr *x, gfc_expr *y)
+{
+  int kind;
+
+  if (x->ts.type == BT_INTEGER)
+    {
+      if (y->ts.type == BT_INTEGER)
+	kind = gfc_default_real_kind;
+      else
+	kind = y->ts.kind;
+    }
+  else
+    {
+      if (y->ts.type == BT_REAL)
+	kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
+      else
+	kind = x->ts.kind;
+    }
+
+  f->ts.type = BT_COMPLEX;
+  f->ts.kind = kind;
+  f->value.function.name
+    = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
+		      gfc_type_letter (x->ts.type), x->ts.kind,
+		      gfc_type_letter (y->ts.type), y->ts.kind);
+}
+
+
+void
+gfc_resolve_conjg (gfc_expr *f, gfc_expr *x)
+{
+  f->ts = x->ts;
+  f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind);
+}
+
+
+void
+gfc_resolve_cos (gfc_expr *f, gfc_expr *x)
+{
+  f->ts = x->ts;
+  f->value.function.name
+    = gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+}
+
+
+void
+gfc_resolve_cosh (gfc_expr *f, gfc_expr *x)
+{
+  f->ts = x->ts;
+  f->value.function.name
+    = gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+}
+
+
+void
+gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
+{
+  f->ts.type = BT_INTEGER;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
+
+  if (dim != NULL)
+    {
+      f->rank = mask->rank - 1;
+      gfc_resolve_dim_arg (dim);
+      f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
+    }
+
+  resolve_mask_arg (mask);
+
+  f->value.function.name
+    = gfc_get_string (PREFIX ("count_%d_%c"), f->ts.kind,
+		      gfc_type_letter (mask->ts.type));
+}
+
+
+void
+gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
+		    gfc_expr *dim)
+{
+  int n, m;
+
+  if (array->ts.type == BT_CHARACTER && array->ref)
+    gfc_resolve_substring_charlen (array);
+
+  f->ts = array->ts;
+  f->rank = array->rank;
+  f->shape = gfc_copy_shape (array->shape, array->rank);
+
+  if (shift->rank > 0)
+    n = 1;
+  else
+    n = 0;
+
+  /* If dim kind is greater than default integer we need to use the larger.  */
+  m = gfc_default_integer_kind;
+  if (dim != NULL)
+    m = m < dim->ts.kind ? dim->ts.kind : m;
+  
+  /* Convert shift to at least m, so we don't need
+      kind=1 and kind=2 versions of the library functions.  */
+  if (shift->ts.kind < m)
+    {
+      gfc_typespec ts;
+      gfc_clear_ts (&ts);
+      ts.type = BT_INTEGER;
+      ts.kind = m;
+      gfc_convert_type_warn (shift, &ts, 2, 0);
+    }
+ 
+  if (dim != NULL)
+    {
+      if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL
+	  && dim->symtree->n.sym->attr.optional)
+	{
+	  /* Mark this for later setting the type in gfc_conv_missing_dummy.  */
+	  dim->representation.length = shift->ts.kind;
+	}
+      else
+	{
+	  gfc_resolve_dim_arg (dim);
+	  /* Convert dim to shift's kind to reduce variations.  */
+	  if (dim->ts.kind != shift->ts.kind)
+	    gfc_convert_type_warn (dim, &shift->ts, 2, 0);
+        }
+    }
+
+  if (array->ts.type == BT_CHARACTER)
+    {
+      if (array->ts.kind == gfc_default_character_kind)
+	f->value.function.name
+	  = gfc_get_string (PREFIX ("cshift%d_%d_char"), n, shift->ts.kind);
+      else
+	f->value.function.name
+	  = gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n, shift->ts.kind,
+			    array->ts.kind);
+    }
+  else
+    f->value.function.name
+	= gfc_get_string (PREFIX ("cshift%d_%d"), n, shift->ts.kind);
+}
+
+
+void
+gfc_resolve_ctime (gfc_expr *f, gfc_expr *time)
+{
+  gfc_typespec ts;
+  gfc_clear_ts (&ts);
+  
+  f->ts.type = BT_CHARACTER;
+  f->ts.kind = gfc_default_character_kind;
+
+  /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
+  if (time->ts.kind != 8)
+    {
+      ts.type = BT_INTEGER;
+      ts.kind = 8;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
+      gfc_convert_type (time, &ts, 2);
+    }
+
+  f->value.function.name = gfc_get_string (PREFIX ("ctime"));
+}
+
+
+void
+gfc_resolve_dble (gfc_expr *f, gfc_expr *a)
+{
+  f->ts.type = BT_REAL;
+  f->ts.kind = gfc_default_double_kind;
+  f->value.function.name
+    = gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
+}
+
+
+void
+gfc_resolve_dim (gfc_expr *f, gfc_expr *a, gfc_expr *p)
+{
+  f->ts.type = a->ts.type;
+  if (p != NULL)
+    f->ts.kind = gfc_kind_max (a,p);
+  else
+    f->ts.kind = a->ts.kind;
+
+  if (p != NULL && a->ts.kind != p->ts.kind)
+    {
+      if (a->ts.kind == gfc_kind_max (a,p))
+	gfc_convert_type (p, &a->ts, 2);
+      else
+	gfc_convert_type (a, &p->ts, 2);
+    }
+
+  f->value.function.name
+    = gfc_get_string ("__dim_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
+}
+
+
+void
+gfc_resolve_dot_product (gfc_expr *f, gfc_expr *a, gfc_expr *b)
+{
+  gfc_expr temp;
+
+  temp.expr_type = EXPR_OP;
+  gfc_clear_ts (&temp.ts);
+  temp.value.op.op = INTRINSIC_NONE;
+  temp.value.op.op1 = a;
+  temp.value.op.op2 = b;
+  gfc_type_convert_binary (&temp, 1);
+  f->ts = temp.ts;
+  f->value.function.name
+    = gfc_get_string (PREFIX ("dot_product_%c%d"),
+		      gfc_type_letter (f->ts.type), f->ts.kind);
+}
+
+
+void
+gfc_resolve_dprod (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
+		   gfc_expr *b ATTRIBUTE_UNUSED)
+{
+  f->ts.kind = gfc_default_double_kind;
+  f->ts.type = BT_REAL;
+  f->value.function.name = gfc_get_string ("__dprod_r%d", f->ts.kind);
+}
+
+
+void
+gfc_resolve_dshift (gfc_expr *f, gfc_expr *i, gfc_expr *j ATTRIBUTE_UNUSED,
+		    gfc_expr *shift ATTRIBUTE_UNUSED)
+{
+  f->ts = i->ts;
+  if (f->value.function.isym->id == GFC_ISYM_DSHIFTL)
+    f->value.function.name = gfc_get_string ("dshiftl_i%d", f->ts.kind);
+  else if (f->value.function.isym->id == GFC_ISYM_DSHIFTR)
+    f->value.function.name = gfc_get_string ("dshiftr_i%d", f->ts.kind);
+  else
+    gcc_unreachable ();
+}
+
+
+void
+gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
+		     gfc_expr *boundary, gfc_expr *dim)
+{
+  int n, m;
+
+  if (array->ts.type == BT_CHARACTER && array->ref)
+    gfc_resolve_substring_charlen (array);
+
+  f->ts = array->ts;
+  f->rank = array->rank;
+  f->shape = gfc_copy_shape (array->shape, array->rank);
+
+  n = 0;
+  if (shift->rank > 0)
+    n = n | 1;
+  if (boundary && boundary->rank > 0)
+    n = n | 2;
+
+  /* If dim kind is greater than default integer we need to use the larger.  */
+  m = gfc_default_integer_kind;
+  if (dim != NULL)
+    m = m < dim->ts.kind ? dim->ts.kind : m;
+  
+  /* Convert shift to at least m, so we don't need
+      kind=1 and kind=2 versions of the library functions.  */
+  if (shift->ts.kind < m)
+    {
+      gfc_typespec ts;
+      gfc_clear_ts (&ts);
+      ts.type = BT_INTEGER;
+      ts.kind = m;
+      gfc_convert_type_warn (shift, &ts, 2, 0);
+    }
+ 
+  if (dim != NULL)
+    {
+      if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL
+	  && dim->symtree->n.sym->attr.optional)
+	{
+	  /* Mark this for later setting the type in gfc_conv_missing_dummy.  */
+	  dim->representation.length = shift->ts.kind;
+	}
+      else
+	{
+	  gfc_resolve_dim_arg (dim);
+	  /* Convert dim to shift's kind to reduce variations.  */
+	  if (dim->ts.kind != shift->ts.kind)
+	    gfc_convert_type_warn (dim, &shift->ts, 2, 0);
+        }
+    }
+
+  if (array->ts.type == BT_CHARACTER)
+    {
+      if (array->ts.kind == gfc_default_character_kind)
+	f->value.function.name
+	  = gfc_get_string (PREFIX ("eoshift%d_%d_char"), n, shift->ts.kind);
+      else
+	f->value.function.name
+	  = gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n, shift->ts.kind,
+			    array->ts.kind);
+    }
+  else
+    f->value.function.name
+	= gfc_get_string (PREFIX ("eoshift%d_%d"), n, shift->ts.kind);
+}
+
+
+void
+gfc_resolve_exp (gfc_expr *f, gfc_expr *x)
+{
+  f->ts = x->ts;
+  f->value.function.name
+    = gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+}
+
+
+void
+gfc_resolve_exponent (gfc_expr *f, gfc_expr *x)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_default_integer_kind;
+  f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind);
+}
+
+
+/* Resolve the EXTENDS_TYPE_OF intrinsic function.  */
+
+void
+gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
+{
+  gfc_symbol *vtab;
+  gfc_symtree *st;
+
+  /* Prevent double resolution.  */
+  if (f->ts.type == BT_LOGICAL)
+    return;
+
+  /* Replace the first argument with the corresponding vtab.  */
+  if (a->ts.type == BT_CLASS)
+    gfc_add_vptr_component (a);
+  else if (a->ts.type == BT_DERIVED)
+    {
+      vtab = gfc_find_derived_vtab (a->ts.u.derived);
+      /* Clear the old expr.  */
+      gfc_free_ref_list (a->ref);
+      memset (a, '\0', sizeof (gfc_expr));
+      /* Construct a new one.  */
+      a->expr_type = EXPR_VARIABLE;
+      st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
+      a->symtree = st;
+      a->ts = vtab->ts;
+    }
+
+  /* Replace the second argument with the corresponding vtab.  */
+  if (mo->ts.type == BT_CLASS)
+    gfc_add_vptr_component (mo);
+  else if (mo->ts.type == BT_DERIVED)
+    {
+      vtab = gfc_find_derived_vtab (mo->ts.u.derived);
+      /* Clear the old expr.  */
+      gfc_free_ref_list (mo->ref);
+      memset (mo, '\0', sizeof (gfc_expr));
+      /* Construct a new one.  */
+      mo->expr_type = EXPR_VARIABLE;
+      st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
+      mo->symtree = st;
+      mo->ts = vtab->ts;
+    }
+
+  f->ts.type = BT_LOGICAL;
+  f->ts.kind = 4;
+
+  f->value.function.isym->formal->ts = a->ts;
+  f->value.function.isym->formal->next->ts = mo->ts;
+
+  /* Call library function.  */
+  f->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
+}
+
+
+void
+gfc_resolve_fdate (gfc_expr *f)
+{
+  f->ts.type = BT_CHARACTER;
+  f->ts.kind = gfc_default_character_kind;
+  f->value.function.name = gfc_get_string (PREFIX ("fdate"));
+}
+
+
+void
+gfc_resolve_floor (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = (kind == NULL)
+	     ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
+  f->value.function.name
+    = gfc_get_string ("__floor%d_%c%d", f->ts.kind,
+		      gfc_type_letter (a->ts.type), a->ts.kind);
+}
+
+
+void
+gfc_resolve_fnum (gfc_expr *f, gfc_expr *n)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_default_integer_kind;
+  if (n->ts.kind != f->ts.kind)
+    gfc_convert_type (n, &f->ts, 2);
+  f->value.function.name = gfc_get_string (PREFIX ("fnum_i%d"), f->ts.kind);
+}
+
+
+void
+gfc_resolve_fraction (gfc_expr *f, gfc_expr *x)
+{
+  f->ts = x->ts;
+  f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind);
+}
+
+
+/* Resolve single-argument g77 math intrinsics, eg BESY0, ERF.  */
+
+void
+gfc_resolve_g77_math1 (gfc_expr *f, gfc_expr *x)
+{
+  f->ts = x->ts;
+  f->value.function.name = gfc_get_string ("<intrinsic>");
+}
+
+
+void
+gfc_resolve_gamma (gfc_expr *f, gfc_expr *x)
+{
+  f->ts = x->ts;
+  f->value.function.name
+    = gfc_get_string ("__tgamma_%d", x->ts.kind);
+}
+
+
+void
+gfc_resolve_getcwd (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = 4;
+  f->value.function.name = gfc_get_string (PREFIX ("getcwd"));
+}
+
+
+void
+gfc_resolve_getgid (gfc_expr *f)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = 4;
+  f->value.function.name = gfc_get_string (PREFIX ("getgid"));
+}
+
+
+void
+gfc_resolve_getpid (gfc_expr *f)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = 4;
+  f->value.function.name = gfc_get_string (PREFIX ("getpid"));
+}
+
+
+void
+gfc_resolve_getuid (gfc_expr *f)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = 4;
+  f->value.function.name = gfc_get_string (PREFIX ("getuid"));
+}
+
+
+void
+gfc_resolve_hostnm (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = 4;
+  f->value.function.name = gfc_get_string (PREFIX ("hostnm"));
+}
+
+
+void
+gfc_resolve_hypot (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
+{
+  f->ts = x->ts;
+  f->value.function.name = gfc_get_string ("__hypot_r%d", x->ts.kind);
+}
+
+
+void
+gfc_resolve_iall (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+  resolve_transformational ("iall", f, array, dim, mask);
+}
+
+
+void
+gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j)
+{
+  /* If the kind of i and j are different, then g77 cross-promoted the
+     kinds to the largest value.  The Fortran 95 standard requires the 
+     kinds to match.  */
+  if (i->ts.kind != j->ts.kind)
+    {
+      if (i->ts.kind == gfc_kind_max (i, j))
+	gfc_convert_type (j, &i->ts, 2);
+      else
+	gfc_convert_type (i, &j->ts, 2);
+    }
+
+  f->ts = i->ts;
+  f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind);
+}
+
+
+void
+gfc_resolve_iany (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+  resolve_transformational ("iany", f, array, dim, mask);
+}
+
+
+void
+gfc_resolve_ibclr (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
+{
+  f->ts = i->ts;
+  f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind);
+}
+
+
+void
+gfc_resolve_ibits (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED,
+		   gfc_expr *len ATTRIBUTE_UNUSED)
+{
+  f->ts = i->ts;
+  f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind);
+}
+
+
+void
+gfc_resolve_ibset (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
+{
+  f->ts = i->ts;
+  f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind);
+}
+
+
+void
+gfc_resolve_iachar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
+{
+  f->ts.type = BT_INTEGER;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
+  f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
+}
+
+
+void
+gfc_resolve_ichar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
+{
+  f->ts.type = BT_INTEGER;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
+  f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
+}
+
+
+void
+gfc_resolve_idnint (gfc_expr *f, gfc_expr *a)
+{
+  gfc_resolve_nint (f, a, NULL);
+}
+
+
+void
+gfc_resolve_ierrno (gfc_expr *f)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_default_integer_kind;
+  f->value.function.name = gfc_get_string (PREFIX ("ierrno_i%d"), f->ts.kind);
+}
+
+
+void
+gfc_resolve_ieor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
+{
+  /* If the kind of i and j are different, then g77 cross-promoted the
+     kinds to the largest value.  The Fortran 95 standard requires the 
+     kinds to match.  */
+  if (i->ts.kind != j->ts.kind)
+    {
+      if (i->ts.kind == gfc_kind_max (i, j))
+	gfc_convert_type (j, &i->ts, 2);
+      else
+	gfc_convert_type (i, &j->ts, 2);
+    }
+
+  f->ts = i->ts;
+  f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind);
+}
+
+
+void
+gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j)
+{
+  /* If the kind of i and j are different, then g77 cross-promoted the
+     kinds to the largest value.  The Fortran 95 standard requires the 
+     kinds to match.  */
+  if (i->ts.kind != j->ts.kind)
+    {
+      if (i->ts.kind == gfc_kind_max (i, j))
+	gfc_convert_type (j, &i->ts, 2);
+      else
+	gfc_convert_type (i, &j->ts, 2);
+    }
+
+  f->ts = i->ts;
+  f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind);
+}
+
+
+void
+gfc_resolve_index_func (gfc_expr *f, gfc_expr *str,
+			gfc_expr *sub_str ATTRIBUTE_UNUSED, gfc_expr *back,
+			gfc_expr *kind)
+{
+  gfc_typespec ts;
+  gfc_clear_ts (&ts);
+
+  f->ts.type = BT_INTEGER;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
+
+  if (back && back->ts.kind != gfc_default_integer_kind)
+    {
+      ts.type = BT_LOGICAL;
+      ts.kind = gfc_default_integer_kind;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
+      gfc_convert_type (back, &ts, 2);
+    }
+
+  f->value.function.name
+    = gfc_get_string ("__index_%d_i%d", str->ts.kind, f->ts.kind);
+}
+
+
+void
+gfc_resolve_int (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = (kind == NULL)
+	     ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
+  f->value.function.name
+    = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
+		      gfc_type_letter (a->ts.type), a->ts.kind);
+}
+
+
+void
+gfc_resolve_int2 (gfc_expr *f, gfc_expr *a)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = 2;
+  f->value.function.name
+    = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
+		      gfc_type_letter (a->ts.type), a->ts.kind);
+}
+
+
+void
+gfc_resolve_int8 (gfc_expr *f, gfc_expr *a)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = 8;
+  f->value.function.name
+    = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
+		      gfc_type_letter (a->ts.type), a->ts.kind);
+}
+
+
+void
+gfc_resolve_long (gfc_expr *f, gfc_expr *a)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = 4;
+  f->value.function.name
+    = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
+		      gfc_type_letter (a->ts.type), a->ts.kind);
+}
+
+
+void
+gfc_resolve_iparity (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+  resolve_transformational ("iparity", f, array, dim, mask);
+}
+
+
+void
+gfc_resolve_isatty (gfc_expr *f, gfc_expr *u)
+{
+  gfc_typespec ts;
+  gfc_clear_ts (&ts);
+  
+  f->ts.type = BT_LOGICAL;
+  f->ts.kind = gfc_default_integer_kind;
+  if (u->ts.kind != gfc_c_int_kind)
+    {
+      ts.type = BT_INTEGER;
+      ts.kind = gfc_c_int_kind;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
+      gfc_convert_type (u, &ts, 2);
+    }
+
+  f->value.function.name = gfc_get_string (PREFIX ("isatty_l%d"), f->ts.kind);
+}
+
+
+void
+gfc_resolve_ishft (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
+{
+  f->ts = i->ts;
+  f->value.function.name
+    = gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
+}
+
+
+void
+gfc_resolve_rshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
+{
+  f->ts = i->ts;
+  f->value.function.name
+    = gfc_get_string ("__rshift_%d_%d", i->ts.kind, shift->ts.kind);
+}
+
+
+void
+gfc_resolve_lshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
+{
+  f->ts = i->ts;
+  f->value.function.name
+    = gfc_get_string ("__lshift_%d_%d", i->ts.kind, shift->ts.kind);
+}
+
+
+void
+gfc_resolve_ishftc (gfc_expr *f, gfc_expr *i, gfc_expr *shift, gfc_expr *size)
+{
+  int s_kind;
+
+  s_kind = (size == NULL) ? gfc_default_integer_kind : size->ts.kind;
+
+  f->ts = i->ts;
+  f->value.function.name
+    = gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
+}
+
+
+void
+gfc_resolve_kill (gfc_expr *f, gfc_expr *p ATTRIBUTE_UNUSED,
+		  gfc_expr *s ATTRIBUTE_UNUSED)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_default_integer_kind;
+  f->value.function.name = gfc_get_string (PREFIX ("kill_i%d"), f->ts.kind);
+}
+
+
+void
+gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
+  resolve_bound (f, array, dim, kind, "__lbound", false);
+}
+
+
+void
+gfc_resolve_lcobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
+  resolve_bound (f, array, dim, kind, "__lcobound", true);
+}
+
+
+void
+gfc_resolve_len (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
+{
+  f->ts.type = BT_INTEGER;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
+  f->value.function.name
+    = gfc_get_string ("__len_%d_i%d", string->ts.kind,
+		      gfc_default_integer_kind);
+}
+
+
+void
+gfc_resolve_len_trim (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
+{
+  f->ts.type = BT_INTEGER;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
+  f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
+}
+
+
+void
+gfc_resolve_lgamma (gfc_expr *f, gfc_expr *x)
+{
+  f->ts = x->ts;
+  f->value.function.name
+    = gfc_get_string ("__lgamma_%d", x->ts.kind);
+}
+
+
+void
+gfc_resolve_link (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
+		  gfc_expr *p2 ATTRIBUTE_UNUSED)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_default_integer_kind;
+  f->value.function.name = gfc_get_string (PREFIX ("link_i%d"), f->ts.kind);
+}
+
+
+void
+gfc_resolve_loc (gfc_expr *f, gfc_expr *x)
+{
+  f->ts.type= BT_INTEGER;
+  f->ts.kind = gfc_index_integer_kind;
+  f->value.function.name = gfc_get_string ("__loc_%d", x->ts.kind);
+}
+
+
+void
+gfc_resolve_log (gfc_expr *f, gfc_expr *x)
+{
+  f->ts = x->ts;
+  f->value.function.name
+    = gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+}
+
+
+void
+gfc_resolve_log10 (gfc_expr *f, gfc_expr *x)
+{
+  f->ts = x->ts;
+  f->value.function.name
+    = gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type),
+		      x->ts.kind);
+}
+
+
+void
+gfc_resolve_logical (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
+{
+  f->ts.type = BT_LOGICAL;
+  f->ts.kind = (kind == NULL)
+	     ? gfc_default_logical_kind : mpz_get_si (kind->value.integer);
+  f->rank = a->rank;
+
+  f->value.function.name
+    = gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
+		      gfc_type_letter (a->ts.type), a->ts.kind);
+}
+
+
+void
+gfc_resolve_malloc (gfc_expr *f, gfc_expr *size)
+{
+  if (size->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 (size, &ts, 2, 0);
+    }
+
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_index_integer_kind;
+  f->value.function.name = gfc_get_string (PREFIX ("malloc"));
+}
+
+
+void
+gfc_resolve_matmul (gfc_expr *f, gfc_expr *a, gfc_expr *b)
+{
+  gfc_expr temp;
+
+  if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
+    {
+      f->ts.type = BT_LOGICAL;
+      f->ts.kind = gfc_default_logical_kind;
+    }
+  else
+    {
+      temp.expr_type = EXPR_OP;
+      gfc_clear_ts (&temp.ts);
+      temp.value.op.op = INTRINSIC_NONE;
+      temp.value.op.op1 = a;
+      temp.value.op.op2 = b;
+      gfc_type_convert_binary (&temp, 1);
+      f->ts = temp.ts;
+    }
+
+  f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
+
+  if (a->rank == 2 && b->rank == 2)
+    {
+      if (a->shape && b->shape)
+	{
+	  f->shape = gfc_get_shape (f->rank);
+	  mpz_init_set (f->shape[0], a->shape[0]);
+	  mpz_init_set (f->shape[1], b->shape[1]);
+	}
+    }
+  else if (a->rank == 1)
+    {
+      if (b->shape)
+	{
+	  f->shape = gfc_get_shape (f->rank);
+	  mpz_init_set (f->shape[0], b->shape[1]);
+	}
+    }
+  else 
+    {
+      /* b->rank == 1 and a->rank == 2 here, all other cases have
+	 been caught in check.c.   */
+      if (a->shape)
+	{
+	  f->shape = gfc_get_shape (f->rank);
+	  mpz_init_set (f->shape[0], a->shape[0]);
+	}
+    }
+
+  f->value.function.name
+    = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f->ts.type),
+		      f->ts.kind);
+}
+
+
+static void
+gfc_resolve_minmax (const char *name, gfc_expr *f, gfc_actual_arglist *args)
+{
+  gfc_actual_arglist *a;
+
+  f->ts.type = args->expr->ts.type;
+  f->ts.kind = args->expr->ts.kind;
+  /* Find the largest type kind.  */
+  for (a = args->next; a; a = a->next)
+    {
+      if (a->expr->ts.kind > f->ts.kind)
+	f->ts.kind = a->expr->ts.kind;
+    }
+
+  /* Convert all parameters to the required kind.  */
+  for (a = args; a; a = a->next)
+    {
+      if (a->expr->ts.kind != f->ts.kind)
+	gfc_convert_type (a->expr, &f->ts, 2);
+    }
+
+  f->value.function.name
+    = gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
+}
+
+
+void
+gfc_resolve_max (gfc_expr *f, gfc_actual_arglist *args)
+{
+  gfc_resolve_minmax ("__max_%c%d", f, args);
+}
+
+
+void
+gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
+		    gfc_expr *mask)
+{
+  const char *name;
+  int i, j, idim;
+
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_default_integer_kind;
+
+  if (dim == NULL)
+    {
+      f->rank = 1;
+      f->shape = gfc_get_shape (1);
+      mpz_init_set_si (f->shape[0], array->rank);
+    }
+  else
+    {
+      f->rank = array->rank - 1;
+      gfc_resolve_dim_arg (dim);
+      if (array->shape && dim->expr_type == EXPR_CONSTANT)
+	{
+	  idim = (int) mpz_get_si (dim->value.integer);
+	  f->shape = gfc_get_shape (f->rank);
+	  for (i = 0, j = 0; i < f->rank; i++, j++)
+	    {
+	      if (i == (idim - 1))
+		j++;
+	      mpz_init_set (f->shape[i], array->shape[j]);
+	    }
+	}
+    }
+
+  if (mask)
+    {
+      if (mask->rank == 0)
+	name = "smaxloc";
+      else
+	name = "mmaxloc";
+
+      resolve_mask_arg (mask);
+    }
+  else
+    name = "maxloc";
+
+  f->value.function.name
+    = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
+		      gfc_type_letter (array->ts.type), array->ts.kind);
+}
+
+
+void
+gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
+		    gfc_expr *mask)
+{
+  const char *name;
+  int i, j, idim;
+
+  f->ts = array->ts;
+
+  if (dim != NULL)
+    {
+      f->rank = array->rank - 1;
+      gfc_resolve_dim_arg (dim);
+
+      if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
+	{
+	  idim = (int) mpz_get_si (dim->value.integer);
+	  f->shape = gfc_get_shape (f->rank);
+	  for (i = 0, j = 0; i < f->rank; i++, j++)
+	    {
+	      if (i == (idim - 1))
+		j++;
+	      mpz_init_set (f->shape[i], array->shape[j]);
+	    }
+	}
+    }
+
+  if (mask)
+    {
+      if (mask->rank == 0)
+	name = "smaxval";
+      else
+	name = "mmaxval";
+
+      resolve_mask_arg (mask);
+    }
+  else
+    name = "maxval";
+
+  f->value.function.name
+    = gfc_get_string (PREFIX ("%s_%c%d"), name,
+		      gfc_type_letter (array->ts.type), array->ts.kind);
+}
+
+
+void
+gfc_resolve_mclock (gfc_expr *f)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = 4;
+  f->value.function.name = PREFIX ("mclock");
+}
+
+
+void
+gfc_resolve_mclock8 (gfc_expr *f)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = 8;
+  f->value.function.name = PREFIX ("mclock8");
+}
+
+
+void
+gfc_resolve_mask (gfc_expr *f, gfc_expr *i ATTRIBUTE_UNUSED,
+		  gfc_expr *kind)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = kind ? mpz_get_si (kind->value.integer)
+		    : gfc_default_integer_kind;
+
+  if (f->value.function.isym->id == GFC_ISYM_MASKL)
+    f->value.function.name = gfc_get_string ("__maskl_i%d", f->ts.kind);
+  else
+    f->value.function.name = gfc_get_string ("__maskr_i%d", f->ts.kind);
+}
+
+
+void
+gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource,
+		   gfc_expr *fsource ATTRIBUTE_UNUSED,
+		   gfc_expr *mask ATTRIBUTE_UNUSED)
+{
+  if (tsource->ts.type == BT_CHARACTER && tsource->ref)
+    gfc_resolve_substring_charlen (tsource);
+
+  if (fsource->ts.type == BT_CHARACTER && fsource->ref)
+    gfc_resolve_substring_charlen (fsource);
+
+  if (tsource->ts.type == BT_CHARACTER)
+    check_charlen_present (tsource);
+
+  f->ts = tsource->ts;
+  f->value.function.name
+    = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
+		      tsource->ts.kind);
+}
+
+
+void
+gfc_resolve_merge_bits (gfc_expr *f, gfc_expr *i,
+			gfc_expr *j ATTRIBUTE_UNUSED,
+			gfc_expr *mask ATTRIBUTE_UNUSED)
+{
+  f->ts = i->ts;
+  f->value.function.name = gfc_get_string ("__merge_bits_i%d", i->ts.kind);
+}
+
+
+void
+gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args)
+{
+  gfc_resolve_minmax ("__min_%c%d", f, args);
+}
+
+
+void
+gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
+		    gfc_expr *mask)
+{
+  const char *name;
+  int i, j, idim;
+
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_default_integer_kind;
+
+  if (dim == NULL)
+    {
+      f->rank = 1;
+      f->shape = gfc_get_shape (1);
+      mpz_init_set_si (f->shape[0], array->rank);
+    }
+  else
+    {
+      f->rank = array->rank - 1;
+      gfc_resolve_dim_arg (dim);
+      if (array->shape && dim->expr_type == EXPR_CONSTANT)
+	{
+	  idim = (int) mpz_get_si (dim->value.integer);
+	  f->shape = gfc_get_shape (f->rank);
+	  for (i = 0, j = 0; i < f->rank; i++, j++)
+	    {
+	      if (i == (idim - 1))
+		j++;
+	      mpz_init_set (f->shape[i], array->shape[j]);
+	    }
+	}
+    }
+
+  if (mask)
+    {
+      if (mask->rank == 0)
+	name = "sminloc";
+      else
+	name = "mminloc";
+
+      resolve_mask_arg (mask);
+    }
+  else
+    name = "minloc";
+
+  f->value.function.name
+    = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
+		      gfc_type_letter (array->ts.type), array->ts.kind);
+}
+
+
+void
+gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
+		    gfc_expr *mask)
+{
+  const char *name;
+  int i, j, idim;
+
+  f->ts = array->ts;
+
+  if (dim != NULL)
+    {
+      f->rank = array->rank - 1;
+      gfc_resolve_dim_arg (dim);
+
+      if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
+	{
+	  idim = (int) mpz_get_si (dim->value.integer);
+	  f->shape = gfc_get_shape (f->rank);
+	  for (i = 0, j = 0; i < f->rank; i++, j++)
+	    {
+	      if (i == (idim - 1))
+		j++;
+	      mpz_init_set (f->shape[i], array->shape[j]);
+	    }
+	}
+    }
+
+  if (mask)
+    {
+      if (mask->rank == 0)
+	name = "sminval";
+      else
+	name = "mminval";
+
+      resolve_mask_arg (mask);
+    }
+  else
+    name = "minval";
+
+  f->value.function.name
+    = gfc_get_string (PREFIX ("%s_%c%d"), name,
+		      gfc_type_letter (array->ts.type), array->ts.kind);
+}
+
+
+void
+gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p)
+{
+  f->ts.type = a->ts.type;
+  if (p != NULL)
+    f->ts.kind = gfc_kind_max (a,p);
+  else
+    f->ts.kind = a->ts.kind;
+
+  if (p != NULL && a->ts.kind != p->ts.kind)
+    {
+      if (a->ts.kind == gfc_kind_max (a,p))
+	gfc_convert_type (p, &a->ts, 2);
+      else
+	gfc_convert_type (a, &p->ts, 2);
+    }
+
+  f->value.function.name
+    = gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
+}
+
+
+void
+gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p)
+{
+  f->ts.type = a->ts.type;
+  if (p != NULL)
+    f->ts.kind = gfc_kind_max (a,p);
+  else
+    f->ts.kind = a->ts.kind;
+
+  if (p != NULL && a->ts.kind != p->ts.kind)
+    {
+      if (a->ts.kind == gfc_kind_max (a,p))
+	gfc_convert_type (p, &a->ts, 2);
+      else
+	gfc_convert_type (a, &p->ts, 2);
+    }
+
+  f->value.function.name
+    = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type),
+		      f->ts.kind);
+}
+
+void
+gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p)
+{
+  if (p->ts.kind != a->ts.kind)
+    gfc_convert_type (p, &a->ts, 2);
+
+  f->ts = a->ts;
+  f->value.function.name
+    = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
+		      a->ts.kind);
+}
+
+void
+gfc_resolve_nint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = (kind == NULL)
+	     ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
+  f->value.function.name
+    = gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
+}
+
+
+void
+gfc_resolve_norm2 (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
+{
+  resolve_transformational ("norm2", f, array, dim, NULL);
+}
+
+
+void
+gfc_resolve_not (gfc_expr *f, gfc_expr *i)
+{
+  f->ts = i->ts;
+  f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
+}
+
+
+void
+gfc_resolve_or (gfc_expr *f, gfc_expr *i, gfc_expr *j)
+{
+  f->ts.type = i->ts.type;
+  f->ts.kind = gfc_kind_max (i, j);
+
+  if (i->ts.kind != j->ts.kind)
+    {
+      if (i->ts.kind == gfc_kind_max (i, j))
+	gfc_convert_type (j, &i->ts, 2);
+      else
+	gfc_convert_type (i, &j->ts, 2);
+    }
+
+  f->value.function.name
+    = gfc_get_string ("__or_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
+}
+
+
+void
+gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
+		  gfc_expr *vector ATTRIBUTE_UNUSED)
+{
+  if (array->ts.type == BT_CHARACTER && array->ref)
+    gfc_resolve_substring_charlen (array);
+
+  f->ts = array->ts;
+  f->rank = 1;
+
+  resolve_mask_arg (mask);
+
+  if (mask->rank != 0)
+    {
+      if (array->ts.type == BT_CHARACTER)
+	f->value.function.name
+	  = array->ts.kind == 1 ? PREFIX ("pack_char")
+				: gfc_get_string
+					(PREFIX ("pack_char%d"),
+					 array->ts.kind);
+      else
+	f->value.function.name = PREFIX ("pack");
+    }
+  else
+    {
+      if (array->ts.type == BT_CHARACTER)
+	f->value.function.name
+	  = array->ts.kind == 1 ? PREFIX ("pack_s_char")
+				: gfc_get_string
+					(PREFIX ("pack_s_char%d"),
+					 array->ts.kind);
+      else
+	f->value.function.name = PREFIX ("pack_s");
+    }
+}
+
+
+void
+gfc_resolve_parity (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
+{
+  resolve_transformational ("parity", f, array, dim, NULL);
+}
+
+
+void
+gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
+		     gfc_expr *mask)
+{
+  resolve_transformational ("product", f, array, dim, mask);
+}
+
+
+void
+gfc_resolve_rank (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_default_integer_kind;
+  f->value.function.name = gfc_get_string ("__rank");
+}
+
+
+void
+gfc_resolve_real (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
+{
+  f->ts.type = BT_REAL;
+
+  if (kind != NULL)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = (a->ts.type == BT_COMPLEX)
+	       ? a->ts.kind : gfc_default_real_kind;
+
+  f->value.function.name
+    = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
+		      gfc_type_letter (a->ts.type), a->ts.kind);
+}
+
+
+void
+gfc_resolve_realpart (gfc_expr *f, gfc_expr *a)
+{
+  f->ts.type = BT_REAL;
+  f->ts.kind = a->ts.kind;
+  f->value.function.name
+    = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
+		      gfc_type_letter (a->ts.type), a->ts.kind);
+}
+
+
+void
+gfc_resolve_rename (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
+		    gfc_expr *p2 ATTRIBUTE_UNUSED)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_default_integer_kind;
+  f->value.function.name = gfc_get_string (PREFIX ("rename_i%d"), f->ts.kind);
+}
+
+
+void
+gfc_resolve_repeat (gfc_expr *f, gfc_expr *string,
+		    gfc_expr *ncopies)
+{
+  int len;
+  gfc_expr *tmp;
+  f->ts.type = BT_CHARACTER;
+  f->ts.kind = string->ts.kind;
+  f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
+
+  /* If possible, generate a character length.  */
+  if (f->ts.u.cl == NULL)
+    f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+
+  tmp = NULL;
+  if (string->expr_type == EXPR_CONSTANT)
+    {
+      len = string->value.character.length;
+      tmp = gfc_get_int_expr (gfc_default_integer_kind, NULL , len);
+    }
+  else if (string->ts.u.cl && string->ts.u.cl->length)
+    {
+      tmp = gfc_copy_expr (string->ts.u.cl->length);
+    }
+
+  if (tmp)
+    f->ts.u.cl->length = gfc_multiply (tmp, gfc_copy_expr (ncopies));
+}
+
+
+void
+gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
+		     gfc_expr *pad ATTRIBUTE_UNUSED,
+		     gfc_expr *order ATTRIBUTE_UNUSED)
+{
+  mpz_t rank;
+  int kind;
+  int i;
+
+  if (source->ts.type == BT_CHARACTER && source->ref)
+    gfc_resolve_substring_charlen (source);
+
+  f->ts = source->ts;
+
+  gfc_array_size (shape, &rank);
+  f->rank = mpz_get_si (rank);
+  mpz_clear (rank);
+  switch (source->ts.type)
+    {
+    case BT_COMPLEX:
+    case BT_REAL:
+    case BT_INTEGER:
+    case BT_LOGICAL:
+    case BT_CHARACTER:
+      kind = source->ts.kind;
+      break;
+
+    default:
+      kind = 0;
+      break;
+    }
+
+  switch (kind)
+    {
+    case 4:
+    case 8:
+    case 10:
+    case 16:
+      if (source->ts.type == BT_COMPLEX || source->ts.type == BT_REAL)
+	f->value.function.name
+	  = gfc_get_string (PREFIX ("reshape_%c%d"),
+			    gfc_type_letter (source->ts.type),
+			    source->ts.kind);
+      else if (source->ts.type == BT_CHARACTER)
+	f->value.function.name = gfc_get_string (PREFIX ("reshape_char%d"),
+						 kind);
+      else
+	f->value.function.name
+	  = gfc_get_string (PREFIX ("reshape_%d"), source->ts.kind);
+      break;
+
+    default:
+      f->value.function.name = (source->ts.type == BT_CHARACTER
+				? PREFIX ("reshape_char") : PREFIX ("reshape"));
+      break;
+    }
+
+  if (shape->expr_type == EXPR_ARRAY && gfc_is_constant_expr (shape))
+    {
+      gfc_constructor *c;
+      f->shape = gfc_get_shape (f->rank);
+      c = gfc_constructor_first (shape->value.constructor);
+      for (i = 0; i < f->rank; i++)
+	{
+	  mpz_init_set (f->shape[i], c->expr->value.integer);
+	  c = gfc_constructor_next (c);
+	}
+    }
+
+  /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
+     so many runtime variations.  */
+  if (shape->ts.kind != gfc_index_integer_kind)
+    {
+      gfc_typespec ts = shape->ts;
+      ts.kind = gfc_index_integer_kind;
+      gfc_convert_type_warn (shape, &ts, 2, 0);
+    }
+  if (order && order->ts.kind != gfc_index_integer_kind)
+    gfc_convert_type_warn (order, &shape->ts, 2, 0);
+}
+
+
+void
+gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x)
+{
+  f->ts = x->ts;
+  f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
+}
+
+
+void
+gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i ATTRIBUTE_UNUSED)
+{
+  f->ts = x->ts;
+  f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
+}
+
+
+void
+gfc_resolve_scan (gfc_expr *f, gfc_expr *string,
+		  gfc_expr *set ATTRIBUTE_UNUSED,
+		  gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
+{
+  f->ts.type = BT_INTEGER;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
+  f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
+}
+
+
+void
+gfc_resolve_secnds (gfc_expr *t1, gfc_expr *t0)
+{
+  t1->ts = t0->ts;
+  t1->value.function.name = gfc_get_string (PREFIX ("secnds"));
+}
+
+
+void
+gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x,
+			  gfc_expr *i ATTRIBUTE_UNUSED)
+{
+  f->ts = x->ts;
+  f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
+}
+
+
+void
+gfc_resolve_shape (gfc_expr *f, gfc_expr *array, gfc_expr *kind)
+{
+  f->ts.type = BT_INTEGER;
+
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
+
+  f->rank = 1;
+  if (array->rank != -1)
+    {
+      f->shape = gfc_get_shape (1);
+      mpz_init_set_ui (f->shape[0], array->rank);
+    }
+
+  f->value.function.name = gfc_get_string (PREFIX ("shape_%d"), f->ts.kind);
+}
+
+
+void
+gfc_resolve_shift (gfc_expr *f, gfc_expr *i, gfc_expr *shift ATTRIBUTE_UNUSED)
+{
+  f->ts = i->ts;
+  if (f->value.function.isym->id == GFC_ISYM_SHIFTA)
+    f->value.function.name = gfc_get_string ("shifta_i%d", f->ts.kind);
+  else if (f->value.function.isym->id == GFC_ISYM_SHIFTL)
+    f->value.function.name = gfc_get_string ("shiftl_i%d", f->ts.kind);
+  else if (f->value.function.isym->id == GFC_ISYM_SHIFTR)
+    f->value.function.name = gfc_get_string ("shiftr_i%d", f->ts.kind);
+  else
+    gcc_unreachable ();
+}
+
+
+void
+gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED)
+{
+  f->ts = a->ts;
+  f->value.function.name
+    = gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
+}
+
+
+void
+gfc_resolve_signal (gfc_expr *f, gfc_expr *number, gfc_expr *handler)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_c_int_kind;
+
+  /* handler can be either BT_INTEGER or BT_PROCEDURE  */
+  if (handler->ts.type == BT_INTEGER)
+    {
+      if (handler->ts.kind != gfc_c_int_kind)
+	gfc_convert_type (handler, &f->ts, 2);
+      f->value.function.name = gfc_get_string (PREFIX ("signal_func_int"));
+    }
+  else
+    f->value.function.name = gfc_get_string (PREFIX ("signal_func"));
+
+  if (number->ts.kind != gfc_c_int_kind)
+    gfc_convert_type (number, &f->ts, 2);
+}
+
+
+void
+gfc_resolve_sin (gfc_expr *f, gfc_expr *x)
+{
+  f->ts = x->ts;
+  f->value.function.name
+    = gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+}
+
+
+void
+gfc_resolve_sinh (gfc_expr *f, gfc_expr *x)
+{
+  f->ts = x->ts;
+  f->value.function.name
+    = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+}
+
+
+void
+gfc_resolve_size (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
+		  gfc_expr *dim ATTRIBUTE_UNUSED, gfc_expr *kind)
+{
+  f->ts.type = BT_INTEGER;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
+}
+
+
+void
+gfc_resolve_stride (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
+		  gfc_expr *dim ATTRIBUTE_UNUSED)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_index_integer_kind;
+}
+
+
+void
+gfc_resolve_spacing (gfc_expr *f, gfc_expr *x)
+{
+  f->ts = x->ts;
+  f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
+}
+
+
+void
+gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
+		    gfc_expr *ncopies)
+{
+  if (source->ts.type == BT_CHARACTER && source->ref)
+    gfc_resolve_substring_charlen (source);
+
+  if (source->ts.type == BT_CHARACTER)
+    check_charlen_present (source);
+
+  f->ts = source->ts;
+  f->rank = source->rank + 1;
+  if (source->rank == 0)
+    {
+      if (source->ts.type == BT_CHARACTER)
+	f->value.function.name
+	  = source->ts.kind == 1 ? PREFIX ("spread_char_scalar")
+				 : gfc_get_string
+					(PREFIX ("spread_char%d_scalar"),
+					 source->ts.kind);
+      else
+	f->value.function.name = PREFIX ("spread_scalar");
+    }
+  else
+    {
+      if (source->ts.type == BT_CHARACTER)
+	f->value.function.name
+	  = source->ts.kind == 1 ? PREFIX ("spread_char")
+				 : gfc_get_string
+					(PREFIX ("spread_char%d"),
+					 source->ts.kind);
+      else
+	f->value.function.name = PREFIX ("spread");
+    }
+
+  if (dim && gfc_is_constant_expr (dim)
+      && ncopies && gfc_is_constant_expr (ncopies) && source->shape[0])
+    {
+      int i, idim;
+      idim = mpz_get_ui (dim->value.integer);
+      f->shape = gfc_get_shape (f->rank);
+      for (i = 0; i < (idim - 1); i++)
+	mpz_init_set (f->shape[i], source->shape[i]);
+
+      mpz_init_set (f->shape[idim - 1], ncopies->value.integer);
+
+      for (i = idim; i < f->rank ; i++)
+	mpz_init_set (f->shape[i], source->shape[i-1]);
+    }
+
+
+  gfc_resolve_dim_arg (dim);
+  gfc_resolve_index (ncopies, 1);
+}
+
+
+void
+gfc_resolve_sqrt (gfc_expr *f, gfc_expr *x)
+{
+  f->ts = x->ts;
+  f->value.function.name
+    = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+}
+
+
+/* Resolve the g77 compatibility function STAT AND FSTAT.  */
+
+void
+gfc_resolve_stat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
+		  gfc_expr *a ATTRIBUTE_UNUSED)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_default_integer_kind;
+  f->value.function.name = gfc_get_string (PREFIX ("stat_i%d"), f->ts.kind);
+}
+
+
+void
+gfc_resolve_lstat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
+		   gfc_expr *a ATTRIBUTE_UNUSED)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_default_integer_kind;
+  f->value.function.name = gfc_get_string (PREFIX ("lstat_i%d"), f->ts.kind);
+}
+
+
+void
+gfc_resolve_fstat (gfc_expr *f, gfc_expr *n, gfc_expr *a ATTRIBUTE_UNUSED)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_default_integer_kind;
+  if (n->ts.kind != f->ts.kind)
+    gfc_convert_type (n, &f->ts, 2);
+
+  f->value.function.name = gfc_get_string (PREFIX ("fstat_i%d"), f->ts.kind);
+}
+
+
+void
+gfc_resolve_fgetc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
+{
+  gfc_typespec ts;
+  gfc_clear_ts (&ts);
+
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_c_int_kind;
+  if (u->ts.kind != gfc_c_int_kind)
+    {
+      ts.type = BT_INTEGER;
+      ts.kind = gfc_c_int_kind;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
+      gfc_convert_type (u, &ts, 2);
+    }
+
+  f->value.function.name = gfc_get_string (PREFIX ("fgetc"));
+}
+
+
+void
+gfc_resolve_fget (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_c_int_kind;
+  f->value.function.name = gfc_get_string (PREFIX ("fget"));
+}
+
+
+void
+gfc_resolve_fputc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
+{
+  gfc_typespec ts;
+  gfc_clear_ts (&ts);
+
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_c_int_kind;
+  if (u->ts.kind != gfc_c_int_kind)
+    {
+      ts.type = BT_INTEGER;
+      ts.kind = gfc_c_int_kind;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
+      gfc_convert_type (u, &ts, 2);
+    }
+
+  f->value.function.name = gfc_get_string (PREFIX ("fputc"));
+}
+
+
+void
+gfc_resolve_fput (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_c_int_kind;
+  f->value.function.name = gfc_get_string (PREFIX ("fput"));
+}
+
+
+void
+gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
+{
+  gfc_typespec ts;
+  gfc_clear_ts (&ts);
+
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_intio_kind;
+  if (u->ts.kind != gfc_c_int_kind)
+    {
+      ts.type = BT_INTEGER;
+      ts.kind = gfc_c_int_kind;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
+      gfc_convert_type (u, &ts, 2);
+    }
+
+  f->value.function.name = gfc_get_string (PREFIX ("ftell2"));
+}
+
+
+void
+gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
+			  gfc_expr *kind)
+{
+  f->ts.type = BT_INTEGER;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
+}
+
+
+void
+gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+  resolve_transformational ("sum", f, array, dim, mask);
+}
+
+
+void
+gfc_resolve_symlnk (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
+		    gfc_expr *p2 ATTRIBUTE_UNUSED)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_default_integer_kind;
+  f->value.function.name = gfc_get_string (PREFIX ("symlnk_i%d"), f->ts.kind);
+}
+
+
+/* Resolve the g77 compatibility function SYSTEM.  */
+
+void
+gfc_resolve_system (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = 4;
+  f->value.function.name = gfc_get_string (PREFIX ("system"));
+}
+
+
+void
+gfc_resolve_tan (gfc_expr *f, gfc_expr *x)
+{
+  f->ts = x->ts;
+  f->value.function.name
+    = gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+}
+
+
+void
+gfc_resolve_tanh (gfc_expr *f, gfc_expr *x)
+{
+  f->ts = x->ts;
+  f->value.function.name
+    = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+}
+
+
+void
+gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
+			 gfc_expr *sub ATTRIBUTE_UNUSED)
+{
+  static char image_index[] = "__image_index";
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_default_integer_kind;
+  f->value.function.name = image_index;
+}
+
+
+void
+gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
+{
+  static char this_image[] = "__this_image";
+  if (array)
+    resolve_bound (f, array, dim, NULL, "__this_image", true);
+  else
+    {
+      f->ts.type = BT_INTEGER;
+      f->ts.kind = gfc_default_integer_kind;
+      f->value.function.name = this_image;
+    }
+}
+
+
+void
+gfc_resolve_time (gfc_expr *f)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = 4;
+  f->value.function.name = gfc_get_string (PREFIX ("time_func"));
+}
+
+
+void
+gfc_resolve_time8 (gfc_expr *f)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = 8;
+  f->value.function.name = gfc_get_string (PREFIX ("time8_func"));
+}
+
+
+void
+gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
+		      gfc_expr *mold, gfc_expr *size)
+{
+  /* TODO: Make this do something meaningful.  */
+  static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
+
+  if (mold->ts.type == BT_CHARACTER
+	&& !mold->ts.u.cl->length
+	&& gfc_is_constant_expr (mold))
+    {
+      int len;
+      if (mold->expr_type == EXPR_CONSTANT)
+        {
+	  len = mold->value.character.length;
+	  mold->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
+						    NULL, len);
+	}
+      else
+	{
+	  gfc_constructor *c = gfc_constructor_first (mold->value.constructor);
+	  len = c->expr->value.character.length;
+	  mold->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
+						    NULL, len);
+	}
+    }
+
+  f->ts = mold->ts;
+
+  if (size == NULL && mold->rank == 0)
+    {
+      f->rank = 0;
+      f->value.function.name = transfer0;
+    }
+  else
+    {
+      f->rank = 1;
+      f->value.function.name = transfer1;
+      if (size && gfc_is_constant_expr (size))
+	{
+	  f->shape = gfc_get_shape (1);
+	  mpz_init_set (f->shape[0], size->value.integer);
+	}
+    }
+}
+
+
+void
+gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
+{
+
+  if (matrix->ts.type == BT_CHARACTER && matrix->ref)
+    gfc_resolve_substring_charlen (matrix);
+
+  f->ts = matrix->ts;
+  f->rank = 2;
+  if (matrix->shape)
+    {
+      f->shape = gfc_get_shape (2);
+      mpz_init_set (f->shape[0], matrix->shape[1]);
+      mpz_init_set (f->shape[1], matrix->shape[0]);
+    }
+
+  switch (matrix->ts.kind)
+    {
+    case 4:
+    case 8:
+    case 10:
+    case 16:
+      switch (matrix->ts.type)
+	{
+	case BT_REAL:
+	case BT_COMPLEX:
+	  f->value.function.name
+	    = gfc_get_string (PREFIX ("transpose_%c%d"),
+			      gfc_type_letter (matrix->ts.type),
+			      matrix->ts.kind);
+	  break;
+
+	case BT_INTEGER:
+	case BT_LOGICAL:
+	  /* Use the integer routines for real and logical cases.  This
+	     assumes they all have the same alignment requirements.  */
+	  f->value.function.name
+	    = gfc_get_string (PREFIX ("transpose_i%d"), matrix->ts.kind);
+	  break;
+
+	default:
+	  if (matrix->ts.type == BT_CHARACTER && matrix->ts.kind == 4)
+	    f->value.function.name = PREFIX ("transpose_char4");
+	  else
+	    f->value.function.name = PREFIX ("transpose");
+	  break;
+	}
+      break;
+
+    default:
+      f->value.function.name = (matrix->ts.type == BT_CHARACTER
+				? PREFIX ("transpose_char")
+				: PREFIX ("transpose"));
+      break;
+    }
+}
+
+
+void
+gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
+{
+  f->ts.type = BT_CHARACTER;
+  f->ts.kind = string->ts.kind;
+  f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
+}
+
+
+void
+gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
+  resolve_bound (f, array, dim, kind, "__ubound", false);
+}
+
+
+void
+gfc_resolve_ucobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
+  resolve_bound (f, array, dim, kind, "__ucobound", true);
+}
+
+
+/* Resolve the g77 compatibility function UMASK.  */
+
+void
+gfc_resolve_umask (gfc_expr *f, gfc_expr *n)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = n->ts.kind;
+  f->value.function.name = gfc_get_string (PREFIX ("umask_i%d"), n->ts.kind);
+}
+
+
+/* Resolve the g77 compatibility function UNLINK.  */
+
+void
+gfc_resolve_unlink (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = 4;
+  f->value.function.name = gfc_get_string (PREFIX ("unlink"));
+}
+
+
+void
+gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit)
+{
+  gfc_typespec ts;
+  gfc_clear_ts (&ts);
+  
+  f->ts.type = BT_CHARACTER;
+  f->ts.kind = gfc_default_character_kind;
+
+  if (unit->ts.kind != gfc_c_int_kind)
+    {
+      ts.type = BT_INTEGER;
+      ts.kind = gfc_c_int_kind;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
+      gfc_convert_type (unit, &ts, 2);
+    }
+
+  f->value.function.name = gfc_get_string (PREFIX ("ttynam"));
+}
+
+
+void
+gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
+		    gfc_expr *field ATTRIBUTE_UNUSED)
+{
+  if (vector->ts.type == BT_CHARACTER && vector->ref)
+    gfc_resolve_substring_charlen (vector);
+
+  f->ts = vector->ts;
+  f->rank = mask->rank;
+  resolve_mask_arg (mask);
+
+  if (vector->ts.type == BT_CHARACTER)
+    {
+      if (vector->ts.kind == 1)
+	f->value.function.name
+	  = gfc_get_string (PREFIX ("unpack%d_char"), field->rank > 0 ? 1 : 0);
+      else
+	f->value.function.name
+	  = gfc_get_string (PREFIX ("unpack%d_char%d"),
+			    field->rank > 0 ? 1 : 0, vector->ts.kind);
+    }
+  else
+    f->value.function.name
+      = gfc_get_string (PREFIX ("unpack%d"), field->rank > 0 ? 1 : 0);
+}
+
+
+void
+gfc_resolve_verify (gfc_expr *f, gfc_expr *string,
+		    gfc_expr *set ATTRIBUTE_UNUSED,
+		    gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
+{
+  f->ts.type = BT_INTEGER;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
+  f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
+}
+
+
+void
+gfc_resolve_xor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
+{
+  f->ts.type = i->ts.type;
+  f->ts.kind = gfc_kind_max (i, j);
+
+  if (i->ts.kind != j->ts.kind)
+    {
+      if (i->ts.kind == gfc_kind_max (i, j))
+	gfc_convert_type (j, &i->ts, 2);
+      else
+	gfc_convert_type (i, &j->ts, 2);
+    }
+
+  f->value.function.name
+    = gfc_get_string ("__xor_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
+}
+
+
+/* Intrinsic subroutine resolution.  */
+
+void
+gfc_resolve_alarm_sub (gfc_code *c)
+{
+  const char *name;
+  gfc_expr *seconds, *handler;
+  gfc_typespec ts;
+  gfc_clear_ts (&ts);
+
+  seconds = c->ext.actual->expr;
+  handler = c->ext.actual->next->expr;
+  ts.type = BT_INTEGER;
+  ts.kind = gfc_c_int_kind;
+
+  /* handler can be either BT_INTEGER or BT_PROCEDURE.
+     In all cases, the status argument is of default integer kind
+     (enforced in check.c) so that the function suffix is fixed.  */
+  if (handler->ts.type == BT_INTEGER)
+    {
+      if (handler->ts.kind != gfc_c_int_kind)
+	gfc_convert_type (handler, &ts, 2);
+      name = gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
+			     gfc_default_integer_kind);
+    }
+  else
+    name = gfc_get_string (PREFIX ("alarm_sub_i%d"),
+			   gfc_default_integer_kind);
+
+  if (seconds->ts.kind != gfc_c_int_kind)
+    gfc_convert_type (seconds, &ts, 2);
+
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+void
+gfc_resolve_cpu_time (gfc_code *c)
+{
+  const char *name;
+  name = gfc_get_string (PREFIX ("cpu_time_%d"), c->ext.actual->expr->ts.kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+/* Create a formal arglist based on an actual one and set the INTENTs given.  */
+
+static gfc_formal_arglist*
+create_formal_for_intents (gfc_actual_arglist* actual, const sym_intent* ints)
+{
+  gfc_formal_arglist* head;
+  gfc_formal_arglist* tail;
+  int i;
+
+  if (!actual)
+    return NULL;
+
+  head = tail = gfc_get_formal_arglist ();
+  for (i = 0; actual; actual = actual->next, tail = tail->next, ++i)
+    {
+      gfc_symbol* sym;
+
+      sym = gfc_new_symbol ("dummyarg", NULL);
+      sym->ts = actual->expr->ts;
+
+      sym->attr.intent = ints[i];
+      tail->sym = sym;
+
+      if (actual->next)
+	tail->next = gfc_get_formal_arglist ();
+    }
+
+  return head;
+}
+
+
+void
+gfc_resolve_atomic_def (gfc_code *c)
+{
+  const char *name = "atomic_define";
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
+gfc_resolve_atomic_ref (gfc_code *c)
+{
+  const char *name = "atomic_ref";
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
+gfc_resolve_mvbits (gfc_code *c)
+{
+  static const sym_intent INTENTS[] = {INTENT_IN, INTENT_IN, INTENT_IN,
+				       INTENT_INOUT, INTENT_IN};
+
+  const char *name;
+  gfc_typespec ts;
+  gfc_clear_ts (&ts);
+
+  /* FROMPOS, LEN and TOPOS are restricted to small values.  As such,
+     they will be converted so that they fit into a C int.  */
+  ts.type = BT_INTEGER;
+  ts.kind = gfc_c_int_kind;
+  if (c->ext.actual->next->expr->ts.kind != gfc_c_int_kind)
+    gfc_convert_type (c->ext.actual->next->expr, &ts, 2);
+  if (c->ext.actual->next->next->expr->ts.kind != gfc_c_int_kind)
+    gfc_convert_type (c->ext.actual->next->next->expr, &ts, 2);
+  if (c->ext.actual->next->next->next->next->expr->ts.kind != gfc_c_int_kind)
+    gfc_convert_type (c->ext.actual->next->next->next->next->expr, &ts, 2);
+
+  /* TO and FROM are guaranteed to have the same kind parameter.  */
+  name = gfc_get_string (PREFIX ("mvbits_i%d"),
+			 c->ext.actual->expr->ts.kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  /* Mark as elemental subroutine as this does not happen automatically.  */
+  c->resolved_sym->attr.elemental = 1;
+
+  /* Create a dummy formal arglist so the INTENTs are known later for purpose
+     of creating temporaries.  */
+  c->resolved_sym->formal = create_formal_for_intents (c->ext.actual, INTENTS);
+}
+
+
+void
+gfc_resolve_random_number (gfc_code *c)
+{
+  const char *name;
+  int kind;
+
+  kind = c->ext.actual->expr->ts.kind;
+  if (c->ext.actual->expr->rank == 0)
+    name = gfc_get_string (PREFIX ("random_r%d"), kind);
+  else
+    name = gfc_get_string (PREFIX ("arandom_r%d"), kind);
+  
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
+gfc_resolve_random_seed (gfc_code *c)
+{
+  const char *name;
+
+  name = gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
+gfc_resolve_rename_sub (gfc_code *c)
+{
+  const char *name;
+  int kind;
+
+  if (c->ext.actual->next->next->expr != NULL)
+    kind = c->ext.actual->next->next->expr->ts.kind;
+  else
+    kind = gfc_default_integer_kind;
+
+  name = gfc_get_string (PREFIX ("rename_i%d_sub"), kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
+gfc_resolve_kill_sub (gfc_code *c)
+{
+  const char *name;
+  int kind;
+
+  if (c->ext.actual->next->next->expr != NULL)
+    kind = c->ext.actual->next->next->expr->ts.kind;
+  else
+    kind = gfc_default_integer_kind;
+
+  name = gfc_get_string (PREFIX ("kill_i%d_sub"), kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+    
+
+void
+gfc_resolve_link_sub (gfc_code *c)
+{
+  const char *name;
+  int kind;
+
+  if (c->ext.actual->next->next->expr != NULL)
+    kind = c->ext.actual->next->next->expr->ts.kind;
+  else
+    kind = gfc_default_integer_kind;
+
+  name = gfc_get_string (PREFIX ("link_i%d_sub"), kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
+gfc_resolve_symlnk_sub (gfc_code *c)
+{
+  const char *name;
+  int kind;
+
+  if (c->ext.actual->next->next->expr != NULL)
+    kind = c->ext.actual->next->next->expr->ts.kind;
+  else
+    kind = gfc_default_integer_kind;
+
+  name = gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+/* G77 compatibility subroutines dtime() and etime().  */
+
+void
+gfc_resolve_dtime_sub (gfc_code *c)
+{
+  const char *name;
+  name = gfc_get_string (PREFIX ("dtime_sub"));
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+void
+gfc_resolve_etime_sub (gfc_code *c)
+{
+  const char *name;
+  name = gfc_get_string (PREFIX ("etime_sub"));
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+/* G77 compatibility subroutines itime(), idate(), ltime() and gmtime().  */
+
+void
+gfc_resolve_itime (gfc_code *c)
+{
+  c->resolved_sym
+    = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
+						    gfc_default_integer_kind));
+}
+
+void
+gfc_resolve_idate (gfc_code *c)
+{
+  c->resolved_sym
+    = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
+						    gfc_default_integer_kind));
+}
+
+void
+gfc_resolve_ltime (gfc_code *c)
+{
+  c->resolved_sym
+    = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
+						    gfc_default_integer_kind));
+}
+
+void
+gfc_resolve_gmtime (gfc_code *c)
+{
+  c->resolved_sym
+    = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
+						    gfc_default_integer_kind));
+}
+
+
+/* G77 compatibility subroutine second().  */
+
+void
+gfc_resolve_second_sub (gfc_code *c)
+{
+  const char *name;
+  name = gfc_get_string (PREFIX ("second_sub"));
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
+gfc_resolve_sleep_sub (gfc_code *c)
+{
+  const char *name;
+  int kind;
+
+  if (c->ext.actual->expr != NULL)
+    kind = c->ext.actual->expr->ts.kind;
+  else
+    kind = gfc_default_integer_kind;
+
+  name = gfc_get_string (PREFIX ("sleep_i%d_sub"), kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+/* G77 compatibility function srand().  */
+
+void
+gfc_resolve_srand (gfc_code *c)
+{
+  const char *name;
+  name = gfc_get_string (PREFIX ("srand"));
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+/* Resolve the getarg intrinsic subroutine.  */
+
+void
+gfc_resolve_getarg (gfc_code *c)
+{
+  const char *name;
+
+  if (c->ext.actual->expr->ts.kind != gfc_default_integer_kind)
+    {
+      gfc_typespec ts;
+      gfc_clear_ts (&ts);
+
+      ts.type = BT_INTEGER;
+      ts.kind = gfc_default_integer_kind;
+
+      gfc_convert_type (c->ext.actual->expr, &ts, 2);
+    }
+
+  name = gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+/* Resolve the getcwd intrinsic subroutine.  */
+
+void
+gfc_resolve_getcwd_sub (gfc_code *c)
+{
+  const char *name;
+  int kind;
+
+  if (c->ext.actual->next->expr != NULL)
+    kind = c->ext.actual->next->expr->ts.kind;
+  else
+    kind = gfc_default_integer_kind;
+
+  name = gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+/* Resolve the get_command intrinsic subroutine.  */
+
+void
+gfc_resolve_get_command (gfc_code *c)
+{
+  const char *name;
+  int kind;
+  kind = gfc_default_integer_kind;
+  name = gfc_get_string (PREFIX ("get_command_i%d"), kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+/* Resolve the get_command_argument intrinsic subroutine.  */
+
+void
+gfc_resolve_get_command_argument (gfc_code *c)
+{
+  const char *name;
+  int kind;
+  kind = gfc_default_integer_kind;
+  name = gfc_get_string (PREFIX ("get_command_argument_i%d"), kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+/* Resolve the get_environment_variable intrinsic subroutine.  */
+
+void
+gfc_resolve_get_environment_variable (gfc_code *code)
+{
+  const char *name;
+  int kind;
+  kind = gfc_default_integer_kind;
+  name = gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind);
+  code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
+gfc_resolve_signal_sub (gfc_code *c)
+{
+  const char *name;
+  gfc_expr *number, *handler, *status;
+  gfc_typespec ts;
+  gfc_clear_ts (&ts);
+
+  number = c->ext.actual->expr;
+  handler = c->ext.actual->next->expr;
+  status = c->ext.actual->next->next->expr;
+  ts.type = BT_INTEGER;
+  ts.kind = gfc_c_int_kind;
+
+  /* handler can be either BT_INTEGER or BT_PROCEDURE  */
+  if (handler->ts.type == BT_INTEGER)
+    {
+      if (handler->ts.kind != gfc_c_int_kind)
+	gfc_convert_type (handler, &ts, 2);
+      name = gfc_get_string (PREFIX ("signal_sub_int"));
+    }
+  else
+    name = gfc_get_string (PREFIX ("signal_sub"));
+
+  if (number->ts.kind != gfc_c_int_kind)
+    gfc_convert_type (number, &ts, 2);
+  if (status != NULL && status->ts.kind != gfc_c_int_kind)
+    gfc_convert_type (status, &ts, 2);
+
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+/* Resolve the SYSTEM intrinsic subroutine.  */
+
+void
+gfc_resolve_system_sub (gfc_code *c)
+{
+  const char *name;
+  name = gfc_get_string (PREFIX ("system_sub"));
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+/* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
+
+void
+gfc_resolve_system_clock (gfc_code *c)
+{
+  const char *name;
+  int kind;
+
+  if (c->ext.actual->expr != NULL)
+    kind = c->ext.actual->expr->ts.kind;
+  else if (c->ext.actual->next->expr != NULL)
+      kind = c->ext.actual->next->expr->ts.kind;
+  else if (c->ext.actual->next->next->expr != NULL)
+      kind = c->ext.actual->next->next->expr->ts.kind;
+  else
+    kind = gfc_default_integer_kind;
+
+  name = gfc_get_string (PREFIX ("system_clock_%d"), kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+/* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine.  */
+void
+gfc_resolve_execute_command_line (gfc_code *c)
+{
+  const char *name;
+  name = gfc_get_string (PREFIX ("execute_command_line_i%d"),
+			 gfc_default_integer_kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+/* Resolve the EXIT intrinsic subroutine.  */
+
+void
+gfc_resolve_exit (gfc_code *c)
+{
+  const char *name;
+  gfc_typespec ts;
+  gfc_expr *n;
+  gfc_clear_ts (&ts);
+
+  /* The STATUS argument has to be of default kind.  If it is not,
+     we convert it.  */
+  ts.type = BT_INTEGER;
+  ts.kind = gfc_default_integer_kind;
+  n = c->ext.actual->expr;
+  if (n != NULL && n->ts.kind != ts.kind)
+    gfc_convert_type (n, &ts, 2);
+
+  name = gfc_get_string (PREFIX ("exit_i%d"), ts.kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+/* Resolve the FLUSH intrinsic subroutine.  */
+
+void
+gfc_resolve_flush (gfc_code *c)
+{
+  const char *name;
+  gfc_typespec ts;
+  gfc_expr *n;
+  gfc_clear_ts (&ts);
+
+  ts.type = BT_INTEGER;
+  ts.kind = gfc_default_integer_kind;
+  n = c->ext.actual->expr;
+  if (n != NULL && n->ts.kind != ts.kind)
+    gfc_convert_type (n, &ts, 2);
+
+  name = gfc_get_string (PREFIX ("flush_i%d"), ts.kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
+gfc_resolve_free (gfc_code *c)
+{
+  gfc_typespec ts;
+  gfc_expr *n;
+  gfc_clear_ts (&ts);
+
+  ts.type = BT_INTEGER;
+  ts.kind = gfc_index_integer_kind;
+  n = c->ext.actual->expr;
+  if (n->ts.kind != ts.kind)
+    gfc_convert_type (n, &ts, 2);
+
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("free"));
+}
+
+
+void
+gfc_resolve_ctime_sub (gfc_code *c)
+{
+  gfc_typespec ts;
+  gfc_clear_ts (&ts);
+  
+  /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
+  if (c->ext.actual->expr->ts.kind != 8)
+    {
+      ts.type = BT_INTEGER;
+      ts.kind = 8;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
+      gfc_convert_type (c->ext.actual->expr, &ts, 2);
+    }
+
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
+}
+
+
+void
+gfc_resolve_fdate_sub (gfc_code *c)
+{
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
+}
+
+
+void
+gfc_resolve_gerror (gfc_code *c)
+{
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
+}
+
+
+void
+gfc_resolve_getlog (gfc_code *c)
+{
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
+}
+
+
+void
+gfc_resolve_hostnm_sub (gfc_code *c)
+{
+  const char *name;
+  int kind;
+
+  if (c->ext.actual->next->expr != NULL)
+    kind = c->ext.actual->next->expr->ts.kind;
+  else
+    kind = gfc_default_integer_kind;
+
+  name = gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
+gfc_resolve_perror (gfc_code *c)
+{
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
+}
+
+/* Resolve the STAT and FSTAT intrinsic subroutines.  */
+
+void
+gfc_resolve_stat_sub (gfc_code *c)
+{
+  const char *name;
+  name = gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
+gfc_resolve_lstat_sub (gfc_code *c)
+{
+  const char *name;
+  name = gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
+gfc_resolve_fstat_sub (gfc_code *c)
+{
+  const char *name;
+  gfc_expr *u;
+  gfc_typespec *ts;
+
+  u = c->ext.actual->expr;
+  ts = &c->ext.actual->next->expr->ts;
+  if (u->ts.kind != ts->kind)
+    gfc_convert_type (u, ts, 2);
+  name = gfc_get_string (PREFIX ("fstat_i%d_sub"), ts->kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
+gfc_resolve_fgetc_sub (gfc_code *c)
+{
+  const char *name;
+  gfc_typespec ts;
+  gfc_expr *u, *st;
+  gfc_clear_ts (&ts);
+
+  u = c->ext.actual->expr;
+  st = c->ext.actual->next->next->expr;
+
+  if (u->ts.kind != gfc_c_int_kind)
+    {
+      ts.type = BT_INTEGER;
+      ts.kind = gfc_c_int_kind;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
+      gfc_convert_type (u, &ts, 2);
+    }
+
+  if (st != NULL)
+    name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), st->ts.kind);
+  else
+    name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind);
+
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
+gfc_resolve_fget_sub (gfc_code *c)
+{
+  const char *name;
+  gfc_expr *st;
+
+  st = c->ext.actual->next->expr;
+  if (st != NULL)
+    name = gfc_get_string (PREFIX ("fget_i%d_sub"), st->ts.kind);
+  else
+    name = gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind);
+
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
+gfc_resolve_fputc_sub (gfc_code *c)
+{
+  const char *name;
+  gfc_typespec ts;
+  gfc_expr *u, *st;
+  gfc_clear_ts (&ts);
+
+  u = c->ext.actual->expr;
+  st = c->ext.actual->next->next->expr;
+
+  if (u->ts.kind != gfc_c_int_kind)
+    {
+      ts.type = BT_INTEGER;
+      ts.kind = gfc_c_int_kind;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
+      gfc_convert_type (u, &ts, 2);
+    }
+
+  if (st != NULL)
+    name = gfc_get_string (PREFIX ("fputc_i%d_sub"), st->ts.kind);
+  else
+    name = gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind);
+
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
+gfc_resolve_fput_sub (gfc_code *c)
+{
+  const char *name;
+  gfc_expr *st;
+
+  st = c->ext.actual->next->expr;
+  if (st != NULL)
+    name = gfc_get_string (PREFIX ("fput_i%d_sub"), st->ts.kind);
+  else
+    name = gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind);
+
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void 
+gfc_resolve_fseek_sub (gfc_code *c)
+{
+  gfc_expr *unit;
+  gfc_expr *offset;
+  gfc_expr *whence;
+  gfc_typespec ts;
+  gfc_clear_ts (&ts);
+
+  unit   = c->ext.actual->expr;
+  offset = c->ext.actual->next->expr;
+  whence = c->ext.actual->next->next->expr;
+
+  if (unit->ts.kind != gfc_c_int_kind)
+    {
+      ts.type = BT_INTEGER;
+      ts.kind = gfc_c_int_kind;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
+      gfc_convert_type (unit, &ts, 2);
+    }
+
+  if (offset->ts.kind != gfc_intio_kind)
+    {
+      ts.type = BT_INTEGER;
+      ts.kind = gfc_intio_kind;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
+      gfc_convert_type (offset, &ts, 2);
+    }
+
+  if (whence->ts.kind != gfc_c_int_kind)
+    {
+      ts.type = BT_INTEGER;
+      ts.kind = gfc_c_int_kind;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
+      gfc_convert_type (whence, &ts, 2);
+    }
+
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
+}
+
+void
+gfc_resolve_ftell_sub (gfc_code *c)
+{
+  const char *name;
+  gfc_expr *unit;
+  gfc_expr *offset;
+  gfc_typespec ts;
+  gfc_clear_ts (&ts);
+
+  unit = c->ext.actual->expr;
+  offset = c->ext.actual->next->expr;
+
+  if (unit->ts.kind != gfc_c_int_kind)
+    {
+      ts.type = BT_INTEGER;
+      ts.kind = gfc_c_int_kind;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
+      gfc_convert_type (unit, &ts, 2);
+    }
+
+  name = gfc_get_string (PREFIX ("ftell_i%d_sub"), offset->ts.kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
+gfc_resolve_ttynam_sub (gfc_code *c)
+{
+  gfc_typespec ts;
+  gfc_clear_ts (&ts);
+  
+  if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
+    {
+      ts.type = BT_INTEGER;
+      ts.kind = gfc_c_int_kind;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
+      gfc_convert_type (c->ext.actual->expr, &ts, 2);
+    }
+
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
+}
+
+
+/* Resolve the UMASK intrinsic subroutine.  */
+
+void
+gfc_resolve_umask_sub (gfc_code *c)
+{
+  const char *name;
+  int kind;
+
+  if (c->ext.actual->next->expr != NULL)
+    kind = c->ext.actual->next->expr->ts.kind;
+  else
+    kind = gfc_default_integer_kind;
+
+  name = gfc_get_string (PREFIX ("umask_i%d_sub"), kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+/* Resolve the UNLINK intrinsic subroutine.  */
+
+void
+gfc_resolve_unlink_sub (gfc_code *c)
+{
+  const char *name;
+  int kind;
+
+  if (c->ext.actual->next->expr != NULL)
+    kind = c->ext.actual->next->expr->ts.kind;
+  else
+    kind = gfc_default_integer_kind;
+
+  name = gfc_get_string (PREFIX ("unlink_i%d_sub"), kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
diff --git a/gcc-4.9/gcc/fortran/iso-c-binding.def b/gcc-4.9/gcc/fortran/iso-c-binding.def
new file mode 100644
index 000000000..5f4baa16c
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/iso-c-binding.def
@@ -0,0 +1,200 @@
+/* Copyright (C) 2006-2014 Free Software Foundation, Inc.
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+/* This file contains the definition of the types provided by the
+   Fortran 2003 ISO_C_BINDING intrinsic module.  */
+
+#ifndef NAMED_INTCST
+# define NAMED_INTCST(a,b,c,d) 
+#endif
+
+#ifndef NAMED_REALCST
+# define NAMED_REALCST(a,b,c,d) 
+#endif
+
+#ifndef NAMED_CMPXCST
+# define NAMED_CMPXCST(a,b,c,d) 
+#endif
+
+#ifndef NAMED_LOGCST
+# define NAMED_LOGCST(a,b,c) 
+#endif
+
+#ifndef NAMED_CHARKNDCST
+# define NAMED_CHARKNDCST(a,b,c) 
+#endif
+
+#ifndef NAMED_FUNCTION
+# define NAMED_FUNCTION(a,b,c,d)
+#endif
+
+#ifndef NAMED_SUBROUTINE
+# define NAMED_SUBROUTINE(a,b,c,d)
+#endif
+
+/* The arguments to NAMED_*CST are:
+     -- an internal name
+     -- the symbol name in the module, as seen by Fortran code
+     -- the value it has, for use in trans-types.c  
+     -- the standard that supports this type  */
+
+NAMED_INTCST (ISOCBINDING_INT, "c_int", gfc_c_int_kind, GFC_STD_F2003)
+NAMED_INTCST (ISOCBINDING_SHORT, "c_short", \
+              get_int_kind_from_node (short_integer_type_node), GFC_STD_F2003)
+NAMED_INTCST (ISOCBINDING_LONG, "c_long", \
+              get_int_kind_from_node (long_integer_type_node), GFC_STD_F2003)
+NAMED_INTCST (ISOCBINDING_LONG_LONG, "c_long_long", \
+              get_int_kind_from_node (long_long_integer_type_node), GFC_STD_F2003)
+
+NAMED_INTCST (ISOCBINDING_INTMAX_T, "c_intmax_t", \
+              get_int_kind_from_name (INTMAX_TYPE), GFC_STD_F2003)
+NAMED_INTCST (ISOCBINDING_INTPTR_T, "c_intptr_t", \
+              get_int_kind_from_name (INTPTR_TYPE), GFC_STD_F2003)
+NAMED_INTCST (ISOCBINDING_PTRDIFF_T, "c_ptrdiff_t", \
+              get_int_kind_from_name (PTRDIFF_TYPE), GFC_STD_F2008_TS)
+NAMED_INTCST (ISOCBINDING_SIZE_T, "c_size_t", \
+              gfc_index_integer_kind, GFC_STD_F2003)
+NAMED_INTCST (ISOCBINDING_SIGNED_CHAR, "c_signed_char", \
+              get_int_kind_from_node (signed_char_type_node), GFC_STD_F2003)
+
+NAMED_INTCST (ISOCBINDING_INT8_T, "c_int8_t", \
+              get_int_kind_from_name (INT8_TYPE), GFC_STD_F2003)
+NAMED_INTCST (ISOCBINDING_INT16_T, "c_int16_t", \
+              get_int_kind_from_name (INT16_TYPE), GFC_STD_F2003)
+NAMED_INTCST (ISOCBINDING_INT32_T, "c_int32_t", \
+              get_int_kind_from_name (INT32_TYPE), GFC_STD_F2003)
+NAMED_INTCST (ISOCBINDING_INT64_T, "c_int64_t", \
+              get_int_kind_from_name (INT64_TYPE), GFC_STD_F2003)
+/* GNU Extension.  */
+NAMED_INTCST (ISOCBINDING_INT128_T, "c_int128_t", \
+              get_int_kind_from_width (128), GFC_STD_GNU)
+
+NAMED_INTCST (ISOCBINDING_INT_LEAST8_T, "c_int_least8_t", \
+              get_int_kind_from_name (INT_LEAST8_TYPE), GFC_STD_F2003)
+NAMED_INTCST (ISOCBINDING_INT_LEAST16_T, "c_int_least16_t", \
+              get_int_kind_from_name (INT_LEAST16_TYPE), GFC_STD_F2003)
+NAMED_INTCST (ISOCBINDING_INT_LEAST32_T, "c_int_least32_t", \
+              get_int_kind_from_name (INT_LEAST32_TYPE), GFC_STD_F2003)
+NAMED_INTCST (ISOCBINDING_INT_LEAST64_T, "c_int_least64_t", \
+              get_int_kind_from_name (INT_LEAST64_TYPE), GFC_STD_F2003)
+/* GNU Extension.  */
+NAMED_INTCST (ISOCBINDING_INT_LEAST128_T, "c_int_least128_t", \
+              get_int_kind_from_minimal_width (128), GFC_STD_GNU)
+
+NAMED_INTCST (ISOCBINDING_INT_FAST8_T, "c_int_fast8_t", \
+              get_int_kind_from_name (INT_FAST8_TYPE), GFC_STD_F2003)
+NAMED_INTCST (ISOCBINDING_INT_FAST16_T, "c_int_fast16_t", \
+              get_int_kind_from_name (INT_FAST16_TYPE), GFC_STD_F2003)
+NAMED_INTCST (ISOCBINDING_INT_FAST32_T, "c_int_fast32_t", \
+              get_int_kind_from_name (INT_FAST32_TYPE), GFC_STD_F2003)
+NAMED_INTCST (ISOCBINDING_INT_FAST64_T, "c_int_fast64_t", \
+              get_int_kind_from_name (INT_FAST64_TYPE), GFC_STD_F2003)
+/* GNU Extension.  */
+NAMED_INTCST (ISOCBINDING_INT_FAST128_T, "c_int_fast128_t",
+	      get_int_kind_from_width (128), GFC_STD_GNU)
+
+NAMED_REALCST (ISOCBINDING_FLOAT, "c_float", \
+               get_real_kind_from_node (float_type_node), GFC_STD_F2003)
+NAMED_REALCST (ISOCBINDING_DOUBLE, "c_double", \
+               get_real_kind_from_node (double_type_node), GFC_STD_F2003)
+NAMED_REALCST (ISOCBINDING_LONG_DOUBLE, "c_long_double", \
+               get_real_kind_from_node (long_double_type_node), GFC_STD_F2003)
+NAMED_REALCST (ISOCBINDING_FLOAT128, "c_float128", \
+	       float128_type_node == NULL_TREE \
+		  ? -4 : get_real_kind_from_node (float128_type_node), \
+	       GFC_STD_GNU)
+NAMED_CMPXCST (ISOCBINDING_FLOAT_COMPLEX, "c_float_complex", \
+               get_real_kind_from_node (float_type_node), GFC_STD_F2003)
+NAMED_CMPXCST (ISOCBINDING_DOUBLE_COMPLEX, "c_double_complex", \
+               get_real_kind_from_node (double_type_node), GFC_STD_F2003)
+NAMED_CMPXCST (ISOCBINDING_LONG_DOUBLE_COMPLEX, "c_long_double_complex", \
+               get_real_kind_from_node (long_double_type_node), GFC_STD_F2003)
+NAMED_CMPXCST (ISOCBINDING_FLOAT128_COMPLEX, "c_float128_complex", \
+	       float128_type_node == NULL_TREE \
+		  ? -4 : get_real_kind_from_node (float128_type_node), \
+	       GFC_STD_GNU)
+
+NAMED_LOGCST (ISOCBINDING_BOOL, "c_bool", \
+              get_int_kind_from_width (BOOL_TYPE_SIZE))
+
+NAMED_CHARKNDCST (ISOCBINDING_CHAR, "c_char", gfc_default_character_kind)
+
+#ifndef NAMED_CHARCST
+# define NAMED_CHARCST(a,b,c) 
+#endif
+
+/* Use langhooks to deal with host to target translations.  */ 
+NAMED_CHARCST (ISOCBINDING_NULL_CHAR, "c_null_char", \
+	       lang_hooks.to_target_charset ('\0'))
+NAMED_CHARCST (ISOCBINDING_ALERT, "c_alert", \
+	       lang_hooks.to_target_charset ('\a'))
+NAMED_CHARCST (ISOCBINDING_BACKSPACE, "c_backspace", \
+	       lang_hooks.to_target_charset ('\b'))
+NAMED_CHARCST (ISOCBINDING_FORM_FEED, "c_form_feed", \
+	       lang_hooks.to_target_charset ('\f'))
+NAMED_CHARCST (ISOCBINDING_NEW_LINE, "c_new_line", \
+	       lang_hooks.to_target_charset ('\n'))
+NAMED_CHARCST (ISOCBINDING_CARRIAGE_RETURN, "c_carriage_return", \
+	       lang_hooks.to_target_charset ('\r'))
+NAMED_CHARCST (ISOCBINDING_HORIZONTAL_TAB, "c_horizontal_tab", \
+	       lang_hooks.to_target_charset ('\t'))
+NAMED_CHARCST (ISOCBINDING_VERTICAL_TAB, "c_vertical_tab", \
+	       lang_hooks.to_target_charset ('\v'))
+
+#ifndef DERIVED_TYPE
+# define DERIVED_TYPE(a,b,c) 
+#endif
+
+DERIVED_TYPE (ISOCBINDING_PTR, "c_ptr", \
+              get_int_kind_from_node (ptr_type_node))
+DERIVED_TYPE (ISOCBINDING_NULL_PTR, "c_null_ptr", \
+              get_int_kind_from_node (ptr_type_node))
+DERIVED_TYPE (ISOCBINDING_FUNPTR, "c_funptr", \
+              get_int_kind_from_node (ptr_type_node))
+DERIVED_TYPE (ISOCBINDING_NULL_FUNPTR, "c_null_funptr", \
+              get_int_kind_from_node (ptr_type_node))
+
+/* The arguments to NAMED_FUNCTIONS and NAMED_SUBROUTINES are:
+     -- the ISYM
+     -- the symbol name in the module, as seen by Fortran code
+     -- the Fortran standard  */
+
+NAMED_SUBROUTINE (ISOCBINDING_F_POINTER, "c_f_pointer",
+                  GFC_ISYM_C_F_POINTER, GFC_STD_F2003)
+NAMED_SUBROUTINE (ISOCBINDING_F_PROCPOINTER, "c_f_procpointer",
+                  GFC_ISYM_C_F_PROCPOINTER, GFC_STD_F2003)
+
+NAMED_FUNCTION (ISOCBINDING_ASSOCIATED, "c_associated",
+		GFC_ISYM_C_ASSOCIATED, GFC_STD_F2003)
+NAMED_FUNCTION (ISOCBINDING_FUNLOC, "c_funloc",
+                GFC_ISYM_C_FUNLOC, GFC_STD_F2003)
+NAMED_FUNCTION (ISOCBINDING_LOC, "c_loc",
+                GFC_ISYM_C_LOC, GFC_STD_F2003)
+
+NAMED_FUNCTION (ISOCBINDING_C_SIZEOF, "c_sizeof", \
+                GFC_ISYM_C_SIZEOF, GFC_STD_F2008)
+
+#undef NAMED_INTCST
+#undef NAMED_REALCST
+#undef NAMED_CMPXCST
+#undef NAMED_LOGCST
+#undef NAMED_CHARCST
+#undef NAMED_CHARKNDCST
+#undef DERIVED_TYPE
+#undef NAMED_FUNCTION
+#undef NAMED_SUBROUTINE
diff --git a/gcc-4.9/gcc/fortran/iso-fortran-env.def b/gcc-4.9/gcc/fortran/iso-fortran-env.def
new file mode 100644
index 000000000..ebadaefb7
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/iso-fortran-env.def
@@ -0,0 +1,128 @@
+/* Copyright (C) 2006-2014 Free Software Foundation, Inc.
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+/* This file contains the definition of the named integer constants provided
+   by the Fortran 2003 ISO_FORTRAN_ENV intrinsic module.  */
+
+#ifndef NAMED_INTCST
+# define NAMED_INTCST(a,b,c,d)
+#endif
+
+#ifndef NAMED_KINDARRAY
+# define NAMED_KINDARRAY(a,b,c,d)
+#endif
+
+#ifndef NAMED_SUBROUTINE
+# define NAMED_SUBROUTINE(a,b,c,d)
+#endif
+
+#ifndef NAMED_FUNCTION
+# define NAMED_FUNCTION(a,b,c,d)
+#endif
+
+/* The arguments to NAMED_INTCST are:
+     -- an internal name
+     -- the symbol name in the module, as seen by Fortran code
+     -- the value it has
+     -- the standard that supports this type  */ 
+
+NAMED_INTCST (ISOFORTRANENV_FILE_ATOMIC_INT_KIND, "atomic_int_kind", \
+              gfc_atomic_int_kind, GFC_STD_F2008)
+NAMED_INTCST (ISOFORTRANENV_FILE_ATOMIC_LOGICAL_KIND, "atomic_logical_kind", \
+              gfc_atomic_logical_kind, GFC_STD_F2008)
+NAMED_INTCST (ISOFORTRANENV_CHARACTER_STORAGE_SIZE, "character_storage_size", \
+              gfc_character_storage_size, GFC_STD_F2003)
+NAMED_INTCST (ISOFORTRANENV_ERROR_UNIT, "error_unit", GFC_STDERR_UNIT_NUMBER, \
+              GFC_STD_F2003)
+NAMED_INTCST (ISOFORTRANENV_FILE_STORAGE_SIZE, "file_storage_size", 8, \
+              GFC_STD_F2003)
+NAMED_INTCST (ISOFORTRANENV_INPUT_UNIT, "input_unit", GFC_STDIN_UNIT_NUMBER, \
+              GFC_STD_F2003)
+NAMED_INTCST (ISOFORTRANENV_INT8, "int8", \
+              gfc_get_int_kind_from_width_isofortranenv (8), GFC_STD_F2008)
+NAMED_INTCST (ISOFORTRANENV_INT16, "int16", \
+              gfc_get_int_kind_from_width_isofortranenv (16), GFC_STD_F2008)
+NAMED_INTCST (ISOFORTRANENV_INT32, "int32", \
+              gfc_get_int_kind_from_width_isofortranenv (32), GFC_STD_F2008)
+NAMED_INTCST (ISOFORTRANENV_INT64, "int64", \
+              gfc_get_int_kind_from_width_isofortranenv (64), GFC_STD_F2008)
+NAMED_INTCST (ISOFORTRANENV_IOSTAT_END, "iostat_end", LIBERROR_END, \
+              GFC_STD_F2003)
+NAMED_INTCST (ISOFORTRANENV_IOSTAT_EOR, "iostat_eor", LIBERROR_EOR, \
+              GFC_STD_F2003)
+NAMED_INTCST (ISOFORTRANENV_IOSTAT_INQUIRE_INTERNAL_UNIT, \
+              "iostat_inquire_internal_unit", LIBERROR_INQUIRE_INTERNAL_UNIT, \
+              GFC_STD_F2008)
+NAMED_INTCST (ISOFORTRANENV_NUMERIC_STORAGE_SIZE, "numeric_storage_size", \
+              gfc_numeric_storage_size, GFC_STD_F2003)
+NAMED_INTCST (ISOFORTRANENV_OUTPUT_UNIT, "output_unit", GFC_STDOUT_UNIT_NUMBER, \
+              GFC_STD_F2003)
+NAMED_INTCST (ISOFORTRANENV_REAL32, "real32", \
+              gfc_get_real_kind_from_width_isofortranenv (32), GFC_STD_F2008)
+NAMED_INTCST (ISOFORTRANENV_REAL64, "real64", \
+              gfc_get_real_kind_from_width_isofortranenv (64), GFC_STD_F2008)
+NAMED_INTCST (ISOFORTRANENV_REAL128, "real128", \
+              gfc_get_real_kind_from_width_isofortranenv (128), GFC_STD_F2008)
+NAMED_INTCST (ISOFORTRANENV_FILE_STAT_LOCKED, "stat_locked", \
+              GFC_STAT_LOCKED, GFC_STD_F2008)
+NAMED_INTCST (ISOFORTRANENV_FILE_STAT_LOCKED_OTHER_IMAGE, \
+              "stat_locked_other_image", \
+	      GFC_STAT_LOCKED_OTHER_IMAGE, GFC_STD_F2008)
+NAMED_INTCST (ISOFORTRANENV_FILE_STAT_STOPPED_IMAGE, "stat_stopped_image", \
+              GFC_STAT_STOPPED_IMAGE, GFC_STD_F2008)
+NAMED_INTCST (ISOFORTRANENV_FILE_STAT_UNLOCKED, "stat_unlocked", \
+              GFC_STAT_UNLOCKED, GFC_STD_F2008)
+
+
+/* The arguments to NAMED_KINDARRAY are:
+     -- an internal name
+     -- the symbol name in the module, as seen by Fortran code
+     -- the gfortran variable containing the information
+     -- the Fortran standard  */
+
+NAMED_KINDARRAY (ISOFORTRAN_CHARACTER_KINDS, "character_kinds", \
+                 gfc_character_kinds, GFC_STD_F2008)
+NAMED_KINDARRAY (ISOFORTRAN_INTEGER_KINDS, "integer_kinds", \
+                 gfc_integer_kinds, GFC_STD_F2008)
+NAMED_KINDARRAY (ISOFORTRAN_LOGICAL_KINDS, "logical_kinds", \
+                 gfc_logical_kinds, GFC_STD_F2008)
+NAMED_KINDARRAY (ISOFORTRAN_REAL_KINDS, "real_kinds", \
+                 gfc_real_kinds, GFC_STD_F2008)
+
+/* The arguments to NAMED_FUNCTIONS are:
+     -- the ISYM
+     -- the symbol name in the module, as seen by Fortran code
+     -- the Fortran standard  */
+
+NAMED_FUNCTION (ISOFORTRAN_COMPILER_OPTIONS, "compiler_options", \
+                GFC_ISYM_COMPILER_OPTIONS, GFC_STD_F2008)
+NAMED_FUNCTION (ISOFORTRAN_COMPILER_VERSION, "compiler_version", \
+                GFC_ISYM_COMPILER_VERSION, GFC_STD_F2008)
+
+#ifndef NAMED_DERIVED_TYPE
+# define NAMED_DERIVED_TYPE(a,b,c,d)
+#endif
+
+NAMED_DERIVED_TYPE (ISOFORTRAN_LOCK_TYPE, "lock_type", \
+              get_int_kind_from_node (ptr_type_node), GFC_STD_F2008)
+
+#undef NAMED_INTCST
+#undef NAMED_KINDARRAY
+#undef NAMED_FUNCTION
+#undef NAMED_SUBROUTINE
+#undef NAMED_DERIVED_TYPE
diff --git a/gcc-4.9/gcc/fortran/lang-specs.h b/gcc-4.9/gcc/fortran/lang-specs.h
new file mode 100644
index 000000000..7560ed42a
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/lang-specs.h
@@ -0,0 +1,77 @@
+/* Contribution to the specs for the GNU Compiler Collection
+   from GNU Fortran 95 compiler.
+   Copyright (C) 2002-2014 Free Software Foundation, Inc.
+
+   This file is free software; you can redistribute it and/or modify
+   it under the terms of the GNU General Public License as published by
+   the Free Software Foundation; either version 3 of the License, or
+   (at your option) any later version.
+
+   This file is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU General Public License for more details.
+
+   You should have received a copy of the GNU General Public License
+   along with GCC; see the file COPYING3.  If not see
+   <http://www.gnu.org/licenses/>.  */
+
+/* This is the contribution to the `default_compilers' array in gcc.c
+   for the f95 language.  */
+
+/* Identical to gcc.c (cpp_options), but omitting %(cpp_unique_options)
+   and -fpch-preprocess on -save-temps.  */
+#define CPP_ONLY_OPTIONS    "%1 %{m*} %{f*} %{g*:%{!g0:%{g*} \
+			     %{!fno-working-directory:-fworking-directory}}} \
+			     %{std*&ansi&trigraphs} %{W*&pedantic*} %{w} \
+			     %{O*} %{undef}"
+
+/* Options that f951 should know about, even if not preprocessing.  */
+#define CPP_FORWARD_OPTIONS "%{i*} %{I*} %{M*}"
+
+#define F951_CPP_OPTIONS    "%{!nocpp: -cpp=%g.f90 %{E} %(cpp_unique_options) \
+			     %{E|M|MM:%(cpp_debug_options) " CPP_ONLY_OPTIONS \
+			     " -fsyntax-only};: " CPP_FORWARD_OPTIONS "}"
+#define F951_OPTIONS        "%(cc1_options) %{J*} \
+			     %{!nostdinc:-fintrinsic-modules-path finclude%s}\
+			     %{!fsyntax-only:%(invoke_as)}"
+#define F951_SOURCE_FORM    "%{!ffree-form:-ffixed-form}"
+
+
+{".F",   "@f77-cpp-input", 0, 0, 0},
+{".FOR", "@f77-cpp-input", 0, 0, 0},
+{".FTN", "@f77-cpp-input", 0, 0, 0},
+{".fpp", "@f77-cpp-input", 0, 0, 0},
+{".FPP", "@f77-cpp-input", 0, 0, 0},
+{"@f77-cpp-input",
+    "f951 %i " F951_SOURCE_FORM " " \
+	  F951_CPP_OPTIONS " %{!E:" F951_OPTIONS "}", 0, 0, 0},
+{".f",   "@f77", 0, 0, 0},
+{".for", "@f77", 0, 0, 0},
+{".ftn", "@f77", 0, 0, 0},
+{"@f77",
+    "f951 %i " F951_SOURCE_FORM " \
+          %{E:%{!cpp:%egfortran does not support -E without -cpp}} \
+          %{cpp:" F951_CPP_OPTIONS ";: " CPP_FORWARD_OPTIONS  "} \
+	  %{!E:" F951_OPTIONS "}", 0, 0, 0},
+{".F90", "@f95-cpp-input", 0, 0, 0},
+{".F95", "@f95-cpp-input", 0, 0, 0},
+{".F03", "@f95-cpp-input", 0, 0, 0},
+{".F08", "@f95-cpp-input", 0, 0, 0},
+{"@f95-cpp-input",
+    "f951 %i " F951_CPP_OPTIONS " %{!E:" F951_OPTIONS "}", 0, 0, 0},
+{".f90", "@f95", 0, 0, 0},
+{".f95", "@f95", 0, 0, 0},
+{".f03", "@f95", 0, 0, 0},
+{".f08", "@f95", 0, 0, 0},
+{"@f95",
+    "f951 %i %{E:%{!cpp:%egfortran does not support -E without -cpp}}\
+	  %{cpp:" F951_CPP_OPTIONS ";:  " CPP_FORWARD_OPTIONS  "} \
+	  %{!E:" F951_OPTIONS "}", 0, 0, 0},
+
+
+#undef CPP_ONLY_OPTIONS
+#undef CPP_FORWARD_OPTIONS
+#undef F951_SOURCE_FORM
+#undef F951_CPP_OPTIONS
+#undef F951_OPTIONS
diff --git a/gcc-4.9/gcc/fortran/lang.opt b/gcc-4.9/gcc/fortran/lang.opt
new file mode 100644
index 000000000..59f635d0c
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/lang.opt
@@ -0,0 +1,692 @@
+; Options for the Fortran 95 front end.
+; Copyright (C) 2003-2014 Free Software Foundation, Inc.
+;
+; This file is part of GCC.
+;
+; GCC is free software; you can redistribute it and/or modify it under
+; the terms of the GNU General Public License as published by the Free
+; Software Foundation; either version 3, or (at your option) any later
+; version.
+; 
+; GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+; WARRANTY; without even the implied warranty of MERCHANTABILITY or
+; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+; for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with GCC; see the file COPYING3.  If not see
+; <http://www.gnu.org/licenses/>.
+
+; See the GCC internals manual for a description of this file's format.
+
+; Please try to keep this file in ASCII collating order.
+
+Language
+Fortran
+
+-all-warnings
+Fortran Alias(Wall)
+
+-assert
+Fortran Separate Alias(A)
+
+-assert=
+Fortran Joined Alias(A)
+
+-comments
+Fortran Alias(C)
+
+-comments-in-macros
+Fortran Alias(CC)
+
+-define-macro
+Fortran Separate Alias(D)
+
+-define-macro=
+Fortran Joined Alias(D)
+
+-dependencies
+Fortran Alias(M)
+
+-dump
+Fortran Separate Alias(d)
+
+-dump=
+Fortran Joined Alias(d)
+
+-include-barrier
+Fortran Alias(I, -)
+
+-include-directory
+Fortran Separate Alias(I)
+
+-include-directory=
+Fortran Joined Alias(I)
+
+-include-directory-after
+Fortran Separate Alias(idirafter)
+
+-include-directory-after=
+Fortran Joined Alias(idirafter)
+
+-include-prefix
+Fortran Separate Alias(iprefix)
+
+-include-prefix=
+Fortran JoinedOrMissing Alias(iprefix)
+
+-no-line-commands
+Fortran Alias(P)
+
+-no-standard-includes
+Fortran Alias(nostdinc)
+
+-output
+Fortran Separate Alias(o)
+
+-output=
+Fortran Joined Alias(o)
+
+-preprocess
+Fortran Undocumented Alias(E)
+
+-print-missing-file-dependencies
+Fortran Alias(MG)
+
+-trace-includes
+Fortran Alias(H)
+
+-undefine-macro
+Fortran Separate Alias(U)
+
+-undefine-macro=
+Fortran Joined Alias(U)
+
+-user-dependencies
+Fortran Alias(MM)
+
+-verbose
+Fortran Alias(v)
+
+-write-dependencies
+Fortran NoDriverArg Separate Alias(MD)
+
+-write-user-dependencies
+Fortran NoDriverArg Separate Alias(MMD)
+
+A
+Fortran Joined Separate
+; Documented in C
+
+C
+Fortran
+; Documented in C
+
+CC
+Fortran
+; Documented in C
+
+D
+Fortran Joined Separate
+; Documented in C
+
+E
+Fortran Undocumented
+
+H
+Fortran
+; Documented in C
+
+I
+Fortran Joined Separate
+; Documented in C
+
+J
+Fortran Joined Separate
+-J<directory>	Put MODULE files in 'directory'
+
+M
+Fortran
+; Documented in C
+
+MD
+Fortran Separate NoDriverArg
+; Documented in C
+
+MF
+Fortran Joined Separate
+; Documented in C
+
+MG
+Fortran
+; Documented in C
+
+MM
+Fortran
+; Documented in C
+
+MMD
+Fortran Separate NoDriverArg
+; Documented in C
+
+MP
+Fortran
+; Documented in C
+
+MT
+Fortran Joined Separate
+; Documented in C
+
+MQ
+Fortran Joined Separate
+; Documented in C
+
+P
+Fortran
+; Documented in C
+
+U
+Fortran Joined Separate
+; Documented in C
+
+Wall
+Fortran
+; Documented in C
+
+Waliasing
+Fortran Warning
+Warn about possible aliasing of dummy arguments
+
+Walign-commons
+Fortran Warning
+Warn about alignment of COMMON blocks
+
+Wampersand
+Fortran Warning
+Warn about missing ampersand in continued character constants
+
+Warray-temporaries
+Fortran Warning
+Warn about creation of array temporaries
+
+Wc-binding-type
+Fortran Warning
+Warn if the type of a variable might be not interoperable with C
+
+Wdate-time
+Fortran
+; Documented in C
+
+Wcharacter-truncation
+Fortran Warning
+Warn about truncated character expressions
+
+Wcompare-reals
+Fortran Warning
+Warn about equality comparisons involving REAL or COMPLEX expressions
+
+Wconversion
+Fortran Warning
+; Documented in C
+
+Wconversion-extra
+Fortran Warning
+Warn about most implicit conversions
+
+Wextra
+Fortran Warning
+Print extra (possibly unwanted) warnings
+
+Wfunction-elimination
+Fortran Warning
+Warn about function call elimination
+
+Wimplicit-interface
+Fortran Warning
+Warn about calls with implicit interface
+
+Wimplicit-procedure
+Fortran Warning
+Warn about called procedures not explicitly declared
+
+Wline-truncation
+Fortran Warning
+Warn about truncated source lines
+
+Wintrinsics-std
+Fortran Warning
+Warn on intrinsics not part of the selected standard
+
+Wopenmp-simd
+Fortran
+; Documented in C
+
+Wreal-q-constant
+Fortran Warning
+Warn about real-literal-constants with 'q' exponent-letter
+
+Wrealloc-lhs
+Fortran Warning
+Warn when a left-hand-side array variable is reallocated
+
+Wrealloc-lhs-all
+Fortran Warning
+Warn when a left-hand-side variable is reallocated
+
+Wtarget-lifetime
+Fortran Warning
+Warn if the pointer in a pointer assignment might outlive its target
+
+Wreturn-type
+Fortran Warning
+; Documented in C
+
+Wsurprising
+Fortran Warning
+Warn about \"suspicious\" constructs
+
+Wtabs
+Fortran Warning
+Permit nonconforming uses of the tab character
+
+Wunderflow
+Fortran Warning
+Warn about underflow of numerical constant expressions
+
+Wintrinsic-shadow
+Fortran Warning
+Warn if a user-procedure has the same name as an intrinsic
+
+Wunused-dummy-argument
+Fortran Warning
+Warn about unused dummy arguments.
+
+Wzerotrip
+Fortran Warning
+Warn about zero-trip DO loops
+
+cpp
+Fortran Negative(nocpp)
+Enable preprocessing
+
+cpp=
+Fortran Joined Negative(nocpp) Undocumented NoDWARFRecord
+; Internal option generated by specs from -cpp.
+
+nocpp
+Fortran Negative(cpp)
+Disable preprocessing
+
+d
+Fortran Joined
+; Documented in common.opt
+
+faggressive-function-elimination
+Fortran
+Eliminate multiple function invokations also for impure functions
+
+falign-commons
+Fortran
+Enable alignment of COMMON blocks
+
+fall-intrinsics
+Fortran RejectNegative
+All intrinsics procedures are available regardless of selected standard
+
+fallow-leading-underscore
+Fortran Undocumented
+; For internal use only: allow the first character of symbol names to be an underscore
+
+fautomatic
+Fortran
+Do not treat local variables and COMMON blocks as if they were named in SAVE statements
+
+fbackslash
+Fortran
+Specify that backslash in string introduces an escape character
+
+fbacktrace
+Fortran
+Produce a backtrace when a runtime error is encountered
+
+fblas-matmul-limit=
+Fortran RejectNegative Joined UInteger
+-fblas-matmul-limit=<n>	Size of the smallest matrix for which matmul will use BLAS
+
+fcheck-array-temporaries
+Fortran
+Produce a warning at runtime if a array temporary has been created for a procedure argument
+
+fconvert=big-endian
+Fortran RejectNegative
+Use big-endian format for unformatted files
+
+fconvert=little-endian
+Fortran RejectNegative
+Use little-endian format for unformatted files
+
+fconvert=native
+Fortran RejectNegative
+Use native format for unformatted files
+
+fconvert=swap
+Fortran RejectNegative
+Swap endianness for unformatted files
+
+fcray-pointer
+Fortran
+Use the Cray Pointer extension
+
+fd-lines-as-code
+Fortran RejectNegative
+Ignore 'D' in column one in fixed form
+
+fd-lines-as-comments
+Fortran RejectNegative
+Treat lines with 'D' in column one as comments
+
+fdefault-double-8
+Fortran
+Set the default double precision kind to an 8 byte wide type
+
+fdefault-integer-8
+Fortran
+Set the default integer kind to an 8 byte wide type
+
+fdefault-real-8
+Fortran
+Set the default real kind to an 8 byte wide type
+
+fdollar-ok
+Fortran
+Allow dollar signs in entity names
+
+fdump-core
+Fortran Ignore
+Does nothing. Preserved for backward compatibility.
+
+fdump-fortran-original
+Fortran
+Display the code tree after parsing
+
+fdump-fortran-optimized
+Fortran
+Display the code tree after front end optimization
+
+fdump-parse-tree
+Fortran
+Display the code tree after parsing; deprecated option
+
+fexternal-blas
+Fortran
+Specify that an external BLAS library should be used for matmul calls on large-size arrays
+
+ff2c
+Fortran
+Use f2c calling convention
+
+ffixed-form
+Fortran RejectNegative
+Assume that the source file is fixed form
+
+finteger-4-integer-8
+Fortran RejectNegative
+Interpret any INTEGER(4) as an INTEGER(8)
+
+fintrinsic-modules-path
+Fortran RejectNegative Separate
+Specify where to find the compiled intrinsic modules
+
+fintrinsic-modules-path=
+Fortran RejectNegative Joined
+Specify where to find the compiled intrinsic modules
+
+ffixed-line-length-none
+Fortran RejectNegative
+Allow arbitrary character line width in fixed mode
+
+ffixed-line-length-
+Fortran RejectNegative Joined UInteger
+-ffixed-line-length-<n>	Use n as character line width in fixed mode
+
+ffpe-trap=
+Fortran RejectNegative JoinedOrMissing
+-ffpe-trap=[...]	Stop on following floating point exceptions
+
+ffpe-summary=
+Fortran RejectNegative JoinedOrMissing
+-ffpe-summary=[...]	Print summary of floating point exceptions
+
+ffree-form
+Fortran RejectNegative
+Assume that the source file is free form
+
+ffree-line-length-none
+Fortran RejectNegative
+Allow arbitrary character line width in free mode
+
+ffree-line-length-
+Fortran RejectNegative Joined UInteger
+-ffree-line-length-<n>	Use n as character line width in free mode
+
+ffrontend-optimize
+Fortran
+Enable front end optimization
+
+fimplicit-none
+Fortran
+Specify that no implicit typing is allowed, unless overridden by explicit IMPLICIT statements
+
+finit-character=
+Fortran RejectNegative Joined UInteger
+-finit-character=<n>	Initialize local character variables to ASCII value n
+
+finit-integer=
+Fortran RejectNegative Joined
+-finit-integer=<n>	Initialize local integer variables to n
+
+finit-local-zero
+Fortran
+Initialize local variables to zero (from g77)
+
+finit-logical=
+Fortran RejectNegative Joined
+-finit-logical=<true|false>	Initialize local logical variables
+
+finit-real=
+Fortran RejectNegative Joined
+-finit-real=<zero|nan|inf|-inf>	Initialize local real variables
+
+fmax-array-constructor=
+Fortran RejectNegative Joined UInteger
+-fmax-array-constructor=<n>	Maximum number of objects in an array constructor
+
+fmax-identifier-length=
+Fortran RejectNegative Joined UInteger
+-fmax-identifier-length=<n>	Maximum identifier length
+
+fmax-subrecord-length=
+Fortran RejectNegative Joined UInteger
+-fmax-subrecord-length=<n>	Maximum length for subrecords
+
+fmax-stack-var-size=
+Fortran RejectNegative Joined UInteger
+-fmax-stack-var-size=<n>	Size in bytes of the largest array that will be put on the stack
+
+fstack-arrays
+Fortran
+Put all local arrays on stack.
+
+fmodule-private
+Fortran
+Set default accessibility of module entities to PRIVATE.
+
+fopenmp
+Fortran
+; Documented in C
+
+fopenmp-simd
+Fortran
+; Documented in C
+
+fpack-derived
+Fortran
+Try to lay out derived types as compactly as possible
+
+fpreprocessed
+Fortran
+; Documented in C
+
+fprotect-parens
+Fortran
+Protect parentheses in expressions
+
+frange-check
+Fortran
+Enable range checking during compilation
+
+freal-4-real-8
+Fortran RejectNegative
+Interpret any REAL(4) as a REAL(8)
+
+freal-4-real-10
+Fortran RejectNegative
+Interpret any REAL(4) as a REAL(10)
+
+freal-4-real-16
+Fortran RejectNegative
+Interpret any REAL(4) as a REAL(16)
+
+freal-8-real-4
+Fortran RejectNegative
+Interpret any REAL(8) as a REAL(4)
+
+freal-8-real-10
+Fortran RejectNegative
+Interpret any REAL(8) as a REAL(10)
+
+freal-8-real-16
+Fortran RejectNegative
+Interpret any REAL(8) as a REAL(16)
+
+frealloc-lhs
+Fortran
+Reallocate the LHS in assignments
+
+frecord-marker=4
+Fortran RejectNegative
+Use a 4-byte record marker for unformatted files
+
+frecord-marker=8
+Fortran RejectNegative
+Use an 8-byte record marker for unformatted files
+
+frecursive
+Fortran
+Allocate local variables on the stack to allow indirect recursion
+
+frepack-arrays
+Fortran
+Copy array sections into a contiguous block on procedure entry
+
+fcoarray=
+Fortran RejectNegative JoinedOrMissing
+-fcoarray=[...]	Specify which coarray parallelization should be used
+
+fcheck=
+Fortran RejectNegative JoinedOrMissing
+-fcheck=[...]	Specify which runtime checks are to be performed
+
+fsecond-underscore
+Fortran
+Append a second underscore if the name already contains an underscore
+
+fshort-enums
+Fortran Var(flag_short_enums)
+; Documented in C
+
+fsign-zero
+Fortran
+Apply negative sign to zero values
+
+funderscoring
+Fortran
+Append underscores to externally visible names
+
+fwhole-file
+Fortran Ignore
+Does nothing.  Preserved for backward compatibility.
+
+fworking-directory
+Fortran
+; Documented in C
+
+idirafter
+Fortran Joined Separate
+; Documented in C
+
+imultilib
+Fortran Joined Separate
+; Documented in C
+
+iprefix
+Fortran Joined Separate
+; Documented in C
+
+iquote
+Fortran Joined Separate
+; Documented in C
+
+isysroot
+Fortran Joined Separate
+; Documented in C
+
+isystem
+Fortran Joined Separate
+; Documented in C
+
+nostdinc
+Fortran
+; Documented in C
+
+o
+Fortran Joined Separate
+; Documented in common.opt
+
+static-libgfortran
+Fortran
+Statically link the GNU Fortran helper library (libgfortran)
+
+std=f2003
+Fortran
+Conform to the ISO Fortran 2003 standard
+
+std=f2008
+Fortran
+Conform to the ISO Fortran 2008 standard
+
+std=f2008ts
+Fortran
+Conform to the ISO Fortran 2008 standard including TS 29113
+
+std=f95
+Fortran
+Conform to the ISO Fortran 95 standard
+
+std=gnu
+Fortran
+Conform to nothing in particular
+
+std=legacy
+Fortran
+Accept extensions to support legacy code
+
+undef
+Fortran
+; Documented in C
+
+v
+Fortran
+; Documented in C
+
+; This comment is to ensure we retain the blank line above.
diff --git a/gcc-4.9/gcc/fortran/libgfortran.h b/gcc-4.9/gcc/fortran/libgfortran.h
new file mode 100644
index 000000000..230b6389f
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/libgfortran.h
@@ -0,0 +1,140 @@
+/* Header file to the Fortran front-end and runtime library
+   Copyright (C) 2007-2014 Free Software Foundation, Inc.
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+
+/* Flags to specify which standard/extension contains a feature.
+   Note that no features were obsoleted nor deleted in F2003.
+   Please remember to keep those definitions in sync with
+   gfortran.texi.  */
+#define GFC_STD_F2008_TS	(1<<9)	/* POST-F2008 technical reports.  */
+#define GFC_STD_F2008_OBS	(1<<8)	/* Obsolescent in F2008.  */
+#define GFC_STD_F2008		(1<<7)	/* New in F2008.  */
+#define GFC_STD_LEGACY		(1<<6)	/* Backward compatibility.  */
+#define GFC_STD_GNU		(1<<5)	/* GNU Fortran extension.  */
+#define GFC_STD_F2003		(1<<4)	/* New in F2003.  */
+#define GFC_STD_F95		(1<<3)	/* New in F95.  */
+#define GFC_STD_F95_DEL		(1<<2)	/* Deleted in F95.  */
+#define GFC_STD_F95_OBS		(1<<1)	/* Obsolescent in F95.  */
+#define GFC_STD_F77		(1<<0)	/* Included in F77, but not deleted or
+					   obsolescent in later standards.  */
+
+
+/* Bitmasks for the various FPE that can be enabled.  */
+#define GFC_FPE_INVALID    (1<<0)
+#define GFC_FPE_DENORMAL   (1<<1)
+#define GFC_FPE_ZERO       (1<<2)
+#define GFC_FPE_OVERFLOW   (1<<3)
+#define GFC_FPE_UNDERFLOW  (1<<4)
+#define GFC_FPE_INEXACT    (1<<5)
+
+/* Defines for floating-point rounding modes.  */
+#define GFC_FPE_DOWNWARD   1
+#define GFC_FPE_TONEAREST  2
+#define GFC_FPE_TOWARDZERO 3
+#define GFC_FPE_UPWARD     4
+
+
+/* Bitmasks for the various runtime checks that can be enabled.  */
+#define GFC_RTCHECK_BOUNDS      (1<<0)
+#define GFC_RTCHECK_ARRAY_TEMPS (1<<1)
+#define GFC_RTCHECK_RECURSION   (1<<2)
+#define GFC_RTCHECK_DO          (1<<3)
+#define GFC_RTCHECK_POINTER     (1<<4)
+#define GFC_RTCHECK_MEM         (1<<5)
+#define GFC_RTCHECK_ALL        (GFC_RTCHECK_BOUNDS | GFC_RTCHECK_ARRAY_TEMPS \
+				| GFC_RTCHECK_RECURSION | GFC_RTCHECK_DO \
+				| GFC_RTCHECK_POINTER | GFC_RTCHECK_MEM)
+
+
+/* Possible values for the CONVERT I/O specifier.  */
+typedef enum
+{
+  GFC_CONVERT_NONE = -1,
+  GFC_CONVERT_NATIVE = 0,
+  GFC_CONVERT_SWAP,
+  GFC_CONVERT_BIG,
+  GFC_CONVERT_LITTLE
+}
+unit_convert;
+
+
+/* Runtime errors.  */
+typedef enum
+{
+  LIBERROR_FIRST = -3,		/* Marker for the first error.  */
+  LIBERROR_EOR = -2,		/* End of record, must be negative.  */
+  LIBERROR_END = -1,		/* End of file, must be negative.  */
+  LIBERROR_OK = 0,		/* Indicates success, must be zero.  */
+  LIBERROR_OS = 5000,		/* OS error, more info in errno.  */
+  LIBERROR_OPTION_CONFLICT,
+  LIBERROR_BAD_OPTION,
+  LIBERROR_MISSING_OPTION,
+  LIBERROR_ALREADY_OPEN,
+  LIBERROR_BAD_UNIT,
+  LIBERROR_FORMAT,
+  LIBERROR_BAD_ACTION,
+  LIBERROR_ENDFILE,
+  LIBERROR_BAD_US,
+  LIBERROR_READ_VALUE,
+  LIBERROR_READ_OVERFLOW,
+  LIBERROR_INTERNAL,
+  LIBERROR_INTERNAL_UNIT,
+  LIBERROR_ALLOCATION,
+  LIBERROR_DIRECT_EOR,
+  LIBERROR_SHORT_RECORD,
+  LIBERROR_CORRUPT_FILE,
+  LIBERROR_INQUIRE_INTERNAL_UNIT, /* Must be different from STAT_STOPPED_IMAGE.  */
+  LIBERROR_LAST			/* Not a real error, the last error # + 1.  */
+}
+libgfortran_error_codes;
+
+/* Must kept in sync with libgfortrancaf.h.  */
+typedef enum
+{
+  GFC_STAT_UNLOCKED = 0,
+  GFC_STAT_LOCKED,
+  GFC_STAT_LOCKED_OTHER_IMAGE,
+  GFC_STAT_STOPPED_IMAGE = 6000 /* See LIBERROR_INQUIRE_INTERNAL_UNIT above. */
+}
+libgfortran_stat_codes;
+
+/* Default unit number for preconnected standard input and output.  */
+#define GFC_STDIN_UNIT_NUMBER 5
+#define GFC_STDOUT_UNIT_NUMBER 6
+#define GFC_STDERR_UNIT_NUMBER 0
+
+
+/* FIXME: Increase to 15 for Fortran 2008. Also needs changes to
+   GFC_DTYPE_RANK_MASK. See PR 36825.  */
+#define GFC_MAX_DIMENSIONS 7
+
+#define GFC_DTYPE_RANK_MASK 0x07
+#define GFC_DTYPE_TYPE_SHIFT 3
+#define GFC_DTYPE_TYPE_MASK 0x38
+#define GFC_DTYPE_SIZE_SHIFT 6
+
+/* Basic types.  BT_VOID is used by ISO C Binding so funcs like c_f_pointer
+   can take any arg with the pointer attribute as a param.  These are also
+   used in the run-time library for IO.  */
+typedef enum
+{ BT_UNKNOWN = 0, BT_INTEGER, BT_LOGICAL, BT_REAL, BT_COMPLEX,
+  BT_DERIVED, BT_CHARACTER, BT_CLASS, BT_PROCEDURE, BT_HOLLERITH, BT_VOID,
+  BT_ASSUMED
+}
+bt;
diff --git a/gcc-4.9/gcc/fortran/match.c b/gcc-4.9/gcc/fortran/match.c
new file mode 100644
index 000000000..4c4609401
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/match.c
@@ -0,0 +1,5749 @@
+/* Matching subroutines in all sizes, shapes and colors.
+   Copyright (C) 2000-2014 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "flags.h"
+#include "gfortran.h"
+#include "match.h"
+#include "parse.h"
+#include "tree.h"
+#include "stringpool.h"
+
+int gfc_matching_ptr_assignment = 0;
+int gfc_matching_procptr_assignment = 0;
+bool gfc_matching_prefix = false;
+
+/* Stack of SELECT TYPE statements.  */
+gfc_select_type_stack *select_type_stack = NULL;
+
+/* For debugging and diagnostic purposes.  Return the textual representation
+   of the intrinsic operator OP.  */
+const char *
+gfc_op2string (gfc_intrinsic_op op)
+{
+  switch (op)
+    {
+    case INTRINSIC_UPLUS:
+    case INTRINSIC_PLUS:
+      return "+";
+
+    case INTRINSIC_UMINUS:
+    case INTRINSIC_MINUS:
+      return "-";
+
+    case INTRINSIC_POWER:
+      return "**";
+    case INTRINSIC_CONCAT:
+      return "//";
+    case INTRINSIC_TIMES:
+      return "*";
+    case INTRINSIC_DIVIDE:
+      return "/";
+
+    case INTRINSIC_AND:
+      return ".and.";
+    case INTRINSIC_OR:
+      return ".or.";
+    case INTRINSIC_EQV:
+      return ".eqv.";
+    case INTRINSIC_NEQV:
+      return ".neqv.";
+
+    case INTRINSIC_EQ_OS:
+      return ".eq.";
+    case INTRINSIC_EQ:
+      return "==";
+    case INTRINSIC_NE_OS:
+      return ".ne.";
+    case INTRINSIC_NE:
+      return "/=";
+    case INTRINSIC_GE_OS:
+      return ".ge.";
+    case INTRINSIC_GE:
+      return ">=";
+    case INTRINSIC_LE_OS:
+      return ".le.";
+    case INTRINSIC_LE:
+      return "<=";
+    case INTRINSIC_LT_OS:
+      return ".lt.";
+    case INTRINSIC_LT:
+      return "<";
+    case INTRINSIC_GT_OS:
+      return ".gt.";
+    case INTRINSIC_GT:
+      return ">";
+    case INTRINSIC_NOT:
+      return ".not.";
+
+    case INTRINSIC_ASSIGN:
+      return "=";
+
+    case INTRINSIC_PARENTHESES:
+      return "parens";
+
+    default:
+      break;
+    }
+
+  gfc_internal_error ("gfc_op2string(): Bad code");
+  /* Not reached.  */
+}
+
+
+/******************** Generic matching subroutines ************************/
+
+/* This function scans the current statement counting the opened and closed
+   parenthesis to make sure they are balanced.  */
+
+match
+gfc_match_parens (void)
+{
+  locus old_loc, where;
+  int count;
+  gfc_instring instring;
+  gfc_char_t c, quote;
+
+  old_loc = gfc_current_locus;
+  count = 0;
+  instring = NONSTRING;
+  quote = ' ';
+
+  for (;;)
+    {
+      c = gfc_next_char_literal (instring);
+      if (c == '\n')
+	break;
+      if (quote == ' ' && ((c == '\'') || (c == '"')))
+	{
+	  quote = c;
+	  instring = INSTRING_WARN;
+	  continue;
+	}
+      if (quote != ' ' && c == quote)
+	{
+	  quote = ' ';
+	  instring = NONSTRING;
+	  continue;
+	}
+
+      if (c == '(' && quote == ' ')
+	{
+	  count++;
+	  where = gfc_current_locus;
+	}
+      if (c == ')' && quote == ' ')
+	{
+	  count--;
+	  where = gfc_current_locus;
+	}
+    }
+
+  gfc_current_locus = old_loc;
+
+  if (count > 0)
+    {
+      gfc_error ("Missing ')' in statement at or before %L", &where);
+      return MATCH_ERROR;
+    }
+  if (count < 0)
+    {
+      gfc_error ("Missing '(' in statement at or before %L", &where);
+      return MATCH_ERROR;
+    }
+
+  return MATCH_YES;
+}
+
+
+/* See if the next character is a special character that has
+   escaped by a \ via the -fbackslash option.  */
+
+match
+gfc_match_special_char (gfc_char_t *res)
+{
+  int len, i;
+  gfc_char_t c, n;
+  match m;
+
+  m = MATCH_YES;
+
+  switch ((c = gfc_next_char_literal (INSTRING_WARN)))
+    {
+    case 'a':
+      *res = '\a';
+      break;
+    case 'b':
+      *res = '\b';
+      break;
+    case 't':
+      *res = '\t';
+      break;
+    case 'f':
+      *res = '\f';
+      break;
+    case 'n':
+      *res = '\n';
+      break;
+    case 'r':
+      *res = '\r';
+      break;
+    case 'v':
+      *res = '\v';
+      break;
+    case '\\':
+      *res = '\\';
+      break;
+    case '0':
+      *res = '\0';
+      break;
+
+    case 'x':
+    case 'u':
+    case 'U':
+      /* Hexadecimal form of wide characters.  */
+      len = (c == 'x' ? 2 : (c == 'u' ? 4 : 8));
+      n = 0;
+      for (i = 0; i < len; i++)
+	{
+	  char buf[2] = { '\0', '\0' };
+
+	  c = gfc_next_char_literal (INSTRING_WARN);
+	  if (!gfc_wide_fits_in_byte (c)
+	      || !gfc_check_digit ((unsigned char) c, 16))
+	    return MATCH_NO;
+
+	  buf[0] = (unsigned char) c;
+	  n = n << 4;
+	  n += strtol (buf, NULL, 16);
+	}
+      *res = n;
+      break;
+
+    default:
+      /* Unknown backslash codes are simply not expanded.  */
+      m = MATCH_NO;
+      break;
+    }
+
+  return m;
+}
+
+
+/* In free form, match at least one space.  Always matches in fixed
+   form.  */
+
+match
+gfc_match_space (void)
+{
+  locus old_loc;
+  char c;
+
+  if (gfc_current_form == FORM_FIXED)
+    return MATCH_YES;
+
+  old_loc = gfc_current_locus;
+
+  c = gfc_next_ascii_char ();
+  if (!gfc_is_whitespace (c))
+    {
+      gfc_current_locus = old_loc;
+      return MATCH_NO;
+    }
+
+  gfc_gobble_whitespace ();
+
+  return MATCH_YES;
+}
+
+
+/* Match an end of statement.  End of statement is optional
+   whitespace, followed by a ';' or '\n' or comment '!'.  If a
+   semicolon is found, we continue to eat whitespace and semicolons.  */
+
+match
+gfc_match_eos (void)
+{
+  locus old_loc;
+  int flag;
+  char c;
+
+  flag = 0;
+
+  for (;;)
+    {
+      old_loc = gfc_current_locus;
+      gfc_gobble_whitespace ();
+
+      c = gfc_next_ascii_char ();
+      switch (c)
+	{
+	case '!':
+	  do
+	    {
+	      c = gfc_next_ascii_char ();
+	    }
+	  while (c != '\n');
+
+	  /* Fall through.  */
+
+	case '\n':
+	  return MATCH_YES;
+
+	case ';':
+	  flag = 1;
+	  continue;
+	}
+
+      break;
+    }
+
+  gfc_current_locus = old_loc;
+  return (flag) ? MATCH_YES : MATCH_NO;
+}
+
+
+/* Match a literal integer on the input, setting the value on
+   MATCH_YES.  Literal ints occur in kind-parameters as well as
+   old-style character length specifications.  If cnt is non-NULL it
+   will be set to the number of digits.  */
+
+match
+gfc_match_small_literal_int (int *value, int *cnt)
+{
+  locus old_loc;
+  char c;
+  int i, j;
+
+  old_loc = gfc_current_locus;
+
+  *value = -1;
+  gfc_gobble_whitespace ();
+  c = gfc_next_ascii_char ();
+  if (cnt)
+    *cnt = 0;
+
+  if (!ISDIGIT (c))
+    {
+      gfc_current_locus = old_loc;
+      return MATCH_NO;
+    }
+
+  i = c - '0';
+  j = 1;
+
+  for (;;)
+    {
+      old_loc = gfc_current_locus;
+      c = gfc_next_ascii_char ();
+
+      if (!ISDIGIT (c))
+	break;
+
+      i = 10 * i + c - '0';
+      j++;
+
+      if (i > 99999999)
+	{
+	  gfc_error ("Integer too large at %C");
+	  return MATCH_ERROR;
+	}
+    }
+
+  gfc_current_locus = old_loc;
+
+  *value = i;
+  if (cnt)
+    *cnt = j;
+  return MATCH_YES;
+}
+
+
+/* Match a small, constant integer expression, like in a kind
+   statement.  On MATCH_YES, 'value' is set.  */
+
+match
+gfc_match_small_int (int *value)
+{
+  gfc_expr *expr;
+  const char *p;
+  match m;
+  int i;
+
+  m = gfc_match_expr (&expr);
+  if (m != MATCH_YES)
+    return m;
+
+  p = gfc_extract_int (expr, &i);
+  gfc_free_expr (expr);
+
+  if (p != NULL)
+    {
+      gfc_error (p);
+      m = MATCH_ERROR;
+    }
+
+  *value = i;
+  return m;
+}
+
+
+/* This function is the same as the gfc_match_small_int, except that
+   we're keeping the pointer to the expr.  This function could just be
+   removed and the previously mentioned one modified, though all calls
+   to it would have to be modified then (and there were a number of
+   them).  Return MATCH_ERROR if fail to extract the int; otherwise,
+   return the result of gfc_match_expr().  The expr (if any) that was
+   matched is returned in the parameter expr.  */
+
+match
+gfc_match_small_int_expr (int *value, gfc_expr **expr)
+{
+  const char *p;
+  match m;
+  int i;
+
+  m = gfc_match_expr (expr);
+  if (m != MATCH_YES)
+    return m;
+
+  p = gfc_extract_int (*expr, &i);
+
+  if (p != NULL)
+    {
+      gfc_error (p);
+      m = MATCH_ERROR;
+    }
+
+  *value = i;
+  return m;
+}
+
+
+/* Matches a statement label.  Uses gfc_match_small_literal_int() to
+   do most of the work.  */
+
+match
+gfc_match_st_label (gfc_st_label **label)
+{
+  locus old_loc;
+  match m;
+  int i, cnt;
+
+  old_loc = gfc_current_locus;
+
+  m = gfc_match_small_literal_int (&i, &cnt);
+  if (m != MATCH_YES)
+    return m;
+
+  if (cnt > 5)
+    {
+      gfc_error ("Too many digits in statement label at %C");
+      goto cleanup;
+    }
+
+  if (i == 0)
+    {
+      gfc_error ("Statement label at %C is zero");
+      goto cleanup;
+    }
+
+  *label = gfc_get_st_label (i);
+  return MATCH_YES;
+
+cleanup:
+
+  gfc_current_locus = old_loc;
+  return MATCH_ERROR;
+}
+
+
+/* Match and validate a label associated with a named IF, DO or SELECT
+   statement.  If the symbol does not have the label attribute, we add
+   it.  We also make sure the symbol does not refer to another
+   (active) block.  A matched label is pointed to by gfc_new_block.  */
+
+match
+gfc_match_label (void)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  match m;
+
+  gfc_new_block = NULL;
+
+  m = gfc_match (" %n :", name);
+  if (m != MATCH_YES)
+    return m;
+
+  if (gfc_get_symbol (name, NULL, &gfc_new_block))
+    {
+      gfc_error ("Label name '%s' at %C is ambiguous", name);
+      return MATCH_ERROR;
+    }
+
+  if (gfc_new_block->attr.flavor == FL_LABEL)
+    {
+      gfc_error ("Duplicate construct label '%s' at %C", name);
+      return MATCH_ERROR;
+    }
+
+  if (!gfc_add_flavor (&gfc_new_block->attr, FL_LABEL, 
+		       gfc_new_block->name, NULL))
+    return MATCH_ERROR;
+
+  return MATCH_YES;
+}
+
+
+/* See if the current input looks like a name of some sort.  Modifies
+   the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
+   Note that options.c restricts max_identifier_length to not more
+   than GFC_MAX_SYMBOL_LEN.  */
+
+match
+gfc_match_name (char *buffer)
+{
+  locus old_loc;
+  int i;
+  char c;
+
+  old_loc = gfc_current_locus;
+  gfc_gobble_whitespace ();
+
+  c = gfc_next_ascii_char ();
+  if (!(ISALPHA (c) || (c == '_' && gfc_option.flag_allow_leading_underscore)))
+    {
+      if (gfc_error_flag_test () == 0 && c != '(')
+	gfc_error ("Invalid character in name at %C");
+      gfc_current_locus = old_loc;
+      return MATCH_NO;
+    }
+
+  i = 0;
+
+  do
+    {
+      buffer[i++] = c;
+
+      if (i > gfc_option.max_identifier_length)
+	{
+	  gfc_error ("Name at %C is too long");
+	  return MATCH_ERROR;
+	}
+
+      old_loc = gfc_current_locus;
+      c = gfc_next_ascii_char ();
+    }
+  while (ISALNUM (c) || c == '_' || (gfc_option.flag_dollar_ok && c == '$'));
+
+  if (c == '$' && !gfc_option.flag_dollar_ok)
+    {
+      gfc_fatal_error ("Invalid character '$' at %L. Use -fdollar-ok to allow "
+		       "it as an extension", &old_loc);
+      return MATCH_ERROR;
+    }
+
+  buffer[i] = '\0';
+  gfc_current_locus = old_loc;
+
+  return MATCH_YES;
+}
+
+
+/* Match a valid name for C, which is almost the same as for Fortran,
+   except that you can start with an underscore, etc..  It could have
+   been done by modifying the gfc_match_name, but this way other
+   things C allows can be done, such as no limits on the length.
+   Also, by rewriting it, we use the gfc_next_char_C() to prevent the
+   input characters from being automatically lower cased, since C is
+   case sensitive.  The parameter, buffer, is used to return the name
+   that is matched.  Return MATCH_ERROR if the name is not a valid C
+   name, MATCH_NO if what we're seeing isn't a name, and MATCH_YES if
+   we successfully match a C name.  */
+
+match
+gfc_match_name_C (const char **buffer)
+{
+  locus old_loc;
+  size_t i = 0;
+  gfc_char_t c;
+  char* buf;
+  size_t cursz = 16;
+
+  old_loc = gfc_current_locus;
+  gfc_gobble_whitespace ();
+
+  /* Get the next char (first possible char of name) and see if
+     it's valid for C (either a letter or an underscore).  */
+  c = gfc_next_char_literal (INSTRING_WARN);
+
+  /* If the user put nothing expect spaces between the quotes, it is valid
+     and simply means there is no name= specifier and the name is the Fortran
+     symbol name, all lowercase.  */
+  if (c == '"' || c == '\'')
+    {
+      gfc_current_locus = old_loc;
+      return MATCH_YES;
+    }
+
+  if (!ISALPHA (c) && c != '_')
+    {
+      gfc_error ("Invalid C name in NAME= specifier at %C");
+      return MATCH_ERROR;
+    }
+
+  buf = XNEWVEC (char, cursz);
+  /* Continue to read valid variable name characters.  */
+  do
+    {
+      gcc_assert (gfc_wide_fits_in_byte (c));
+
+      buf[i++] = (unsigned char) c;
+
+      if (i >= cursz)
+	{
+	  cursz *= 2;
+	  buf = XRESIZEVEC (char, buf, cursz);
+	}
+
+      old_loc = gfc_current_locus;
+
+      /* Get next char; param means we're in a string.  */
+      c = gfc_next_char_literal (INSTRING_WARN);
+    } while (ISALNUM (c) || c == '_');
+
+  /* The binding label will be needed later anyway, so just insert it
+     into the symbol table.  */
+  buf[i] = '\0';
+  *buffer = IDENTIFIER_POINTER (get_identifier (buf));
+  XDELETEVEC (buf);
+  gfc_current_locus = old_loc;
+
+  /* See if we stopped because of whitespace.  */
+  if (c == ' ')
+    {
+      gfc_gobble_whitespace ();
+      c = gfc_peek_ascii_char ();
+      if (c != '"' && c != '\'')
+        {
+          gfc_error ("Embedded space in NAME= specifier at %C");
+          return MATCH_ERROR;
+        }
+    }
+
+  /* If we stopped because we had an invalid character for a C name, report
+     that to the user by returning MATCH_NO.  */
+  if (c != '"' && c != '\'')
+    {
+      gfc_error ("Invalid C name in NAME= specifier at %C");
+      return MATCH_ERROR;
+    }
+
+  return MATCH_YES;
+}
+
+
+/* Match a symbol on the input.  Modifies the pointer to the symbol
+   pointer if successful.  */
+
+match
+gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc)
+{
+  char buffer[GFC_MAX_SYMBOL_LEN + 1];
+  match m;
+
+  m = gfc_match_name (buffer);
+  if (m != MATCH_YES)
+    return m;
+
+  if (host_assoc)
+    return (gfc_get_ha_sym_tree (buffer, matched_symbol))
+	    ? MATCH_ERROR : MATCH_YES;
+
+  if (gfc_get_sym_tree (buffer, NULL, matched_symbol, false))
+    return MATCH_ERROR;
+
+  return MATCH_YES;
+}
+
+
+match
+gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc)
+{
+  gfc_symtree *st;
+  match m;
+
+  m = gfc_match_sym_tree (&st, host_assoc);
+
+  if (m == MATCH_YES)
+    {
+      if (st)
+	*matched_symbol = st->n.sym;
+      else
+	*matched_symbol = NULL;
+    }
+  else
+    *matched_symbol = NULL;
+  return m;
+}
+
+
+/* Match an intrinsic operator.  Returns an INTRINSIC enum. While matching,
+   we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
+   in matchexp.c.  */
+
+match
+gfc_match_intrinsic_op (gfc_intrinsic_op *result)
+{
+  locus orig_loc = gfc_current_locus;
+  char ch;
+
+  gfc_gobble_whitespace ();
+  ch = gfc_next_ascii_char ();
+  switch (ch)
+    {
+    case '+':
+      /* Matched "+".  */
+      *result = INTRINSIC_PLUS;
+      return MATCH_YES;
+
+    case '-':
+      /* Matched "-".  */
+      *result = INTRINSIC_MINUS;
+      return MATCH_YES;
+
+    case '=':
+      if (gfc_next_ascii_char () == '=')
+	{
+	  /* Matched "==".  */
+	  *result = INTRINSIC_EQ;
+	  return MATCH_YES;
+	}
+      break;
+
+    case '<':
+      if (gfc_peek_ascii_char () == '=')
+	{
+	  /* Matched "<=".  */
+	  gfc_next_ascii_char ();
+	  *result = INTRINSIC_LE;
+	  return MATCH_YES;
+	}
+      /* Matched "<".  */
+      *result = INTRINSIC_LT;
+      return MATCH_YES;
+
+    case '>':
+      if (gfc_peek_ascii_char () == '=')
+	{
+	  /* Matched ">=".  */
+	  gfc_next_ascii_char ();
+	  *result = INTRINSIC_GE;
+	  return MATCH_YES;
+	}
+      /* Matched ">".  */
+      *result = INTRINSIC_GT;
+      return MATCH_YES;
+
+    case '*':
+      if (gfc_peek_ascii_char () == '*')
+	{
+	  /* Matched "**".  */
+	  gfc_next_ascii_char ();
+	  *result = INTRINSIC_POWER;
+	  return MATCH_YES;
+	}
+      /* Matched "*".  */
+      *result = INTRINSIC_TIMES;
+      return MATCH_YES;
+
+    case '/':
+      ch = gfc_peek_ascii_char ();
+      if (ch == '=')
+	{
+	  /* Matched "/=".  */
+	  gfc_next_ascii_char ();
+	  *result = INTRINSIC_NE;
+	  return MATCH_YES;
+	}
+      else if (ch == '/')
+	{
+	  /* Matched "//".  */
+	  gfc_next_ascii_char ();
+	  *result = INTRINSIC_CONCAT;
+	  return MATCH_YES;
+	}
+      /* Matched "/".  */
+      *result = INTRINSIC_DIVIDE;
+      return MATCH_YES;
+
+    case '.':
+      ch = gfc_next_ascii_char ();
+      switch (ch)
+	{
+	case 'a':
+	  if (gfc_next_ascii_char () == 'n'
+	      && gfc_next_ascii_char () == 'd'
+	      && gfc_next_ascii_char () == '.')
+	    {
+	      /* Matched ".and.".  */
+	      *result = INTRINSIC_AND;
+	      return MATCH_YES;
+	    }
+	  break;
+
+	case 'e':
+	  if (gfc_next_ascii_char () == 'q')
+	    {
+	      ch = gfc_next_ascii_char ();
+	      if (ch == '.')
+		{
+		  /* Matched ".eq.".  */
+		  *result = INTRINSIC_EQ_OS;
+		  return MATCH_YES;
+		}
+	      else if (ch == 'v')
+		{
+		  if (gfc_next_ascii_char () == '.')
+		    {
+		      /* Matched ".eqv.".  */
+		      *result = INTRINSIC_EQV;
+		      return MATCH_YES;
+		    }
+		}
+	    }
+	  break;
+
+	case 'g':
+	  ch = gfc_next_ascii_char ();
+	  if (ch == 'e')
+	    {
+	      if (gfc_next_ascii_char () == '.')
+		{
+		  /* Matched ".ge.".  */
+		  *result = INTRINSIC_GE_OS;
+		  return MATCH_YES;
+		}
+	    }
+	  else if (ch == 't')
+	    {
+	      if (gfc_next_ascii_char () == '.')
+		{
+		  /* Matched ".gt.".  */
+		  *result = INTRINSIC_GT_OS;
+		  return MATCH_YES;
+		}
+	    }
+	  break;
+
+	case 'l':
+	  ch = gfc_next_ascii_char ();
+	  if (ch == 'e')
+	    {
+	      if (gfc_next_ascii_char () == '.')
+		{
+		  /* Matched ".le.".  */
+		  *result = INTRINSIC_LE_OS;
+		  return MATCH_YES;
+		}
+	    }
+	  else if (ch == 't')
+	    {
+	      if (gfc_next_ascii_char () == '.')
+		{
+		  /* Matched ".lt.".  */
+		  *result = INTRINSIC_LT_OS;
+		  return MATCH_YES;
+		}
+	    }
+	  break;
+
+	case 'n':
+	  ch = gfc_next_ascii_char ();
+	  if (ch == 'e')
+	    {
+	      ch = gfc_next_ascii_char ();
+	      if (ch == '.')
+		{
+		  /* Matched ".ne.".  */
+		  *result = INTRINSIC_NE_OS;
+		  return MATCH_YES;
+		}
+	      else if (ch == 'q')
+		{
+		  if (gfc_next_ascii_char () == 'v'
+		      && gfc_next_ascii_char () == '.')
+		    {
+		      /* Matched ".neqv.".  */
+		      *result = INTRINSIC_NEQV;
+		      return MATCH_YES;
+		    }
+		}
+	    }
+	  else if (ch == 'o')
+	    {
+	      if (gfc_next_ascii_char () == 't'
+		  && gfc_next_ascii_char () == '.')
+		{
+		  /* Matched ".not.".  */
+		  *result = INTRINSIC_NOT;
+		  return MATCH_YES;
+		}
+	    }
+	  break;
+
+	case 'o':
+	  if (gfc_next_ascii_char () == 'r'
+	      && gfc_next_ascii_char () == '.')
+	    {
+	      /* Matched ".or.".  */
+	      *result = INTRINSIC_OR;
+	      return MATCH_YES;
+	    }
+	  break;
+
+	default:
+	  break;
+	}
+      break;
+
+    default:
+      break;
+    }
+
+  gfc_current_locus = orig_loc;
+  return MATCH_NO;
+}
+
+
+/* Match a loop control phrase:
+
+    <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
+
+   If the final integer expression is not present, a constant unity
+   expression is returned.  We don't return MATCH_ERROR until after
+   the equals sign is seen.  */
+
+match
+gfc_match_iterator (gfc_iterator *iter, int init_flag)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_expr *var, *e1, *e2, *e3;
+  locus start;
+  match m;
+
+  e1 = e2 = e3 = NULL;
+
+  /* Match the start of an iterator without affecting the symbol table.  */
+
+  start = gfc_current_locus;
+  m = gfc_match (" %n =", name);
+  gfc_current_locus = start;
+
+  if (m != MATCH_YES)
+    return MATCH_NO;
+
+  m = gfc_match_variable (&var, 0);
+  if (m != MATCH_YES)
+    return MATCH_NO;
+
+  /* F2008, C617 & C565.  */
+  if (var->symtree->n.sym->attr.codimension)
+    {
+      gfc_error ("Loop variable at %C cannot be a coarray");
+      goto cleanup;
+    }
+
+  if (var->ref != NULL)
+    {
+      gfc_error ("Loop variable at %C cannot be a sub-component");
+      goto cleanup;
+    }
+
+  gfc_match_char ('=');
+
+  var->symtree->n.sym->attr.implied_index = 1;
+
+  m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1);
+  if (m == MATCH_NO)
+    goto syntax;
+  if (m == MATCH_ERROR)
+    goto cleanup;
+
+  if (gfc_match_char (',') != MATCH_YES)
+    goto syntax;
+
+  m = init_flag ? gfc_match_init_expr (&e2) : gfc_match_expr (&e2);
+  if (m == MATCH_NO)
+    goto syntax;
+  if (m == MATCH_ERROR)
+    goto cleanup;
+
+  if (gfc_match_char (',') != MATCH_YES)
+    {
+      e3 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+      goto done;
+    }
+
+  m = init_flag ? gfc_match_init_expr (&e3) : gfc_match_expr (&e3);
+  if (m == MATCH_ERROR)
+    goto cleanup;
+  if (m == MATCH_NO)
+    {
+      gfc_error ("Expected a step value in iterator at %C");
+      goto cleanup;
+    }
+
+done:
+  iter->var = var;
+  iter->start = e1;
+  iter->end = e2;
+  iter->step = e3;
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in iterator at %C");
+
+cleanup:
+  gfc_free_expr (e1);
+  gfc_free_expr (e2);
+  gfc_free_expr (e3);
+
+  return MATCH_ERROR;
+}
+
+
+/* Tries to match the next non-whitespace character on the input.
+   This subroutine does not return MATCH_ERROR.  */
+
+match
+gfc_match_char (char c)
+{
+  locus where;
+
+  where = gfc_current_locus;
+  gfc_gobble_whitespace ();
+
+  if (gfc_next_ascii_char () == c)
+    return MATCH_YES;
+
+  gfc_current_locus = where;
+  return MATCH_NO;
+}
+
+
+/* General purpose matching subroutine.  The target string is a
+   scanf-like format string in which spaces correspond to arbitrary
+   whitespace (including no whitespace), characters correspond to
+   themselves.  The %-codes are:
+
+   %%  Literal percent sign
+   %e  Expression, pointer to a pointer is set
+   %s  Symbol, pointer to the symbol is set
+   %n  Name, character buffer is set to name
+   %t  Matches end of statement.
+   %o  Matches an intrinsic operator, returned as an INTRINSIC enum.
+   %l  Matches a statement label
+   %v  Matches a variable expression (an lvalue)
+   %   Matches a required space (in free form) and optional spaces.  */
+
+match
+gfc_match (const char *target, ...)
+{
+  gfc_st_label **label;
+  int matches, *ip;
+  locus old_loc;
+  va_list argp;
+  char c, *np;
+  match m, n;
+  void **vp;
+  const char *p;
+
+  old_loc = gfc_current_locus;
+  va_start (argp, target);
+  m = MATCH_NO;
+  matches = 0;
+  p = target;
+
+loop:
+  c = *p++;
+  switch (c)
+    {
+    case ' ':
+      gfc_gobble_whitespace ();
+      goto loop;
+    case '\0':
+      m = MATCH_YES;
+      break;
+
+    case '%':
+      c = *p++;
+      switch (c)
+	{
+	case 'e':
+	  vp = va_arg (argp, void **);
+	  n = gfc_match_expr ((gfc_expr **) vp);
+	  if (n != MATCH_YES)
+	    {
+	      m = n;
+	      goto not_yes;
+	    }
+
+	  matches++;
+	  goto loop;
+
+	case 'v':
+	  vp = va_arg (argp, void **);
+	  n = gfc_match_variable ((gfc_expr **) vp, 0);
+	  if (n != MATCH_YES)
+	    {
+	      m = n;
+	      goto not_yes;
+	    }
+
+	  matches++;
+	  goto loop;
+
+	case 's':
+	  vp = va_arg (argp, void **);
+	  n = gfc_match_symbol ((gfc_symbol **) vp, 0);
+	  if (n != MATCH_YES)
+	    {
+	      m = n;
+	      goto not_yes;
+	    }
+
+	  matches++;
+	  goto loop;
+
+	case 'n':
+	  np = va_arg (argp, char *);
+	  n = gfc_match_name (np);
+	  if (n != MATCH_YES)
+	    {
+	      m = n;
+	      goto not_yes;
+	    }
+
+	  matches++;
+	  goto loop;
+
+	case 'l':
+	  label = va_arg (argp, gfc_st_label **);
+	  n = gfc_match_st_label (label);
+	  if (n != MATCH_YES)
+	    {
+	      m = n;
+	      goto not_yes;
+	    }
+
+	  matches++;
+	  goto loop;
+
+	case 'o':
+	  ip = va_arg (argp, int *);
+	  n = gfc_match_intrinsic_op ((gfc_intrinsic_op *) ip);
+	  if (n != MATCH_YES)
+	    {
+	      m = n;
+	      goto not_yes;
+	    }
+
+	  matches++;
+	  goto loop;
+
+	case 't':
+	  if (gfc_match_eos () != MATCH_YES)
+	    {
+	      m = MATCH_NO;
+	      goto not_yes;
+	    }
+	  goto loop;
+
+	case ' ':
+	  if (gfc_match_space () == MATCH_YES)
+	    goto loop;
+	  m = MATCH_NO;
+	  goto not_yes;
+
+	case '%':
+	  break;	/* Fall through to character matcher.  */
+
+	default:
+	  gfc_internal_error ("gfc_match(): Bad match code %c", c);
+	}
+
+    default:
+
+      /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
+	 expect an upper case character here!  */
+      gcc_assert (TOLOWER (c) == c);
+
+      if (c == gfc_next_ascii_char ())
+	goto loop;
+      break;
+    }
+
+not_yes:
+  va_end (argp);
+
+  if (m != MATCH_YES)
+    {
+      /* Clean up after a failed match.  */
+      gfc_current_locus = old_loc;
+      va_start (argp, target);
+
+      p = target;
+      for (; matches > 0; matches--)
+	{
+	  while (*p++ != '%');
+
+	  switch (*p++)
+	    {
+	    case '%':
+	      matches++;
+	      break;		/* Skip.  */
+
+	    /* Matches that don't have to be undone */
+	    case 'o':
+	    case 'l':
+	    case 'n':
+	    case 's':
+	      (void) va_arg (argp, void **);
+	      break;
+
+	    case 'e':
+	    case 'v':
+	      vp = va_arg (argp, void **);
+	      gfc_free_expr ((struct gfc_expr *)*vp);
+	      *vp = NULL;
+	      break;
+	    }
+	}
+
+      va_end (argp);
+    }
+
+  return m;
+}
+
+
+/*********************** Statement level matching **********************/
+
+/* Matches the start of a program unit, which is the program keyword
+   followed by an obligatory symbol.  */
+
+match
+gfc_match_program (void)
+{
+  gfc_symbol *sym;
+  match m;
+
+  m = gfc_match ("% %s%t", &sym);
+
+  if (m == MATCH_NO)
+    {
+      gfc_error ("Invalid form of PROGRAM statement at %C");
+      m = MATCH_ERROR;
+    }
+
+  if (m == MATCH_ERROR)
+    return m;
+
+  if (!gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL))
+    return MATCH_ERROR;
+
+  gfc_new_block = sym;
+
+  return MATCH_YES;
+}
+
+
+/* Match a simple assignment statement.  */
+
+match
+gfc_match_assignment (void)
+{
+  gfc_expr *lvalue, *rvalue;
+  locus old_loc;
+  match m;
+
+  old_loc = gfc_current_locus;
+
+  lvalue = NULL;
+  m = gfc_match (" %v =", &lvalue);
+  if (m != MATCH_YES)
+    {
+      gfc_current_locus = old_loc;
+      gfc_free_expr (lvalue);
+      return MATCH_NO;
+    }
+
+  rvalue = NULL;
+  m = gfc_match (" %e%t", &rvalue);
+  if (m != MATCH_YES)
+    {
+      gfc_current_locus = old_loc;
+      gfc_free_expr (lvalue);
+      gfc_free_expr (rvalue);
+      return m;
+    }
+
+  gfc_set_sym_referenced (lvalue->symtree->n.sym);
+
+  new_st.op = EXEC_ASSIGN;
+  new_st.expr1 = lvalue;
+  new_st.expr2 = rvalue;
+
+  gfc_check_do_variable (lvalue->symtree);
+
+  return MATCH_YES;
+}
+
+
+/* Match a pointer assignment statement.  */
+
+match
+gfc_match_pointer_assignment (void)
+{
+  gfc_expr *lvalue, *rvalue;
+  locus old_loc;
+  match m;
+
+  old_loc = gfc_current_locus;
+
+  lvalue = rvalue = NULL;
+  gfc_matching_ptr_assignment = 0;
+  gfc_matching_procptr_assignment = 0;
+
+  m = gfc_match (" %v =>", &lvalue);
+  if (m != MATCH_YES)
+    {
+      m = MATCH_NO;
+      goto cleanup;
+    }
+
+  if (lvalue->symtree->n.sym->attr.proc_pointer
+      || gfc_is_proc_ptr_comp (lvalue))
+    gfc_matching_procptr_assignment = 1;
+  else
+    gfc_matching_ptr_assignment = 1;
+
+  m = gfc_match (" %e%t", &rvalue);
+  gfc_matching_ptr_assignment = 0;
+  gfc_matching_procptr_assignment = 0;
+  if (m != MATCH_YES)
+    goto cleanup;
+
+  new_st.op = EXEC_POINTER_ASSIGN;
+  new_st.expr1 = lvalue;
+  new_st.expr2 = rvalue;
+
+  return MATCH_YES;
+
+cleanup:
+  gfc_current_locus = old_loc;
+  gfc_free_expr (lvalue);
+  gfc_free_expr (rvalue);
+  return m;
+}
+
+
+/* We try to match an easy arithmetic IF statement. This only happens
+   when just after having encountered a simple IF statement. This code
+   is really duplicate with parts of the gfc_match_if code, but this is
+   *much* easier.  */
+
+static match
+match_arithmetic_if (void)
+{
+  gfc_st_label *l1, *l2, *l3;
+  gfc_expr *expr;
+  match m;
+
+  m = gfc_match (" ( %e ) %l , %l , %l%t", &expr, &l1, &l2, &l3);
+  if (m != MATCH_YES)
+    return m;
+
+  if (!gfc_reference_st_label (l1, ST_LABEL_TARGET)
+      || !gfc_reference_st_label (l2, ST_LABEL_TARGET)
+      || !gfc_reference_st_label (l3, ST_LABEL_TARGET))
+    {
+      gfc_free_expr (expr);
+      return MATCH_ERROR;
+    }
+
+  if (!gfc_notify_std (GFC_STD_F95_OBS, "Arithmetic IF statement at %C"))
+    return MATCH_ERROR;
+
+  new_st.op = EXEC_ARITHMETIC_IF;
+  new_st.expr1 = expr;
+  new_st.label1 = l1;
+  new_st.label2 = l2;
+  new_st.label3 = l3;
+
+  return MATCH_YES;
+}
+
+
+/* The IF statement is a bit of a pain.  First of all, there are three
+   forms of it, the simple IF, the IF that starts a block and the
+   arithmetic IF.
+
+   There is a problem with the simple IF and that is the fact that we
+   only have a single level of undo information on symbols.  What this
+   means is for a simple IF, we must re-match the whole IF statement
+   multiple times in order to guarantee that the symbol table ends up
+   in the proper state.  */
+
+static match match_simple_forall (void);
+static match match_simple_where (void);
+
+match
+gfc_match_if (gfc_statement *if_type)
+{
+  gfc_expr *expr;
+  gfc_st_label *l1, *l2, *l3;
+  locus old_loc, old_loc2;
+  gfc_code *p;
+  match m, n;
+
+  n = gfc_match_label ();
+  if (n == MATCH_ERROR)
+    return n;
+
+  old_loc = gfc_current_locus;
+
+  m = gfc_match (" if ( %e", &expr);
+  if (m != MATCH_YES)
+    return m;
+
+  old_loc2 = gfc_current_locus;
+  gfc_current_locus = old_loc;
+
+  if (gfc_match_parens () == MATCH_ERROR)
+    return MATCH_ERROR;
+
+  gfc_current_locus = old_loc2;
+
+  if (gfc_match_char (')') != MATCH_YES)
+    {
+      gfc_error ("Syntax error in IF-expression at %C");
+      gfc_free_expr (expr);
+      return MATCH_ERROR;
+    }
+
+  m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3);
+
+  if (m == MATCH_YES)
+    {
+      if (n == MATCH_YES)
+	{
+	  gfc_error ("Block label not appropriate for arithmetic IF "
+		     "statement at %C");
+	  gfc_free_expr (expr);
+	  return MATCH_ERROR;
+	}
+
+      if (!gfc_reference_st_label (l1, ST_LABEL_TARGET)
+	  || !gfc_reference_st_label (l2, ST_LABEL_TARGET)
+	  || !gfc_reference_st_label (l3, ST_LABEL_TARGET))
+	{
+	  gfc_free_expr (expr);
+	  return MATCH_ERROR;
+	}
+
+      if (!gfc_notify_std (GFC_STD_F95_OBS, "Arithmetic IF statement at %C"))
+	return MATCH_ERROR;
+
+      new_st.op = EXEC_ARITHMETIC_IF;
+      new_st.expr1 = expr;
+      new_st.label1 = l1;
+      new_st.label2 = l2;
+      new_st.label3 = l3;
+
+      *if_type = ST_ARITHMETIC_IF;
+      return MATCH_YES;
+    }
+
+  if (gfc_match (" then%t") == MATCH_YES)
+    {
+      new_st.op = EXEC_IF;
+      new_st.expr1 = expr;
+      *if_type = ST_IF_BLOCK;
+      return MATCH_YES;
+    }
+
+  if (n == MATCH_YES)
+    {
+      gfc_error ("Block label is not appropriate for IF statement at %C");
+      gfc_free_expr (expr);
+      return MATCH_ERROR;
+    }
+
+  /* At this point the only thing left is a simple IF statement.  At
+     this point, n has to be MATCH_NO, so we don't have to worry about
+     re-matching a block label.  From what we've got so far, try
+     matching an assignment.  */
+
+  *if_type = ST_SIMPLE_IF;
+
+  m = gfc_match_assignment ();
+  if (m == MATCH_YES)
+    goto got_match;
+
+  gfc_free_expr (expr);
+  gfc_undo_symbols ();
+  gfc_current_locus = old_loc;
+
+  /* m can be MATCH_NO or MATCH_ERROR, here.  For MATCH_ERROR, a mangled
+     assignment was found.  For MATCH_NO, continue to call the various
+     matchers.  */
+  if (m == MATCH_ERROR)
+    return MATCH_ERROR;
+
+  gfc_match (" if ( %e ) ", &expr);	/* Guaranteed to match.  */
+
+  m = gfc_match_pointer_assignment ();
+  if (m == MATCH_YES)
+    goto got_match;
+
+  gfc_free_expr (expr);
+  gfc_undo_symbols ();
+  gfc_current_locus = old_loc;
+
+  gfc_match (" if ( %e ) ", &expr);	/* Guaranteed to match.  */
+
+  /* Look at the next keyword to see which matcher to call.  Matching
+     the keyword doesn't affect the symbol table, so we don't have to
+     restore between tries.  */
+
+#define match(string, subr, statement) \
+  if (gfc_match (string) == MATCH_YES) { m = subr(); goto got_match; }
+
+  gfc_clear_error ();
+
+  match ("allocate", gfc_match_allocate, ST_ALLOCATE)
+  match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
+  match ("backspace", gfc_match_backspace, ST_BACKSPACE)
+  match ("call", gfc_match_call, ST_CALL)
+  match ("close", gfc_match_close, ST_CLOSE)
+  match ("continue", gfc_match_continue, ST_CONTINUE)
+  match ("cycle", gfc_match_cycle, ST_CYCLE)
+  match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
+  match ("end file", gfc_match_endfile, ST_END_FILE)
+  match ("error stop", gfc_match_error_stop, ST_ERROR_STOP)
+  match ("exit", gfc_match_exit, ST_EXIT)
+  match ("flush", gfc_match_flush, ST_FLUSH)
+  match ("forall", match_simple_forall, ST_FORALL)
+  match ("go to", gfc_match_goto, ST_GOTO)
+  match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
+  match ("inquire", gfc_match_inquire, ST_INQUIRE)
+  match ("lock", gfc_match_lock, ST_LOCK)
+  match ("nullify", gfc_match_nullify, ST_NULLIFY)
+  match ("open", gfc_match_open, ST_OPEN)
+  match ("pause", gfc_match_pause, ST_NONE)
+  match ("print", gfc_match_print, ST_WRITE)
+  match ("read", gfc_match_read, ST_READ)
+  match ("return", gfc_match_return, ST_RETURN)
+  match ("rewind", gfc_match_rewind, ST_REWIND)
+  match ("stop", gfc_match_stop, ST_STOP)
+  match ("wait", gfc_match_wait, ST_WAIT)
+  match ("sync all", gfc_match_sync_all, ST_SYNC_CALL);
+  match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES);
+  match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
+  match ("unlock", gfc_match_unlock, ST_UNLOCK)
+  match ("where", match_simple_where, ST_WHERE)
+  match ("write", gfc_match_write, ST_WRITE)
+
+  /* The gfc_match_assignment() above may have returned a MATCH_NO
+     where the assignment was to a named constant.  Check that
+     special case here.  */
+  m = gfc_match_assignment ();
+  if (m == MATCH_NO)
+   {
+      gfc_error ("Cannot assign to a named constant at %C");
+      gfc_free_expr (expr);
+      gfc_undo_symbols ();
+      gfc_current_locus = old_loc;
+      return MATCH_ERROR;
+   }
+
+  /* All else has failed, so give up.  See if any of the matchers has
+     stored an error message of some sort.  */
+  if (gfc_error_check () == 0)
+    gfc_error ("Unclassifiable statement in IF-clause at %C");
+
+  gfc_free_expr (expr);
+  return MATCH_ERROR;
+
+got_match:
+  if (m == MATCH_NO)
+    gfc_error ("Syntax error in IF-clause at %C");
+  if (m != MATCH_YES)
+    {
+      gfc_free_expr (expr);
+      return MATCH_ERROR;
+    }
+
+  /* At this point, we've matched the single IF and the action clause
+     is in new_st.  Rearrange things so that the IF statement appears
+     in new_st.  */
+
+  p = gfc_get_code (EXEC_IF);
+  p->next = XCNEW (gfc_code);
+  *p->next = new_st;
+  p->next->loc = gfc_current_locus;
+
+  p->expr1 = expr;
+
+  gfc_clear_new_st ();
+
+  new_st.op = EXEC_IF;
+  new_st.block = p;
+
+  return MATCH_YES;
+}
+
+#undef match
+
+
+/* Match an ELSE statement.  */
+
+match
+gfc_match_else (void)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+
+  if (gfc_match_eos () == MATCH_YES)
+    return MATCH_YES;
+
+  if (gfc_match_name (name) != MATCH_YES
+      || gfc_current_block () == NULL
+      || gfc_match_eos () != MATCH_YES)
+    {
+      gfc_error ("Unexpected junk after ELSE statement at %C");
+      return MATCH_ERROR;
+    }
+
+  if (strcmp (name, gfc_current_block ()->name) != 0)
+    {
+      gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
+		 name, gfc_current_block ()->name);
+      return MATCH_ERROR;
+    }
+
+  return MATCH_YES;
+}
+
+
+/* Match an ELSE IF statement.  */
+
+match
+gfc_match_elseif (void)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_expr *expr;
+  match m;
+
+  m = gfc_match (" ( %e ) then", &expr);
+  if (m != MATCH_YES)
+    return m;
+
+  if (gfc_match_eos () == MATCH_YES)
+    goto done;
+
+  if (gfc_match_name (name) != MATCH_YES
+      || gfc_current_block () == NULL
+      || gfc_match_eos () != MATCH_YES)
+    {
+      gfc_error ("Unexpected junk after ELSE IF statement at %C");
+      goto cleanup;
+    }
+
+  if (strcmp (name, gfc_current_block ()->name) != 0)
+    {
+      gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
+		 name, gfc_current_block ()->name);
+      goto cleanup;
+    }
+
+done:
+  new_st.op = EXEC_IF;
+  new_st.expr1 = expr;
+  return MATCH_YES;
+
+cleanup:
+  gfc_free_expr (expr);
+  return MATCH_ERROR;
+}
+
+
+/* Free a gfc_iterator structure.  */
+
+void
+gfc_free_iterator (gfc_iterator *iter, int flag)
+{
+
+  if (iter == NULL)
+    return;
+
+  gfc_free_expr (iter->var);
+  gfc_free_expr (iter->start);
+  gfc_free_expr (iter->end);
+  gfc_free_expr (iter->step);
+
+  if (flag)
+    free (iter);
+}
+
+
+/* Match a CRITICAL statement.  */
+match
+gfc_match_critical (void)
+{
+  gfc_st_label *label = NULL;
+
+  if (gfc_match_label () == MATCH_ERROR)
+    return MATCH_ERROR;
+
+  if (gfc_match (" critical") != MATCH_YES)
+    return MATCH_NO;
+
+  if (gfc_match_st_label (&label) == MATCH_ERROR)
+    return MATCH_ERROR;
+
+  if (gfc_match_eos () != MATCH_YES)
+    {
+      gfc_syntax_error (ST_CRITICAL);
+      return MATCH_ERROR;
+    }
+
+  if (gfc_pure (NULL))
+    {
+      gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
+      return MATCH_ERROR;
+    }
+
+  if (gfc_find_state (COMP_DO_CONCURRENT))
+    {
+      gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT "
+		 "block");
+      return MATCH_ERROR;
+    }
+
+  gfc_unset_implicit_pure (NULL);
+
+  if (!gfc_notify_std (GFC_STD_F2008, "CRITICAL statement at %C"))
+    return MATCH_ERROR;
+
+  if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+    {
+       gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+       return MATCH_ERROR;
+    }
+
+  if (gfc_find_state (COMP_CRITICAL))
+    {
+      gfc_error ("Nested CRITICAL block at %C");
+      return MATCH_ERROR;
+    }
+
+  new_st.op = EXEC_CRITICAL;
+
+  if (label != NULL
+      && !gfc_reference_st_label (label, ST_LABEL_TARGET))
+    return MATCH_ERROR;
+
+  return MATCH_YES;
+}
+
+
+/* Match a BLOCK statement.  */
+
+match
+gfc_match_block (void)
+{
+  match m;
+
+  if (gfc_match_label () == MATCH_ERROR)
+    return MATCH_ERROR;
+
+  if (gfc_match (" block") != MATCH_YES)
+    return MATCH_NO;
+
+  /* For this to be a correct BLOCK statement, the line must end now.  */
+  m = gfc_match_eos ();
+  if (m == MATCH_ERROR)
+    return MATCH_ERROR;
+  if (m == MATCH_NO)
+    return MATCH_NO;
+
+  return MATCH_YES;
+}
+
+
+/* Match an ASSOCIATE statement.  */
+
+match
+gfc_match_associate (void)
+{
+  if (gfc_match_label () == MATCH_ERROR)
+    return MATCH_ERROR;
+
+  if (gfc_match (" associate") != MATCH_YES)
+    return MATCH_NO;
+
+  /* Match the association list.  */
+  if (gfc_match_char ('(') != MATCH_YES)
+    {
+      gfc_error ("Expected association list at %C");
+      return MATCH_ERROR;
+    }
+  new_st.ext.block.assoc = NULL;
+  while (true)
+    {
+      gfc_association_list* newAssoc = gfc_get_association_list ();
+      gfc_association_list* a;
+
+      /* Match the next association.  */
+      if (gfc_match (" %n => %e", newAssoc->name, &newAssoc->target)
+	    != MATCH_YES)
+	{
+	  gfc_error ("Expected association at %C");
+	  goto assocListError;
+	}
+      newAssoc->where = gfc_current_locus;
+
+      /* Check that the current name is not yet in the list.  */
+      for (a = new_st.ext.block.assoc; a; a = a->next)
+	if (!strcmp (a->name, newAssoc->name))
+	  {
+	    gfc_error ("Duplicate name '%s' in association at %C",
+		       newAssoc->name);
+	    goto assocListError;
+	  }
+
+      /* The target expression must not be coindexed.  */
+      if (gfc_is_coindexed (newAssoc->target))
+	{
+	  gfc_error ("Association target at %C must not be coindexed");
+	  goto assocListError;
+	}
+
+      /* The `variable' field is left blank for now; because the target is not
+	 yet resolved, we can't use gfc_has_vector_subscript to determine it
+	 for now.  This is set during resolution.  */
+
+      /* Put it into the list.  */
+      newAssoc->next = new_st.ext.block.assoc;
+      new_st.ext.block.assoc = newAssoc;
+
+      /* Try next one or end if closing parenthesis is found.  */
+      gfc_gobble_whitespace ();
+      if (gfc_peek_char () == ')')
+	break;
+      if (gfc_match_char (',') != MATCH_YES)
+	{
+	  gfc_error ("Expected ')' or ',' at %C");
+	  return MATCH_ERROR;
+	}
+
+      continue;
+
+assocListError:
+      free (newAssoc);
+      goto error;
+    }
+  if (gfc_match_char (')') != MATCH_YES)
+    {
+      /* This should never happen as we peek above.  */
+      gcc_unreachable ();
+    }
+
+  if (gfc_match_eos () != MATCH_YES)
+    {
+      gfc_error ("Junk after ASSOCIATE statement at %C");
+      goto error;
+    }
+
+  return MATCH_YES;
+
+error:
+  gfc_free_association_list (new_st.ext.block.assoc);
+  return MATCH_ERROR;
+}
+
+
+/* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
+   an accessible derived type.  */
+
+static match
+match_derived_type_spec (gfc_typespec *ts)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  locus old_locus;
+  gfc_symbol *derived;
+
+  old_locus = gfc_current_locus;
+
+  if (gfc_match ("%n", name) != MATCH_YES)
+    {
+       gfc_current_locus = old_locus;
+       return MATCH_NO;
+    }
+
+  gfc_find_symbol (name, NULL, 1, &derived);
+
+  if (derived && derived->attr.flavor == FL_PROCEDURE && derived->attr.generic)
+    derived = gfc_find_dt_in_generic (derived);
+
+  if (derived && derived->attr.flavor == FL_DERIVED)
+    {
+      ts->type = BT_DERIVED;
+      ts->u.derived = derived;
+      return MATCH_YES;
+    }
+
+  gfc_current_locus = old_locus;
+  return MATCH_NO;
+}
+
+
+/* Match a Fortran 2003 type-spec (F03:R401).  This is similar to
+   gfc_match_decl_type_spec() from decl.c, with the following exceptions:
+   It only includes the intrinsic types from the Fortran 2003 standard
+   (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
+   the implicit_flag is not needed, so it was removed. Derived types are
+   identified by their name alone.  */
+
+match
+gfc_match_type_spec (gfc_typespec *ts)
+{
+  match m;
+  locus old_locus;
+
+  gfc_clear_ts (ts);
+  gfc_gobble_whitespace ();
+  old_locus = gfc_current_locus;
+
+  if (match_derived_type_spec (ts) == MATCH_YES)
+    {
+      /* Enforce F03:C401.  */
+      if (ts->u.derived->attr.abstract)
+	{
+	  gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
+		     ts->u.derived->name, &old_locus);
+	  return MATCH_ERROR;
+	}
+      return MATCH_YES;
+    }
+
+  if (gfc_match ("integer") == MATCH_YES)
+    {
+      ts->type = BT_INTEGER;
+      ts->kind = gfc_default_integer_kind;
+      goto kind_selector;
+    }
+
+  if (gfc_match ("real") == MATCH_YES)
+    {
+      ts->type = BT_REAL;
+      ts->kind = gfc_default_real_kind;
+      goto kind_selector;
+    }
+
+  if (gfc_match ("double precision") == MATCH_YES)
+    {
+      ts->type = BT_REAL;
+      ts->kind = gfc_default_double_kind;
+      return MATCH_YES;
+    }
+
+  if (gfc_match ("complex") == MATCH_YES)
+    {
+      ts->type = BT_COMPLEX;
+      ts->kind = gfc_default_complex_kind;
+      goto kind_selector;
+    }
+
+  if (gfc_match ("character") == MATCH_YES)
+    {
+      ts->type = BT_CHARACTER;
+
+      m = gfc_match_char_spec (ts);
+
+      if (m == MATCH_NO)
+	m = MATCH_YES;
+
+      return m;
+    }
+
+  if (gfc_match ("logical") == MATCH_YES)
+    {
+      ts->type = BT_LOGICAL;
+      ts->kind = gfc_default_logical_kind;
+      goto kind_selector;
+    }
+
+  /* If a type is not matched, simply return MATCH_NO.  */
+  gfc_current_locus = old_locus;
+  return MATCH_NO;
+
+kind_selector:
+
+  gfc_gobble_whitespace ();
+  if (gfc_peek_ascii_char () == '*')
+    {
+      gfc_error ("Invalid type-spec at %C");
+      return MATCH_ERROR;
+    }
+
+  m = gfc_match_kind_spec (ts, false);
+
+  if (m == MATCH_NO)
+    m = MATCH_YES;		/* No kind specifier found.  */
+
+  return m;
+}
+
+
+/******************** FORALL subroutines ********************/
+
+/* Free a list of FORALL iterators.  */
+
+void
+gfc_free_forall_iterator (gfc_forall_iterator *iter)
+{
+  gfc_forall_iterator *next;
+
+  while (iter)
+    {
+      next = iter->next;
+      gfc_free_expr (iter->var);
+      gfc_free_expr (iter->start);
+      gfc_free_expr (iter->end);
+      gfc_free_expr (iter->stride);
+      free (iter);
+      iter = next;
+    }
+}
+
+
+/* Match an iterator as part of a FORALL statement.  The format is:
+
+     <var> = <start>:<end>[:<stride>]
+
+   On MATCH_NO, the caller tests for the possibility that there is a
+   scalar mask expression.  */
+
+static match
+match_forall_iterator (gfc_forall_iterator **result)
+{
+  gfc_forall_iterator *iter;
+  locus where;
+  match m;
+
+  where = gfc_current_locus;
+  iter = XCNEW (gfc_forall_iterator);
+
+  m = gfc_match_expr (&iter->var);
+  if (m != MATCH_YES)
+    goto cleanup;
+
+  if (gfc_match_char ('=') != MATCH_YES
+      || iter->var->expr_type != EXPR_VARIABLE)
+    {
+      m = MATCH_NO;
+      goto cleanup;
+    }
+
+  m = gfc_match_expr (&iter->start);
+  if (m != MATCH_YES)
+    goto cleanup;
+
+  if (gfc_match_char (':') != MATCH_YES)
+    goto syntax;
+
+  m = gfc_match_expr (&iter->end);
+  if (m == MATCH_NO)
+    goto syntax;
+  if (m == MATCH_ERROR)
+    goto cleanup;
+
+  if (gfc_match_char (':') == MATCH_NO)
+    iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+  else
+    {
+      m = gfc_match_expr (&iter->stride);
+      if (m == MATCH_NO)
+	goto syntax;
+      if (m == MATCH_ERROR)
+	goto cleanup;
+    }
+
+  /* Mark the iteration variable's symbol as used as a FORALL index.  */
+  iter->var->symtree->n.sym->forall_index = true;
+
+  *result = iter;
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in FORALL iterator at %C");
+  m = MATCH_ERROR;
+
+cleanup:
+
+  gfc_current_locus = where;
+  gfc_free_forall_iterator (iter);
+  return m;
+}
+
+
+/* Match the header of a FORALL statement.  */
+
+static match
+match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
+{
+  gfc_forall_iterator *head, *tail, *new_iter;
+  gfc_expr *msk;
+  match m;
+
+  gfc_gobble_whitespace ();
+
+  head = tail = NULL;
+  msk = NULL;
+
+  if (gfc_match_char ('(') != MATCH_YES)
+    return MATCH_NO;
+
+  m = match_forall_iterator (&new_iter);
+  if (m == MATCH_ERROR)
+    goto cleanup;
+  if (m == MATCH_NO)
+    goto syntax;
+
+  head = tail = new_iter;
+
+  for (;;)
+    {
+      if (gfc_match_char (',') != MATCH_YES)
+	break;
+
+      m = match_forall_iterator (&new_iter);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+
+      if (m == MATCH_YES)
+	{
+	  tail->next = new_iter;
+	  tail = new_iter;
+	  continue;
+	}
+
+      /* Have to have a mask expression.  */
+
+      m = gfc_match_expr (&msk);
+      if (m == MATCH_NO)
+	goto syntax;
+      if (m == MATCH_ERROR)
+	goto cleanup;
+
+      break;
+    }
+
+  if (gfc_match_char (')') == MATCH_NO)
+    goto syntax;
+
+  *phead = head;
+  *mask = msk;
+  return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (ST_FORALL);
+
+cleanup:
+  gfc_free_expr (msk);
+  gfc_free_forall_iterator (head);
+
+  return MATCH_ERROR;
+}
+
+/* Match the rest of a simple FORALL statement that follows an
+   IF statement.  */
+
+static match
+match_simple_forall (void)
+{
+  gfc_forall_iterator *head;
+  gfc_expr *mask;
+  gfc_code *c;
+  match m;
+
+  mask = NULL;
+  head = NULL;
+  c = NULL;
+
+  m = match_forall_header (&head, &mask);
+
+  if (m == MATCH_NO)
+    goto syntax;
+  if (m != MATCH_YES)
+    goto cleanup;
+
+  m = gfc_match_assignment ();
+
+  if (m == MATCH_ERROR)
+    goto cleanup;
+  if (m == MATCH_NO)
+    {
+      m = gfc_match_pointer_assignment ();
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_NO)
+	goto syntax;
+    }
+
+  c = XCNEW (gfc_code);
+  *c = new_st;
+  c->loc = gfc_current_locus;
+
+  if (gfc_match_eos () != MATCH_YES)
+    goto syntax;
+
+  gfc_clear_new_st ();
+  new_st.op = EXEC_FORALL;
+  new_st.expr1 = mask;
+  new_st.ext.forall_iterator = head;
+  new_st.block = gfc_get_code (EXEC_FORALL);
+  new_st.block->next = c;
+
+  return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (ST_FORALL);
+
+cleanup:
+  gfc_free_forall_iterator (head);
+  gfc_free_expr (mask);
+
+  return MATCH_ERROR;
+}
+
+
+/* Match a FORALL statement.  */
+
+match
+gfc_match_forall (gfc_statement *st)
+{
+  gfc_forall_iterator *head;
+  gfc_expr *mask;
+  gfc_code *c;
+  match m0, m;
+
+  head = NULL;
+  mask = NULL;
+  c = NULL;
+
+  m0 = gfc_match_label ();
+  if (m0 == MATCH_ERROR)
+    return MATCH_ERROR;
+
+  m = gfc_match (" forall");
+  if (m != MATCH_YES)
+    return m;
+
+  m = match_forall_header (&head, &mask);
+  if (m == MATCH_ERROR)
+    goto cleanup;
+  if (m == MATCH_NO)
+    goto syntax;
+
+  if (gfc_match_eos () == MATCH_YES)
+    {
+      *st = ST_FORALL_BLOCK;
+      new_st.op = EXEC_FORALL;
+      new_st.expr1 = mask;
+      new_st.ext.forall_iterator = head;
+      return MATCH_YES;
+    }
+
+  m = gfc_match_assignment ();
+  if (m == MATCH_ERROR)
+    goto cleanup;
+  if (m == MATCH_NO)
+    {
+      m = gfc_match_pointer_assignment ();
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_NO)
+	goto syntax;
+    }
+
+  c = XCNEW (gfc_code);
+  *c = new_st;
+  c->loc = gfc_current_locus;
+
+  gfc_clear_new_st ();
+  new_st.op = EXEC_FORALL;
+  new_st.expr1 = mask;
+  new_st.ext.forall_iterator = head;
+  new_st.block = gfc_get_code (EXEC_FORALL);
+  new_st.block->next = c;
+
+  *st = ST_FORALL;
+  return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (ST_FORALL);
+
+cleanup:
+  gfc_free_forall_iterator (head);
+  gfc_free_expr (mask);
+  gfc_free_statements (c);
+  return MATCH_NO;
+}
+
+
+/* Match a DO statement.  */
+
+match
+gfc_match_do (void)
+{
+  gfc_iterator iter, *ip;
+  locus old_loc;
+  gfc_st_label *label;
+  match m;
+
+  old_loc = gfc_current_locus;
+
+  label = NULL;
+  iter.var = iter.start = iter.end = iter.step = NULL;
+
+  m = gfc_match_label ();
+  if (m == MATCH_ERROR)
+    return m;
+
+  if (gfc_match (" do") != MATCH_YES)
+    return MATCH_NO;
+
+  m = gfc_match_st_label (&label);
+  if (m == MATCH_ERROR)
+    goto cleanup;
+
+  /* Match an infinite DO, make it like a DO WHILE(.TRUE.).  */
+
+  if (gfc_match_eos () == MATCH_YES)
+    {
+      iter.end = gfc_get_logical_expr (gfc_default_logical_kind, NULL, true);
+      new_st.op = EXEC_DO_WHILE;
+      goto done;
+    }
+
+  /* Match an optional comma, if no comma is found, a space is obligatory.  */
+  if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES)
+    return MATCH_NO;
+
+  /* Check for balanced parens.  */
+
+  if (gfc_match_parens () == MATCH_ERROR)
+    return MATCH_ERROR;
+
+  if (gfc_match (" concurrent") == MATCH_YES)
+    {
+      gfc_forall_iterator *head;
+      gfc_expr *mask;
+
+      if (!gfc_notify_std (GFC_STD_F2008, "DO CONCURRENT construct at %C"))
+	return MATCH_ERROR;
+
+
+      mask = NULL;
+      head = NULL;
+      m = match_forall_header (&head, &mask);
+
+      if (m == MATCH_NO)
+	return m;
+      if (m == MATCH_ERROR)
+	goto concurr_cleanup;
+
+      if (gfc_match_eos () != MATCH_YES)
+	goto concurr_cleanup;
+
+      if (label != NULL
+	   && !gfc_reference_st_label (label, ST_LABEL_DO_TARGET))
+	goto concurr_cleanup;
+
+      new_st.label1 = label;
+      new_st.op = EXEC_DO_CONCURRENT;
+      new_st.expr1 = mask;
+      new_st.ext.forall_iterator = head;
+
+      return MATCH_YES;
+
+concurr_cleanup:
+      gfc_syntax_error (ST_DO);
+      gfc_free_expr (mask);
+      gfc_free_forall_iterator (head);
+      return MATCH_ERROR;
+    }
+
+  /* See if we have a DO WHILE.  */
+  if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
+    {
+      new_st.op = EXEC_DO_WHILE;
+      goto done;
+    }
+
+  /* The abortive DO WHILE may have done something to the symbol
+     table, so we start over.  */
+  gfc_undo_symbols ();
+  gfc_current_locus = old_loc;
+
+  gfc_match_label ();		/* This won't error.  */
+  gfc_match (" do ");		/* This will work.  */
+
+  gfc_match_st_label (&label);	/* Can't error out.  */
+  gfc_match_char (',');		/* Optional comma.  */
+
+  m = gfc_match_iterator (&iter, 0);
+  if (m == MATCH_NO)
+    return MATCH_NO;
+  if (m == MATCH_ERROR)
+    goto cleanup;
+
+  iter.var->symtree->n.sym->attr.implied_index = 0;
+  gfc_check_do_variable (iter.var->symtree);
+
+  if (gfc_match_eos () != MATCH_YES)
+    {
+      gfc_syntax_error (ST_DO);
+      goto cleanup;
+    }
+
+  new_st.op = EXEC_DO;
+
+done:
+  if (label != NULL
+      && !gfc_reference_st_label (label, ST_LABEL_DO_TARGET))
+    goto cleanup;
+
+  new_st.label1 = label;
+
+  if (new_st.op == EXEC_DO_WHILE)
+    new_st.expr1 = iter.end;
+  else
+    {
+      new_st.ext.iterator = ip = gfc_get_iterator ();
+      *ip = iter;
+    }
+
+  return MATCH_YES;
+
+cleanup:
+  gfc_free_iterator (&iter, 0);
+
+  return MATCH_ERROR;
+}
+
+
+/* Match an EXIT or CYCLE statement.  */
+
+static match
+match_exit_cycle (gfc_statement st, gfc_exec_op op)
+{
+  gfc_state_data *p, *o;
+  gfc_symbol *sym;
+  match m;
+  int cnt;
+
+  if (gfc_match_eos () == MATCH_YES)
+    sym = NULL;
+  else
+    {
+      char name[GFC_MAX_SYMBOL_LEN + 1];
+      gfc_symtree* stree;
+
+      m = gfc_match ("% %n%t", name);
+      if (m == MATCH_ERROR)
+	return MATCH_ERROR;
+      if (m == MATCH_NO)
+	{
+	  gfc_syntax_error (st);
+	  return MATCH_ERROR;
+	}
+
+      /* Find the corresponding symbol.  If there's a BLOCK statement
+	 between here and the label, it is not in gfc_current_ns but a parent
+	 namespace!  */
+      stree = gfc_find_symtree_in_proc (name, gfc_current_ns);
+      if (!stree)
+	{
+	  gfc_error ("Name '%s' in %s statement at %C is unknown",
+		     name, gfc_ascii_statement (st));
+	  return MATCH_ERROR;
+	}
+
+      sym = stree->n.sym;
+      if (sym->attr.flavor != FL_LABEL)
+	{
+	  gfc_error ("Name '%s' in %s statement at %C is not a construct name",
+		     name, gfc_ascii_statement (st));
+	  return MATCH_ERROR;
+	}
+    }
+
+  /* Find the loop specified by the label (or lack of a label).  */
+  for (o = NULL, p = gfc_state_stack; p; p = p->previous)
+    if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
+      o = p;
+    else if (p->state == COMP_CRITICAL)
+      {
+	gfc_error("%s statement at %C leaves CRITICAL construct",
+		  gfc_ascii_statement (st));
+	return MATCH_ERROR;
+      }
+    else if (p->state == COMP_DO_CONCURRENT
+	     && (op == EXEC_EXIT || (sym && sym != p->sym)))
+      {
+	/* F2008, C821 & C845.  */
+	gfc_error("%s statement at %C leaves DO CONCURRENT construct",
+		  gfc_ascii_statement (st));
+	return MATCH_ERROR;
+      }
+    else if ((sym && sym == p->sym)
+	     || (!sym && (p->state == COMP_DO
+			  || p->state == COMP_DO_CONCURRENT)))
+      break;
+
+  if (p == NULL)
+    {
+      if (sym == NULL)
+	gfc_error ("%s statement at %C is not within a construct",
+		   gfc_ascii_statement (st));
+      else
+	gfc_error ("%s statement at %C is not within construct '%s'",
+		   gfc_ascii_statement (st), sym->name);
+
+      return MATCH_ERROR;
+    }
+
+  /* Special checks for EXIT from non-loop constructs.  */
+  switch (p->state)
+    {
+    case COMP_DO:
+    case COMP_DO_CONCURRENT:
+      break;
+
+    case COMP_CRITICAL:
+      /* This is already handled above.  */
+      gcc_unreachable ();
+
+    case COMP_ASSOCIATE:
+    case COMP_BLOCK:
+    case COMP_IF:
+    case COMP_SELECT:
+    case COMP_SELECT_TYPE:
+      gcc_assert (sym);
+      if (op == EXEC_CYCLE)
+	{
+	  gfc_error ("CYCLE statement at %C is not applicable to non-loop"
+		     " construct '%s'", sym->name);
+	  return MATCH_ERROR;
+	}
+      gcc_assert (op == EXEC_EXIT);
+      if (!gfc_notify_std (GFC_STD_F2008, "EXIT statement with no"
+			   " do-construct-name at %C"))
+	return MATCH_ERROR;
+      break;
+
+    default:
+      gfc_error ("%s statement at %C is not applicable to construct '%s'",
+		 gfc_ascii_statement (st), sym->name);
+      return MATCH_ERROR;
+    }
+
+  if (o != NULL)
+    {
+      gfc_error ("%s statement at %C leaving OpenMP structured block",
+		 gfc_ascii_statement (st));
+      return MATCH_ERROR;
+    }
+
+  for (o = p, cnt = 0; o->state == COMP_DO && o->previous != NULL; cnt++)
+    o = o->previous;
+  if (cnt > 0
+      && o != NULL
+      && o->state == COMP_OMP_STRUCTURED_BLOCK
+      && (o->head->op == EXEC_OMP_DO
+	  || o->head->op == EXEC_OMP_PARALLEL_DO))
+    {
+      int collapse = 1;
+      gcc_assert (o->head->next != NULL
+		  && (o->head->next->op == EXEC_DO
+		      || o->head->next->op == EXEC_DO_WHILE)
+		  && o->previous != NULL
+		  && o->previous->tail->op == o->head->op);
+      if (o->previous->tail->ext.omp_clauses != NULL
+	  && o->previous->tail->ext.omp_clauses->collapse > 1)
+	collapse = o->previous->tail->ext.omp_clauses->collapse;
+      if (st == ST_EXIT && cnt <= collapse)
+	{
+	  gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
+	  return MATCH_ERROR;
+	}
+      if (st == ST_CYCLE && cnt < collapse)
+	{
+	  gfc_error ("CYCLE statement at %C to non-innermost collapsed"
+		     " !$OMP DO loop");
+	  return MATCH_ERROR;
+	}
+    }
+
+  /* Save the first statement in the construct - needed by the backend.  */
+  new_st.ext.which_construct = p->construct;
+
+  new_st.op = op;
+
+  return MATCH_YES;
+}
+
+
+/* Match the EXIT statement.  */
+
+match
+gfc_match_exit (void)
+{
+  return match_exit_cycle (ST_EXIT, EXEC_EXIT);
+}
+
+
+/* Match the CYCLE statement.  */
+
+match
+gfc_match_cycle (void)
+{
+  return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
+}
+
+
+/* Match a number or character constant after an (ALL) STOP or PAUSE statement.  */
+
+static match
+gfc_match_stopcode (gfc_statement st)
+{
+  gfc_expr *e;
+  match m;
+
+  e = NULL;
+
+  if (gfc_match_eos () != MATCH_YES)
+    {
+      m = gfc_match_init_expr (&e);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_NO)
+	goto syntax;
+
+      if (gfc_match_eos () != MATCH_YES)
+	goto syntax;
+    }
+
+  if (gfc_pure (NULL))
+    {
+      gfc_error ("%s statement not allowed in PURE procedure at %C",
+		 gfc_ascii_statement (st));
+      goto cleanup;
+    }
+
+  gfc_unset_implicit_pure (NULL);
+
+  if (st == ST_STOP && gfc_find_state (COMP_CRITICAL))
+    {
+      gfc_error ("Image control statement STOP at %C in CRITICAL block");
+      goto cleanup;
+    }
+  if (st == ST_STOP && gfc_find_state (COMP_DO_CONCURRENT))
+    {
+      gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
+      goto cleanup;
+    }
+
+  if (e != NULL)
+    {
+      if (!(e->ts.type == BT_CHARACTER || e->ts.type == BT_INTEGER))
+	{
+	  gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
+		     &e->where);
+	  goto cleanup;
+	}
+
+      if (e->rank != 0)
+	{
+	  gfc_error ("STOP code at %L must be scalar",
+		     &e->where);
+	  goto cleanup;
+	}
+
+      if (e->ts.type == BT_CHARACTER
+	  && e->ts.kind != gfc_default_character_kind)
+	{
+	  gfc_error ("STOP code at %L must be default character KIND=%d",
+		     &e->where, (int) gfc_default_character_kind);
+	  goto cleanup;
+	}
+
+      if (e->ts.type == BT_INTEGER
+	  && e->ts.kind != gfc_default_integer_kind)
+	{
+	  gfc_error ("STOP code at %L must be default integer KIND=%d",
+		     &e->where, (int) gfc_default_integer_kind);
+	  goto cleanup;
+	}
+    }
+
+  switch (st)
+    {
+    case ST_STOP:
+      new_st.op = EXEC_STOP;
+      break;
+    case ST_ERROR_STOP:
+      new_st.op = EXEC_ERROR_STOP;
+      break;
+    case ST_PAUSE:
+      new_st.op = EXEC_PAUSE;
+      break;
+    default:
+      gcc_unreachable ();
+    }
+
+  new_st.expr1 = e;
+  new_st.ext.stop_code = -1;
+
+  return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (st);
+
+cleanup:
+
+  gfc_free_expr (e);
+  return MATCH_ERROR;
+}
+
+
+/* Match the (deprecated) PAUSE statement.  */
+
+match
+gfc_match_pause (void)
+{
+  match m;
+
+  m = gfc_match_stopcode (ST_PAUSE);
+  if (m == MATCH_YES)
+    {
+      if (!gfc_notify_std (GFC_STD_F95_DEL, "PAUSE statement at %C"))
+	m = MATCH_ERROR;
+    }
+  return m;
+}
+
+
+/* Match the STOP statement.  */
+
+match
+gfc_match_stop (void)
+{
+  return gfc_match_stopcode (ST_STOP);
+}
+
+
+/* Match the ERROR STOP statement.  */
+
+match
+gfc_match_error_stop (void)
+{
+  if (!gfc_notify_std (GFC_STD_F2008, "ERROR STOP statement at %C"))
+    return MATCH_ERROR;
+
+  return gfc_match_stopcode (ST_ERROR_STOP);
+}
+
+
+/* Match LOCK/UNLOCK statement. Syntax:
+     LOCK ( lock-variable [ , lock-stat-list ] )
+     UNLOCK ( lock-variable [ , sync-stat-list ] )
+   where lock-stat is ACQUIRED_LOCK or sync-stat
+   and sync-stat is STAT= or ERRMSG=.  */
+
+static match
+lock_unlock_statement (gfc_statement st)
+{
+  match m;
+  gfc_expr *tmp, *lockvar, *acq_lock, *stat, *errmsg;
+  bool saw_acq_lock, saw_stat, saw_errmsg;
+
+  tmp = lockvar = acq_lock = stat = errmsg = NULL;
+  saw_acq_lock = saw_stat = saw_errmsg = false;
+
+  if (gfc_pure (NULL))
+    {
+      gfc_error ("Image control statement %s at %C in PURE procedure",
+		 st == ST_LOCK ? "LOCK" : "UNLOCK");
+      return MATCH_ERROR;
+    }
+
+  gfc_unset_implicit_pure (NULL);
+
+  if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+    {
+       gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+       return MATCH_ERROR;
+    }
+
+  if (gfc_find_state (COMP_CRITICAL))
+    {
+      gfc_error ("Image control statement %s at %C in CRITICAL block",
+		 st == ST_LOCK ? "LOCK" : "UNLOCK");
+      return MATCH_ERROR;
+    }
+
+  if (gfc_find_state (COMP_DO_CONCURRENT))
+    {
+      gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
+		 st == ST_LOCK ? "LOCK" : "UNLOCK");
+      return MATCH_ERROR;
+    }
+
+  if (gfc_match_char ('(') != MATCH_YES)
+    goto syntax;
+
+  if (gfc_match ("%e", &lockvar) != MATCH_YES)
+    goto syntax;
+  m = gfc_match_char (',');
+  if (m == MATCH_ERROR)
+    goto syntax;
+  if (m == MATCH_NO)
+    {
+      m = gfc_match_char (')');
+      if (m == MATCH_YES)
+	goto done;
+      goto syntax;
+    }
+
+  for (;;)
+    {
+      m = gfc_match (" stat = %v", &tmp);
+      if (m == MATCH_ERROR)
+	goto syntax;
+      if (m == MATCH_YES)
+	{
+	  if (saw_stat)
+	    {
+	      gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
+	      goto cleanup;
+	    }
+	  stat = tmp;
+	  saw_stat = true;
+
+	  m = gfc_match_char (',');
+	  if (m == MATCH_YES)
+	    continue;
+
+	  tmp = NULL;
+	  break;
+	}
+
+      m = gfc_match (" errmsg = %v", &tmp);
+      if (m == MATCH_ERROR)
+	goto syntax;
+      if (m == MATCH_YES)
+	{
+	  if (saw_errmsg)
+	    {
+	      gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
+	      goto cleanup;
+	    }
+	  errmsg = tmp;
+	  saw_errmsg = true;
+
+	  m = gfc_match_char (',');
+	  if (m == MATCH_YES)
+	    continue;
+
+	  tmp = NULL;
+	  break;
+	}
+
+      m = gfc_match (" acquired_lock = %v", &tmp);
+      if (m == MATCH_ERROR || st == ST_UNLOCK)
+	goto syntax;
+      if (m == MATCH_YES)
+	{
+	  if (saw_acq_lock)
+	    {
+	      gfc_error ("Redundant ACQUIRED_LOCK tag found at %L ",
+			 &tmp->where);
+	      goto cleanup;
+	    }
+	  acq_lock = tmp;
+	  saw_acq_lock = true;
+
+	  m = gfc_match_char (',');
+	  if (m == MATCH_YES)
+	    continue;
+
+	  tmp = NULL;
+	  break;
+	}
+
+      break;
+    }
+
+  if (m == MATCH_ERROR)
+    goto syntax;
+
+  if (gfc_match (" )%t") != MATCH_YES)
+    goto syntax;
+
+done:
+  switch (st)
+    {
+    case ST_LOCK:
+      new_st.op = EXEC_LOCK;
+      break;
+    case ST_UNLOCK:
+      new_st.op = EXEC_UNLOCK;
+      break;
+    default:
+      gcc_unreachable ();
+    }
+
+  new_st.expr1 = lockvar;
+  new_st.expr2 = stat;
+  new_st.expr3 = errmsg;
+  new_st.expr4 = acq_lock;
+
+  return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (st);
+
+cleanup:
+  if (acq_lock != tmp)
+    gfc_free_expr (acq_lock);
+  if (errmsg != tmp)
+    gfc_free_expr (errmsg);
+  if (stat != tmp)
+    gfc_free_expr (stat);
+
+  gfc_free_expr (tmp);
+  gfc_free_expr (lockvar);
+
+  return MATCH_ERROR;
+}
+
+
+match
+gfc_match_lock (void)
+{
+  if (!gfc_notify_std (GFC_STD_F2008, "LOCK statement at %C"))
+    return MATCH_ERROR;
+
+  return lock_unlock_statement (ST_LOCK);
+}
+
+
+match
+gfc_match_unlock (void)
+{
+  if (!gfc_notify_std (GFC_STD_F2008, "UNLOCK statement at %C"))
+    return MATCH_ERROR;
+
+  return lock_unlock_statement (ST_UNLOCK);
+}
+
+
+/* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
+     SYNC ALL [(sync-stat-list)]
+     SYNC MEMORY [(sync-stat-list)]
+     SYNC IMAGES (image-set [, sync-stat-list] )
+   with sync-stat is int-expr or *.  */
+
+static match
+sync_statement (gfc_statement st)
+{
+  match m;
+  gfc_expr *tmp, *imageset, *stat, *errmsg;
+  bool saw_stat, saw_errmsg;
+
+  tmp = imageset = stat = errmsg = NULL;
+  saw_stat = saw_errmsg = false;
+
+  if (gfc_pure (NULL))
+    {
+      gfc_error ("Image control statement SYNC at %C in PURE procedure");
+      return MATCH_ERROR;
+    }
+
+  gfc_unset_implicit_pure (NULL);
+
+  if (!gfc_notify_std (GFC_STD_F2008, "SYNC statement at %C"))
+    return MATCH_ERROR;
+
+  if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+    {
+       gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+       return MATCH_ERROR;
+    }
+
+  if (gfc_find_state (COMP_CRITICAL))
+    {
+      gfc_error ("Image control statement SYNC at %C in CRITICAL block");
+      return MATCH_ERROR;
+    }
+
+  if (gfc_find_state (COMP_DO_CONCURRENT))
+    {
+      gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
+      return MATCH_ERROR;
+    }
+
+  if (gfc_match_eos () == MATCH_YES)
+    {
+      if (st == ST_SYNC_IMAGES)
+	goto syntax;
+      goto done;
+    }
+
+  if (gfc_match_char ('(') != MATCH_YES)
+    goto syntax;
+
+  if (st == ST_SYNC_IMAGES)
+    {
+      /* Denote '*' as imageset == NULL.  */
+      m = gfc_match_char ('*');
+      if (m == MATCH_ERROR)
+	goto syntax;
+      if (m == MATCH_NO)
+	{
+	  if (gfc_match ("%e", &imageset) != MATCH_YES)
+	    goto syntax;
+	}
+      m = gfc_match_char (',');
+      if (m == MATCH_ERROR)
+	goto syntax;
+      if (m == MATCH_NO)
+	{
+	  m = gfc_match_char (')');
+	  if (m == MATCH_YES)
+	    goto done;
+	  goto syntax;
+	}
+    }
+
+  for (;;)
+    {
+      m = gfc_match (" stat = %v", &tmp);
+      if (m == MATCH_ERROR)
+	goto syntax;
+      if (m == MATCH_YES)
+	{
+	  if (saw_stat)
+	    {
+	      gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
+	      goto cleanup;
+	    }
+	  stat = tmp;
+	  saw_stat = true;
+
+	  if (gfc_match_char (',') == MATCH_YES)
+	    continue;
+
+	  tmp = NULL;
+	  break;
+	}
+
+      m = gfc_match (" errmsg = %v", &tmp);
+      if (m == MATCH_ERROR)
+	goto syntax;
+      if (m == MATCH_YES)
+	{
+	  if (saw_errmsg)
+	    {
+	      gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
+	      goto cleanup;
+	    }
+	  errmsg = tmp;
+	  saw_errmsg = true;
+
+	  if (gfc_match_char (',') == MATCH_YES)
+	    continue;
+
+	  tmp = NULL;
+	  break;
+	}
+
+	break;
+    }
+
+  if (gfc_match (" )%t") != MATCH_YES)
+    goto syntax;
+
+done:
+  switch (st)
+    {
+    case ST_SYNC_ALL:
+      new_st.op = EXEC_SYNC_ALL;
+      break;
+    case ST_SYNC_IMAGES:
+      new_st.op = EXEC_SYNC_IMAGES;
+      break;
+    case ST_SYNC_MEMORY:
+      new_st.op = EXEC_SYNC_MEMORY;
+      break;
+    default:
+      gcc_unreachable ();
+    }
+
+  new_st.expr1 = imageset;
+  new_st.expr2 = stat;
+  new_st.expr3 = errmsg;
+
+  return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (st);
+
+cleanup:
+  if (stat != tmp)
+    gfc_free_expr (stat);
+  if (errmsg != tmp)
+    gfc_free_expr (errmsg);
+
+  gfc_free_expr (tmp);
+  gfc_free_expr (imageset);
+
+  return MATCH_ERROR;
+}
+
+
+/* Match SYNC ALL statement.  */
+
+match
+gfc_match_sync_all (void)
+{
+  return sync_statement (ST_SYNC_ALL);
+}
+
+
+/* Match SYNC IMAGES statement.  */
+
+match
+gfc_match_sync_images (void)
+{
+  return sync_statement (ST_SYNC_IMAGES);
+}
+
+
+/* Match SYNC MEMORY statement.  */
+
+match
+gfc_match_sync_memory (void)
+{
+  return sync_statement (ST_SYNC_MEMORY);
+}
+
+
+/* Match a CONTINUE statement.  */
+
+match
+gfc_match_continue (void)
+{
+  if (gfc_match_eos () != MATCH_YES)
+    {
+      gfc_syntax_error (ST_CONTINUE);
+      return MATCH_ERROR;
+    }
+
+  new_st.op = EXEC_CONTINUE;
+  return MATCH_YES;
+}
+
+
+/* Match the (deprecated) ASSIGN statement.  */
+
+match
+gfc_match_assign (void)
+{
+  gfc_expr *expr;
+  gfc_st_label *label;
+
+  if (gfc_match (" %l", &label) == MATCH_YES)
+    {
+      if (!gfc_reference_st_label (label, ST_LABEL_UNKNOWN))
+	return MATCH_ERROR;
+      if (gfc_match (" to %v%t", &expr) == MATCH_YES)
+	{
+	  if (!gfc_notify_std (GFC_STD_F95_DEL, "ASSIGN statement at %C"))
+	    return MATCH_ERROR;
+
+	  expr->symtree->n.sym->attr.assign = 1;
+
+	  new_st.op = EXEC_LABEL_ASSIGN;
+	  new_st.label1 = label;
+	  new_st.expr1 = expr;
+	  return MATCH_YES;
+	}
+    }
+  return MATCH_NO;
+}
+
+
+/* Match the GO TO statement.  As a computed GOTO statement is
+   matched, it is transformed into an equivalent SELECT block.  No
+   tree is necessary, and the resulting jumps-to-jumps are
+   specifically optimized away by the back end.  */
+
+match
+gfc_match_goto (void)
+{
+  gfc_code *head, *tail;
+  gfc_expr *expr;
+  gfc_case *cp;
+  gfc_st_label *label;
+  int i;
+  match m;
+
+  if (gfc_match (" %l%t", &label) == MATCH_YES)
+    {
+      if (!gfc_reference_st_label (label, ST_LABEL_TARGET))
+	return MATCH_ERROR;
+
+      new_st.op = EXEC_GOTO;
+      new_st.label1 = label;
+      return MATCH_YES;
+    }
+
+  /* The assigned GO TO statement.  */
+
+  if (gfc_match_variable (&expr, 0) == MATCH_YES)
+    {
+      if (!gfc_notify_std (GFC_STD_F95_DEL, "Assigned GOTO statement at %C"))
+	return MATCH_ERROR;
+
+      new_st.op = EXEC_GOTO;
+      new_st.expr1 = expr;
+
+      if (gfc_match_eos () == MATCH_YES)
+	return MATCH_YES;
+
+      /* Match label list.  */
+      gfc_match_char (',');
+      if (gfc_match_char ('(') != MATCH_YES)
+	{
+	  gfc_syntax_error (ST_GOTO);
+	  return MATCH_ERROR;
+	}
+      head = tail = NULL;
+
+      do
+	{
+	  m = gfc_match_st_label (&label);
+	  if (m != MATCH_YES)
+	    goto syntax;
+
+	  if (!gfc_reference_st_label (label, ST_LABEL_TARGET))
+	    goto cleanup;
+
+	  if (head == NULL)
+	    head = tail = gfc_get_code (EXEC_GOTO);
+	  else
+	    {
+	      tail->block = gfc_get_code (EXEC_GOTO);
+	      tail = tail->block;
+	    }
+
+	  tail->label1 = label;
+	}
+      while (gfc_match_char (',') == MATCH_YES);
+
+      if (gfc_match (")%t") != MATCH_YES)
+	goto syntax;
+
+      if (head == NULL)
+	{
+	   gfc_error ("Statement label list in GOTO at %C cannot be empty");
+	   goto syntax;
+	}
+      new_st.block = head;
+
+      return MATCH_YES;
+    }
+
+  /* Last chance is a computed GO TO statement.  */
+  if (gfc_match_char ('(') != MATCH_YES)
+    {
+      gfc_syntax_error (ST_GOTO);
+      return MATCH_ERROR;
+    }
+
+  head = tail = NULL;
+  i = 1;
+
+  do
+    {
+      m = gfc_match_st_label (&label);
+      if (m != MATCH_YES)
+	goto syntax;
+
+      if (!gfc_reference_st_label (label, ST_LABEL_TARGET))
+	goto cleanup;
+
+      if (head == NULL)
+	head = tail = gfc_get_code (EXEC_SELECT);
+      else
+	{
+	  tail->block = gfc_get_code (EXEC_SELECT);
+	  tail = tail->block;
+	}
+
+      cp = gfc_get_case ();
+      cp->low = cp->high = gfc_get_int_expr (gfc_default_integer_kind,
+					     NULL, i++);
+
+      tail->ext.block.case_list = cp;
+
+      tail->next = gfc_get_code (EXEC_GOTO);
+      tail->next->label1 = label;
+    }
+  while (gfc_match_char (',') == MATCH_YES);
+
+  if (gfc_match_char (')') != MATCH_YES)
+    goto syntax;
+
+  if (head == NULL)
+    {
+      gfc_error ("Statement label list in GOTO at %C cannot be empty");
+      goto syntax;
+    }
+
+  /* Get the rest of the statement.  */
+  gfc_match_char (',');
+
+  if (gfc_match (" %e%t", &expr) != MATCH_YES)
+    goto syntax;
+
+  if (!gfc_notify_std (GFC_STD_F95_OBS, "Computed GOTO at %C"))
+    return MATCH_ERROR;
+
+  /* At this point, a computed GOTO has been fully matched and an
+     equivalent SELECT statement constructed.  */
+
+  new_st.op = EXEC_SELECT;
+  new_st.expr1 = NULL;
+
+  /* Hack: For a "real" SELECT, the expression is in expr. We put
+     it in expr2 so we can distinguish then and produce the correct
+     diagnostics.  */
+  new_st.expr2 = expr;
+  new_st.block = head;
+  return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (ST_GOTO);
+cleanup:
+  gfc_free_statements (head);
+  return MATCH_ERROR;
+}
+
+
+/* Frees a list of gfc_alloc structures.  */
+
+void
+gfc_free_alloc_list (gfc_alloc *p)
+{
+  gfc_alloc *q;
+
+  for (; p; p = q)
+    {
+      q = p->next;
+      gfc_free_expr (p->expr);
+      free (p);
+    }
+}
+
+
+/* Match an ALLOCATE statement.  */
+
+match
+gfc_match_allocate (void)
+{
+  gfc_alloc *head, *tail;
+  gfc_expr *stat, *errmsg, *tmp, *source, *mold;
+  gfc_typespec ts;
+  gfc_symbol *sym;
+  match m;
+  locus old_locus, deferred_locus;
+  bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3;
+  bool saw_unlimited = false;
+
+  head = tail = NULL;
+  stat = errmsg = source = mold = tmp = NULL;
+  saw_stat = saw_errmsg = saw_source = saw_mold = saw_deferred = false;
+
+  if (gfc_match_char ('(') != MATCH_YES)
+    goto syntax;
+
+  /* Match an optional type-spec.  */
+  old_locus = gfc_current_locus;
+  m = gfc_match_type_spec (&ts);
+  if (m == MATCH_ERROR)
+    goto cleanup;
+  else if (m == MATCH_NO)
+    {
+      char name[GFC_MAX_SYMBOL_LEN + 3];
+
+      if (gfc_match ("%n :: ", name) == MATCH_YES)
+	{
+	  gfc_error ("Error in type-spec at %L", &old_locus);
+	  goto cleanup;
+	}
+
+      ts.type = BT_UNKNOWN;
+    }
+  else
+    {
+      if (gfc_match (" :: ") == MATCH_YES)
+	{
+	  if (!gfc_notify_std (GFC_STD_F2003, "typespec in ALLOCATE at %L", 
+			       &old_locus))
+	    goto cleanup;
+
+	  if (ts.deferred)
+	    {
+	      gfc_error ("Type-spec at %L cannot contain a deferred "
+			 "type parameter", &old_locus);
+	      goto cleanup;
+	    }
+
+	  if (ts.type == BT_CHARACTER)
+	    ts.u.cl->length_from_typespec = true;
+	}
+      else
+	{
+	  ts.type = BT_UNKNOWN;
+	  gfc_current_locus = old_locus;
+	}
+    }
+
+  for (;;)
+    {
+      if (head == NULL)
+	head = tail = gfc_get_alloc ();
+      else
+	{
+	  tail->next = gfc_get_alloc ();
+	  tail = tail->next;
+	}
+
+      m = gfc_match_variable (&tail->expr, 0);
+      if (m == MATCH_NO)
+	goto syntax;
+      if (m == MATCH_ERROR)
+	goto cleanup;
+
+      if (gfc_check_do_variable (tail->expr->symtree))
+	goto cleanup;
+
+      bool impure = gfc_impure_variable (tail->expr->symtree->n.sym);
+      if (impure && gfc_pure (NULL))
+	{
+	  gfc_error ("Bad allocate-object at %C for a PURE procedure");
+	  goto cleanup;
+	}
+
+      if (impure)
+	gfc_unset_implicit_pure (NULL);
+
+      if (tail->expr->ts.deferred)
+	{
+	  saw_deferred = true;
+	  deferred_locus = tail->expr->where;
+	}
+
+      if (gfc_find_state (COMP_DO_CONCURRENT)
+	  || gfc_find_state (COMP_CRITICAL))
+	{
+	  gfc_ref *ref;
+	  bool coarray = tail->expr->symtree->n.sym->attr.codimension;
+	  for (ref = tail->expr->ref; ref; ref = ref->next)
+	    if (ref->type == REF_COMPONENT)
+	      coarray = ref->u.c.component->attr.codimension;
+
+	  if (coarray && gfc_find_state (COMP_DO_CONCURRENT))
+	    {
+	      gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
+	      goto cleanup;
+	    }
+	  if (coarray && gfc_find_state (COMP_CRITICAL))
+	    {
+	      gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
+	      goto cleanup;
+	    }
+	}
+
+      /* Check for F08:C628.  */
+      sym = tail->expr->symtree->n.sym;
+      b1 = !(tail->expr->ref
+	     && (tail->expr->ref->type == REF_COMPONENT
+		 || tail->expr->ref->type == REF_ARRAY));
+      if (sym && sym->ts.type == BT_CLASS && sym->attr.class_ok)
+	b2 = !(CLASS_DATA (sym)->attr.allocatable
+	       || CLASS_DATA (sym)->attr.class_pointer);
+      else
+	b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
+		      || sym->attr.proc_pointer);
+      b3 = sym && sym->ns && sym->ns->proc_name
+	   && (sym->ns->proc_name->attr.allocatable
+	       || sym->ns->proc_name->attr.pointer
+	       || sym->ns->proc_name->attr.proc_pointer);
+      if (b1 && b2 && !b3)
+	{
+	  gfc_error ("Allocate-object at %L is neither a data pointer "
+		     "nor an allocatable variable", &tail->expr->where);
+	  goto cleanup;
+	}
+
+      /* The ALLOCATE statement had an optional typespec.  Check the
+	 constraints.  */
+      if (ts.type != BT_UNKNOWN)
+	{
+	  /* Enforce F03:C624.  */
+	  if (!gfc_type_compatible (&tail->expr->ts, &ts))
+	    {
+	      gfc_error ("Type of entity at %L is type incompatible with "
+			 "typespec", &tail->expr->where);
+	      goto cleanup;
+	    }
+
+	  /* Enforce F03:C627.  */
+	  if (ts.kind != tail->expr->ts.kind && !UNLIMITED_POLY (tail->expr))
+	    {
+	      gfc_error ("Kind type parameter for entity at %L differs from "
+			 "the kind type parameter of the typespec",
+			 &tail->expr->where);
+	      goto cleanup;
+	    }
+	}
+
+      if (tail->expr->ts.type == BT_DERIVED)
+	tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
+
+      saw_unlimited = saw_unlimited | UNLIMITED_POLY (tail->expr);
+
+      if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
+	{
+	  gfc_error ("Shape specification for allocatable scalar at %C");
+	  goto cleanup;
+	}
+
+      if (gfc_match_char (',') != MATCH_YES)
+	break;
+
+alloc_opt_list:
+
+      m = gfc_match (" stat = %v", &tmp);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_YES)
+	{
+	  /* Enforce C630.  */
+	  if (saw_stat)
+	    {
+	      gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
+	      goto cleanup;
+	    }
+
+	  stat = tmp;
+	  tmp = NULL;
+	  saw_stat = true;
+
+	  if (gfc_check_do_variable (stat->symtree))
+	    goto cleanup;
+
+	  if (gfc_match_char (',') == MATCH_YES)
+	    goto alloc_opt_list;
+	}
+
+      m = gfc_match (" errmsg = %v", &tmp);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_YES)
+	{
+	  if (!gfc_notify_std (GFC_STD_F2003, "ERRMSG tag at %L", &tmp->where))
+	    goto cleanup;
+
+	  /* Enforce C630.  */
+	  if (saw_errmsg)
+	    {
+	      gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
+	      goto cleanup;
+	    }
+
+	  errmsg = tmp;
+	  tmp = NULL;
+	  saw_errmsg = true;
+
+	  if (gfc_match_char (',') == MATCH_YES)
+	    goto alloc_opt_list;
+	}
+
+      m = gfc_match (" source = %e", &tmp);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_YES)
+	{
+	  if (!gfc_notify_std (GFC_STD_F2003, "SOURCE tag at %L", &tmp->where))
+	    goto cleanup;
+
+	  /* Enforce C630.  */
+	  if (saw_source)
+	    {
+	      gfc_error ("Redundant SOURCE tag found at %L ", &tmp->where);
+	      goto cleanup;
+	    }
+
+	  /* The next 2 conditionals check C631.  */
+	  if (ts.type != BT_UNKNOWN)
+	    {
+	      gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
+			 &tmp->where, &old_locus);
+	      goto cleanup;
+	    }
+
+	  if (head->next
+	      && !gfc_notify_std (GFC_STD_F2008, "SOURCE tag at %L"
+				  " with more than a single allocate object", 
+				  &tmp->where))
+	    goto cleanup;
+
+	  source = tmp;
+	  tmp = NULL;
+	  saw_source = true;
+
+	  if (gfc_match_char (',') == MATCH_YES)
+	    goto alloc_opt_list;
+	}
+
+      m = gfc_match (" mold = %e", &tmp);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_YES)
+	{
+	  if (!gfc_notify_std (GFC_STD_F2008, "MOLD tag at %L", &tmp->where))
+	    goto cleanup;
+
+	  /* Check F08:C636.  */
+	  if (saw_mold)
+	    {
+	      gfc_error ("Redundant MOLD tag found at %L ", &tmp->where);
+	      goto cleanup;
+	    }
+
+	  /* Check F08:C637.  */
+	  if (ts.type != BT_UNKNOWN)
+	    {
+	      gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
+			 &tmp->where, &old_locus);
+	      goto cleanup;
+	    }
+
+	  mold = tmp;
+	  tmp = NULL;
+	  saw_mold = true;
+	  mold->mold = 1;
+
+	  if (gfc_match_char (',') == MATCH_YES)
+	    goto alloc_opt_list;
+	}
+
+	gfc_gobble_whitespace ();
+
+	if (gfc_peek_char () == ')')
+	  break;
+    }
+
+  if (gfc_match (" )%t") != MATCH_YES)
+    goto syntax;
+
+  /* Check F08:C637.  */
+  if (source && mold)
+    {
+      gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
+		  &mold->where, &source->where);
+      goto cleanup;
+    }
+
+  /* Check F03:C623,  */
+  if (saw_deferred && ts.type == BT_UNKNOWN && !source && !mold)
+    {
+      gfc_error ("Allocate-object at %L with a deferred type parameter "
+		 "requires either a type-spec or SOURCE tag or a MOLD tag",
+		 &deferred_locus);
+      goto cleanup;
+    }
+
+  /* Check F03:C625,  */
+  if (saw_unlimited && ts.type == BT_UNKNOWN && !source && !mold)
+    {
+      for (tail = head; tail; tail = tail->next)
+	{
+	  if (UNLIMITED_POLY (tail->expr))
+	    gfc_error ("Unlimited polymorphic allocate-object at %L "
+		       "requires either a type-spec or SOURCE tag "
+		       "or a MOLD tag", &tail->expr->where);
+	}
+      goto cleanup;
+    }
+
+  new_st.op = EXEC_ALLOCATE;
+  new_st.expr1 = stat;
+  new_st.expr2 = errmsg;
+  if (source)
+    new_st.expr3 = source;
+  else
+    new_st.expr3 = mold;
+  new_st.ext.alloc.list = head;
+  new_st.ext.alloc.ts = ts;
+
+  return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (ST_ALLOCATE);
+
+cleanup:
+  gfc_free_expr (errmsg);
+  gfc_free_expr (source);
+  gfc_free_expr (stat);
+  gfc_free_expr (mold);
+  if (tmp && tmp->expr_type) gfc_free_expr (tmp);
+  gfc_free_alloc_list (head);
+  return MATCH_ERROR;
+}
+
+
+/* Match a NULLIFY statement. A NULLIFY statement is transformed into
+   a set of pointer assignments to intrinsic NULL().  */
+
+match
+gfc_match_nullify (void)
+{
+  gfc_code *tail;
+  gfc_expr *e, *p;
+  match m;
+
+  tail = NULL;
+
+  if (gfc_match_char ('(') != MATCH_YES)
+    goto syntax;
+
+  for (;;)
+    {
+      m = gfc_match_variable (&p, 0);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_NO)
+	goto syntax;
+
+      if (gfc_check_do_variable (p->symtree))
+	goto cleanup;
+
+      /* F2008, C1242.  */
+      if (gfc_is_coindexed (p))
+	{
+	  gfc_error ("Pointer object at %C shall not be coindexed");
+	  goto cleanup;
+	}
+
+      /* build ' => NULL() '.  */
+      e = gfc_get_null_expr (&gfc_current_locus);
+
+      /* Chain to list.  */
+      if (tail == NULL)
+	{
+	  tail = &new_st;
+	  tail->op = EXEC_POINTER_ASSIGN;
+	}
+      else
+	{
+	  tail->next = gfc_get_code (EXEC_POINTER_ASSIGN);
+	  tail = tail->next;
+	}
+
+      tail->expr1 = p;
+      tail->expr2 = e;
+
+      if (gfc_match (" )%t") == MATCH_YES)
+	break;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+    }
+
+  return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (ST_NULLIFY);
+
+cleanup:
+  gfc_free_statements (new_st.next);
+  new_st.next = NULL;
+  gfc_free_expr (new_st.expr1);
+  new_st.expr1 = NULL;
+  gfc_free_expr (new_st.expr2);
+  new_st.expr2 = NULL;
+  return MATCH_ERROR;
+}
+
+
+/* Match a DEALLOCATE statement.  */
+
+match
+gfc_match_deallocate (void)
+{
+  gfc_alloc *head, *tail;
+  gfc_expr *stat, *errmsg, *tmp;
+  gfc_symbol *sym;
+  match m;
+  bool saw_stat, saw_errmsg, b1, b2;
+
+  head = tail = NULL;
+  stat = errmsg = tmp = NULL;
+  saw_stat = saw_errmsg = false;
+
+  if (gfc_match_char ('(') != MATCH_YES)
+    goto syntax;
+
+  for (;;)
+    {
+      if (head == NULL)
+	head = tail = gfc_get_alloc ();
+      else
+	{
+	  tail->next = gfc_get_alloc ();
+	  tail = tail->next;
+	}
+
+      m = gfc_match_variable (&tail->expr, 0);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_NO)
+	goto syntax;
+
+      if (gfc_check_do_variable (tail->expr->symtree))
+	goto cleanup;
+
+      sym = tail->expr->symtree->n.sym;
+
+      bool impure = gfc_impure_variable (sym);
+      if (impure && gfc_pure (NULL))
+	{
+	  gfc_error ("Illegal allocate-object at %C for a PURE procedure");
+	  goto cleanup;
+	}
+
+      if (impure)
+	gfc_unset_implicit_pure (NULL);
+
+      if (gfc_is_coarray (tail->expr)
+	  && gfc_find_state (COMP_DO_CONCURRENT))
+	{
+	  gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
+	  goto cleanup;
+	}
+
+      if (gfc_is_coarray (tail->expr)
+	  && gfc_find_state (COMP_CRITICAL))
+	{
+	  gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
+	  goto cleanup;
+	}
+
+      /* FIXME: disable the checking on derived types.  */
+      b1 = !(tail->expr->ref
+	   && (tail->expr->ref->type == REF_COMPONENT
+	       || tail->expr->ref->type == REF_ARRAY));
+      if (sym && sym->ts.type == BT_CLASS)
+	b2 = !(CLASS_DATA (sym)->attr.allocatable
+	       || CLASS_DATA (sym)->attr.class_pointer);
+      else
+	b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
+		      || sym->attr.proc_pointer);
+      if (b1 && b2)
+	{
+	  gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
+		     "nor an allocatable variable");
+	  goto cleanup;
+	}
+
+      if (gfc_match_char (',') != MATCH_YES)
+	break;
+
+dealloc_opt_list:
+
+      m = gfc_match (" stat = %v", &tmp);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_YES)
+	{
+	  if (saw_stat)
+	    {
+	      gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
+	      gfc_free_expr (tmp);
+	      goto cleanup;
+	    }
+
+	  stat = tmp;
+	  saw_stat = true;
+
+	  if (gfc_check_do_variable (stat->symtree))
+	    goto cleanup;
+
+	  if (gfc_match_char (',') == MATCH_YES)
+	    goto dealloc_opt_list;
+	}
+
+      m = gfc_match (" errmsg = %v", &tmp);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_YES)
+	{
+	  if (!gfc_notify_std (GFC_STD_F2003, "ERRMSG at %L", &tmp->where))
+	    goto cleanup;
+
+	  if (saw_errmsg)
+	    {
+	      gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
+	      gfc_free_expr (tmp);
+	      goto cleanup;
+	    }
+
+	  errmsg = tmp;
+	  saw_errmsg = true;
+
+	  if (gfc_match_char (',') == MATCH_YES)
+	    goto dealloc_opt_list;
+	}
+
+	gfc_gobble_whitespace ();
+
+	if (gfc_peek_char () == ')')
+	  break;
+    }
+
+  if (gfc_match (" )%t") != MATCH_YES)
+    goto syntax;
+
+  new_st.op = EXEC_DEALLOCATE;
+  new_st.expr1 = stat;
+  new_st.expr2 = errmsg;
+  new_st.ext.alloc.list = head;
+
+  return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (ST_DEALLOCATE);
+
+cleanup:
+  gfc_free_expr (errmsg);
+  gfc_free_expr (stat);
+  gfc_free_alloc_list (head);
+  return MATCH_ERROR;
+}
+
+
+/* Match a RETURN statement.  */
+
+match
+gfc_match_return (void)
+{
+  gfc_expr *e;
+  match m;
+  gfc_compile_state s;
+
+  e = NULL;
+
+  if (gfc_find_state (COMP_CRITICAL))
+    {
+      gfc_error ("Image control statement RETURN at %C in CRITICAL block");
+      return MATCH_ERROR;
+    }
+
+  if (gfc_find_state (COMP_DO_CONCURRENT))
+    {
+      gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
+      return MATCH_ERROR;
+    }
+
+  if (gfc_match_eos () == MATCH_YES)
+    goto done;
+
+  if (!gfc_find_state (COMP_SUBROUTINE))
+    {
+      gfc_error ("Alternate RETURN statement at %C is only allowed within "
+		 "a SUBROUTINE");
+      goto cleanup;
+    }
+
+  if (gfc_current_form == FORM_FREE)
+    {
+      /* The following are valid, so we can't require a blank after the
+	RETURN keyword:
+	  return+1
+	  return(1)  */
+      char c = gfc_peek_ascii_char ();
+      if (ISALPHA (c) || ISDIGIT (c))
+	return MATCH_NO;
+    }
+
+  m = gfc_match (" %e%t", &e);
+  if (m == MATCH_YES)
+    goto done;
+  if (m == MATCH_ERROR)
+    goto cleanup;
+
+  gfc_syntax_error (ST_RETURN);
+
+cleanup:
+  gfc_free_expr (e);
+  return MATCH_ERROR;
+
+done:
+  gfc_enclosing_unit (&s);
+  if (s == COMP_PROGRAM
+      && !gfc_notify_std (GFC_STD_GNU, "RETURN statement in "
+			  "main program at %C"))
+      return MATCH_ERROR;
+
+  new_st.op = EXEC_RETURN;
+  new_st.expr1 = e;
+
+  return MATCH_YES;
+}
+
+
+/* Match the call of a type-bound procedure, if CALL%var has already been
+   matched and var found to be a derived-type variable.  */
+
+static match
+match_typebound_call (gfc_symtree* varst)
+{
+  gfc_expr* base;
+  match m;
+
+  base = gfc_get_expr ();
+  base->expr_type = EXPR_VARIABLE;
+  base->symtree = varst;
+  base->where = gfc_current_locus;
+  gfc_set_sym_referenced (varst->n.sym);
+
+  m = gfc_match_varspec (base, 0, true, true);
+  if (m == MATCH_NO)
+    gfc_error ("Expected component reference at %C");
+  if (m != MATCH_YES)
+    {
+      gfc_free_expr (base);
+      return MATCH_ERROR;
+    }
+
+  if (gfc_match_eos () != MATCH_YES)
+    {
+      gfc_error ("Junk after CALL at %C");
+      gfc_free_expr (base);
+      return MATCH_ERROR;
+    }
+
+  if (base->expr_type == EXPR_COMPCALL)
+    new_st.op = EXEC_COMPCALL;
+  else if (base->expr_type == EXPR_PPC)
+    new_st.op = EXEC_CALL_PPC;
+  else
+    {
+      gfc_error ("Expected type-bound procedure or procedure pointer component "
+		 "at %C");
+      gfc_free_expr (base);
+      return MATCH_ERROR;
+    }
+  new_st.expr1 = base;
+
+  return MATCH_YES;
+}
+
+
+/* Match a CALL statement.  The tricky part here are possible
+   alternate return specifiers.  We handle these by having all
+   "subroutines" actually return an integer via a register that gives
+   the return number.  If the call specifies alternate returns, we
+   generate code for a SELECT statement whose case clauses contain
+   GOTOs to the various labels.  */
+
+match
+gfc_match_call (void)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_actual_arglist *a, *arglist;
+  gfc_case *new_case;
+  gfc_symbol *sym;
+  gfc_symtree *st;
+  gfc_code *c;
+  match m;
+  int i;
+
+  arglist = NULL;
+
+  m = gfc_match ("% %n", name);
+  if (m == MATCH_NO)
+    goto syntax;
+  if (m != MATCH_YES)
+    return m;
+
+  if (gfc_get_ha_sym_tree (name, &st))
+    return MATCH_ERROR;
+
+  sym = st->n.sym;
+
+  /* If this is a variable of derived-type, it probably starts a type-bound
+     procedure call.  */
+  if ((sym->attr.flavor != FL_PROCEDURE
+       || gfc_is_function_return_value (sym, gfc_current_ns))
+      && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS))
+    return match_typebound_call (st);
+
+  /* If it does not seem to be callable (include functions so that the
+     right association is made.  They are thrown out in resolution.)
+     ...  */
+  if (!sym->attr.generic
+	&& !sym->attr.subroutine
+	&& !sym->attr.function)
+    {
+      if (!(sym->attr.external && !sym->attr.referenced))
+	{
+	  /* ...create a symbol in this scope...  */
+	  if (sym->ns != gfc_current_ns
+	        && gfc_get_sym_tree (name, NULL, &st, false) == 1)
+            return MATCH_ERROR;
+
+	  if (sym != st->n.sym)
+	    sym = st->n.sym;
+	}
+
+      /* ...and then to try to make the symbol into a subroutine.  */
+      if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
+	return MATCH_ERROR;
+    }
+
+  gfc_set_sym_referenced (sym);
+
+  if (gfc_match_eos () != MATCH_YES)
+    {
+      m = gfc_match_actual_arglist (1, &arglist);
+      if (m == MATCH_NO)
+	goto syntax;
+      if (m == MATCH_ERROR)
+	goto cleanup;
+
+      if (gfc_match_eos () != MATCH_YES)
+	goto syntax;
+    }
+
+  /* If any alternate return labels were found, construct a SELECT
+     statement that will jump to the right place.  */
+
+  i = 0;
+  for (a = arglist; a; a = a->next)
+    if (a->expr == NULL)
+      {
+	i = 1;
+	break;
+      }
+
+  if (i)
+    {
+      gfc_symtree *select_st;
+      gfc_symbol *select_sym;
+      char name[GFC_MAX_SYMBOL_LEN + 1];
+
+      new_st.next = c = gfc_get_code (EXEC_SELECT);
+      sprintf (name, "_result_%s", sym->name);
+      gfc_get_ha_sym_tree (name, &select_st);   /* Can't fail.  */
+
+      select_sym = select_st->n.sym;
+      select_sym->ts.type = BT_INTEGER;
+      select_sym->ts.kind = gfc_default_integer_kind;
+      gfc_set_sym_referenced (select_sym);
+      c->expr1 = gfc_get_expr ();
+      c->expr1->expr_type = EXPR_VARIABLE;
+      c->expr1->symtree = select_st;
+      c->expr1->ts = select_sym->ts;
+      c->expr1->where = gfc_current_locus;
+
+      i = 0;
+      for (a = arglist; a; a = a->next)
+	{
+	  if (a->expr != NULL)
+	    continue;
+
+	  if (!gfc_reference_st_label (a->label, ST_LABEL_TARGET))
+	    continue;
+
+	  i++;
+
+	  c->block = gfc_get_code (EXEC_SELECT);
+	  c = c->block;
+
+	  new_case = gfc_get_case ();
+	  new_case->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, i);
+	  new_case->low = new_case->high;
+	  c->ext.block.case_list = new_case;
+
+	  c->next = gfc_get_code (EXEC_GOTO);
+	  c->next->label1 = a->label;
+	}
+    }
+
+  new_st.op = EXEC_CALL;
+  new_st.symtree = st;
+  new_st.ext.actual = arglist;
+
+  return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (ST_CALL);
+
+cleanup:
+  gfc_free_actual_arglist (arglist);
+  return MATCH_ERROR;
+}
+
+
+/* Given a name, return a pointer to the common head structure,
+   creating it if it does not exist. If FROM_MODULE is nonzero, we
+   mangle the name so that it doesn't interfere with commons defined
+   in the using namespace.
+   TODO: Add to global symbol tree.  */
+
+gfc_common_head *
+gfc_get_common (const char *name, int from_module)
+{
+  gfc_symtree *st;
+  static int serial = 0;
+  char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
+
+  if (from_module)
+    {
+      /* A use associated common block is only needed to correctly layout
+	 the variables it contains.  */
+      snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
+      st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
+    }
+  else
+    {
+      st = gfc_find_symtree (gfc_current_ns->common_root, name);
+
+      if (st == NULL)
+	st = gfc_new_symtree (&gfc_current_ns->common_root, name);
+    }
+
+  if (st->n.common == NULL)
+    {
+      st->n.common = gfc_get_common_head ();
+      st->n.common->where = gfc_current_locus;
+      strcpy (st->n.common->name, name);
+    }
+
+  return st->n.common;
+}
+
+
+/* Match a common block name.  */
+
+match match_common_name (char *name)
+{
+  match m;
+
+  if (gfc_match_char ('/') == MATCH_NO)
+    {
+      name[0] = '\0';
+      return MATCH_YES;
+    }
+
+  if (gfc_match_char ('/') == MATCH_YES)
+    {
+      name[0] = '\0';
+      return MATCH_YES;
+    }
+
+  m = gfc_match_name (name);
+
+  if (m == MATCH_ERROR)
+    return MATCH_ERROR;
+  if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
+    return MATCH_YES;
+
+  gfc_error ("Syntax error in common block name at %C");
+  return MATCH_ERROR;
+}
+
+
+/* Match a COMMON statement.  */
+
+match
+gfc_match_common (void)
+{
+  gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_common_head *t;
+  gfc_array_spec *as;
+  gfc_equiv *e1, *e2;
+  match m;
+
+  old_blank_common = gfc_current_ns->blank_common.head;
+  if (old_blank_common)
+    {
+      while (old_blank_common->common_next)
+	old_blank_common = old_blank_common->common_next;
+    }
+
+  as = NULL;
+
+  for (;;)
+    {
+      m = match_common_name (name);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+
+      if (name[0] == '\0')
+	{
+	  t = &gfc_current_ns->blank_common;
+	  if (t->head == NULL)
+	    t->where = gfc_current_locus;
+	}
+      else
+	{
+	  t = gfc_get_common (name, 0);
+	}
+      head = &t->head;
+
+      if (*head == NULL)
+	tail = NULL;
+      else
+	{
+	  tail = *head;
+	  while (tail->common_next)
+	    tail = tail->common_next;
+	}
+
+      /* Grab the list of symbols.  */
+      for (;;)
+	{
+	  m = gfc_match_symbol (&sym, 0);
+	  if (m == MATCH_ERROR)
+	    goto cleanup;
+	  if (m == MATCH_NO)
+	    goto syntax;
+
+          /* Store a ref to the common block for error checking.  */
+          sym->common_block = t;
+          sym->common_block->refs++;
+
+          /* See if we know the current common block is bind(c), and if
+             so, then see if we can check if the symbol is (which it'll
+             need to be).  This can happen if the bind(c) attr stmt was
+             applied to the common block, and the variable(s) already
+             defined, before declaring the common block.  */
+          if (t->is_bind_c == 1)
+            {
+              if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1)
+                {
+                  /* 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 ("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);
+                }
+
+              if (sym->attr.is_bind_c == 1)
+                gfc_error_now ("Variable '%s' in common block "
+                               "'%s' at %C can not be bind(c) since "
+                               "it is not global", sym->name, t->name);
+            }
+
+	  if (sym->attr.in_common)
+	    {
+	      gfc_error ("Symbol '%s' at %C is already in a COMMON block",
+			 sym->name);
+	      goto cleanup;
+	    }
+
+	  if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL)
+	       || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
+	    {
+	      if (!gfc_notify_std (GFC_STD_GNU, "Initialized symbol '%s' at "
+				   "%C can only be COMMON in BLOCK DATA", 
+				   sym->name))
+		goto cleanup;
+	    }
+
+	  if (!gfc_add_in_common (&sym->attr, sym->name, NULL))
+	    goto cleanup;
+
+	  if (tail != NULL)
+	    tail->common_next = sym;
+	  else
+	    *head = sym;
+
+	  tail = sym;
+
+	  /* Deal with an optional array specification after the
+	     symbol name.  */
+	  m = gfc_match_array_spec (&as, true, true);
+	  if (m == MATCH_ERROR)
+	    goto cleanup;
+
+	  if (m == MATCH_YES)
+	    {
+	      if (as->type != AS_EXPLICIT)
+		{
+		  gfc_error ("Array specification for symbol '%s' in COMMON "
+			     "at %C must be explicit", sym->name);
+		  goto cleanup;
+		}
+
+	      if (!gfc_add_dimension (&sym->attr, sym->name, NULL))
+		goto cleanup;
+
+	      if (sym->attr.pointer)
+		{
+		  gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
+			     "POINTER array", sym->name);
+		  goto cleanup;
+		}
+
+	      sym->as = as;
+	      as = NULL;
+
+	    }
+
+	  sym->common_head = t;
+
+	  /* Check to see if the symbol is already in an equivalence group.
+	     If it is, set the other members as being in common.  */
+	  if (sym->attr.in_equivalence)
+	    {
+	      for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
+		{
+		  for (e2 = e1; e2; e2 = e2->eq)
+		    if (e2->expr->symtree->n.sym == sym)
+		      goto equiv_found;
+
+		  continue;
+
+	  equiv_found:
+
+		  for (e2 = e1; e2; e2 = e2->eq)
+		    {
+		      other = e2->expr->symtree->n.sym;
+		      if (other->common_head
+			  && other->common_head != sym->common_head)
+			{
+			  gfc_error ("Symbol '%s', in COMMON block '%s' at "
+				     "%C is being indirectly equivalenced to "
+				     "another COMMON block '%s'",
+				     sym->name, sym->common_head->name,
+				     other->common_head->name);
+			    goto cleanup;
+			}
+		      other->attr.in_common = 1;
+		      other->common_head = t;
+		    }
+		}
+	    }
+
+
+	  gfc_gobble_whitespace ();
+	  if (gfc_match_eos () == MATCH_YES)
+	    goto done;
+	  if (gfc_peek_ascii_char () == '/')
+	    break;
+	  if (gfc_match_char (',') != MATCH_YES)
+	    goto syntax;
+	  gfc_gobble_whitespace ();
+	  if (gfc_peek_ascii_char () == '/')
+	    break;
+	}
+    }
+
+done:
+  return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (ST_COMMON);
+
+cleanup:
+  gfc_free_array_spec (as);
+  return MATCH_ERROR;
+}
+
+
+/* Match a BLOCK DATA program unit.  */
+
+match
+gfc_match_block_data (void)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_symbol *sym;
+  match m;
+
+  if (gfc_match_eos () == MATCH_YES)
+    {
+      gfc_new_block = NULL;
+      return MATCH_YES;
+    }
+
+  m = gfc_match ("% %n%t", name);
+  if (m != MATCH_YES)
+    return MATCH_ERROR;
+
+  if (gfc_get_symbol (name, NULL, &sym))
+    return MATCH_ERROR;
+
+  if (!gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL))
+    return MATCH_ERROR;
+
+  gfc_new_block = sym;
+
+  return MATCH_YES;
+}
+
+
+/* Free a namelist structure.  */
+
+void
+gfc_free_namelist (gfc_namelist *name)
+{
+  gfc_namelist *n;
+
+  for (; name; name = n)
+    {
+      n = name->next;
+      free (name);
+    }
+}
+
+
+/* Match a NAMELIST statement.  */
+
+match
+gfc_match_namelist (void)
+{
+  gfc_symbol *group_name, *sym;
+  gfc_namelist *nl;
+  match m, m2;
+
+  m = gfc_match (" / %s /", &group_name);
+  if (m == MATCH_NO)
+    goto syntax;
+  if (m == MATCH_ERROR)
+    goto error;
+
+  for (;;)
+    {
+      if (group_name->ts.type != BT_UNKNOWN)
+	{
+	  gfc_error ("Namelist group name '%s' at %C already has a basic "
+		     "type of %s", group_name->name,
+		     gfc_typename (&group_name->ts));
+	  return MATCH_ERROR;
+	}
+
+      if (group_name->attr.flavor == FL_NAMELIST
+	  && group_name->attr.use_assoc
+	  && !gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
+			      "at %C already is USE associated and can"
+			      "not be respecified.", group_name->name))
+	return MATCH_ERROR;
+
+      if (group_name->attr.flavor != FL_NAMELIST
+	  && !gfc_add_flavor (&group_name->attr, FL_NAMELIST, 
+			      group_name->name, NULL))
+	return MATCH_ERROR;
+
+      for (;;)
+	{
+	  m = gfc_match_symbol (&sym, 1);
+	  if (m == MATCH_NO)
+	    goto syntax;
+	  if (m == MATCH_ERROR)
+	    goto error;
+
+	  if (sym->attr.in_namelist == 0
+	      && !gfc_add_in_namelist (&sym->attr, sym->name, NULL))
+	    goto error;
+
+	  /* Use gfc_error_check here, rather than goto error, so that
+	     these are the only errors for the next two lines.  */
+	  if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
+	    {
+	      gfc_error ("Assumed size array '%s' in namelist '%s' at "
+			 "%C is not allowed", sym->name, group_name->name);
+	      gfc_error_check ();
+	    }
+
+	  nl = gfc_get_namelist ();
+	  nl->sym = sym;
+	  sym->refs++;
+
+	  if (group_name->namelist == NULL)
+	    group_name->namelist = group_name->namelist_tail = nl;
+	  else
+	    {
+	      group_name->namelist_tail->next = nl;
+	      group_name->namelist_tail = nl;
+	    }
+
+	  if (gfc_match_eos () == MATCH_YES)
+	    goto done;
+
+	  m = gfc_match_char (',');
+
+	  if (gfc_match_char ('/') == MATCH_YES)
+	    {
+	      m2 = gfc_match (" %s /", &group_name);
+	      if (m2 == MATCH_YES)
+		break;
+	      if (m2 == MATCH_ERROR)
+		goto error;
+	      goto syntax;
+	    }
+
+	  if (m != MATCH_YES)
+	    goto syntax;
+	}
+    }
+
+done:
+  return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (ST_NAMELIST);
+
+error:
+  return MATCH_ERROR;
+}
+
+
+/* Match a MODULE statement.  */
+
+match
+gfc_match_module (void)
+{
+  match m;
+
+  m = gfc_match (" %s%t", &gfc_new_block);
+  if (m != MATCH_YES)
+    return m;
+
+  if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE, 
+		       gfc_new_block->name, NULL))
+    return MATCH_ERROR;
+
+  return MATCH_YES;
+}
+
+
+/* Free equivalence sets and lists.  Recursively is the easiest way to
+   do this.  */
+
+void
+gfc_free_equiv_until (gfc_equiv *eq, gfc_equiv *stop)
+{
+  if (eq == stop)
+    return;
+
+  gfc_free_equiv (eq->eq);
+  gfc_free_equiv_until (eq->next, stop);
+  gfc_free_expr (eq->expr);
+  free (eq);
+}
+
+
+void
+gfc_free_equiv (gfc_equiv *eq)
+{
+  gfc_free_equiv_until (eq, NULL);
+}
+
+
+/* Match an EQUIVALENCE statement.  */
+
+match
+gfc_match_equivalence (void)
+{
+  gfc_equiv *eq, *set, *tail;
+  gfc_ref *ref;
+  gfc_symbol *sym;
+  match m;
+  gfc_common_head *common_head = NULL;
+  bool common_flag;
+  int cnt;
+
+  tail = NULL;
+
+  for (;;)
+    {
+      eq = gfc_get_equiv ();
+      if (tail == NULL)
+	tail = eq;
+
+      eq->next = gfc_current_ns->equiv;
+      gfc_current_ns->equiv = eq;
+
+      if (gfc_match_char ('(') != MATCH_YES)
+	goto syntax;
+
+      set = eq;
+      common_flag = FALSE;
+      cnt = 0;
+
+      for (;;)
+	{
+	  m = gfc_match_equiv_variable (&set->expr);
+	  if (m == MATCH_ERROR)
+	    goto cleanup;
+	  if (m == MATCH_NO)
+	    goto syntax;
+
+	  /*  count the number of objects.  */
+	  cnt++;
+
+	  if (gfc_match_char ('%') == MATCH_YES)
+	    {
+	      gfc_error ("Derived type component %C is not a "
+			 "permitted EQUIVALENCE member");
+	      goto cleanup;
+	    }
+
+	  for (ref = set->expr->ref; ref; ref = ref->next)
+	    if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
+	      {
+		gfc_error ("Array reference in EQUIVALENCE at %C cannot "
+			   "be an array section");
+		goto cleanup;
+	      }
+
+	  sym = set->expr->symtree->n.sym;
+
+	  if (!gfc_add_in_equivalence (&sym->attr, sym->name, NULL))
+	    goto cleanup;
+
+	  if (sym->attr.in_common)
+	    {
+	      common_flag = TRUE;
+	      common_head = sym->common_head;
+	    }
+
+	  if (gfc_match_char (')') == MATCH_YES)
+	    break;
+
+	  if (gfc_match_char (',') != MATCH_YES)
+	    goto syntax;
+
+	  set->eq = gfc_get_equiv ();
+	  set = set->eq;
+	}
+
+      if (cnt < 2)
+	{
+	  gfc_error ("EQUIVALENCE at %C requires two or more objects");
+	  goto cleanup;
+	}
+
+      /* If one of the members of an equivalence is in common, then
+	 mark them all as being in common.  Before doing this, check
+	 that members of the equivalence group are not in different
+	 common blocks.  */
+      if (common_flag)
+	for (set = eq; set; set = set->eq)
+	  {
+	    sym = set->expr->symtree->n.sym;
+	    if (sym->common_head && sym->common_head != common_head)
+	      {
+		gfc_error ("Attempt to indirectly overlap COMMON "
+			   "blocks %s and %s by EQUIVALENCE at %C",
+			   sym->common_head->name, common_head->name);
+		goto cleanup;
+	      }
+	    sym->attr.in_common = 1;
+	    sym->common_head = common_head;
+	  }
+
+      if (gfc_match_eos () == MATCH_YES)
+	break;
+      if (gfc_match_char (',') != MATCH_YES)
+	{
+	  gfc_error ("Expecting a comma in EQUIVALENCE at %C");
+	  goto cleanup;
+	}
+    }
+
+  return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (ST_EQUIVALENCE);
+
+cleanup:
+  eq = tail->next;
+  tail->next = NULL;
+
+  gfc_free_equiv (gfc_current_ns->equiv);
+  gfc_current_ns->equiv = eq;
+
+  return MATCH_ERROR;
+}
+
+
+/* Check that a statement function is not recursive. This is done by looking
+   for the statement function symbol(sym) by looking recursively through its
+   expression(e).  If a reference to sym is found, true is returned.
+   12.5.4 requires that any variable of function that is implicitly typed
+   shall have that type confirmed by any subsequent type declaration.  The
+   implicit typing is conveniently done here.  */
+static bool
+recursive_stmt_fcn (gfc_expr *, gfc_symbol *);
+
+static bool
+check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
+{
+
+  if (e == NULL)
+    return false;
+
+  switch (e->expr_type)
+    {
+    case EXPR_FUNCTION:
+      if (e->symtree == NULL)
+	return false;
+
+      /* Check the name before testing for nested recursion!  */
+      if (sym->name == e->symtree->n.sym->name)
+	return true;
+
+      /* Catch recursion via other statement functions.  */
+      if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
+	  && e->symtree->n.sym->value
+	  && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
+	return true;
+
+      if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
+	gfc_set_default_type (e->symtree->n.sym, 0, NULL);
+
+      break;
+
+    case EXPR_VARIABLE:
+      if (e->symtree && sym->name == e->symtree->n.sym->name)
+	return true;
+
+      if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
+	gfc_set_default_type (e->symtree->n.sym, 0, NULL);
+      break;
+
+    default:
+      break;
+    }
+
+  return false;
+}
+
+
+static bool
+recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
+{
+  return gfc_traverse_expr (e, sym, check_stmt_fcn, 0);
+}
+
+
+/* Match a statement function declaration.  It is so easy to match
+   non-statement function statements with a MATCH_ERROR as opposed to
+   MATCH_NO that we suppress error message in most cases.  */
+
+match
+gfc_match_st_function (void)
+{
+  gfc_error_buf old_error;
+  gfc_symbol *sym;
+  gfc_expr *expr;
+  match m;
+
+  m = gfc_match_symbol (&sym, 0);
+  if (m != MATCH_YES)
+    return m;
+
+  gfc_push_error (&old_error);
+
+  if (!gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, sym->name, NULL))
+    goto undo_error;
+
+  if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
+    goto undo_error;
+
+  m = gfc_match (" = %e%t", &expr);
+  if (m == MATCH_NO)
+    goto undo_error;
+
+  gfc_free_error (&old_error);
+  if (m == MATCH_ERROR)
+    return m;
+
+  if (recursive_stmt_fcn (expr, sym))
+    {
+      gfc_error ("Statement function at %L is recursive", &expr->where);
+      return MATCH_ERROR;
+    }
+
+  sym->value = expr;
+
+  if (!gfc_notify_std (GFC_STD_F95_OBS, "Statement function at %C"))
+    return MATCH_ERROR;
+
+  return MATCH_YES;
+
+undo_error:
+  gfc_pop_error (&old_error);
+  return MATCH_NO;
+}
+
+
+/***************** SELECT CASE subroutines ******************/
+
+/* Free a single case structure.  */
+
+static void
+free_case (gfc_case *p)
+{
+  if (p->low == p->high)
+    p->high = NULL;
+  gfc_free_expr (p->low);
+  gfc_free_expr (p->high);
+  free (p);
+}
+
+
+/* Free a list of case structures.  */
+
+void
+gfc_free_case_list (gfc_case *p)
+{
+  gfc_case *q;
+
+  for (; p; p = q)
+    {
+      q = p->next;
+      free_case (p);
+    }
+}
+
+
+/* Match a single case selector.  */
+
+static match
+match_case_selector (gfc_case **cp)
+{
+  gfc_case *c;
+  match m;
+
+  c = gfc_get_case ();
+  c->where = gfc_current_locus;
+
+  if (gfc_match_char (':') == MATCH_YES)
+    {
+      m = gfc_match_init_expr (&c->high);
+      if (m == MATCH_NO)
+	goto need_expr;
+      if (m == MATCH_ERROR)
+	goto cleanup;
+    }
+  else
+    {
+      m = gfc_match_init_expr (&c->low);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_NO)
+	goto need_expr;
+
+      /* If we're not looking at a ':' now, make a range out of a single
+	 target.  Else get the upper bound for the case range.  */
+      if (gfc_match_char (':') != MATCH_YES)
+	c->high = c->low;
+      else
+	{
+	  m = gfc_match_init_expr (&c->high);
+	  if (m == MATCH_ERROR)
+	    goto cleanup;
+	  /* MATCH_NO is fine.  It's OK if nothing is there!  */
+	}
+    }
+
+  *cp = c;
+  return MATCH_YES;
+
+need_expr:
+  gfc_error ("Expected initialization expression in CASE at %C");
+
+cleanup:
+  free_case (c);
+  return MATCH_ERROR;
+}
+
+
+/* Match the end of a case statement.  */
+
+static match
+match_case_eos (void)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  match m;
+
+  if (gfc_match_eos () == MATCH_YES)
+    return MATCH_YES;
+
+  /* If the case construct doesn't have a case-construct-name, we
+     should have matched the EOS.  */
+  if (!gfc_current_block ())
+    return MATCH_NO;
+
+  gfc_gobble_whitespace ();
+
+  m = gfc_match_name (name);
+  if (m != MATCH_YES)
+    return m;
+
+  if (strcmp (name, gfc_current_block ()->name) != 0)
+    {
+      gfc_error ("Expected block name '%s' of SELECT construct at %C",
+		 gfc_current_block ()->name);
+      return MATCH_ERROR;
+    }
+
+  return gfc_match_eos ();
+}
+
+
+/* Match a SELECT statement.  */
+
+match
+gfc_match_select (void)
+{
+  gfc_expr *expr;
+  match m;
+
+  m = gfc_match_label ();
+  if (m == MATCH_ERROR)
+    return m;
+
+  m = gfc_match (" select case ( %e )%t", &expr);
+  if (m != MATCH_YES)
+    return m;
+
+  new_st.op = EXEC_SELECT;
+  new_st.expr1 = expr;
+
+  return MATCH_YES;
+}
+
+
+/* Transfer the selector typespec to the associate name.  */
+
+static void
+copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
+{
+  gfc_ref *ref;
+  gfc_symbol *assoc_sym;
+
+  assoc_sym = associate->symtree->n.sym;
+
+  /* At this stage the expression rank and arrayspec dimensions have
+     not been completely sorted out. We must get the expr2->rank
+     right here, so that the correct class container is obtained.  */
+  ref = selector->ref;
+  while (ref && ref->next)
+    ref = ref->next;
+
+  if (selector->ts.type == BT_CLASS && CLASS_DATA (selector)->as
+      && ref && ref->type == REF_ARRAY)
+    {
+      /* Ensure that the array reference type is set.  We cannot use
+	 gfc_resolve_expr at this point, so the usable parts of
+	 resolve.c(resolve_array_ref) are employed to do it.  */
+      if (ref->u.ar.type == AR_UNKNOWN)
+	{
+	  ref->u.ar.type = AR_ELEMENT;
+	  for (int i = 0; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
+	    if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
+		|| ref->u.ar.dimen_type[i] == DIMEN_VECTOR
+		|| (ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN
+		    && ref->u.ar.start[i] && ref->u.ar.start[i]->rank))
+	      {
+		ref->u.ar.type = AR_SECTION;
+		break;
+	      }
+	}
+
+      if (ref->u.ar.type == AR_FULL)
+	selector->rank = CLASS_DATA (selector)->as->rank;
+      else if (ref->u.ar.type == AR_SECTION)
+	selector->rank = ref->u.ar.dimen;
+      else
+	selector->rank = 0;
+    }
+
+  if (selector->rank)
+    {
+      assoc_sym->attr.dimension = 1;
+      assoc_sym->as = gfc_get_array_spec ();
+      assoc_sym->as->rank = selector->rank;
+      assoc_sym->as->type = AS_DEFERRED;
+    }
+  else
+    assoc_sym->as = NULL;
+
+  if (selector->ts.type == BT_CLASS)
+    {
+      /* The correct class container has to be available.  */
+      assoc_sym->ts.type = BT_CLASS;
+      assoc_sym->ts.u.derived = CLASS_DATA (selector)->ts.u.derived;
+      assoc_sym->attr.pointer = 1;
+      gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr, &assoc_sym->as);
+    }
+}
+
+
+/* Push the current selector onto the SELECT TYPE stack.  */
+
+static void
+select_type_push (gfc_symbol *sel)
+{
+  gfc_select_type_stack *top = gfc_get_select_type_stack ();
+  top->selector = sel;
+  top->tmp = NULL;
+  top->prev = select_type_stack;
+
+  select_type_stack = top;
+}
+
+
+/* Set the temporary for the current intrinsic SELECT TYPE selector.  */
+
+static gfc_symtree *
+select_intrinsic_set_tmp (gfc_typespec *ts)
+{
+  char name[GFC_MAX_SYMBOL_LEN];
+  gfc_symtree *tmp;
+  int charlen = 0;
+
+  if (ts->type == BT_CLASS || ts->type == BT_DERIVED)
+    return NULL;
+
+  if (select_type_stack->selector->ts.type == BT_CLASS
+      && !select_type_stack->selector->attr.class_ok)
+    return NULL;
+
+  if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length
+      && ts->u.cl->length->expr_type == EXPR_CONSTANT)
+    charlen = mpz_get_si (ts->u.cl->length->value.integer);
+
+  if (ts->type != BT_CHARACTER)
+    sprintf (name, "__tmp_%s_%d", gfc_basic_typename (ts->type),
+	     ts->kind);
+  else
+    sprintf (name, "__tmp_%s_%d_%d", gfc_basic_typename (ts->type),
+	     charlen, ts->kind);
+
+  gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
+  gfc_add_type (tmp->n.sym, ts, NULL);
+
+  /* Copy across the array spec to the selector.  */
+  if (select_type_stack->selector->ts.type == BT_CLASS
+      && (CLASS_DATA (select_type_stack->selector)->attr.dimension
+	  || CLASS_DATA (select_type_stack->selector)->attr.codimension))
+    {
+      tmp->n.sym->attr.pointer = 1;
+      tmp->n.sym->attr.dimension
+		= CLASS_DATA (select_type_stack->selector)->attr.dimension;
+      tmp->n.sym->attr.codimension
+		= CLASS_DATA (select_type_stack->selector)->attr.codimension;
+      tmp->n.sym->as
+	= gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
+    }
+
+  gfc_set_sym_referenced (tmp->n.sym);
+  gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
+  tmp->n.sym->attr.select_type_temporary = 1;
+
+  return tmp;
+}
+
+
+/* Set up a temporary for the current TYPE IS / CLASS IS branch .  */
+
+static void
+select_type_set_tmp (gfc_typespec *ts)
+{
+  char name[GFC_MAX_SYMBOL_LEN];
+  gfc_symtree *tmp = NULL;
+
+  if (!ts)
+    {
+      select_type_stack->tmp = NULL;
+      return;
+    }
+
+  tmp = select_intrinsic_set_tmp (ts);
+
+  if (tmp == NULL)
+    {
+      if (!ts->u.derived)
+	return;
+
+      if (ts->type == BT_CLASS)
+	sprintf (name, "__tmp_class_%s", ts->u.derived->name);
+      else
+	sprintf (name, "__tmp_type_%s", ts->u.derived->name);
+      gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
+      gfc_add_type (tmp->n.sym, ts, NULL);
+
+      if (select_type_stack->selector->ts.type == BT_CLASS
+	&& select_type_stack->selector->attr.class_ok)
+	{
+	  tmp->n.sym->attr.pointer
+		= CLASS_DATA (select_type_stack->selector)->attr.class_pointer;
+
+	  /* Copy across the array spec to the selector.  */
+	  if (CLASS_DATA (select_type_stack->selector)->attr.dimension
+	      || CLASS_DATA (select_type_stack->selector)->attr.codimension)
+	    {
+	      tmp->n.sym->attr.dimension
+		    = CLASS_DATA (select_type_stack->selector)->attr.dimension;
+	      tmp->n.sym->attr.codimension
+		    = CLASS_DATA (select_type_stack->selector)->attr.codimension;
+	      tmp->n.sym->as
+	    = gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
+	    }
+    }
+
+  gfc_set_sym_referenced (tmp->n.sym);
+  gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
+  tmp->n.sym->attr.select_type_temporary = 1;
+
+  if (ts->type == BT_CLASS)
+    gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
+			    &tmp->n.sym->as);
+    }
+
+  /* Add an association for it, so the rest of the parser knows it is
+     an associate-name.  The target will be set during resolution.  */
+  tmp->n.sym->assoc = gfc_get_association_list ();
+  tmp->n.sym->assoc->dangling = 1;
+  tmp->n.sym->assoc->st = tmp;
+
+  select_type_stack->tmp = tmp;
+}
+
+
+/* Match a SELECT TYPE statement.  */
+
+match
+gfc_match_select_type (void)
+{
+  gfc_expr *expr1, *expr2 = NULL;
+  match m;
+  char name[GFC_MAX_SYMBOL_LEN];
+  bool class_array;
+  gfc_symbol *sym;
+
+  m = gfc_match_label ();
+  if (m == MATCH_ERROR)
+    return m;
+
+  m = gfc_match (" select type ( ");
+  if (m != MATCH_YES)
+    return m;
+
+  m = gfc_match (" %n => %e", name, &expr2);
+  if (m == MATCH_YES)
+    {
+      expr1 = gfc_get_expr();
+      expr1->expr_type = EXPR_VARIABLE;
+      if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
+	{
+	  m = MATCH_ERROR;
+	  goto cleanup;
+	}
+
+      sym = expr1->symtree->n.sym;
+      if (expr2->ts.type == BT_UNKNOWN)
+	sym->attr.untyped = 1;
+      else
+	copy_ts_from_selector_to_associate (expr1, expr2);
+
+      sym->attr.flavor = FL_VARIABLE;
+      sym->attr.referenced = 1;
+      sym->attr.class_ok = 1;
+    }
+  else
+    {
+      m = gfc_match (" %e ", &expr1);
+      if (m != MATCH_YES)
+	return m;
+    }
+
+  m = gfc_match (" )%t");
+  if (m != MATCH_YES)
+    {
+      gfc_error ("parse error in SELECT TYPE statement at %C");
+      goto cleanup;
+    }
+
+  /* This ghastly expression seems to be needed to distinguish a CLASS
+     array, which can have a reference, from other expressions that
+     have references, such as derived type components, and are not
+     allowed by the standard.
+     TODO: see if it is sufficient to exclude component and substring
+     references.  */
+  class_array = expr1->expr_type == EXPR_VARIABLE
+		  && expr1->ts.type == BT_CLASS
+		  && CLASS_DATA (expr1)
+		  && (strcmp (CLASS_DATA (expr1)->name, "_data") == 0)
+		  && (CLASS_DATA (expr1)->attr.dimension
+		      || CLASS_DATA (expr1)->attr.codimension)
+		  && expr1->ref
+		  && expr1->ref->type == REF_ARRAY
+		  && expr1->ref->next == NULL;
+
+  /* Check for F03:C811.  */
+  if (!expr2 && (expr1->expr_type != EXPR_VARIABLE
+		  || (!class_array && expr1->ref != NULL)))
+    {
+      gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
+		 "use associate-name=>");
+      m = MATCH_ERROR;
+      goto cleanup;
+    }
+
+  new_st.op = EXEC_SELECT_TYPE;
+  new_st.expr1 = expr1;
+  new_st.expr2 = expr2;
+  new_st.ext.block.ns = gfc_current_ns;
+
+  select_type_push (expr1->symtree->n.sym);
+
+  return MATCH_YES;
+
+cleanup:
+  gfc_free_expr (expr1);
+  gfc_free_expr (expr2);
+  return m;
+}
+
+
+/* Match a CASE statement.  */
+
+match
+gfc_match_case (void)
+{
+  gfc_case *c, *head, *tail;
+  match m;
+
+  head = tail = NULL;
+
+  if (gfc_current_state () != COMP_SELECT)
+    {
+      gfc_error ("Unexpected CASE statement at %C");
+      return MATCH_ERROR;
+    }
+
+  if (gfc_match ("% default") == MATCH_YES)
+    {
+      m = match_case_eos ();
+      if (m == MATCH_NO)
+	goto syntax;
+      if (m == MATCH_ERROR)
+	goto cleanup;
+
+      new_st.op = EXEC_SELECT;
+      c = gfc_get_case ();
+      c->where = gfc_current_locus;
+      new_st.ext.block.case_list = c;
+      return MATCH_YES;
+    }
+
+  if (gfc_match_char ('(') != MATCH_YES)
+    goto syntax;
+
+  for (;;)
+    {
+      if (match_case_selector (&c) == MATCH_ERROR)
+	goto cleanup;
+
+      if (head == NULL)
+	head = c;
+      else
+	tail->next = c;
+
+      tail = c;
+
+      if (gfc_match_char (')') == MATCH_YES)
+	break;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+    }
+
+  m = match_case_eos ();
+  if (m == MATCH_NO)
+    goto syntax;
+  if (m == MATCH_ERROR)
+    goto cleanup;
+
+  new_st.op = EXEC_SELECT;
+  new_st.ext.block.case_list = head;
+
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in CASE specification at %C");
+
+cleanup:
+  gfc_free_case_list (head);  /* new_st is cleaned up in parse.c.  */
+  return MATCH_ERROR;
+}
+
+
+/* Match a TYPE IS statement.  */
+
+match
+gfc_match_type_is (void)
+{
+  gfc_case *c = NULL;
+  match m;
+
+  if (gfc_current_state () != COMP_SELECT_TYPE)
+    {
+      gfc_error ("Unexpected TYPE IS statement at %C");
+      return MATCH_ERROR;
+    }
+
+  if (gfc_match_char ('(') != MATCH_YES)
+    goto syntax;
+
+  c = gfc_get_case ();
+  c->where = gfc_current_locus;
+
+  if (gfc_match_type_spec (&c->ts) == MATCH_ERROR)
+    goto cleanup;
+
+  if (gfc_match_char (')') != MATCH_YES)
+    goto syntax;
+
+  m = match_case_eos ();
+  if (m == MATCH_NO)
+    goto syntax;
+  if (m == MATCH_ERROR)
+    goto cleanup;
+
+  new_st.op = EXEC_SELECT_TYPE;
+  new_st.ext.block.case_list = c;
+
+  if (c->ts.type == BT_DERIVED && c->ts.u.derived
+      && (c->ts.u.derived->attr.sequence
+	  || c->ts.u.derived->attr.is_bind_c))
+    {
+      gfc_error ("The type-spec shall not specify a sequence derived "
+		 "type or a type with the BIND attribute in SELECT "
+		 "TYPE at %C [F2003:C815]");
+      return MATCH_ERROR;
+    }
+
+  /* Create temporary variable.  */
+  select_type_set_tmp (&c->ts);
+
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in TYPE IS specification at %C");
+
+cleanup:
+  if (c != NULL)
+    gfc_free_case_list (c);  /* new_st is cleaned up in parse.c.  */
+  return MATCH_ERROR;
+}
+
+
+/* Match a CLASS IS or CLASS DEFAULT statement.  */
+
+match
+gfc_match_class_is (void)
+{
+  gfc_case *c = NULL;
+  match m;
+
+  if (gfc_current_state () != COMP_SELECT_TYPE)
+    return MATCH_NO;
+
+  if (gfc_match ("% default") == MATCH_YES)
+    {
+      m = match_case_eos ();
+      if (m == MATCH_NO)
+	goto syntax;
+      if (m == MATCH_ERROR)
+	goto cleanup;
+
+      new_st.op = EXEC_SELECT_TYPE;
+      c = gfc_get_case ();
+      c->where = gfc_current_locus;
+      c->ts.type = BT_UNKNOWN;
+      new_st.ext.block.case_list = c;
+      select_type_set_tmp (NULL);
+      return MATCH_YES;
+    }
+
+  m = gfc_match ("% is");
+  if (m == MATCH_NO)
+    goto syntax;
+  if (m == MATCH_ERROR)
+    goto cleanup;
+
+  if (gfc_match_char ('(') != MATCH_YES)
+    goto syntax;
+
+  c = gfc_get_case ();
+  c->where = gfc_current_locus;
+
+  if (match_derived_type_spec (&c->ts) == MATCH_ERROR)
+    goto cleanup;
+
+  if (c->ts.type == BT_DERIVED)
+    c->ts.type = BT_CLASS;
+
+  if (gfc_match_char (')') != MATCH_YES)
+    goto syntax;
+
+  m = match_case_eos ();
+  if (m == MATCH_NO)
+    goto syntax;
+  if (m == MATCH_ERROR)
+    goto cleanup;
+
+  new_st.op = EXEC_SELECT_TYPE;
+  new_st.ext.block.case_list = c;
+
+  /* Create temporary variable.  */
+  select_type_set_tmp (&c->ts);
+
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in CLASS IS specification at %C");
+
+cleanup:
+  if (c != NULL)
+    gfc_free_case_list (c);  /* new_st is cleaned up in parse.c.  */
+  return MATCH_ERROR;
+}
+
+
+/********************* WHERE subroutines ********************/
+
+/* Match the rest of a simple WHERE statement that follows an IF statement.
+ */
+
+static match
+match_simple_where (void)
+{
+  gfc_expr *expr;
+  gfc_code *c;
+  match m;
+
+  m = gfc_match (" ( %e )", &expr);
+  if (m != MATCH_YES)
+    return m;
+
+  m = gfc_match_assignment ();
+  if (m == MATCH_NO)
+    goto syntax;
+  if (m == MATCH_ERROR)
+    goto cleanup;
+
+  if (gfc_match_eos () != MATCH_YES)
+    goto syntax;
+
+  c = gfc_get_code (EXEC_WHERE);
+  c->expr1 = expr;
+
+  c->next = XCNEW (gfc_code);
+  *c->next = new_st;
+  gfc_clear_new_st ();
+
+  new_st.op = EXEC_WHERE;
+  new_st.block = c;
+
+  return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (ST_WHERE);
+
+cleanup:
+  gfc_free_expr (expr);
+  return MATCH_ERROR;
+}
+
+
+/* Match a WHERE statement.  */
+
+match
+gfc_match_where (gfc_statement *st)
+{
+  gfc_expr *expr;
+  match m0, m;
+  gfc_code *c;
+
+  m0 = gfc_match_label ();
+  if (m0 == MATCH_ERROR)
+    return m0;
+
+  m = gfc_match (" where ( %e )", &expr);
+  if (m != MATCH_YES)
+    return m;
+
+  if (gfc_match_eos () == MATCH_YES)
+    {
+      *st = ST_WHERE_BLOCK;
+      new_st.op = EXEC_WHERE;
+      new_st.expr1 = expr;
+      return MATCH_YES;
+    }
+
+  m = gfc_match_assignment ();
+  if (m == MATCH_NO)
+    gfc_syntax_error (ST_WHERE);
+
+  if (m != MATCH_YES)
+    {
+      gfc_free_expr (expr);
+      return MATCH_ERROR;
+    }
+
+  /* We've got a simple WHERE statement.  */
+  *st = ST_WHERE;
+  c = gfc_get_code (EXEC_WHERE);
+  c->expr1 = expr;
+
+  c->next = XCNEW (gfc_code);
+  *c->next = new_st;
+  gfc_clear_new_st ();
+
+  new_st.op = EXEC_WHERE;
+  new_st.block = c;
+
+  return MATCH_YES;
+}
+
+
+/* Match an ELSEWHERE statement.  We leave behind a WHERE node in
+   new_st if successful.  */
+
+match
+gfc_match_elsewhere (void)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_expr *expr;
+  match m;
+
+  if (gfc_current_state () != COMP_WHERE)
+    {
+      gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
+      return MATCH_ERROR;
+    }
+
+  expr = NULL;
+
+  if (gfc_match_char ('(') == MATCH_YES)
+    {
+      m = gfc_match_expr (&expr);
+      if (m == MATCH_NO)
+	goto syntax;
+      if (m == MATCH_ERROR)
+	return MATCH_ERROR;
+
+      if (gfc_match_char (')') != MATCH_YES)
+	goto syntax;
+    }
+
+  if (gfc_match_eos () != MATCH_YES)
+    {
+      /* Only makes sense if we have a where-construct-name.  */
+      if (!gfc_current_block ())
+	{
+	  m = MATCH_ERROR;
+	  goto cleanup;
+	}
+      /* Better be a name at this point.  */
+      m = gfc_match_name (name);
+      if (m == MATCH_NO)
+	goto syntax;
+      if (m == MATCH_ERROR)
+	goto cleanup;
+
+      if (gfc_match_eos () != MATCH_YES)
+	goto syntax;
+
+      if (strcmp (name, gfc_current_block ()->name) != 0)
+	{
+	  gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
+		     name, gfc_current_block ()->name);
+	  goto cleanup;
+	}
+    }
+
+  new_st.op = EXEC_WHERE;
+  new_st.expr1 = expr;
+  return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (ST_ELSEWHERE);
+
+cleanup:
+  gfc_free_expr (expr);
+  return MATCH_ERROR;
+}
diff --git a/gcc-4.9/gcc/fortran/match.h b/gcc-4.9/gcc/fortran/match.h
new file mode 100644
index 000000000..385e84020
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/match.h
@@ -0,0 +1,255 @@
+/* All matcher functions.
+   Copyright (C) 2003-2014 Free Software Foundation, Inc.
+   Contributed by Steven Bosscher
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+
+#ifndef GFC_MATCH_H
+#define GFC_MATCH_H
+
+/* gfc_new_block points to the symbol of a newly matched block.  */
+extern gfc_symbol *gfc_new_block;
+
+/* Current statement label.  Zero means no statement label.  Because
+   new_st can get wiped during statement matching, we have to keep it
+   separate.  */
+extern gfc_st_label *gfc_statement_label;
+
+extern int gfc_matching_ptr_assignment;
+extern int gfc_matching_procptr_assignment;
+extern bool gfc_matching_prefix;
+
+/* Default access specifier while matching procedure bindings.  */
+extern gfc_access gfc_typebound_default_access;
+
+/****************** All gfc_match* routines *****************/
+
+/* match.c.  */
+
+/* Generic match subroutines.  */
+match gfc_match_special_char (gfc_char_t *);
+match gfc_match_space (void);
+match gfc_match_eos (void);
+match gfc_match_small_literal_int (int *, int *);
+match gfc_match_st_label (gfc_st_label **);
+match gfc_match_label (void);
+match gfc_match_small_int (int *);
+match gfc_match_small_int_expr (int *, gfc_expr **);
+match gfc_match_name (char *);
+match gfc_match_name_C (const char **buffer);
+match gfc_match_symbol (gfc_symbol **, int);
+match gfc_match_sym_tree (gfc_symtree **, int);
+match gfc_match_intrinsic_op (gfc_intrinsic_op *);
+match gfc_match_char (char);
+match gfc_match (const char *, ...);
+match gfc_match_iterator (gfc_iterator *, int);
+match gfc_match_parens (void);
+match gfc_match_type_spec (gfc_typespec *);
+
+
+/* Statement matchers.  */
+match gfc_match_program (void);
+match gfc_match_pointer_assignment (void);
+match gfc_match_assignment (void);
+match gfc_match_if (gfc_statement *);
+match gfc_match_else (void);
+match gfc_match_elseif (void);
+match gfc_match_critical (void);
+match gfc_match_block (void);
+match gfc_match_associate (void);
+match gfc_match_do (void);
+match gfc_match_cycle (void);
+match gfc_match_exit (void);
+match gfc_match_lock (void);
+match gfc_match_pause (void);
+match gfc_match_stop (void);
+match gfc_match_error_stop (void);
+match gfc_match_continue (void);
+match gfc_match_assign (void);
+match gfc_match_goto (void);
+match gfc_match_sync_all (void);
+match gfc_match_sync_images (void);
+match gfc_match_sync_memory (void);
+match gfc_match_unlock (void);
+
+match gfc_match_allocate (void);
+match gfc_match_nullify (void);
+match gfc_match_deallocate (void);
+match gfc_match_return (void);
+match gfc_match_call (void);
+
+/* We want to use this function to check for a common-block-name
+   that can exist in a bind statement, so removed the "static"
+   declaration of the function in match.c.
+ 
+   TODO: should probably rename this now that it'll be globally seen to
+   gfc_match_common_name.  */
+match match_common_name (char *name);
+
+match gfc_match_common (void);
+match gfc_match_block_data (void);
+match gfc_match_namelist (void);
+match gfc_match_module (void);
+match gfc_match_equivalence (void);
+match gfc_match_st_function (void);
+match gfc_match_case (void);
+match gfc_match_select (void);
+match gfc_match_select_type (void);
+match gfc_match_type_is (void);
+match gfc_match_class_is (void);
+match gfc_match_where (gfc_statement *);
+match gfc_match_elsewhere (void);
+match gfc_match_forall (gfc_statement *);
+
+/* Other functions.  */
+
+gfc_common_head *gfc_get_common (const char *, int);
+
+/* openmp.c.  */
+
+/* OpenMP directive matchers.  */
+match gfc_match_omp_eos (void);
+match gfc_match_omp_atomic (void);
+match gfc_match_omp_barrier (void);
+match gfc_match_omp_critical (void);
+match gfc_match_omp_do (void);
+match gfc_match_omp_flush (void);
+match gfc_match_omp_master (void);
+match gfc_match_omp_ordered (void);
+match gfc_match_omp_parallel (void);
+match gfc_match_omp_parallel_do (void);
+match gfc_match_omp_parallel_sections (void);
+match gfc_match_omp_parallel_workshare (void);
+match gfc_match_omp_sections (void);
+match gfc_match_omp_single (void);
+match gfc_match_omp_task (void);
+match gfc_match_omp_taskwait (void);
+match gfc_match_omp_taskyield (void);
+match gfc_match_omp_threadprivate (void);
+match gfc_match_omp_workshare (void);
+match gfc_match_omp_end_nowait (void);
+match gfc_match_omp_end_single (void);
+
+/* decl.c.  */
+
+match gfc_match_data (void);
+match gfc_match_null (gfc_expr **);
+match gfc_match_kind_spec (gfc_typespec *, bool);
+match gfc_match_old_kind_spec (gfc_typespec *);
+match gfc_match_decl_type_spec (gfc_typespec *, int);
+
+match gfc_match_end (gfc_statement *);
+match gfc_match_data_decl (void);
+match gfc_match_formal_arglist (gfc_symbol *, int, int);
+match gfc_match_procedure (void);
+match gfc_match_generic (void);
+match gfc_match_function_decl (void);
+match gfc_match_entry (void);
+match gfc_match_subroutine (void);
+match gfc_match_derived_decl (void);
+match gfc_match_final_decl (void);
+
+match gfc_match_implicit_none (void);
+match gfc_match_implicit (void);
+
+void gfc_set_constant_character_len (int, gfc_expr *, int);
+
+/* Matchers for attribute declarations.  */
+match gfc_match_allocatable (void);
+match gfc_match_asynchronous (void);
+match gfc_match_codimension (void);
+match gfc_match_contiguous (void);
+match gfc_match_dimension (void);
+match gfc_match_external (void);
+match gfc_match_gcc_attributes (void);
+match gfc_match_import (void);
+match gfc_match_intent (void);
+match gfc_match_intrinsic (void);
+match gfc_match_optional (void);
+match gfc_match_parameter (void);
+match gfc_match_pointer (void);
+match gfc_match_protected (void);
+match gfc_match_private (gfc_statement *);
+match gfc_match_public (gfc_statement *);
+match gfc_match_save (void);
+match gfc_match_modproc (void);
+match gfc_match_target (void);
+match gfc_match_value (void);
+match gfc_match_volatile (void);
+
+/* decl.c.  */
+
+/* Fortran 2003 c interop.
+   TODO: some of these should be moved to another file rather than decl.c */
+void set_com_block_bind_c (gfc_common_head *, int);
+bool set_verify_bind_c_sym (gfc_symbol *, int);
+bool set_verify_bind_c_com_block (gfc_common_head *, int);
+bool get_bind_c_idents (void);
+match gfc_match_bind_c_stmt (void);
+match gfc_match_suffix (gfc_symbol *, gfc_symbol **);
+match gfc_match_bind_c (gfc_symbol *, bool);
+match gfc_get_type_attr_spec (symbol_attribute *, char*);
+
+/* primary.c.  */
+match gfc_match_structure_constructor (gfc_symbol *, gfc_expr **);
+match gfc_match_variable (gfc_expr **, int);
+match gfc_match_equiv_variable (gfc_expr **);
+match gfc_match_actual_arglist (int, gfc_actual_arglist **);
+match gfc_match_literal_constant (gfc_expr **, int);
+
+/* expr.c -- FIXME: this one should be eliminated by moving the
+   matcher to matchexp.c and a call to a new function in expr.c that
+   only makes sure the init expr. is valid.  */
+bool gfc_reduce_init_expr (gfc_expr *expr);
+match gfc_match_init_expr (gfc_expr **);
+
+/* array.c.  */
+match gfc_match_array_spec (gfc_array_spec **, bool, bool);
+match gfc_match_array_ref (gfc_array_ref *, gfc_array_spec *, int, int);
+match gfc_match_array_constructor (gfc_expr **);
+
+/* interface.c.  */
+match gfc_match_abstract_interface (void);
+match gfc_match_generic_spec (interface_type *, char *, gfc_intrinsic_op *);
+match gfc_match_interface (void);
+match gfc_match_end_interface (void);
+
+/* io.c.  */
+match gfc_match_format (void);
+match gfc_match_open (void);
+match gfc_match_close (void);
+match gfc_match_endfile (void);
+match gfc_match_backspace (void);
+match gfc_match_rewind (void);
+match gfc_match_flush (void);
+match gfc_match_inquire (void);
+match gfc_match_read (void);
+match gfc_match_wait (void);
+match gfc_match_write (void);
+match gfc_match_print (void);
+
+/* matchexp.c.  */
+match gfc_match_defined_op_name (char *, int);
+match gfc_match_expr (gfc_expr **);
+
+/* module.c.  */
+match gfc_match_use (void);
+void gfc_use_modules (void);
+
+#endif  /* GFC_MATCH_H  */
+
diff --git a/gcc-4.9/gcc/fortran/matchexp.c b/gcc-4.9/gcc/fortran/matchexp.c
new file mode 100644
index 000000000..1320b9628
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/matchexp.c
@@ -0,0 +1,901 @@
+/* Expression parser.
+   Copyright (C) 2000-2014 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "gfortran.h"
+#include "arith.h"
+#include "match.h"
+
+static char expression_syntax[] = N_("Syntax error in expression at %C");
+
+
+/* Match a user-defined operator name.  This is a normal name with a
+   few restrictions.  The error_flag controls whether an error is
+   raised if 'true' or 'false' are used or not.  */
+
+match
+gfc_match_defined_op_name (char *result, int error_flag)
+{
+  static const char * const badops[] = {
+    "and", "or", "not", "eqv", "neqv", "eq", "ne", "ge", "le", "lt", "gt",
+      NULL
+  };
+
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  locus old_loc;
+  match m;
+  int i;
+
+  old_loc = gfc_current_locus;
+
+  m = gfc_match (" . %n .", name);
+  if (m != MATCH_YES)
+    return m;
+
+  /* .true. and .false. have interpretations as constants.  Trying to
+     use these as operators will fail at a later time.  */
+
+  if (strcmp (name, "true") == 0 || strcmp (name, "false") == 0)
+    {
+      if (error_flag)
+	goto error;
+      gfc_current_locus = old_loc;
+      return MATCH_NO;
+    }
+
+  for (i = 0; badops[i]; i++)
+    if (strcmp (badops[i], name) == 0)
+      goto error;
+
+  for (i = 0; name[i]; i++)
+    if (!ISALPHA (name[i]))
+      {
+	gfc_error ("Bad character '%c' in OPERATOR name at %C", name[i]);
+	return MATCH_ERROR;
+      }
+
+  strcpy (result, name);
+  return MATCH_YES;
+
+error:
+  gfc_error ("The name '%s' cannot be used as a defined operator at %C",
+	     name);
+
+  gfc_current_locus = old_loc;
+  return MATCH_ERROR;
+}
+
+
+/* Match a user defined operator.  The symbol found must be an
+   operator already.  */
+
+static match
+match_defined_operator (gfc_user_op **result)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  match m;
+
+  m = gfc_match_defined_op_name (name, 0);
+  if (m != MATCH_YES)
+    return m;
+
+  *result = gfc_get_uop (name);
+  return MATCH_YES;
+}
+
+
+/* Check to see if the given operator is next on the input.  If this
+   is not the case, the parse pointer remains where it was.  */
+
+static int
+next_operator (gfc_intrinsic_op t)
+{
+  gfc_intrinsic_op u;
+  locus old_loc;
+
+  old_loc = gfc_current_locus;
+  if (gfc_match_intrinsic_op (&u) == MATCH_YES && t == u)
+    return 1;
+
+  gfc_current_locus = old_loc;
+  return 0;
+}
+
+
+/* Call the INTRINSIC_PARENTHESES function.  This is both
+   used explicitly, as below, or by resolve.c to generate
+   temporaries.  */
+
+gfc_expr *
+gfc_get_parentheses (gfc_expr *e)
+{
+  gfc_expr *e2;
+
+  e2 = gfc_get_operator_expr (&e->where, INTRINSIC_PARENTHESES, e, NULL);
+  e2->ts = e->ts;
+  e2->rank = e->rank;
+
+  return e2;
+}
+
+
+/* Match a primary expression.  */
+
+static match
+match_primary (gfc_expr **result)
+{
+  match m;
+  gfc_expr *e;
+
+  m = gfc_match_literal_constant (result, 0);
+  if (m != MATCH_NO)
+    return m;
+
+  m = gfc_match_array_constructor (result);
+  if (m != MATCH_NO)
+    return m;
+
+  m = gfc_match_rvalue (result);
+  if (m != MATCH_NO)
+    return m;
+
+  /* Match an expression in parentheses.  */
+  if (gfc_match_char ('(') != MATCH_YES)
+    return MATCH_NO;
+
+  m = gfc_match_expr (&e);
+  if (m == MATCH_NO)
+    goto syntax;
+  if (m == MATCH_ERROR)
+    return m;
+
+  m = gfc_match_char (')');
+  if (m == MATCH_NO)
+    gfc_error ("Expected a right parenthesis in expression at %C");
+
+  /* Now we have the expression inside the parentheses, build the
+     expression pointing to it. By 7.1.7.2, any expression in
+     parentheses shall be treated as a data entity.  */
+  *result = gfc_get_parentheses (e);
+
+  if (m != MATCH_YES)
+    {
+      gfc_free_expr (*result);
+      return MATCH_ERROR;
+    }
+
+  return MATCH_YES;
+
+syntax:
+  gfc_error (expression_syntax);
+  return MATCH_ERROR;
+}
+
+
+/* Match a level 1 expression.  */
+
+static match
+match_level_1 (gfc_expr **result)
+{
+  gfc_user_op *uop;
+  gfc_expr *e, *f;
+  locus where;
+  match m;
+
+  gfc_gobble_whitespace ();
+  where = gfc_current_locus;
+  uop = NULL;
+  m = match_defined_operator (&uop);
+  if (m == MATCH_ERROR)
+    return m;
+
+  m = match_primary (&e);
+  if (m != MATCH_YES)
+    return m;
+
+  if (uop == NULL)
+    *result = e;
+  else
+    {
+      f = gfc_get_operator_expr (&where, INTRINSIC_USER, e, NULL);
+      f->value.op.uop = uop;
+      *result = f;
+    }
+
+  return MATCH_YES;
+}
+
+
+/* As a GNU extension we support an expanded level-2 expression syntax.
+   Via this extension we support (arbitrary) nesting of unary plus and
+   minus operations following unary and binary operators, such as **.
+   The grammar of section 7.1.1.3 is effectively rewritten as:
+
+	R704  mult-operand     is level-1-expr [ power-op ext-mult-operand ]
+	R704' ext-mult-operand is add-op ext-mult-operand
+			       or mult-operand
+	R705  add-operand      is add-operand mult-op ext-mult-operand
+			       or mult-operand
+	R705' ext-add-operand  is add-op ext-add-operand
+			       or add-operand
+	R706  level-2-expr     is [ level-2-expr ] add-op ext-add-operand
+			       or add-operand
+ */
+
+static match match_ext_mult_operand (gfc_expr **result);
+static match match_ext_add_operand (gfc_expr **result);
+
+static int
+match_add_op (void)
+{
+  if (next_operator (INTRINSIC_MINUS))
+    return -1;
+  if (next_operator (INTRINSIC_PLUS))
+    return 1;
+  return 0;
+}
+
+
+static match
+match_mult_operand (gfc_expr **result)
+{
+  gfc_expr *e, *exp, *r;
+  locus where;
+  match m;
+
+  m = match_level_1 (&e);
+  if (m != MATCH_YES)
+    return m;
+
+  if (!next_operator (INTRINSIC_POWER))
+    {
+      *result = e;
+      return MATCH_YES;
+    }
+
+  where = gfc_current_locus;
+
+  m = match_ext_mult_operand (&exp);
+  if (m == MATCH_NO)
+    gfc_error ("Expected exponent in expression at %C");
+  if (m != MATCH_YES)
+    {
+      gfc_free_expr (e);
+      return MATCH_ERROR;
+    }
+
+  r = gfc_power (e, exp);
+  if (r == NULL)
+    {
+      gfc_free_expr (e);
+      gfc_free_expr (exp);
+      return MATCH_ERROR;
+    }
+
+  r->where = where;
+  *result = r;
+
+  return MATCH_YES;
+}
+
+
+static match
+match_ext_mult_operand (gfc_expr **result)
+{
+  gfc_expr *all, *e;
+  locus where;
+  match m;
+  int i;
+
+  where = gfc_current_locus;
+  i = match_add_op ();
+
+  if (i == 0)
+    return match_mult_operand (result);
+
+  if (gfc_notification_std (GFC_STD_GNU) == ERROR)
+    {
+      gfc_error ("Extension: Unary operator following "
+		 "arithmetic operator (use parentheses) at %C");
+      return MATCH_ERROR;
+    }
+  else
+    gfc_warning ("Extension: Unary operator following "
+		 "arithmetic operator (use parentheses) at %C");
+
+  m = match_ext_mult_operand (&e);
+  if (m != MATCH_YES)
+    return m;
+
+  if (i == -1)
+    all = gfc_uminus (e);
+  else
+    all = gfc_uplus (e);
+
+  if (all == NULL)
+    {
+      gfc_free_expr (e);
+      return MATCH_ERROR;
+    }
+
+  all->where = where;
+  *result = all;
+  return MATCH_YES;
+}
+
+
+static match
+match_add_operand (gfc_expr **result)
+{
+  gfc_expr *all, *e, *total;
+  locus where, old_loc;
+  match m;
+  gfc_intrinsic_op i;
+
+  m = match_mult_operand (&all);
+  if (m != MATCH_YES)
+    return m;
+
+  for (;;)
+    {
+      /* Build up a string of products or quotients.  */
+
+      old_loc = gfc_current_locus;
+
+      if (next_operator (INTRINSIC_TIMES))
+	i = INTRINSIC_TIMES;
+      else
+	{
+	  if (next_operator (INTRINSIC_DIVIDE))
+	    i = INTRINSIC_DIVIDE;
+	  else
+	    break;
+	}
+
+      where = gfc_current_locus;
+
+      m = match_ext_mult_operand (&e);
+      if (m == MATCH_NO)
+	{
+	  gfc_current_locus = old_loc;
+	  break;
+	}
+
+      if (m == MATCH_ERROR)
+	{
+	  gfc_free_expr (all);
+	  return MATCH_ERROR;
+	}
+
+      if (i == INTRINSIC_TIMES)
+	total = gfc_multiply (all, e);
+      else
+	total = gfc_divide (all, e);
+
+      if (total == NULL)
+	{
+	  gfc_free_expr (all);
+	  gfc_free_expr (e);
+	  return MATCH_ERROR;
+	}
+
+      all = total;
+      all->where = where;
+    }
+
+  *result = all;
+  return MATCH_YES;
+}
+
+
+static match
+match_ext_add_operand (gfc_expr **result)
+{
+  gfc_expr *all, *e;
+  locus where;
+  match m;
+  int i;
+
+  where = gfc_current_locus;
+  i = match_add_op ();
+
+  if (i == 0)
+    return match_add_operand (result);
+
+  if (gfc_notification_std (GFC_STD_GNU) == ERROR)
+    {
+      gfc_error ("Extension: Unary operator following "
+		 "arithmetic operator (use parentheses) at %C");
+      return MATCH_ERROR;
+    }
+  else
+    gfc_warning ("Extension: Unary operator following "
+		"arithmetic operator (use parentheses) at %C");
+
+  m = match_ext_add_operand (&e);
+  if (m != MATCH_YES)
+    return m;
+
+  if (i == -1)
+    all = gfc_uminus (e);
+  else
+    all = gfc_uplus (e);
+
+  if (all == NULL)
+    {
+      gfc_free_expr (e);
+      return MATCH_ERROR;
+    }
+
+  all->where = where;
+  *result = all;
+  return MATCH_YES;
+}
+
+
+/* Match a level 2 expression.  */
+
+static match
+match_level_2 (gfc_expr **result)
+{
+  gfc_expr *all, *e, *total;
+  locus where;
+  match m;
+  int i;
+
+  where = gfc_current_locus;
+  i = match_add_op ();
+
+  if (i != 0)
+    {
+      m = match_ext_add_operand (&e);
+      if (m == MATCH_NO)
+	{
+	  gfc_error (expression_syntax);
+	  m = MATCH_ERROR;
+	}
+    }
+  else
+    m = match_add_operand (&e);
+
+  if (m != MATCH_YES)
+    return m;
+
+  if (i == 0)
+    all = e;
+  else
+    {
+      if (i == -1)
+	all = gfc_uminus (e);
+      else
+	all = gfc_uplus (e);
+
+      if (all == NULL)
+	{
+	  gfc_free_expr (e);
+	  return MATCH_ERROR;
+	}
+    }
+
+  all->where = where;
+
+  /* Append add-operands to the sum.  */
+
+  for (;;)
+    {
+      where = gfc_current_locus;
+      i = match_add_op ();
+      if (i == 0)
+	break;
+
+      m = match_ext_add_operand (&e);
+      if (m == MATCH_NO)
+	gfc_error (expression_syntax);
+      if (m != MATCH_YES)
+	{
+	  gfc_free_expr (all);
+	  return MATCH_ERROR;
+	}
+
+      if (i == -1)
+	total = gfc_subtract (all, e);
+      else
+	total = gfc_add (all, e);
+
+      if (total == NULL)
+	{
+	  gfc_free_expr (all);
+	  gfc_free_expr (e);
+	  return MATCH_ERROR;
+	}
+
+      all = total;
+      all->where = where;
+    }
+
+  *result = all;
+  return MATCH_YES;
+}
+
+
+/* Match a level three expression.  */
+
+static match
+match_level_3 (gfc_expr **result)
+{
+  gfc_expr *all, *e, *total = NULL;
+  locus where;
+  match m;
+
+  m = match_level_2 (&all);
+  if (m != MATCH_YES)
+    return m;
+
+  for (;;)
+    {
+      if (!next_operator (INTRINSIC_CONCAT))
+	break;
+
+      where = gfc_current_locus;
+
+      m = match_level_2 (&e);
+      if (m == MATCH_NO)
+	gfc_error (expression_syntax);
+      if (m != MATCH_YES)
+	{
+	  gfc_free_expr (all);
+	  return MATCH_ERROR;
+	}
+
+      total = gfc_concat (all, e);
+      if (total == NULL)
+	{
+	  gfc_free_expr (all);
+	  gfc_free_expr (e);
+	  return MATCH_ERROR;
+	}
+
+      all = total;
+      all->where = where;
+    }
+
+  *result = all;
+  return MATCH_YES;
+}
+
+
+/* Match a level 4 expression.  */
+
+static match
+match_level_4 (gfc_expr **result)
+{
+  gfc_expr *left, *right, *r;
+  gfc_intrinsic_op i;
+  locus old_loc;
+  locus where;
+  match m;
+
+  m = match_level_3 (&left);
+  if (m != MATCH_YES)
+    return m;
+
+  old_loc = gfc_current_locus;
+
+  if (gfc_match_intrinsic_op (&i) != MATCH_YES)
+    {
+      *result = left;
+      return MATCH_YES;
+    }
+
+  if (i != INTRINSIC_EQ && i != INTRINSIC_NE && i != INTRINSIC_GE
+      && i != INTRINSIC_LE && i != INTRINSIC_LT && i != INTRINSIC_GT
+      && i != INTRINSIC_EQ_OS && i != INTRINSIC_NE_OS && i != INTRINSIC_GE_OS
+      && i != INTRINSIC_LE_OS && i != INTRINSIC_LT_OS && i != INTRINSIC_GT_OS)
+    {
+      gfc_current_locus = old_loc;
+      *result = left;
+      return MATCH_YES;
+    }
+
+  where = gfc_current_locus;
+
+  m = match_level_3 (&right);
+  if (m == MATCH_NO)
+    gfc_error (expression_syntax);
+  if (m != MATCH_YES)
+    {
+      gfc_free_expr (left);
+      return MATCH_ERROR;
+    }
+
+  switch (i)
+    {
+    case INTRINSIC_EQ:
+    case INTRINSIC_EQ_OS:
+      r = gfc_eq (left, right, i);
+      break;
+
+    case INTRINSIC_NE:
+    case INTRINSIC_NE_OS:
+      r = gfc_ne (left, right, i);
+      break;
+
+    case INTRINSIC_LT:
+    case INTRINSIC_LT_OS:
+      r = gfc_lt (left, right, i);
+      break;
+
+    case INTRINSIC_LE:
+    case INTRINSIC_LE_OS:
+      r = gfc_le (left, right, i);
+      break;
+
+    case INTRINSIC_GT:
+    case INTRINSIC_GT_OS:
+      r = gfc_gt (left, right, i);
+      break;
+
+    case INTRINSIC_GE:
+    case INTRINSIC_GE_OS:
+      r = gfc_ge (left, right, i);
+      break;
+
+    default:
+      gfc_internal_error ("match_level_4(): Bad operator");
+    }
+
+  if (r == NULL)
+    {
+      gfc_free_expr (left);
+      gfc_free_expr (right);
+      return MATCH_ERROR;
+    }
+
+  r->where = where;
+  *result = r;
+
+  return MATCH_YES;
+}
+
+
+static match
+match_and_operand (gfc_expr **result)
+{
+  gfc_expr *e, *r;
+  locus where;
+  match m;
+  int i;
+
+  i = next_operator (INTRINSIC_NOT);
+  where = gfc_current_locus;
+
+  m = match_level_4 (&e);
+  if (m != MATCH_YES)
+    return m;
+
+  r = e;
+  if (i)
+    {
+      r = gfc_not (e);
+      if (r == NULL)
+	{
+	  gfc_free_expr (e);
+	  return MATCH_ERROR;
+	}
+    }
+
+  r->where = where;
+  *result = r;
+
+  return MATCH_YES;
+}
+
+
+static match
+match_or_operand (gfc_expr **result)
+{
+  gfc_expr *all, *e, *total;
+  locus where;
+  match m;
+
+  m = match_and_operand (&all);
+  if (m != MATCH_YES)
+    return m;
+
+  for (;;)
+    {
+      if (!next_operator (INTRINSIC_AND))
+	break;
+      where = gfc_current_locus;
+
+      m = match_and_operand (&e);
+      if (m == MATCH_NO)
+	gfc_error (expression_syntax);
+      if (m != MATCH_YES)
+	{
+	  gfc_free_expr (all);
+	  return MATCH_ERROR;
+	}
+
+      total = gfc_and (all, e);
+      if (total == NULL)
+	{
+	  gfc_free_expr (all);
+	  gfc_free_expr (e);
+	  return MATCH_ERROR;
+	}
+
+      all = total;
+      all->where = where;
+    }
+
+  *result = all;
+  return MATCH_YES;
+}
+
+
+static match
+match_equiv_operand (gfc_expr **result)
+{
+  gfc_expr *all, *e, *total;
+  locus where;
+  match m;
+
+  m = match_or_operand (&all);
+  if (m != MATCH_YES)
+    return m;
+
+  for (;;)
+    {
+      if (!next_operator (INTRINSIC_OR))
+	break;
+      where = gfc_current_locus;
+
+      m = match_or_operand (&e);
+      if (m == MATCH_NO)
+	gfc_error (expression_syntax);
+      if (m != MATCH_YES)
+	{
+	  gfc_free_expr (all);
+	  return MATCH_ERROR;
+	}
+
+      total = gfc_or (all, e);
+      if (total == NULL)
+	{
+	  gfc_free_expr (all);
+	  gfc_free_expr (e);
+	  return MATCH_ERROR;
+	}
+
+      all = total;
+      all->where = where;
+    }
+
+  *result = all;
+  return MATCH_YES;
+}
+
+
+/* Match a level 5 expression.  */
+
+static match
+match_level_5 (gfc_expr **result)
+{
+  gfc_expr *all, *e, *total;
+  locus where;
+  match m;
+  gfc_intrinsic_op i;
+
+  m = match_equiv_operand (&all);
+  if (m != MATCH_YES)
+    return m;
+
+  for (;;)
+    {
+      if (next_operator (INTRINSIC_EQV))
+	i = INTRINSIC_EQV;
+      else
+	{
+	  if (next_operator (INTRINSIC_NEQV))
+	    i = INTRINSIC_NEQV;
+	  else
+	    break;
+	}
+
+      where = gfc_current_locus;
+
+      m = match_equiv_operand (&e);
+      if (m == MATCH_NO)
+	gfc_error (expression_syntax);
+      if (m != MATCH_YES)
+	{
+	  gfc_free_expr (all);
+	  return MATCH_ERROR;
+	}
+
+      if (i == INTRINSIC_EQV)
+	total = gfc_eqv (all, e);
+      else
+	total = gfc_neqv (all, e);
+
+      if (total == NULL)
+	{
+	  gfc_free_expr (all);
+	  gfc_free_expr (e);
+	  return MATCH_ERROR;
+	}
+
+      all = total;
+      all->where = where;
+    }
+
+  *result = all;
+  return MATCH_YES;
+}
+
+
+/* Match an expression.  At this level, we are stringing together
+   level 5 expressions separated by binary operators.  */
+
+match
+gfc_match_expr (gfc_expr **result)
+{
+  gfc_expr *all, *e;
+  gfc_user_op *uop;
+  locus where;
+  match m;
+
+  m = match_level_5 (&all);
+  if (m != MATCH_YES)
+    return m;
+
+  for (;;)
+    {
+      uop = NULL;
+      m = match_defined_operator (&uop);
+      if (m == MATCH_NO)
+	break;
+      if (m == MATCH_ERROR)
+	{
+	  gfc_free_expr (all);
+	  return MATCH_ERROR;
+	}
+
+      where = gfc_current_locus;
+
+      m = match_level_5 (&e);
+      if (m == MATCH_NO)
+	gfc_error (expression_syntax);
+      if (m != MATCH_YES)
+	{
+	  gfc_free_expr (all);
+	  return MATCH_ERROR;
+	}
+
+      all = gfc_get_operator_expr (&where, INTRINSIC_USER, all, e);
+      all->value.op.uop = uop;
+    }
+
+  *result = all;
+  return MATCH_YES;
+}
diff --git a/gcc-4.9/gcc/fortran/mathbuiltins.def b/gcc-4.9/gcc/fortran/mathbuiltins.def
new file mode 100644
index 000000000..d5bf60dab
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/mathbuiltins.def
@@ -0,0 +1,72 @@
+/* Copyright (C) 2004-2014 Free Software Foundation, Inc.
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+/* DEFINE_MATH_BUILTIN (CODE, NAME, ARGTYPE)
+   NAME	  The name of the builtin
+   SNAME  The name of the builtin as a string
+   ARGTYPE The type of the arguments.  See f95-lang.c
+
+   Use DEFINE_MATH_BUILTIN_C if the complex versions of the builtin are
+   also available.  */
+DEFINE_MATH_BUILTIN_C (ACOS,  "acos",   0)
+DEFINE_MATH_BUILTIN_C (ACOSH, "acosh",  0)
+DEFINE_MATH_BUILTIN_C (ASIN,  "asin",   0)
+DEFINE_MATH_BUILTIN_C (ASINH, "asinh",  0)
+DEFINE_MATH_BUILTIN_C (ATAN,  "atan",   0)
+DEFINE_MATH_BUILTIN_C (ATANH, "atanh",  0)
+DEFINE_MATH_BUILTIN   (ATAN2, "atan2",  1)
+DEFINE_MATH_BUILTIN_C (COS,   "cos",    0)
+DEFINE_MATH_BUILTIN_C (COSH,  "cosh",   0)
+DEFINE_MATH_BUILTIN_C (EXP,   "exp",    0)
+DEFINE_MATH_BUILTIN_C (LOG,   "log",    0)
+DEFINE_MATH_BUILTIN_C (LOG10, "log10",  0)
+DEFINE_MATH_BUILTIN_C (SIN,   "sin",    0)
+DEFINE_MATH_BUILTIN_C (SINH,  "sinh",   0)
+DEFINE_MATH_BUILTIN_C (SQRT,  "sqrt",   0)
+DEFINE_MATH_BUILTIN_C (TAN,   "tan",    0)
+DEFINE_MATH_BUILTIN_C (TANH,  "tanh",   0)
+DEFINE_MATH_BUILTIN   (J0,    "j0",     0)
+DEFINE_MATH_BUILTIN   (J1,    "j1",     0)
+DEFINE_MATH_BUILTIN   (JN,    "jn",     2)
+DEFINE_MATH_BUILTIN   (Y0,    "y0",     0)
+DEFINE_MATH_BUILTIN   (Y1,    "y1",     0)
+DEFINE_MATH_BUILTIN   (YN,    "yn",     2)
+DEFINE_MATH_BUILTIN   (ERF,   "erf",    0)
+DEFINE_MATH_BUILTIN   (ERFC,  "erfc",   0)
+DEFINE_MATH_BUILTIN   (TGAMMA,"tgamma", 0)
+DEFINE_MATH_BUILTIN   (LGAMMA,"lgamma", 0)
+DEFINE_MATH_BUILTIN   (HYPOT, "hypot",  1)
+
+/* OTHER_BUILTIN (CODE, NAME, PROTOTYPE_TYPE, CONST)
+   For floating-point builtins that do not directly correspond to a
+   Fortran intrinsic. This is used to map the different variants (float,
+   double and long double) and to build the quad-precision decls.  */
+OTHER_BUILTIN (CABS,      "cabs",      cabs,    true)
+OTHER_BUILTIN (COPYSIGN,  "copysign",  2,       true)
+OTHER_BUILTIN (CPOW,      "cpow",      cpow,    true)
+OTHER_BUILTIN (FABS,      "fabs",      1,       true)
+OTHER_BUILTIN (FMOD,      "fmod",      2,       true)
+OTHER_BUILTIN (FREXP,     "frexp",     frexp,   false)
+OTHER_BUILTIN (LLROUND,   "llround",   llround, true)
+OTHER_BUILTIN (LROUND,    "lround",    lround,  true)
+OTHER_BUILTIN (IROUND,    "iround",    iround,  true)
+OTHER_BUILTIN (NEXTAFTER, "nextafter", 2,       true)
+OTHER_BUILTIN (POW,       "pow",       1,       true)
+OTHER_BUILTIN (ROUND,     "round",     1,       true)
+OTHER_BUILTIN (SCALBN,    "scalbn",    scalbn,  true)
+OTHER_BUILTIN (TRUNC,     "trunc",     1,       true)
diff --git a/gcc-4.9/gcc/fortran/misc.c b/gcc-4.9/gcc/fortran/misc.c
new file mode 100644
index 000000000..3c0dfb459
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/misc.c
@@ -0,0 +1,276 @@
+/* Miscellaneous stuff that doesn't fit anywhere else.
+   Copyright (C) 2000-2014 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "gfortran.h"
+
+
+/* Initialize a typespec to unknown.  */
+
+void
+gfc_clear_ts (gfc_typespec *ts)
+{
+  ts->type = BT_UNKNOWN;
+  ts->u.derived = NULL;
+  ts->kind = 0;
+  ts->u.cl = NULL;
+  ts->interface = NULL;
+  /* flag that says if the type is C interoperable */
+  ts->is_c_interop = 0;
+  /* says what f90 type the C kind interops with */
+  ts->f90_type = BT_UNKNOWN;
+  /* flag that says whether it's from iso_c_binding or not */
+  ts->is_iso_c = 0;
+  ts->deferred = false;
+}
+
+
+/* Open a file for reading.  */
+
+FILE *
+gfc_open_file (const char *name)
+{
+  if (!*name)
+    return stdin;
+
+  return fopen (name, "r");
+}
+
+
+/* Return a string for each type.  */
+
+const char *
+gfc_basic_typename (bt type)
+{
+  const char *p;
+
+  switch (type)
+    {
+    case BT_INTEGER:
+      p = "INTEGER";
+      break;
+    case BT_REAL:
+      p = "REAL";
+      break;
+    case BT_COMPLEX:
+      p = "COMPLEX";
+      break;
+    case BT_LOGICAL:
+      p = "LOGICAL";
+      break;
+    case BT_CHARACTER:
+      p = "CHARACTER";
+      break;
+    case BT_HOLLERITH:
+      p = "HOLLERITH";
+      break;
+    case BT_DERIVED:
+      p = "DERIVED";
+      break;
+    case BT_CLASS:
+      p = "CLASS";
+      break;
+    case BT_PROCEDURE:
+      p = "PROCEDURE";
+      break;
+    case BT_VOID:
+      p = "VOID";
+      break;
+    case BT_UNKNOWN:
+      p = "UNKNOWN";
+      break;
+    case BT_ASSUMED:
+      p = "TYPE(*)";
+      break;
+    default:
+      gfc_internal_error ("gfc_basic_typename(): Undefined type");
+    }
+
+  return p;
+}
+
+
+/* Return a string describing the type and kind of a typespec.  Because
+   we return alternating buffers, this subroutine can appear twice in
+   the argument list of a single statement.  */
+
+const char *
+gfc_typename (gfc_typespec *ts)
+{
+  static char buffer1[GFC_MAX_SYMBOL_LEN + 7];  /* 7 for "TYPE()" + '\0'.  */
+  static char buffer2[GFC_MAX_SYMBOL_LEN + 7];
+  static int flag = 0;
+  char *buffer;
+
+  buffer = flag ? buffer1 : buffer2;
+  flag = !flag;
+
+  switch (ts->type)
+    {
+    case BT_INTEGER:
+      sprintf (buffer, "INTEGER(%d)", ts->kind);
+      break;
+    case BT_REAL:
+      sprintf (buffer, "REAL(%d)", ts->kind);
+      break;
+    case BT_COMPLEX:
+      sprintf (buffer, "COMPLEX(%d)", ts->kind);
+      break;
+    case BT_LOGICAL:
+      sprintf (buffer, "LOGICAL(%d)", ts->kind);
+      break;
+    case BT_CHARACTER:
+      sprintf (buffer, "CHARACTER(%d)", ts->kind);
+      break;
+    case BT_HOLLERITH:
+      sprintf (buffer, "HOLLERITH");
+      break;
+    case BT_DERIVED:
+      sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
+      break;
+    case BT_CLASS:
+      ts = &ts->u.derived->components->ts;
+      if (ts->u.derived->attr.unlimited_polymorphic)
+	sprintf (buffer, "CLASS(*)");
+      else
+	sprintf (buffer, "CLASS(%s)", ts->u.derived->name);
+      break;
+    case BT_ASSUMED:
+      sprintf (buffer, "TYPE(*)");
+      break;
+    case BT_PROCEDURE:
+      strcpy (buffer, "PROCEDURE");
+      break;
+    case BT_UNKNOWN:
+      strcpy (buffer, "UNKNOWN");
+      break;
+    default:
+      gfc_internal_error ("gfc_typename(): Undefined type");
+    }
+
+  return buffer;
+}
+
+
+/* Given an mstring array and a code, locate the code in the table,
+   returning a pointer to the string.  */
+
+const char *
+gfc_code2string (const mstring *m, int code)
+{
+  while (m->string != NULL)
+    {
+      if (m->tag == code)
+	return m->string;
+      m++;
+    }
+
+  gfc_internal_error ("gfc_code2string(): Bad code");
+  /* Not reached */
+}
+
+
+/* Given an mstring array and a string, returns the value of the tag
+   field.  Returns the final tag if no matches to the string are found.  */
+
+int
+gfc_string2code (const mstring *m, const char *string)
+{
+  for (; m->string != NULL; m++)
+    if (strcmp (m->string, string) == 0)
+      return m->tag;
+
+  return m->tag;
+}
+
+
+/* Convert an intent code to a string.  */
+/* TODO: move to gfortran.h as define.  */
+
+const char *
+gfc_intent_string (sym_intent i)
+{
+  return gfc_code2string (intents, i);
+}
+
+
+/***************** Initialization functions ****************/
+
+/* Top level initialization.  */
+
+void
+gfc_init_1 (void)
+{
+  gfc_error_init_1 ();
+  gfc_scanner_init_1 ();
+  gfc_arith_init_1 ();
+  gfc_intrinsic_init_1 ();
+}
+
+
+/* Per program unit initialization.  */
+
+void
+gfc_init_2 (void)
+{
+  gfc_symbol_init_2 ();
+  gfc_module_init_2 ();
+}
+
+
+/******************* Destructor functions ******************/
+
+/* Call all of the top level destructors.  */
+
+void
+gfc_done_1 (void)
+{
+  gfc_scanner_done_1 ();
+  gfc_intrinsic_done_1 ();
+  gfc_arith_done_1 ();
+}
+
+
+/* Per program unit destructors.  */
+
+void
+gfc_done_2 (void)
+{
+  gfc_symbol_done_2 ();
+  gfc_module_done_2 ();
+}
+
+
+/* Returns the index into the table of C interoperable kinds where the
+   kind with the given name (c_kind_name) was found.  */
+
+int
+get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
+{
+  int index = 0;
+
+  for (index = 0; index < ISOCBINDING_LAST; index++)
+    if (strcmp (kinds_table[index].name, c_kind_name) == 0)
+      return index;
+
+  return ISOCBINDING_INVALID;
+}
diff --git a/gcc-4.9/gcc/fortran/module.c b/gcc-4.9/gcc/fortran/module.c
new file mode 100644
index 000000000..52fdebe34
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/module.c
@@ -0,0 +1,6559 @@
+/* Handle modules, which amounts to loading and saving symbols and
+   their attendant structures.
+   Copyright (C) 2000-2014 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+/* The syntax of gfortran modules resembles that of lisp lists, i.e. a
+   sequence of atoms, which can be left or right parenthesis, names,
+   integers or strings.  Parenthesis are always matched which allows
+   us to skip over sections at high speed without having to know
+   anything about the internal structure of the lists.  A "name" is
+   usually a fortran 95 identifier, but can also start with '@' in
+   order to reference a hidden symbol.
+
+   The first line of a module is an informational message about what
+   created the module, the file it came from and when it was created.
+   The second line is a warning for people not to edit the module.
+   The rest of the module looks like:
+
+   ( ( <Interface info for UPLUS> )
+     ( <Interface info for UMINUS> )
+     ...
+   )
+   ( ( <name of operator interface> <module of op interface> <i/f1> ... )
+     ...
+   )
+   ( ( <name of generic interface> <module of generic interface> <i/f1> ... )
+     ...
+   )
+   ( ( <common name> <symbol> <saved flag>)
+     ...
+   )
+
+   ( equivalence list )
+
+   ( <Symbol Number (in no particular order)>
+     <True name of symbol>
+     <Module name of symbol>
+     ( <symbol information> )
+     ...
+   )
+   ( <Symtree name>
+     <Ambiguous flag>
+     <Symbol number>
+     ...
+   )
+
+   In general, symbols refer to other symbols by their symbol number,
+   which are zero based.  Symbols are written to the module in no
+   particular order.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "gfortran.h"
+#include "arith.h"
+#include "match.h"
+#include "parse.h" /* FIXME */
+#include "constructor.h"
+#include "cpp.h"
+#include "tree.h"
+#include "stringpool.h"
+#include "scanner.h"
+#include <zlib.h>
+
+#define MODULE_EXTENSION ".mod"
+
+/* Don't put any single quote (') in MOD_VERSION, if you want it to be
+   recognized.  */
+#define MOD_VERSION "12"
+
+
+/* Structure that describes a position within a module file.  */
+
+typedef struct
+{
+  int column, line;
+  long pos;
+}
+module_locus;
+
+/* Structure for list of symbols of intrinsic modules.  */
+typedef struct
+{
+  int id;
+  const char *name;
+  int value;
+  int standard;
+}
+intmod_sym;
+
+
+typedef enum
+{
+  P_UNKNOWN = 0, P_OTHER, P_NAMESPACE, P_COMPONENT, P_SYMBOL
+}
+pointer_t;
+
+/* The fixup structure lists pointers to pointers that have to
+   be updated when a pointer value becomes known.  */
+
+typedef struct fixup_t
+{
+  void **pointer;
+  struct fixup_t *next;
+}
+fixup_t;
+
+
+/* Structure for holding extra info needed for pointers being read.  */
+
+enum gfc_rsym_state
+{
+  UNUSED,
+  NEEDED,
+  USED
+};
+
+enum gfc_wsym_state
+{
+  UNREFERENCED = 0,
+  NEEDS_WRITE,
+  WRITTEN
+};
+
+typedef struct pointer_info
+{
+  BBT_HEADER (pointer_info);
+  int integer;
+  pointer_t type;
+
+  /* The first component of each member of the union is the pointer
+     being stored.  */
+
+  fixup_t *fixup;
+
+  union
+  {
+    void *pointer;	/* Member for doing pointer searches.  */
+
+    struct
+    {
+      gfc_symbol *sym;
+      char *true_name, *module, *binding_label;
+      fixup_t *stfixup;
+      gfc_symtree *symtree;
+      enum gfc_rsym_state state;
+      int ns, referenced, renamed;
+      module_locus where;
+    }
+    rsym;
+
+    struct
+    {
+      gfc_symbol *sym;
+      enum gfc_wsym_state state;
+    }
+    wsym;
+  }
+  u;
+
+}
+pointer_info;
+
+#define gfc_get_pointer_info() XCNEW (pointer_info)
+
+
+/* Local variables */
+
+/* The gzFile for the module we're reading or writing.  */
+static gzFile module_fp;
+
+
+/* The name of the module we're reading (USE'ing) or writing.  */
+static const char *module_name;
+static gfc_use_list *module_list;
+
+/* Content of module.  */
+static char* module_content;
+
+static long module_pos;
+static int module_line, module_column, only_flag;
+static int prev_module_line, prev_module_column;
+
+static enum
+{ IO_INPUT, IO_OUTPUT }
+iomode;
+
+static gfc_use_rename *gfc_rename_list;
+static pointer_info *pi_root;
+static int symbol_number;	/* Counter for assigning symbol numbers */
+
+/* Tells mio_expr_ref to make symbols for unused equivalence members.  */
+static bool in_load_equiv;
+
+
+
+/*****************************************************************/
+
+/* Pointer/integer conversion.  Pointers between structures are stored
+   as integers in the module file.  The next couple of subroutines
+   handle this translation for reading and writing.  */
+
+/* Recursively free the tree of pointer structures.  */
+
+static void
+free_pi_tree (pointer_info *p)
+{
+  if (p == NULL)
+    return;
+
+  if (p->fixup != NULL)
+    gfc_internal_error ("free_pi_tree(): Unresolved fixup");
+
+  free_pi_tree (p->left);
+  free_pi_tree (p->right);
+
+  if (iomode == IO_INPUT)
+    {
+      XDELETEVEC (p->u.rsym.true_name);
+      XDELETEVEC (p->u.rsym.module);
+      XDELETEVEC (p->u.rsym.binding_label);
+    }
+
+  free (p);
+}
+
+
+/* Compare pointers when searching by pointer.  Used when writing a
+   module.  */
+
+static int
+compare_pointers (void *_sn1, void *_sn2)
+{
+  pointer_info *sn1, *sn2;
+
+  sn1 = (pointer_info *) _sn1;
+  sn2 = (pointer_info *) _sn2;
+
+  if (sn1->u.pointer < sn2->u.pointer)
+    return -1;
+  if (sn1->u.pointer > sn2->u.pointer)
+    return 1;
+
+  return 0;
+}
+
+
+/* Compare integers when searching by integer.  Used when reading a
+   module.  */
+
+static int
+compare_integers (void *_sn1, void *_sn2)
+{
+  pointer_info *sn1, *sn2;
+
+  sn1 = (pointer_info *) _sn1;
+  sn2 = (pointer_info *) _sn2;
+
+  if (sn1->integer < sn2->integer)
+    return -1;
+  if (sn1->integer > sn2->integer)
+    return 1;
+
+  return 0;
+}
+
+
+/* Initialize the pointer_info tree.  */
+
+static void
+init_pi_tree (void)
+{
+  compare_fn compare;
+  pointer_info *p;
+
+  pi_root = NULL;
+  compare = (iomode == IO_INPUT) ? compare_integers : compare_pointers;
+
+  /* Pointer 0 is the NULL pointer.  */
+  p = gfc_get_pointer_info ();
+  p->u.pointer = NULL;
+  p->integer = 0;
+  p->type = P_OTHER;
+
+  gfc_insert_bbt (&pi_root, p, compare);
+
+  /* Pointer 1 is the current namespace.  */
+  p = gfc_get_pointer_info ();
+  p->u.pointer = gfc_current_ns;
+  p->integer = 1;
+  p->type = P_NAMESPACE;
+
+  gfc_insert_bbt (&pi_root, p, compare);
+
+  symbol_number = 2;
+}
+
+
+/* During module writing, call here with a pointer to something,
+   returning the pointer_info node.  */
+
+static pointer_info *
+find_pointer (void *gp)
+{
+  pointer_info *p;
+
+  p = pi_root;
+  while (p != NULL)
+    {
+      if (p->u.pointer == gp)
+	break;
+      p = (gp < p->u.pointer) ? p->left : p->right;
+    }
+
+  return p;
+}
+
+
+/* Given a pointer while writing, returns the pointer_info tree node,
+   creating it if it doesn't exist.  */
+
+static pointer_info *
+get_pointer (void *gp)
+{
+  pointer_info *p;
+
+  p = find_pointer (gp);
+  if (p != NULL)
+    return p;
+
+  /* Pointer doesn't have an integer.  Give it one.  */
+  p = gfc_get_pointer_info ();
+
+  p->u.pointer = gp;
+  p->integer = symbol_number++;
+
+  gfc_insert_bbt (&pi_root, p, compare_pointers);
+
+  return p;
+}
+
+
+/* Given an integer during reading, find it in the pointer_info tree,
+   creating the node if not found.  */
+
+static pointer_info *
+get_integer (int integer)
+{
+  pointer_info *p, t;
+  int c;
+
+  t.integer = integer;
+
+  p = pi_root;
+  while (p != NULL)
+    {
+      c = compare_integers (&t, p);
+      if (c == 0)
+	break;
+
+      p = (c < 0) ? p->left : p->right;
+    }
+
+  if (p != NULL)
+    return p;
+
+  p = gfc_get_pointer_info ();
+  p->integer = integer;
+  p->u.pointer = NULL;
+
+  gfc_insert_bbt (&pi_root, p, compare_integers);
+
+  return p;
+}
+
+
+/* Resolve any fixups using a known pointer.  */
+
+static void
+resolve_fixups (fixup_t *f, void *gp)
+{
+  fixup_t *next;
+
+  for (; f; f = next)
+    {
+      next = f->next;
+      *(f->pointer) = gp;
+      free (f);
+    }
+}
+
+
+/* Convert a string such that it starts with a lower-case character. Used
+   to convert the symtree name of a derived-type to the symbol name or to
+   the name of the associated generic function.  */
+
+static const char *
+dt_lower_string (const char *name)
+{
+  if (name[0] != (char) TOLOWER ((unsigned char) name[0]))
+    return gfc_get_string ("%c%s", (char) TOLOWER ((unsigned char) name[0]),
+			   &name[1]);
+  return gfc_get_string (name);
+}
+
+
+/* Convert a string such that it starts with an upper-case character. Used to
+   return the symtree-name for a derived type; the symbol name itself and the
+   symtree/symbol name of the associated generic function start with a lower-
+   case character.  */
+
+static const char *
+dt_upper_string (const char *name)
+{
+  if (name[0] != (char) TOUPPER ((unsigned char) name[0]))
+    return gfc_get_string ("%c%s", (char) TOUPPER ((unsigned char) name[0]),
+			   &name[1]);
+  return gfc_get_string (name);
+}
+
+/* Call here during module reading when we know what pointer to
+   associate with an integer.  Any fixups that exist are resolved at
+   this time.  */
+
+static void
+associate_integer_pointer (pointer_info *p, void *gp)
+{
+  if (p->u.pointer != NULL)
+    gfc_internal_error ("associate_integer_pointer(): Already associated");
+
+  p->u.pointer = gp;
+
+  resolve_fixups (p->fixup, gp);
+
+  p->fixup = NULL;
+}
+
+
+/* During module reading, given an integer and a pointer to a pointer,
+   either store the pointer from an already-known value or create a
+   fixup structure in order to store things later.  Returns zero if
+   the reference has been actually stored, or nonzero if the reference
+   must be fixed later (i.e., associate_integer_pointer must be called
+   sometime later.  Returns the pointer_info structure.  */
+
+static pointer_info *
+add_fixup (int integer, void *gp)
+{
+  pointer_info *p;
+  fixup_t *f;
+  char **cp;
+
+  p = get_integer (integer);
+
+  if (p->integer == 0 || p->u.pointer != NULL)
+    {
+      cp = (char **) gp;
+      *cp = (char *) p->u.pointer;
+    }
+  else
+    {
+      f = XCNEW (fixup_t);
+
+      f->next = p->fixup;
+      p->fixup = f;
+
+      f->pointer = (void **) gp;
+    }
+
+  return p;
+}
+
+
+/*****************************************************************/
+
+/* Parser related subroutines */
+
+/* Free the rename list left behind by a USE statement.  */
+
+static void
+free_rename (gfc_use_rename *list)
+{
+  gfc_use_rename *next;
+
+  for (; list; list = next)
+    {
+      next = list->next;
+      free (list);
+    }
+}
+
+
+/* Match a USE statement.  */
+
+match
+gfc_match_use (void)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1], module_nature[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_use_rename *tail = NULL, *new_use;
+  interface_type type, type2;
+  gfc_intrinsic_op op;
+  match m;
+  gfc_use_list *use_list;
+ 
+  use_list = gfc_get_use_list ();
+  
+  if (gfc_match (" , ") == MATCH_YES)
+    {
+      if ((m = gfc_match (" %n ::", module_nature)) == MATCH_YES)
+	{
+	  if (!gfc_notify_std (GFC_STD_F2003, "module "
+			       "nature in USE statement at %C"))
+	    goto cleanup;
+
+	  if (strcmp (module_nature, "intrinsic") == 0)
+	    use_list->intrinsic = true;
+	  else
+	    {
+	      if (strcmp (module_nature, "non_intrinsic") == 0)
+		use_list->non_intrinsic = true;
+	      else
+		{
+		  gfc_error ("Module nature in USE statement at %C shall "
+			     "be either INTRINSIC or NON_INTRINSIC");
+		  goto cleanup;
+		}
+	    }
+	}
+      else
+	{
+	  /* Help output a better error message than "Unclassifiable
+	     statement".  */
+	  gfc_match (" %n", module_nature);
+	  if (strcmp (module_nature, "intrinsic") == 0
+	      || strcmp (module_nature, "non_intrinsic") == 0)
+	    gfc_error ("\"::\" was expected after module nature at %C "
+		       "but was not found");
+	  free (use_list);
+	  return m;
+	}
+    }
+  else
+    {
+      m = gfc_match (" ::");
+      if (m == MATCH_YES &&
+	  !gfc_notify_std(GFC_STD_F2003, "\"USE :: module\" at %C"))
+	goto cleanup;
+
+      if (m != MATCH_YES)
+	{
+	  m = gfc_match ("% ");
+	  if (m != MATCH_YES)
+	    {
+	      free (use_list);
+	      return m;
+	    }
+	}
+    }
+
+  use_list->where = gfc_current_locus;
+
+  m = gfc_match_name (name);
+  if (m != MATCH_YES)
+    {
+      free (use_list);
+      return m;
+    }
+
+  use_list->module_name = gfc_get_string (name);
+
+  if (gfc_match_eos () == MATCH_YES)
+    goto done;
+
+  if (gfc_match_char (',') != MATCH_YES)
+    goto syntax;
+
+  if (gfc_match (" only :") == MATCH_YES)
+    use_list->only_flag = true;
+
+  if (gfc_match_eos () == MATCH_YES)
+    goto done;
+
+  for (;;)
+    {
+      /* Get a new rename struct and add it to the rename list.  */
+      new_use = gfc_get_use_rename ();
+      new_use->where = gfc_current_locus;
+      new_use->found = 0;
+
+      if (use_list->rename == NULL)
+	use_list->rename = new_use;
+      else
+	tail->next = new_use;
+      tail = new_use;
+
+      /* See what kind of interface we're dealing with.  Assume it is
+	 not an operator.  */
+      new_use->op = INTRINSIC_NONE;
+      if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR)
+	goto cleanup;
+
+      switch (type)
+	{
+	case INTERFACE_NAMELESS:
+	  gfc_error ("Missing generic specification in USE statement at %C");
+	  goto cleanup;
+
+	case INTERFACE_USER_OP:
+	case INTERFACE_GENERIC:
+	  m = gfc_match (" =>");
+
+	  if (type == INTERFACE_USER_OP && m == MATCH_YES
+	      && (!gfc_notify_std(GFC_STD_F2003, "Renaming "
+				  "operators in USE statements at %C")))
+	    goto cleanup;
+
+	  if (type == INTERFACE_USER_OP)
+	    new_use->op = INTRINSIC_USER;
+
+	  if (use_list->only_flag)
+	    {
+	      if (m != MATCH_YES)
+		strcpy (new_use->use_name, name);
+	      else
+		{
+		  strcpy (new_use->local_name, name);
+		  m = gfc_match_generic_spec (&type2, new_use->use_name, &op);
+		  if (type != type2)
+		    goto syntax;
+		  if (m == MATCH_NO)
+		    goto syntax;
+		  if (m == MATCH_ERROR)
+		    goto cleanup;
+		}
+	    }
+	  else
+	    {
+	      if (m != MATCH_YES)
+		goto syntax;
+	      strcpy (new_use->local_name, name);
+
+	      m = gfc_match_generic_spec (&type2, new_use->use_name, &op);
+	      if (type != type2)
+		goto syntax;
+	      if (m == MATCH_NO)
+		goto syntax;
+	      if (m == MATCH_ERROR)
+		goto cleanup;
+	    }
+
+	  if (strcmp (new_use->use_name, use_list->module_name) == 0
+	      || strcmp (new_use->local_name, use_list->module_name) == 0)
+	    {
+	      gfc_error ("The name '%s' at %C has already been used as "
+			 "an external module name.", use_list->module_name);
+	      goto cleanup;
+	    }
+	  break;
+
+	case INTERFACE_INTRINSIC_OP:
+	  new_use->op = op;
+	  break;
+
+	default:
+	  gcc_unreachable ();
+	}
+
+      if (gfc_match_eos () == MATCH_YES)
+	break;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+    }
+
+done:
+  if (module_list)
+    {
+      gfc_use_list *last = module_list;
+      while (last->next)
+	last = last->next;
+      last->next = use_list;
+    }
+  else
+    module_list = use_list;
+
+  return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (ST_USE);
+
+cleanup:
+  free_rename (use_list->rename);
+  free (use_list);
+  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
+   the number of instances of this name. If interface is
+   true, a user-defined operator is sought, otherwise only
+   non-operators are sought.  */
+
+static const char *
+find_use_name_n (const char *name, int *inst, bool interface)
+{
+  gfc_use_rename *u;
+  const char *low_name = NULL;
+  int i;
+
+  /* For derived types.  */
+  if (name[0] != (char) TOLOWER ((unsigned char) name[0]))
+    low_name = dt_lower_string (name);
+
+  i = 0;
+  for (u = gfc_rename_list; u; u = u->next)
+    {
+      if ((!low_name && strcmp (u->use_name, name) != 0)
+	  || (low_name && strcmp (u->use_name, low_name) != 0)
+	  || (u->op == INTRINSIC_USER && !interface)
+	  || (u->op != INTRINSIC_USER &&  interface))
+	continue;
+      if (++i == *inst)
+	break;
+    }
+
+  if (!*inst)
+    {
+      *inst = i;
+      return NULL;
+    }
+
+  if (u == NULL)
+    return only_flag ? NULL : name;
+
+  u->found = 1;
+
+  if (low_name)
+    {
+      if (u->local_name[0] == '\0')
+	return name;
+      return dt_upper_string (u->local_name);
+    }
+
+  return (u->local_name[0] != '\0') ? u->local_name : name;
+}
+
+
+/* Given a name, return the name under which to load this symbol.
+   Returns NULL if this symbol shouldn't be loaded.  */
+
+static const char *
+find_use_name (const char *name, bool interface)
+{
+  int i = 1;
+  return find_use_name_n (name, &i, interface);
+}
+
+
+/* Given a real name, return the number of use names associated with it.  */
+
+static int
+number_use_names (const char *name, bool interface)
+{
+  int i = 0;
+  find_use_name_n (name, &i, interface);
+  return i;
+}
+
+
+/* Try to find the operator in the current list.  */
+
+static gfc_use_rename *
+find_use_operator (gfc_intrinsic_op op)
+{
+  gfc_use_rename *u;
+
+  for (u = gfc_rename_list; u; u = u->next)
+    if (u->op == op)
+      return u;
+
+  return NULL;
+}
+
+
+/*****************************************************************/
+
+/* The next couple of subroutines maintain a tree used to avoid a
+   brute-force search for a combination of true name and module name.
+   While symtree names, the name that a particular symbol is known by
+   can changed with USE statements, we still have to keep track of the
+   true names to generate the correct reference, and also avoid
+   loading the same real symbol twice in a program unit.
+
+   When we start reading, the true name tree is built and maintained
+   as symbols are read.  The tree is searched as we load new symbols
+   to see if it already exists someplace in the namespace.  */
+
+typedef struct true_name
+{
+  BBT_HEADER (true_name);
+  const char *name;
+  gfc_symbol *sym;
+}
+true_name;
+
+static true_name *true_name_root;
+
+
+/* Compare two true_name structures.  */
+
+static int
+compare_true_names (void *_t1, void *_t2)
+{
+  true_name *t1, *t2;
+  int c;
+
+  t1 = (true_name *) _t1;
+  t2 = (true_name *) _t2;
+
+  c = ((t1->sym->module > t2->sym->module)
+       - (t1->sym->module < t2->sym->module));
+  if (c != 0)
+    return c;
+
+  return strcmp (t1->name, t2->name);
+}
+
+
+/* Given a true name, search the true name tree to see if it exists
+   within the main namespace.  */
+
+static gfc_symbol *
+find_true_name (const char *name, const char *module)
+{
+  true_name t, *p;
+  gfc_symbol sym;
+  int c;
+
+  t.name = gfc_get_string (name);
+  if (module != NULL)
+    sym.module = gfc_get_string (module);
+  else
+    sym.module = NULL;
+  t.sym = &sym;
+
+  p = true_name_root;
+  while (p != NULL)
+    {
+      c = compare_true_names ((void *) (&t), (void *) p);
+      if (c == 0)
+	return p->sym;
+
+      p = (c < 0) ? p->left : p->right;
+    }
+
+  return NULL;
+}
+
+
+/* Given a gfc_symbol pointer that is not in the true name tree, add it.  */
+
+static void
+add_true_name (gfc_symbol *sym)
+{
+  true_name *t;
+
+  t = XCNEW (true_name);
+  t->sym = sym;
+  if (sym->attr.flavor == FL_DERIVED)
+    t->name = dt_upper_string (sym->name);
+  else
+    t->name = sym->name;
+
+  gfc_insert_bbt (&true_name_root, t, compare_true_names);
+}
+
+
+/* Recursive function to build the initial true name tree by
+   recursively traversing the current namespace.  */
+
+static void
+build_tnt (gfc_symtree *st)
+{
+  const char *name;
+  if (st == NULL)
+    return;
+
+  build_tnt (st->left);
+  build_tnt (st->right);
+
+  if (st->n.sym->attr.flavor == FL_DERIVED)
+    name = dt_upper_string (st->n.sym->name);
+  else
+    name = st->n.sym->name;
+
+  if (find_true_name (name, st->n.sym->module) != NULL)
+    return;
+
+  add_true_name (st->n.sym);
+}
+
+
+/* Initialize the true name tree with the current namespace.  */
+
+static void
+init_true_name_tree (void)
+{
+  true_name_root = NULL;
+  build_tnt (gfc_current_ns->sym_root);
+}
+
+
+/* Recursively free a true name tree node.  */
+
+static void
+free_true_name (true_name *t)
+{
+  if (t == NULL)
+    return;
+  free_true_name (t->left);
+  free_true_name (t->right);
+
+  free (t);
+}
+
+
+/*****************************************************************/
+
+/* Module reading and writing.  */
+
+/* The following are versions similar to the ones in scanner.c, but
+   for dealing with compressed module files.  */
+
+static gzFile
+gzopen_included_file_1 (const char *name, gfc_directorylist *list,
+                     bool module, bool system)
+{
+  char *fullname;
+  gfc_directorylist *p;
+  gzFile f;
+
+  for (p = list; p; p = p->next)
+    {
+      if (module && !p->use_for_modules)
+       continue;
+
+      fullname = (char *) alloca(strlen (p->path) + strlen (name) + 1);
+      strcpy (fullname, p->path);
+      strcat (fullname, name);
+
+      f = gzopen (fullname, "r");
+      if (f != NULL)
+       {
+         if (gfc_cpp_makedep ())
+           gfc_cpp_add_dep (fullname, system);
+
+         return f;
+       }
+    }
+
+  return NULL;
+}
+
+static gzFile 
+gzopen_included_file (const char *name, bool include_cwd, bool module)
+{
+  gzFile f = NULL;
+
+  if (IS_ABSOLUTE_PATH (name) || include_cwd)
+    {
+      f = gzopen (name, "r");
+      if (f && gfc_cpp_makedep ())
+       gfc_cpp_add_dep (name, false);
+    }
+
+  if (!f)
+    f = gzopen_included_file_1 (name, include_dirs, module, false);
+
+  return f;
+}
+
+static gzFile
+gzopen_intrinsic_module (const char* name)
+{
+  gzFile f = NULL;
+
+  if (IS_ABSOLUTE_PATH (name))
+    {
+      f = gzopen (name, "r");
+      if (f && gfc_cpp_makedep ())
+        gfc_cpp_add_dep (name, true);
+    }
+
+  if (!f)
+    f = gzopen_included_file_1 (name, intrinsic_modules_dirs, true, true);
+
+  return f;
+}
+
+
+typedef enum
+{
+  ATOM_NAME, ATOM_LPAREN, ATOM_RPAREN, ATOM_INTEGER, ATOM_STRING
+}
+atom_type;
+
+static atom_type last_atom;
+
+
+/* The name buffer must be at least as long as a symbol name.  Right
+   now it's not clear how we're going to store numeric constants--
+   probably as a hexadecimal string, since this will allow the exact
+   number to be preserved (this can't be done by a decimal
+   representation).  Worry about that later.  TODO!  */
+
+#define MAX_ATOM_SIZE 100
+
+static int atom_int;
+static char *atom_string, atom_name[MAX_ATOM_SIZE];
+
+
+/* Report problems with a module.  Error reporting is not very
+   elaborate, since this sorts of errors shouldn't really happen.
+   This subroutine never returns.  */
+
+static void bad_module (const char *) ATTRIBUTE_NORETURN;
+
+static void
+bad_module (const char *msgid)
+{
+  XDELETEVEC (module_content);
+  module_content = NULL;
+
+  switch (iomode)
+    {
+    case IO_INPUT:
+      gfc_fatal_error ("Reading module %s at line %d column %d: %s",
+	  	       module_name, module_line, module_column, msgid);
+      break;
+    case IO_OUTPUT:
+      gfc_fatal_error ("Writing module %s at line %d column %d: %s",
+	  	       module_name, module_line, module_column, msgid);
+      break;
+    default:
+      gfc_fatal_error ("Module %s at line %d column %d: %s",
+	  	       module_name, module_line, module_column, msgid);
+      break;
+    }
+}
+
+
+/* Set the module's input pointer.  */
+
+static void
+set_module_locus (module_locus *m)
+{
+  module_column = m->column;
+  module_line = m->line;
+  module_pos = m->pos;
+}
+
+
+/* Get the module's input pointer so that we can restore it later.  */
+
+static void
+get_module_locus (module_locus *m)
+{
+  m->column = module_column;
+  m->line = module_line;
+  m->pos = module_pos;
+}
+
+
+/* Get the next character in the module, updating our reckoning of
+   where we are.  */
+
+static int
+module_char (void)
+{
+  const char c = module_content[module_pos++];
+  if (c == '\0')
+    bad_module ("Unexpected EOF");
+
+  prev_module_line = module_line;
+  prev_module_column = module_column;
+
+  if (c == '\n')
+    {
+      module_line++;
+      module_column = 0;
+    }
+
+  module_column++;
+  return c;
+}
+
+/* Unget a character while remembering the line and column.  Works for
+   a single character only.  */
+
+static void
+module_unget_char (void)
+{
+  module_line = prev_module_line;
+  module_column = prev_module_column;
+  module_pos--;
+}
+
+/* Parse a string constant.  The delimiter is guaranteed to be a
+   single quote.  */
+
+static void
+parse_string (void)
+{
+  int c;
+  size_t cursz = 30;
+  size_t len = 0;
+
+  atom_string = XNEWVEC (char, cursz);
+
+  for ( ; ; )
+    {
+      c = module_char ();
+
+      if (c == '\'')
+	{
+	  int c2 = module_char ();
+	  if (c2 != '\'')
+	    {
+	      module_unget_char ();
+	      break;
+	    }
+	}
+
+      if (len >= cursz)
+	{
+	  cursz *= 2;
+	  atom_string = XRESIZEVEC (char, atom_string, cursz);
+	}
+      atom_string[len] = c;
+      len++;
+    }
+
+  atom_string = XRESIZEVEC (char, atom_string, len + 1);
+  atom_string[len] = '\0'; 	/* C-style string for debug purposes.  */
+}
+
+
+/* Parse a small integer.  */
+
+static void
+parse_integer (int c)
+{
+  atom_int = c - '0';
+
+  for (;;)
+    {
+      c = module_char ();
+      if (!ISDIGIT (c))
+	{
+	  module_unget_char ();
+	  break;
+	}
+
+      atom_int = 10 * atom_int + c - '0';
+      if (atom_int > 99999999)
+	bad_module ("Integer overflow");
+    }
+
+}
+
+
+/* Parse a name.  */
+
+static void
+parse_name (int c)
+{
+  char *p;
+  int len;
+
+  p = atom_name;
+
+  *p++ = c;
+  len = 1;
+
+  for (;;)
+    {
+      c = module_char ();
+      if (!ISALNUM (c) && c != '_' && c != '-')
+	{
+	  module_unget_char ();
+	  break;
+	}
+
+      *p++ = c;
+      if (++len > GFC_MAX_SYMBOL_LEN)
+	bad_module ("Name too long");
+    }
+
+  *p = '\0';
+
+}
+
+
+/* Read the next atom in the module's input stream.  */
+
+static atom_type
+parse_atom (void)
+{
+  int c;
+
+  do
+    {
+      c = module_char ();
+    }
+  while (c == ' ' || c == '\r' || c == '\n');
+
+  switch (c)
+    {
+    case '(':
+      return ATOM_LPAREN;
+
+    case ')':
+      return ATOM_RPAREN;
+
+    case '\'':
+      parse_string ();
+      return ATOM_STRING;
+
+    case '0':
+    case '1':
+    case '2':
+    case '3':
+    case '4':
+    case '5':
+    case '6':
+    case '7':
+    case '8':
+    case '9':
+      parse_integer (c);
+      return ATOM_INTEGER;
+
+    case 'a':
+    case 'b':
+    case 'c':
+    case 'd':
+    case 'e':
+    case 'f':
+    case 'g':
+    case 'h':
+    case 'i':
+    case 'j':
+    case 'k':
+    case 'l':
+    case 'm':
+    case 'n':
+    case 'o':
+    case 'p':
+    case 'q':
+    case 'r':
+    case 's':
+    case 't':
+    case 'u':
+    case 'v':
+    case 'w':
+    case 'x':
+    case 'y':
+    case 'z':
+    case 'A':
+    case 'B':
+    case 'C':
+    case 'D':
+    case 'E':
+    case 'F':
+    case 'G':
+    case 'H':
+    case 'I':
+    case 'J':
+    case 'K':
+    case 'L':
+    case 'M':
+    case 'N':
+    case 'O':
+    case 'P':
+    case 'Q':
+    case 'R':
+    case 'S':
+    case 'T':
+    case 'U':
+    case 'V':
+    case 'W':
+    case 'X':
+    case 'Y':
+    case 'Z':
+      parse_name (c);
+      return ATOM_NAME;
+
+    default:
+      bad_module ("Bad name");
+    }
+
+  /* Not reached.  */
+}
+
+
+/* Peek at the next atom on the input.  */
+
+static atom_type
+peek_atom (void)
+{
+  int c;
+
+  do
+    {
+      c = module_char ();
+    }
+  while (c == ' ' || c == '\r' || c == '\n');
+
+  switch (c)
+    {
+    case '(':
+      module_unget_char ();
+      return ATOM_LPAREN;
+
+    case ')':
+      module_unget_char ();
+      return ATOM_RPAREN;
+
+    case '\'':
+      module_unget_char ();
+      return ATOM_STRING;
+
+    case '0':
+    case '1':
+    case '2':
+    case '3':
+    case '4':
+    case '5':
+    case '6':
+    case '7':
+    case '8':
+    case '9':
+      module_unget_char ();
+      return ATOM_INTEGER;
+
+    case 'a':
+    case 'b':
+    case 'c':
+    case 'd':
+    case 'e':
+    case 'f':
+    case 'g':
+    case 'h':
+    case 'i':
+    case 'j':
+    case 'k':
+    case 'l':
+    case 'm':
+    case 'n':
+    case 'o':
+    case 'p':
+    case 'q':
+    case 'r':
+    case 's':
+    case 't':
+    case 'u':
+    case 'v':
+    case 'w':
+    case 'x':
+    case 'y':
+    case 'z':
+    case 'A':
+    case 'B':
+    case 'C':
+    case 'D':
+    case 'E':
+    case 'F':
+    case 'G':
+    case 'H':
+    case 'I':
+    case 'J':
+    case 'K':
+    case 'L':
+    case 'M':
+    case 'N':
+    case 'O':
+    case 'P':
+    case 'Q':
+    case 'R':
+    case 'S':
+    case 'T':
+    case 'U':
+    case 'V':
+    case 'W':
+    case 'X':
+    case 'Y':
+    case 'Z':
+      module_unget_char ();
+      return ATOM_NAME;
+
+    default:
+      bad_module ("Bad name");
+    }
+}
+
+
+/* Read the next atom from the input, requiring that it be a
+   particular kind.  */
+
+static void
+require_atom (atom_type type)
+{
+  atom_type t;
+  const char *p;
+  int column, line;
+
+  column = module_column;
+  line = module_line;
+
+  t = parse_atom ();
+  if (t != type)
+    {
+      switch (type)
+	{
+	case ATOM_NAME:
+	  p = _("Expected name");
+	  break;
+	case ATOM_LPAREN:
+	  p = _("Expected left parenthesis");
+	  break;
+	case ATOM_RPAREN:
+	  p = _("Expected right parenthesis");
+	  break;
+	case ATOM_INTEGER:
+	  p = _("Expected integer");
+	  break;
+	case ATOM_STRING:
+	  p = _("Expected string");
+	  break;
+	default:
+	  gfc_internal_error ("require_atom(): bad atom type required");
+	}
+
+      module_column = column;
+      module_line = line;
+      bad_module (p);
+    }
+}
+
+
+/* Given a pointer to an mstring array, require that the current input
+   be one of the strings in the array.  We return the enum value.  */
+
+static int
+find_enum (const mstring *m)
+{
+  int i;
+
+  i = gfc_string2code (m, atom_name);
+  if (i >= 0)
+    return i;
+
+  bad_module ("find_enum(): Enum not found");
+
+  /* Not reached.  */
+}
+
+
+/* Read a string. The caller is responsible for freeing.  */
+
+static char*
+read_string (void)
+{
+  char* p;
+  require_atom (ATOM_STRING);
+  p = atom_string;
+  atom_string = NULL;
+  return p;
+}
+
+
+/**************** Module output subroutines ***************************/
+
+/* Output a character to a module file.  */
+
+static void
+write_char (char out)
+{
+  if (gzputc (module_fp, out) == EOF)
+    gfc_fatal_error ("Error writing modules file: %s", xstrerror (errno));
+
+  if (out != '\n')
+    module_column++;
+  else
+    {
+      module_column = 1;
+      module_line++;
+    }
+}
+
+
+/* Write an atom to a module.  The line wrapping isn't perfect, but it
+   should work most of the time.  This isn't that big of a deal, since
+   the file really isn't meant to be read by people anyway.  */
+
+static void
+write_atom (atom_type atom, const void *v)
+{
+  char buffer[20];
+  int i, len;
+  const char *p;
+
+  switch (atom)
+    {
+    case ATOM_STRING:
+    case ATOM_NAME:
+      p = (const char *) v;
+      break;
+
+    case ATOM_LPAREN:
+      p = "(";
+      break;
+
+    case ATOM_RPAREN:
+      p = ")";
+      break;
+
+    case ATOM_INTEGER:
+      i = *((const int *) v);
+      if (i < 0)
+	gfc_internal_error ("write_atom(): Writing negative integer");
+
+      sprintf (buffer, "%d", i);
+      p = buffer;
+      break;
+
+    default:
+      gfc_internal_error ("write_atom(): Trying to write dab atom");
+
+    }
+
+  if(p == NULL || *p == '\0') 
+     len = 0;
+  else
+  len = strlen (p);
+
+  if (atom != ATOM_RPAREN)
+    {
+      if (module_column + len > 72)
+	write_char ('\n');
+      else
+	{
+
+	  if (last_atom != ATOM_LPAREN && module_column != 1)
+	    write_char (' ');
+	}
+    }
+
+  if (atom == ATOM_STRING)
+    write_char ('\'');
+
+  while (p != NULL && *p)
+    {
+      if (atom == ATOM_STRING && *p == '\'')
+	write_char ('\'');
+      write_char (*p++);
+    }
+
+  if (atom == ATOM_STRING)
+    write_char ('\'');
+
+  last_atom = atom;
+}
+
+
+
+/***************** Mid-level I/O subroutines *****************/
+
+/* These subroutines let their caller read or write atoms without
+   caring about which of the two is actually happening.  This lets a
+   subroutine concentrate on the actual format of the data being
+   written.  */
+
+static void mio_expr (gfc_expr **);
+pointer_info *mio_symbol_ref (gfc_symbol **);
+pointer_info *mio_interface_rest (gfc_interface **);
+static void mio_symtree_ref (gfc_symtree **);
+
+/* Read or write an enumerated value.  On writing, we return the input
+   value for the convenience of callers.  We avoid using an integer
+   pointer because enums are sometimes inside bitfields.  */
+
+static int
+mio_name (int t, const mstring *m)
+{
+  if (iomode == IO_OUTPUT)
+    write_atom (ATOM_NAME, gfc_code2string (m, t));
+  else
+    {
+      require_atom (ATOM_NAME);
+      t = find_enum (m);
+    }
+
+  return t;
+}
+
+/* Specialization of mio_name.  */
+
+#define DECL_MIO_NAME(TYPE) \
+ static inline TYPE \
+ MIO_NAME(TYPE) (TYPE t, const mstring *m) \
+ { \
+   return (TYPE) mio_name ((int) t, m); \
+ }
+#define MIO_NAME(TYPE) mio_name_##TYPE
+
+static void
+mio_lparen (void)
+{
+  if (iomode == IO_OUTPUT)
+    write_atom (ATOM_LPAREN, NULL);
+  else
+    require_atom (ATOM_LPAREN);
+}
+
+
+static void
+mio_rparen (void)
+{
+  if (iomode == IO_OUTPUT)
+    write_atom (ATOM_RPAREN, NULL);
+  else
+    require_atom (ATOM_RPAREN);
+}
+
+
+static void
+mio_integer (int *ip)
+{
+  if (iomode == IO_OUTPUT)
+    write_atom (ATOM_INTEGER, ip);
+  else
+    {
+      require_atom (ATOM_INTEGER);
+      *ip = atom_int;
+    }
+}
+
+
+/* Read or write a gfc_intrinsic_op value.  */
+
+static void
+mio_intrinsic_op (gfc_intrinsic_op* op)
+{
+  /* FIXME: Would be nicer to do this via the operators symbolic name.  */
+  if (iomode == IO_OUTPUT)
+    {
+      int converted = (int) *op;
+      write_atom (ATOM_INTEGER, &converted);
+    }
+  else
+    {
+      require_atom (ATOM_INTEGER);
+      *op = (gfc_intrinsic_op) atom_int;
+    }
+}
+
+
+/* Read or write a character pointer that points to a string on the heap.  */
+
+static const char *
+mio_allocated_string (const char *s)
+{
+  if (iomode == IO_OUTPUT)
+    {
+      write_atom (ATOM_STRING, s);
+      return s;
+    }
+  else
+    {
+      require_atom (ATOM_STRING);
+      return atom_string;
+    }
+}
+
+
+/* Functions for quoting and unquoting strings.  */
+
+static char *
+quote_string (const gfc_char_t *s, const size_t slength)
+{
+  const gfc_char_t *p;
+  char *res, *q;
+  size_t len = 0, i;
+
+  /* Calculate the length we'll need: a backslash takes two ("\\"),
+     non-printable characters take 10 ("\Uxxxxxxxx") and others take 1.  */
+  for (p = s, i = 0; i < slength; p++, i++)
+    {
+      if (*p == '\\')
+	len += 2;
+      else if (!gfc_wide_is_printable (*p))
+	len += 10;
+      else
+	len++;
+    }
+
+  q = res = XCNEWVEC (char, len + 1);
+  for (p = s, i = 0; i < slength; p++, i++)
+    {
+      if (*p == '\\')
+	*q++ = '\\', *q++ = '\\';
+      else if (!gfc_wide_is_printable (*p))
+	{
+	  sprintf (q, "\\U%08" HOST_WIDE_INT_PRINT "x",
+		   (unsigned HOST_WIDE_INT) *p);
+	  q += 10;
+	}
+      else
+	*q++ = (unsigned char) *p;
+    }
+
+  res[len] = '\0';
+  return res;
+}
+
+static gfc_char_t *
+unquote_string (const char *s)
+{
+  size_t len, i;
+  const char *p;
+  gfc_char_t *res;
+
+  for (p = s, len = 0; *p; p++, len++)
+    {
+      if (*p != '\\')
+	continue;
+	
+      if (p[1] == '\\')
+	p++;
+      else if (p[1] == 'U')
+	p += 9; /* That is a "\U????????". */
+      else
+	gfc_internal_error ("unquote_string(): got bad string");
+    }
+
+  res = gfc_get_wide_string (len + 1);
+  for (i = 0, p = s; i < len; i++, p++)
+    {
+      gcc_assert (*p);
+
+      if (*p != '\\')
+	res[i] = (unsigned char) *p;
+      else if (p[1] == '\\')
+	{
+	  res[i] = (unsigned char) '\\';
+	  p++;
+	}
+      else
+	{
+	  /* We read the 8-digits hexadecimal constant that follows.  */
+	  int j;
+	  unsigned n;
+	  gfc_char_t c = 0;
+
+	  gcc_assert (p[1] == 'U');
+	  for (j = 0; j < 8; j++)
+	    {
+	      c = c << 4;
+	      gcc_assert (sscanf (&p[j+2], "%01x", &n) == 1);
+	      c += n;
+	    }
+
+	  res[i] = c;
+	  p += 9;
+	}
+    }
+
+  res[len] = '\0';
+  return res;
+}
+
+
+/* Read or write a character pointer that points to a wide string on the
+   heap, performing quoting/unquoting of nonprintable characters using the
+   form \U???????? (where each ? is a hexadecimal digit).
+   Length is the length of the string, only known and used in output mode.  */
+
+static const gfc_char_t *
+mio_allocated_wide_string (const gfc_char_t *s, const size_t length)
+{
+  if (iomode == IO_OUTPUT)
+    {
+      char *quoted = quote_string (s, length);
+      write_atom (ATOM_STRING, quoted);
+      free (quoted);
+      return s;
+    }
+  else
+    {
+      gfc_char_t *unquoted;
+
+      require_atom (ATOM_STRING);
+      unquoted = unquote_string (atom_string);
+      free (atom_string);
+      return unquoted;
+    }
+}
+
+
+/* Read or write a string that is in static memory.  */
+
+static void
+mio_pool_string (const char **stringp)
+{
+  /* TODO: one could write the string only once, and refer to it via a
+     fixup pointer.  */
+
+  /* As a special case we have to deal with a NULL string.  This
+     happens for the 'module' member of 'gfc_symbol's that are not in a
+     module.  We read / write these as the empty string.  */
+  if (iomode == IO_OUTPUT)
+    {
+      const char *p = *stringp == NULL ? "" : *stringp;
+      write_atom (ATOM_STRING, p);
+    }
+  else
+    {
+      require_atom (ATOM_STRING);
+      *stringp = atom_string[0] == '\0' ? NULL : gfc_get_string (atom_string);
+      free (atom_string);
+    }
+}
+
+
+/* Read or write a string that is inside of some already-allocated
+   structure.  */
+
+static void
+mio_internal_string (char *string)
+{
+  if (iomode == IO_OUTPUT)
+    write_atom (ATOM_STRING, string);
+  else
+    {
+      require_atom (ATOM_STRING);
+      strcpy (string, atom_string);
+      free (atom_string);
+    }
+}
+
+
+typedef enum
+{ AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
+  AB_POINTER, AB_TARGET, AB_DUMMY, AB_RESULT, AB_DATA,
+  AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE,
+  AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
+  AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE,
+  AB_ALLOC_COMP, AB_POINTER_COMP, AB_PROC_POINTER_COMP, AB_PRIVATE_COMP,
+  AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_LOCK_COMP,
+  AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
+  AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
+  AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER,
+  AB_IMPLICIT_PURE, AB_ARTIFICIAL, AB_UNLIMITED_POLY
+}
+ab_attribute;
+
+static const mstring attr_bits[] =
+{
+    minit ("ALLOCATABLE", AB_ALLOCATABLE),
+    minit ("ARTIFICIAL", AB_ARTIFICIAL),
+    minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS),
+    minit ("DIMENSION", AB_DIMENSION),
+    minit ("CODIMENSION", AB_CODIMENSION),
+    minit ("CONTIGUOUS", AB_CONTIGUOUS),
+    minit ("EXTERNAL", AB_EXTERNAL),
+    minit ("INTRINSIC", AB_INTRINSIC),
+    minit ("OPTIONAL", AB_OPTIONAL),
+    minit ("POINTER", AB_POINTER),
+    minit ("VOLATILE", AB_VOLATILE),
+    minit ("TARGET", AB_TARGET),
+    minit ("THREADPRIVATE", AB_THREADPRIVATE),
+    minit ("DUMMY", AB_DUMMY),
+    minit ("RESULT", AB_RESULT),
+    minit ("DATA", AB_DATA),
+    minit ("IN_NAMELIST", AB_IN_NAMELIST),
+    minit ("IN_COMMON", AB_IN_COMMON),
+    minit ("FUNCTION", AB_FUNCTION),
+    minit ("SUBROUTINE", AB_SUBROUTINE),
+    minit ("SEQUENCE", AB_SEQUENCE),
+    minit ("ELEMENTAL", AB_ELEMENTAL),
+    minit ("PURE", AB_PURE),
+    minit ("RECURSIVE", AB_RECURSIVE),
+    minit ("GENERIC", AB_GENERIC),
+    minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
+    minit ("CRAY_POINTER", AB_CRAY_POINTER),
+    minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
+    minit ("IS_BIND_C", AB_IS_BIND_C),
+    minit ("IS_C_INTEROP", AB_IS_C_INTEROP),
+    minit ("IS_ISO_C", AB_IS_ISO_C),
+    minit ("VALUE", AB_VALUE),
+    minit ("ALLOC_COMP", AB_ALLOC_COMP),
+    minit ("COARRAY_COMP", AB_COARRAY_COMP),
+    minit ("LOCK_COMP", AB_LOCK_COMP),
+    minit ("POINTER_COMP", AB_POINTER_COMP),
+    minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP),
+    minit ("PRIVATE_COMP", AB_PRIVATE_COMP),
+    minit ("ZERO_COMP", AB_ZERO_COMP),
+    minit ("PROTECTED", AB_PROTECTED),
+    minit ("ABSTRACT", AB_ABSTRACT),
+    minit ("IS_CLASS", AB_IS_CLASS),
+    minit ("PROCEDURE", AB_PROCEDURE),
+    minit ("PROC_POINTER", AB_PROC_POINTER),
+    minit ("VTYPE", AB_VTYPE),
+    minit ("VTAB", AB_VTAB),
+    minit ("CLASS_POINTER", AB_CLASS_POINTER),
+    minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE),
+    minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY),
+    minit (NULL, -1)
+};
+
+/* For binding attributes.  */
+static const mstring binding_passing[] =
+{
+    minit ("PASS", 0),
+    minit ("NOPASS", 1),
+    minit (NULL, -1)
+};
+static const mstring binding_overriding[] =
+{
+    minit ("OVERRIDABLE", 0),
+    minit ("NON_OVERRIDABLE", 1),
+    minit ("DEFERRED", 2),
+    minit (NULL, -1)
+};
+static const mstring binding_generic[] =
+{
+    minit ("SPECIFIC", 0),
+    minit ("GENERIC", 1),
+    minit (NULL, -1)
+};
+static const mstring binding_ppc[] =
+{
+    minit ("NO_PPC", 0),
+    minit ("PPC", 1),
+    minit (NULL, -1)
+};
+
+/* Specialization of mio_name.  */
+DECL_MIO_NAME (ab_attribute)
+DECL_MIO_NAME (ar_type)
+DECL_MIO_NAME (array_type)
+DECL_MIO_NAME (bt)
+DECL_MIO_NAME (expr_t)
+DECL_MIO_NAME (gfc_access)
+DECL_MIO_NAME (gfc_intrinsic_op)
+DECL_MIO_NAME (ifsrc)
+DECL_MIO_NAME (save_state)
+DECL_MIO_NAME (procedure_type)
+DECL_MIO_NAME (ref_type)
+DECL_MIO_NAME (sym_flavor)
+DECL_MIO_NAME (sym_intent)
+#undef DECL_MIO_NAME
+
+/* Symbol attributes are stored in list with the first three elements
+   being the enumerated fields, while the remaining elements (if any)
+   indicate the individual attribute bits.  The access field is not
+   saved-- it controls what symbols are exported when a module is
+   written.  */
+
+static void
+mio_symbol_attribute (symbol_attribute *attr)
+{
+  atom_type t;
+  unsigned ext_attr,extension_level;
+
+  mio_lparen ();
+
+  attr->flavor = MIO_NAME (sym_flavor) (attr->flavor, flavors);
+  attr->intent = MIO_NAME (sym_intent) (attr->intent, intents);
+  attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
+  attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
+  attr->save = MIO_NAME (save_state) (attr->save, save_status);
+  
+  ext_attr = attr->ext_attr;
+  mio_integer ((int *) &ext_attr);
+  attr->ext_attr = ext_attr;
+
+  extension_level = attr->extension;
+  mio_integer ((int *) &extension_level);
+  attr->extension = extension_level;
+
+  if (iomode == IO_OUTPUT)
+    {
+      if (attr->allocatable)
+	MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits);
+      if (attr->artificial)
+	MIO_NAME (ab_attribute) (AB_ARTIFICIAL, attr_bits);
+      if (attr->asynchronous)
+	MIO_NAME (ab_attribute) (AB_ASYNCHRONOUS, attr_bits);
+      if (attr->dimension)
+	MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
+      if (attr->codimension)
+	MIO_NAME (ab_attribute) (AB_CODIMENSION, attr_bits);
+      if (attr->contiguous)
+	MIO_NAME (ab_attribute) (AB_CONTIGUOUS, attr_bits);
+      if (attr->external)
+	MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits);
+      if (attr->intrinsic)
+	MIO_NAME (ab_attribute) (AB_INTRINSIC, attr_bits);
+      if (attr->optional)
+	MIO_NAME (ab_attribute) (AB_OPTIONAL, attr_bits);
+      if (attr->pointer)
+	MIO_NAME (ab_attribute) (AB_POINTER, attr_bits);
+      if (attr->class_pointer)
+	MIO_NAME (ab_attribute) (AB_CLASS_POINTER, attr_bits);
+      if (attr->is_protected)
+	MIO_NAME (ab_attribute) (AB_PROTECTED, attr_bits);
+      if (attr->value)
+	MIO_NAME (ab_attribute) (AB_VALUE, attr_bits);
+      if (attr->volatile_)
+	MIO_NAME (ab_attribute) (AB_VOLATILE, attr_bits);
+      if (attr->target)
+	MIO_NAME (ab_attribute) (AB_TARGET, attr_bits);
+      if (attr->threadprivate)
+	MIO_NAME (ab_attribute) (AB_THREADPRIVATE, attr_bits);
+      if (attr->dummy)
+	MIO_NAME (ab_attribute) (AB_DUMMY, attr_bits);
+      if (attr->result)
+	MIO_NAME (ab_attribute) (AB_RESULT, attr_bits);
+      /* We deliberately don't preserve the "entry" flag.  */
+
+      if (attr->data)
+	MIO_NAME (ab_attribute) (AB_DATA, attr_bits);
+      if (attr->in_namelist)
+	MIO_NAME (ab_attribute) (AB_IN_NAMELIST, attr_bits);
+      if (attr->in_common)
+	MIO_NAME (ab_attribute) (AB_IN_COMMON, attr_bits);
+
+      if (attr->function)
+	MIO_NAME (ab_attribute) (AB_FUNCTION, attr_bits);
+      if (attr->subroutine)
+	MIO_NAME (ab_attribute) (AB_SUBROUTINE, attr_bits);
+      if (attr->generic)
+	MIO_NAME (ab_attribute) (AB_GENERIC, attr_bits);
+      if (attr->abstract)
+	MIO_NAME (ab_attribute) (AB_ABSTRACT, attr_bits);
+
+      if (attr->sequence)
+	MIO_NAME (ab_attribute) (AB_SEQUENCE, attr_bits);
+      if (attr->elemental)
+	MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits);
+      if (attr->pure)
+	MIO_NAME (ab_attribute) (AB_PURE, attr_bits);
+      if (attr->implicit_pure)
+	MIO_NAME (ab_attribute) (AB_IMPLICIT_PURE, attr_bits);
+      if (attr->unlimited_polymorphic)
+	MIO_NAME (ab_attribute) (AB_UNLIMITED_POLY, attr_bits);
+      if (attr->recursive)
+	MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits);
+      if (attr->always_explicit)
+	MIO_NAME (ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
+      if (attr->cray_pointer)
+	MIO_NAME (ab_attribute) (AB_CRAY_POINTER, attr_bits);
+      if (attr->cray_pointee)
+	MIO_NAME (ab_attribute) (AB_CRAY_POINTEE, attr_bits);
+      if (attr->is_bind_c)
+	MIO_NAME(ab_attribute) (AB_IS_BIND_C, attr_bits);
+      if (attr->is_c_interop)
+	MIO_NAME(ab_attribute) (AB_IS_C_INTEROP, attr_bits);
+      if (attr->is_iso_c)
+	MIO_NAME(ab_attribute) (AB_IS_ISO_C, attr_bits);
+      if (attr->alloc_comp)
+	MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits);
+      if (attr->pointer_comp)
+	MIO_NAME (ab_attribute) (AB_POINTER_COMP, attr_bits);
+      if (attr->proc_pointer_comp)
+	MIO_NAME (ab_attribute) (AB_PROC_POINTER_COMP, attr_bits);
+      if (attr->private_comp)
+	MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
+      if (attr->coarray_comp)
+	MIO_NAME (ab_attribute) (AB_COARRAY_COMP, attr_bits);
+      if (attr->lock_comp)
+	MIO_NAME (ab_attribute) (AB_LOCK_COMP, attr_bits);
+      if (attr->zero_comp)
+	MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
+      if (attr->is_class)
+	MIO_NAME (ab_attribute) (AB_IS_CLASS, attr_bits);
+      if (attr->procedure)
+	MIO_NAME (ab_attribute) (AB_PROCEDURE, attr_bits);
+      if (attr->proc_pointer)
+	MIO_NAME (ab_attribute) (AB_PROC_POINTER, attr_bits);
+      if (attr->vtype)
+	MIO_NAME (ab_attribute) (AB_VTYPE, attr_bits);
+      if (attr->vtab)
+	MIO_NAME (ab_attribute) (AB_VTAB, attr_bits);
+
+      mio_rparen ();
+
+    }
+  else
+    {
+      for (;;)
+	{
+	  t = parse_atom ();
+	  if (t == ATOM_RPAREN)
+	    break;
+	  if (t != ATOM_NAME)
+	    bad_module ("Expected attribute bit name");
+
+	  switch ((ab_attribute) find_enum (attr_bits))
+	    {
+	    case AB_ALLOCATABLE:
+	      attr->allocatable = 1;
+	      break;
+	    case AB_ARTIFICIAL:
+	      attr->artificial = 1;
+	      break;
+	    case AB_ASYNCHRONOUS:
+	      attr->asynchronous = 1;
+	      break;
+	    case AB_DIMENSION:
+	      attr->dimension = 1;
+	      break;
+	    case AB_CODIMENSION:
+	      attr->codimension = 1;
+	      break;
+	    case AB_CONTIGUOUS:
+	      attr->contiguous = 1;
+	      break;
+	    case AB_EXTERNAL:
+	      attr->external = 1;
+	      break;
+	    case AB_INTRINSIC:
+	      attr->intrinsic = 1;
+	      break;
+	    case AB_OPTIONAL:
+	      attr->optional = 1;
+	      break;
+	    case AB_POINTER:
+	      attr->pointer = 1;
+	      break;
+	    case AB_CLASS_POINTER:
+	      attr->class_pointer = 1;
+	      break;
+	    case AB_PROTECTED:
+	      attr->is_protected = 1;
+	      break;
+	    case AB_VALUE:
+	      attr->value = 1;
+	      break;
+	    case AB_VOLATILE:
+	      attr->volatile_ = 1;
+	      break;
+	    case AB_TARGET:
+	      attr->target = 1;
+	      break;
+	    case AB_THREADPRIVATE:
+	      attr->threadprivate = 1;
+	      break;
+	    case AB_DUMMY:
+	      attr->dummy = 1;
+	      break;
+	    case AB_RESULT:
+	      attr->result = 1;
+	      break;
+	    case AB_DATA:
+	      attr->data = 1;
+	      break;
+	    case AB_IN_NAMELIST:
+	      attr->in_namelist = 1;
+	      break;
+	    case AB_IN_COMMON:
+	      attr->in_common = 1;
+	      break;
+	    case AB_FUNCTION:
+	      attr->function = 1;
+	      break;
+	    case AB_SUBROUTINE:
+	      attr->subroutine = 1;
+	      break;
+	    case AB_GENERIC:
+	      attr->generic = 1;
+	      break;
+	    case AB_ABSTRACT:
+	      attr->abstract = 1;
+	      break;
+	    case AB_SEQUENCE:
+	      attr->sequence = 1;
+	      break;
+	    case AB_ELEMENTAL:
+	      attr->elemental = 1;
+	      break;
+	    case AB_PURE:
+	      attr->pure = 1;
+	      break;
+	    case AB_IMPLICIT_PURE:
+	      attr->implicit_pure = 1;
+	      break;
+	    case AB_UNLIMITED_POLY:
+	      attr->unlimited_polymorphic = 1;
+	      break;
+	    case AB_RECURSIVE:
+	      attr->recursive = 1;
+	      break;
+	    case AB_ALWAYS_EXPLICIT:
+	      attr->always_explicit = 1;
+	      break;
+	    case AB_CRAY_POINTER:
+	      attr->cray_pointer = 1;
+	      break;
+	    case AB_CRAY_POINTEE:
+	      attr->cray_pointee = 1;
+	      break;
+	    case AB_IS_BIND_C:
+	      attr->is_bind_c = 1;
+	      break;
+	    case AB_IS_C_INTEROP:
+	      attr->is_c_interop = 1;
+	      break;
+	    case AB_IS_ISO_C:
+	      attr->is_iso_c = 1;
+	      break;
+	    case AB_ALLOC_COMP:
+	      attr->alloc_comp = 1;
+	      break;
+	    case AB_COARRAY_COMP:
+	      attr->coarray_comp = 1;
+	      break;
+	    case AB_LOCK_COMP:
+	      attr->lock_comp = 1;
+	      break;
+	    case AB_POINTER_COMP:
+	      attr->pointer_comp = 1;
+	      break;
+	    case AB_PROC_POINTER_COMP:
+	      attr->proc_pointer_comp = 1;
+	      break;
+	    case AB_PRIVATE_COMP:
+	      attr->private_comp = 1;
+	      break;
+	    case AB_ZERO_COMP:
+	      attr->zero_comp = 1;
+	      break;
+	    case AB_IS_CLASS:
+	      attr->is_class = 1;
+	      break;
+	    case AB_PROCEDURE:
+	      attr->procedure = 1;
+	      break;
+	    case AB_PROC_POINTER:
+	      attr->proc_pointer = 1;
+	      break;
+	    case AB_VTYPE:
+	      attr->vtype = 1;
+	      break;
+	    case AB_VTAB:
+	      attr->vtab = 1;
+	      break;
+	    }
+	}
+    }
+}
+
+
+static const mstring bt_types[] = {
+    minit ("INTEGER", BT_INTEGER),
+    minit ("REAL", BT_REAL),
+    minit ("COMPLEX", BT_COMPLEX),
+    minit ("LOGICAL", BT_LOGICAL),
+    minit ("CHARACTER", BT_CHARACTER),
+    minit ("DERIVED", BT_DERIVED),
+    minit ("CLASS", BT_CLASS),
+    minit ("PROCEDURE", BT_PROCEDURE),
+    minit ("UNKNOWN", BT_UNKNOWN),
+    minit ("VOID", BT_VOID),
+    minit ("ASSUMED", BT_ASSUMED),
+    minit (NULL, -1)
+};
+
+
+static void
+mio_charlen (gfc_charlen **clp)
+{
+  gfc_charlen *cl;
+
+  mio_lparen ();
+
+  if (iomode == IO_OUTPUT)
+    {
+      cl = *clp;
+      if (cl != NULL)
+	mio_expr (&cl->length);
+    }
+  else
+    {
+      if (peek_atom () != ATOM_RPAREN)
+	{
+	  cl = gfc_new_charlen (gfc_current_ns, NULL);
+	  mio_expr (&cl->length);
+	  *clp = cl;
+	}
+    }
+
+  mio_rparen ();
+}
+
+
+/* See if a name is a generated name.  */
+
+static int
+check_unique_name (const char *name)
+{
+  return *name == '@';
+}
+
+
+static void
+mio_typespec (gfc_typespec *ts)
+{
+  mio_lparen ();
+
+  ts->type = MIO_NAME (bt) (ts->type, bt_types);
+
+  if (ts->type != BT_DERIVED && ts->type != BT_CLASS)
+    mio_integer (&ts->kind);
+  else
+    mio_symbol_ref (&ts->u.derived);
+
+  mio_symbol_ref (&ts->interface);
+
+  /* Add info for C interop and is_iso_c.  */
+  mio_integer (&ts->is_c_interop);
+  mio_integer (&ts->is_iso_c);
+  
+  /* If the typespec is for an identifier either from iso_c_binding, or
+     a constant that was initialized to an identifier from it, use the
+     f90_type.  Otherwise, use the ts->type, since it shouldn't matter.  */
+  if (ts->is_iso_c)
+    ts->f90_type = MIO_NAME (bt) (ts->f90_type, bt_types);
+  else
+    ts->f90_type = MIO_NAME (bt) (ts->type, bt_types);
+
+  if (ts->type != BT_CHARACTER)
+    {
+      /* ts->u.cl is only valid for BT_CHARACTER.  */
+      mio_lparen ();
+      mio_rparen ();
+    }
+  else
+    mio_charlen (&ts->u.cl);
+
+  /* So as not to disturb the existing API, use an ATOM_NAME to
+     transmit deferred characteristic for characters (F2003).  */
+  if (iomode == IO_OUTPUT)
+    {
+      if (ts->type == BT_CHARACTER && ts->deferred)
+	write_atom (ATOM_NAME, "DEFERRED_CL");
+    }
+  else if (peek_atom () != ATOM_RPAREN)
+    {
+      if (parse_atom () != ATOM_NAME)
+	bad_module ("Expected string");
+      ts->deferred = 1;
+    }
+
+  mio_rparen ();
+}
+
+
+static const mstring array_spec_types[] = {
+    minit ("EXPLICIT", AS_EXPLICIT),
+    minit ("ASSUMED_RANK", AS_ASSUMED_RANK),
+    minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
+    minit ("DEFERRED", AS_DEFERRED),
+    minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE),
+    minit (NULL, -1)
+};
+
+
+static void
+mio_array_spec (gfc_array_spec **asp)
+{
+  gfc_array_spec *as;
+  int i;
+
+  mio_lparen ();
+
+  if (iomode == IO_OUTPUT)
+    {
+      int rank;
+
+      if (*asp == NULL)
+	goto done;
+      as = *asp;
+
+      /* mio_integer expects nonnegative values.  */
+      rank = as->rank > 0 ? as->rank : 0;
+      mio_integer (&rank);
+    }
+  else
+    {
+      if (peek_atom () == ATOM_RPAREN)
+	{
+	  *asp = NULL;
+	  goto done;
+	}
+
+      *asp = as = gfc_get_array_spec ();
+      mio_integer (&as->rank);
+    }
+
+  mio_integer (&as->corank);
+  as->type = MIO_NAME (array_type) (as->type, array_spec_types);
+
+  if (iomode == IO_INPUT && as->type == AS_ASSUMED_RANK)
+    as->rank = -1;
+  if (iomode == IO_INPUT && as->corank)
+    as->cotype = (as->type == AS_DEFERRED) ? AS_DEFERRED : AS_EXPLICIT;
+
+  if (as->rank + as->corank > 0)
+    for (i = 0; i < as->rank + as->corank; i++)
+      {
+	mio_expr (&as->lower[i]);
+	mio_expr (&as->upper[i]);
+      }
+
+done:
+  mio_rparen ();
+}
+
+
+/* Given a pointer to an array reference structure (which lives in a
+   gfc_ref structure), find the corresponding array specification
+   structure.  Storing the pointer in the ref structure doesn't quite
+   work when loading from a module. Generating code for an array
+   reference also needs more information than just the array spec.  */
+
+static const mstring array_ref_types[] = {
+    minit ("FULL", AR_FULL),
+    minit ("ELEMENT", AR_ELEMENT),
+    minit ("SECTION", AR_SECTION),
+    minit (NULL, -1)
+};
+
+
+static void
+mio_array_ref (gfc_array_ref *ar)
+{
+  int i;
+
+  mio_lparen ();
+  ar->type = MIO_NAME (ar_type) (ar->type, array_ref_types);
+  mio_integer (&ar->dimen);
+
+  switch (ar->type)
+    {
+    case AR_FULL:
+      break;
+
+    case AR_ELEMENT:
+      for (i = 0; i < ar->dimen; i++)
+	mio_expr (&ar->start[i]);
+
+      break;
+
+    case AR_SECTION:
+      for (i = 0; i < ar->dimen; i++)
+	{
+	  mio_expr (&ar->start[i]);
+	  mio_expr (&ar->end[i]);
+	  mio_expr (&ar->stride[i]);
+	}
+
+      break;
+
+    case AR_UNKNOWN:
+      gfc_internal_error ("mio_array_ref(): Unknown array ref");
+    }
+
+  /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
+     we can't call mio_integer directly.  Instead loop over each element
+     and cast it to/from an integer.  */
+  if (iomode == IO_OUTPUT)
+    {
+      for (i = 0; i < ar->dimen; i++)
+	{
+	  int tmp = (int)ar->dimen_type[i];
+	  write_atom (ATOM_INTEGER, &tmp);
+	}
+    }
+  else
+    {
+      for (i = 0; i < ar->dimen; i++)
+	{
+	  require_atom (ATOM_INTEGER);
+	  ar->dimen_type[i] = (enum gfc_array_ref_dimen_type) atom_int;
+	}
+    }
+
+  if (iomode == IO_INPUT)
+    {
+      ar->where = gfc_current_locus;
+
+      for (i = 0; i < ar->dimen; i++)
+	ar->c_where[i] = gfc_current_locus;
+    }
+
+  mio_rparen ();
+}
+
+
+/* Saves or restores a pointer.  The pointer is converted back and
+   forth from an integer.  We return the pointer_info pointer so that
+   the caller can take additional action based on the pointer type.  */
+
+static pointer_info *
+mio_pointer_ref (void *gp)
+{
+  pointer_info *p;
+
+  if (iomode == IO_OUTPUT)
+    {
+      p = get_pointer (*((char **) gp));
+      write_atom (ATOM_INTEGER, &p->integer);
+    }
+  else
+    {
+      require_atom (ATOM_INTEGER);
+      p = add_fixup (atom_int, gp);
+    }
+
+  return p;
+}
+
+
+/* Save and load references to components that occur within
+   expressions.  We have to describe these references by a number and
+   by name.  The number is necessary for forward references during
+   reading, and the name is necessary if the symbol already exists in
+   the namespace and is not loaded again.  */
+
+static void
+mio_component_ref (gfc_component **cp)
+{
+  pointer_info *p;
+
+  p = mio_pointer_ref (cp);
+  if (p->type == P_UNKNOWN)
+    p->type = P_COMPONENT;
+}
+
+
+static void mio_namespace_ref (gfc_namespace **nsp);
+static void mio_formal_arglist (gfc_formal_arglist **formal);
+static void mio_typebound_proc (gfc_typebound_proc** proc);
+
+static void
+mio_component (gfc_component *c, int vtype)
+{
+  pointer_info *p;
+  int n;
+
+  mio_lparen ();
+
+  if (iomode == IO_OUTPUT)
+    {
+      p = get_pointer (c);
+      mio_integer (&p->integer);
+    }
+  else
+    {
+      mio_integer (&n);
+      p = get_integer (n);
+      associate_integer_pointer (p, c);
+    }
+
+  if (p->type == P_UNKNOWN)
+    p->type = P_COMPONENT;
+
+  mio_pool_string (&c->name);
+  mio_typespec (&c->ts);
+  mio_array_spec (&c->as);
+
+  mio_symbol_attribute (&c->attr);
+  if (c->ts.type == BT_CLASS)
+    c->attr.class_ok = 1;
+  c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types); 
+
+  if (!vtype || strcmp (c->name, "_final") == 0
+      || strcmp (c->name, "_hash") == 0)
+    mio_expr (&c->initializer);
+
+  if (c->attr.proc_pointer)
+    mio_typebound_proc (&c->tb);
+
+  mio_rparen ();
+}
+
+
+static void
+mio_component_list (gfc_component **cp, int vtype)
+{
+  gfc_component *c, *tail;
+
+  mio_lparen ();
+
+  if (iomode == IO_OUTPUT)
+    {
+      for (c = *cp; c; c = c->next)
+	mio_component (c, vtype);
+    }
+  else
+    {
+      *cp = NULL;
+      tail = NULL;
+
+      for (;;)
+	{
+	  if (peek_atom () == ATOM_RPAREN)
+	    break;
+
+	  c = gfc_get_component ();
+	  mio_component (c, vtype);
+
+	  if (tail == NULL)
+	    *cp = c;
+	  else
+	    tail->next = c;
+
+	  tail = c;
+	}
+    }
+
+  mio_rparen ();
+}
+
+
+static void
+mio_actual_arg (gfc_actual_arglist *a)
+{
+  mio_lparen ();
+  mio_pool_string (&a->name);
+  mio_expr (&a->expr);
+  mio_rparen ();
+}
+
+
+static void
+mio_actual_arglist (gfc_actual_arglist **ap)
+{
+  gfc_actual_arglist *a, *tail;
+
+  mio_lparen ();
+
+  if (iomode == IO_OUTPUT)
+    {
+      for (a = *ap; a; a = a->next)
+	mio_actual_arg (a);
+
+    }
+  else
+    {
+      tail = NULL;
+
+      for (;;)
+	{
+	  if (peek_atom () != ATOM_LPAREN)
+	    break;
+
+	  a = gfc_get_actual_arglist ();
+
+	  if (tail == NULL)
+	    *ap = a;
+	  else
+	    tail->next = a;
+
+	  tail = a;
+	  mio_actual_arg (a);
+	}
+    }
+
+  mio_rparen ();
+}
+
+
+/* Read and write formal argument lists.  */
+
+static void
+mio_formal_arglist (gfc_formal_arglist **formal)
+{
+  gfc_formal_arglist *f, *tail;
+
+  mio_lparen ();
+
+  if (iomode == IO_OUTPUT)
+    {
+      for (f = *formal; f; f = f->next)
+	mio_symbol_ref (&f->sym);
+    }
+  else
+    {
+      *formal = tail = NULL;
+
+      while (peek_atom () != ATOM_RPAREN)
+	{
+	  f = gfc_get_formal_arglist ();
+	  mio_symbol_ref (&f->sym);
+
+	  if (*formal == NULL)
+	    *formal = f;
+	  else
+	    tail->next = f;
+
+	  tail = f;
+	}
+    }
+
+  mio_rparen ();
+}
+
+
+/* Save or restore a reference to a symbol node.  */
+
+pointer_info *
+mio_symbol_ref (gfc_symbol **symp)
+{
+  pointer_info *p;
+
+  p = mio_pointer_ref (symp);
+  if (p->type == P_UNKNOWN)
+    p->type = P_SYMBOL;
+
+  if (iomode == IO_OUTPUT)
+    {
+      if (p->u.wsym.state == UNREFERENCED)
+	p->u.wsym.state = NEEDS_WRITE;
+    }
+  else
+    {
+      if (p->u.rsym.state == UNUSED)
+	p->u.rsym.state = NEEDED;
+    }
+  return p;
+}
+
+
+/* Save or restore a reference to a symtree node.  */
+
+static void
+mio_symtree_ref (gfc_symtree **stp)
+{
+  pointer_info *p;
+  fixup_t *f;
+
+  if (iomode == IO_OUTPUT)
+    mio_symbol_ref (&(*stp)->n.sym);
+  else
+    {
+      require_atom (ATOM_INTEGER);
+      p = get_integer (atom_int);
+
+      /* An unused equivalence member; make a symbol and a symtree
+	 for it.  */
+      if (in_load_equiv && p->u.rsym.symtree == NULL)
+	{
+	  /* Since this is not used, it must have a unique name.  */
+	  p->u.rsym.symtree = gfc_get_unique_symtree (gfc_current_ns);
+
+	  /* Make the symbol.  */
+	  if (p->u.rsym.sym == NULL)
+	    {
+	      p->u.rsym.sym = gfc_new_symbol (p->u.rsym.true_name,
+					      gfc_current_ns);
+	      p->u.rsym.sym->module = gfc_get_string (p->u.rsym.module);
+	    }
+
+	  p->u.rsym.symtree->n.sym = p->u.rsym.sym;
+	  p->u.rsym.symtree->n.sym->refs++;
+	  p->u.rsym.referenced = 1;
+
+	  /* If the symbol is PRIVATE and in COMMON, load_commons will
+	     generate a fixup symbol, which must be associated.  */
+	  if (p->fixup)
+	    resolve_fixups (p->fixup, p->u.rsym.sym);
+	  p->fixup = NULL;
+	}
+      
+      if (p->type == P_UNKNOWN)
+	p->type = P_SYMBOL;
+
+      if (p->u.rsym.state == UNUSED)
+	p->u.rsym.state = NEEDED;
+
+      if (p->u.rsym.symtree != NULL)
+	{
+	  *stp = p->u.rsym.symtree;
+	}
+      else
+	{
+	  f = XCNEW (fixup_t);
+
+	  f->next = p->u.rsym.stfixup;
+	  p->u.rsym.stfixup = f;
+
+	  f->pointer = (void **) stp;
+	}
+    }
+}
+
+
+static void
+mio_iterator (gfc_iterator **ip)
+{
+  gfc_iterator *iter;
+
+  mio_lparen ();
+
+  if (iomode == IO_OUTPUT)
+    {
+      if (*ip == NULL)
+	goto done;
+    }
+  else
+    {
+      if (peek_atom () == ATOM_RPAREN)
+	{
+	  *ip = NULL;
+	  goto done;
+	}
+
+      *ip = gfc_get_iterator ();
+    }
+
+  iter = *ip;
+
+  mio_expr (&iter->var);
+  mio_expr (&iter->start);
+  mio_expr (&iter->end);
+  mio_expr (&iter->step);
+
+done:
+  mio_rparen ();
+}
+
+
+static void
+mio_constructor (gfc_constructor_base *cp)
+{
+  gfc_constructor *c;
+
+  mio_lparen ();
+
+  if (iomode == IO_OUTPUT)
+    {
+      for (c = gfc_constructor_first (*cp); c; c = gfc_constructor_next (c))
+	{
+	  mio_lparen ();
+	  mio_expr (&c->expr);
+	  mio_iterator (&c->iterator);
+	  mio_rparen ();
+	}
+    }
+  else
+    {
+      while (peek_atom () != ATOM_RPAREN)
+	{
+	  c = gfc_constructor_append_expr (cp, NULL, NULL);
+
+	  mio_lparen ();
+	  mio_expr (&c->expr);
+	  mio_iterator (&c->iterator);
+	  mio_rparen ();
+	}
+    }
+
+  mio_rparen ();
+}
+
+
+static const mstring ref_types[] = {
+    minit ("ARRAY", REF_ARRAY),
+    minit ("COMPONENT", REF_COMPONENT),
+    minit ("SUBSTRING", REF_SUBSTRING),
+    minit (NULL, -1)
+};
+
+
+static void
+mio_ref (gfc_ref **rp)
+{
+  gfc_ref *r;
+
+  mio_lparen ();
+
+  r = *rp;
+  r->type = MIO_NAME (ref_type) (r->type, ref_types);
+
+  switch (r->type)
+    {
+    case REF_ARRAY:
+      mio_array_ref (&r->u.ar);
+      break;
+
+    case REF_COMPONENT:
+      mio_symbol_ref (&r->u.c.sym);
+      mio_component_ref (&r->u.c.component);
+      break;
+
+    case REF_SUBSTRING:
+      mio_expr (&r->u.ss.start);
+      mio_expr (&r->u.ss.end);
+      mio_charlen (&r->u.ss.length);
+      break;
+    }
+
+  mio_rparen ();
+}
+
+
+static void
+mio_ref_list (gfc_ref **rp)
+{
+  gfc_ref *ref, *head, *tail;
+
+  mio_lparen ();
+
+  if (iomode == IO_OUTPUT)
+    {
+      for (ref = *rp; ref; ref = ref->next)
+	mio_ref (&ref);
+    }
+  else
+    {
+      head = tail = NULL;
+
+      while (peek_atom () != ATOM_RPAREN)
+	{
+	  if (head == NULL)
+	    head = tail = gfc_get_ref ();
+	  else
+	    {
+	      tail->next = gfc_get_ref ();
+	      tail = tail->next;
+	    }
+
+	  mio_ref (&tail);
+	}
+
+      *rp = head;
+    }
+
+  mio_rparen ();
+}
+
+
+/* Read and write an integer value.  */
+
+static void
+mio_gmp_integer (mpz_t *integer)
+{
+  char *p;
+
+  if (iomode == IO_INPUT)
+    {
+      if (parse_atom () != ATOM_STRING)
+	bad_module ("Expected integer string");
+
+      mpz_init (*integer);
+      if (mpz_set_str (*integer, atom_string, 10))
+	bad_module ("Error converting integer");
+
+      free (atom_string);
+    }
+  else
+    {
+      p = mpz_get_str (NULL, 10, *integer);
+      write_atom (ATOM_STRING, p);
+      free (p);
+    }
+}
+
+
+static void
+mio_gmp_real (mpfr_t *real)
+{
+  mp_exp_t exponent;
+  char *p;
+
+  if (iomode == IO_INPUT)
+    {
+      if (parse_atom () != ATOM_STRING)
+	bad_module ("Expected real string");
+
+      mpfr_init (*real);
+      mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
+      free (atom_string);
+    }
+  else
+    {
+      p = mpfr_get_str (NULL, &exponent, 16, 0, *real, GFC_RND_MODE);
+
+      if (mpfr_nan_p (*real) || mpfr_inf_p (*real))
+	{
+	  write_atom (ATOM_STRING, p);
+	  free (p);
+	  return;
+	}
+
+      atom_string = XCNEWVEC (char, strlen (p) + 20);
+
+      sprintf (atom_string, "0.%s@%ld", p, exponent);
+
+      /* Fix negative numbers.  */
+      if (atom_string[2] == '-')
+	{
+	  atom_string[0] = '-';
+	  atom_string[1] = '0';
+	  atom_string[2] = '.';
+	}
+
+      write_atom (ATOM_STRING, atom_string);
+
+      free (atom_string);
+      free (p);
+    }
+}
+
+
+/* Save and restore the shape of an array constructor.  */
+
+static void
+mio_shape (mpz_t **pshape, int rank)
+{
+  mpz_t *shape;
+  atom_type t;
+  int n;
+
+  /* A NULL shape is represented by ().  */
+  mio_lparen ();
+
+  if (iomode == IO_OUTPUT)
+    {
+      shape = *pshape;
+      if (!shape)
+	{
+	  mio_rparen ();
+	  return;
+	}
+    }
+  else
+    {
+      t = peek_atom ();
+      if (t == ATOM_RPAREN)
+	{
+	  *pshape = NULL;
+	  mio_rparen ();
+	  return;
+	}
+
+      shape = gfc_get_shape (rank);
+      *pshape = shape;
+    }
+
+  for (n = 0; n < rank; n++)
+    mio_gmp_integer (&shape[n]);
+
+  mio_rparen ();
+}
+
+
+static const mstring expr_types[] = {
+    minit ("OP", EXPR_OP),
+    minit ("FUNCTION", EXPR_FUNCTION),
+    minit ("CONSTANT", EXPR_CONSTANT),
+    minit ("VARIABLE", EXPR_VARIABLE),
+    minit ("SUBSTRING", EXPR_SUBSTRING),
+    minit ("STRUCTURE", EXPR_STRUCTURE),
+    minit ("ARRAY", EXPR_ARRAY),
+    minit ("NULL", EXPR_NULL),
+    minit ("COMPCALL", EXPR_COMPCALL),
+    minit (NULL, -1)
+};
+
+/* INTRINSIC_ASSIGN is missing because it is used as an index for
+   generic operators, not in expressions.  INTRINSIC_USER is also
+   replaced by the correct function name by the time we see it.  */
+
+static const mstring intrinsics[] =
+{
+    minit ("UPLUS", INTRINSIC_UPLUS),
+    minit ("UMINUS", INTRINSIC_UMINUS),
+    minit ("PLUS", INTRINSIC_PLUS),
+    minit ("MINUS", INTRINSIC_MINUS),
+    minit ("TIMES", INTRINSIC_TIMES),
+    minit ("DIVIDE", INTRINSIC_DIVIDE),
+    minit ("POWER", INTRINSIC_POWER),
+    minit ("CONCAT", INTRINSIC_CONCAT),
+    minit ("AND", INTRINSIC_AND),
+    minit ("OR", INTRINSIC_OR),
+    minit ("EQV", INTRINSIC_EQV),
+    minit ("NEQV", INTRINSIC_NEQV),
+    minit ("EQ_SIGN", INTRINSIC_EQ),
+    minit ("EQ", INTRINSIC_EQ_OS),
+    minit ("NE_SIGN", INTRINSIC_NE),
+    minit ("NE", INTRINSIC_NE_OS),
+    minit ("GT_SIGN", INTRINSIC_GT),
+    minit ("GT", INTRINSIC_GT_OS),
+    minit ("GE_SIGN", INTRINSIC_GE),
+    minit ("GE", INTRINSIC_GE_OS),
+    minit ("LT_SIGN", INTRINSIC_LT),
+    minit ("LT", INTRINSIC_LT_OS),
+    minit ("LE_SIGN", INTRINSIC_LE),
+    minit ("LE", INTRINSIC_LE_OS),
+    minit ("NOT", INTRINSIC_NOT),
+    minit ("PARENTHESES", INTRINSIC_PARENTHESES),
+    minit (NULL, -1)
+};
+
+
+/* Remedy a couple of situations where the gfc_expr's can be defective.  */
+ 
+static void
+fix_mio_expr (gfc_expr *e)
+{
+  gfc_symtree *ns_st = NULL;
+  const char *fname;
+
+  if (iomode != IO_OUTPUT)
+    return;
+
+  if (e->symtree)
+    {
+      /* If this is a symtree for a symbol that came from a contained module
+	 namespace, it has a unique name and we should look in the current
+	 namespace to see if the required, non-contained symbol is available
+	 yet. If so, the latter should be written.  */
+      if (e->symtree->n.sym && check_unique_name (e->symtree->name))
+	{
+          const char *name = e->symtree->n.sym->name;
+	  if (e->symtree->n.sym->attr.flavor == FL_DERIVED)
+	    name = dt_upper_string (name);
+	  ns_st = gfc_find_symtree (gfc_current_ns->sym_root, name);
+	}
+
+      /* On the other hand, if the existing symbol is the module name or the
+	 new symbol is a dummy argument, do not do the promotion.  */
+      if (ns_st && ns_st->n.sym
+	  && ns_st->n.sym->attr.flavor != FL_MODULE
+	  && !e->symtree->n.sym->attr.dummy)
+	e->symtree = ns_st;
+    }
+  else if (e->expr_type == EXPR_FUNCTION && e->value.function.name)
+    {
+      gfc_symbol *sym;
+
+      /* In some circumstances, a function used in an initialization
+	 expression, in one use associated module, can fail to be
+	 coupled to its symtree when used in a specification
+	 expression in another module.  */
+      fname = e->value.function.esym ? e->value.function.esym->name
+				     : e->value.function.isym->name;
+      e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
+
+      if (e->symtree)
+	return;
+
+      /* This is probably a reference to a private procedure from another
+	 module.  To prevent a segfault, make a generic with no specific
+	 instances.  If this module is used, without the required
+	 specific coming from somewhere, the appropriate error message
+	 is issued.  */
+      gfc_get_symbol (fname, gfc_current_ns, &sym);
+      sym->attr.flavor = FL_PROCEDURE;
+      sym->attr.generic = 1;
+      e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
+      gfc_commit_symbol (sym);
+    }
+}
+
+
+/* Read and write expressions.  The form "()" is allowed to indicate a
+   NULL expression.  */
+
+static void
+mio_expr (gfc_expr **ep)
+{
+  gfc_expr *e;
+  atom_type t;
+  int flag;
+
+  mio_lparen ();
+
+  if (iomode == IO_OUTPUT)
+    {
+      if (*ep == NULL)
+	{
+	  mio_rparen ();
+	  return;
+	}
+
+      e = *ep;
+      MIO_NAME (expr_t) (e->expr_type, expr_types);
+    }
+  else
+    {
+      t = parse_atom ();
+      if (t == ATOM_RPAREN)
+	{
+	  *ep = NULL;
+	  return;
+	}
+
+      if (t != ATOM_NAME)
+	bad_module ("Expected expression type");
+
+      e = *ep = gfc_get_expr ();
+      e->where = gfc_current_locus;
+      e->expr_type = (expr_t) find_enum (expr_types);
+    }
+
+  mio_typespec (&e->ts);
+  mio_integer (&e->rank);
+
+  fix_mio_expr (e);
+
+  switch (e->expr_type)
+    {
+    case EXPR_OP:
+      e->value.op.op
+	= MIO_NAME (gfc_intrinsic_op) (e->value.op.op, intrinsics);
+
+      switch (e->value.op.op)
+	{
+	case INTRINSIC_UPLUS:
+	case INTRINSIC_UMINUS:
+	case INTRINSIC_NOT:
+	case INTRINSIC_PARENTHESES:
+	  mio_expr (&e->value.op.op1);
+	  break;
+
+	case INTRINSIC_PLUS:
+	case INTRINSIC_MINUS:
+	case INTRINSIC_TIMES:
+	case INTRINSIC_DIVIDE:
+	case INTRINSIC_POWER:
+	case INTRINSIC_CONCAT:
+	case INTRINSIC_AND:
+	case INTRINSIC_OR:
+	case INTRINSIC_EQV:
+	case INTRINSIC_NEQV:
+	case INTRINSIC_EQ:
+	case INTRINSIC_EQ_OS:
+	case INTRINSIC_NE:
+	case INTRINSIC_NE_OS:
+	case INTRINSIC_GT:
+	case INTRINSIC_GT_OS:
+	case INTRINSIC_GE:
+	case INTRINSIC_GE_OS:
+	case INTRINSIC_LT:
+	case INTRINSIC_LT_OS:
+	case INTRINSIC_LE:
+	case INTRINSIC_LE_OS:
+	  mio_expr (&e->value.op.op1);
+	  mio_expr (&e->value.op.op2);
+	  break;
+
+	default:
+	  bad_module ("Bad operator");
+	}
+
+      break;
+
+    case EXPR_FUNCTION:
+      mio_symtree_ref (&e->symtree);
+      mio_actual_arglist (&e->value.function.actual);
+
+      if (iomode == IO_OUTPUT)
+	{
+	  e->value.function.name
+	    = mio_allocated_string (e->value.function.name);
+	  if (e->value.function.esym)
+	    flag = 1;
+	  else if (e->ref)
+	    flag = 2;
+	  else
+	    flag = 0;
+	  mio_integer (&flag);
+	  switch (flag)
+	    {
+	    case 1:
+	      mio_symbol_ref (&e->value.function.esym);
+	      break;
+	    case 2:
+	      mio_ref_list (&e->ref);
+	      break;
+	    default:
+	      write_atom (ATOM_STRING, e->value.function.isym->name);
+	    }
+	}
+      else
+	{
+	  require_atom (ATOM_STRING);
+	  e->value.function.name = gfc_get_string (atom_string);
+	  free (atom_string);
+
+	  mio_integer (&flag);
+	  switch (flag)
+	    {
+	    case 1:
+	      mio_symbol_ref (&e->value.function.esym);
+	      break;
+	    case 2:
+	      mio_ref_list (&e->ref);
+	      break;
+	    default:
+	      require_atom (ATOM_STRING);
+	      e->value.function.isym = gfc_find_function (atom_string);
+	      free (atom_string);
+	    }
+	}
+
+      break;
+
+    case EXPR_VARIABLE:
+      mio_symtree_ref (&e->symtree);
+      mio_ref_list (&e->ref);
+      break;
+
+    case EXPR_SUBSTRING:
+      e->value.character.string
+	= CONST_CAST (gfc_char_t *,
+		      mio_allocated_wide_string (e->value.character.string,
+						 e->value.character.length));
+      mio_ref_list (&e->ref);
+      break;
+
+    case EXPR_STRUCTURE:
+    case EXPR_ARRAY:
+      mio_constructor (&e->value.constructor);
+      mio_shape (&e->shape, e->rank);
+      break;
+
+    case EXPR_CONSTANT:
+      switch (e->ts.type)
+	{
+	case BT_INTEGER:
+	  mio_gmp_integer (&e->value.integer);
+	  break;
+
+	case BT_REAL:
+	  gfc_set_model_kind (e->ts.kind);
+	  mio_gmp_real (&e->value.real);
+	  break;
+
+	case BT_COMPLEX:
+	  gfc_set_model_kind (e->ts.kind);
+	  mio_gmp_real (&mpc_realref (e->value.complex));
+	  mio_gmp_real (&mpc_imagref (e->value.complex));
+	  break;
+
+	case BT_LOGICAL:
+	  mio_integer (&e->value.logical);
+	  break;
+
+	case BT_CHARACTER:
+	  mio_integer (&e->value.character.length);
+	  e->value.character.string
+	    = CONST_CAST (gfc_char_t *,
+			  mio_allocated_wide_string (e->value.character.string,
+						     e->value.character.length));
+	  break;
+
+	default:
+	  bad_module ("Bad type in constant expression");
+	}
+
+      break;
+
+    case EXPR_NULL:
+      break;
+
+    case EXPR_COMPCALL:
+    case EXPR_PPC:
+      gcc_unreachable ();
+      break;
+    }
+
+  mio_rparen ();
+}
+
+
+/* Read and write namelists.  */
+
+static void
+mio_namelist (gfc_symbol *sym)
+{
+  gfc_namelist *n, *m;
+  const char *check_name;
+
+  mio_lparen ();
+
+  if (iomode == IO_OUTPUT)
+    {
+      for (n = sym->namelist; n; n = n->next)
+	mio_symbol_ref (&n->sym);
+    }
+  else
+    {
+      /* This departure from the standard is flagged as an error.
+	 It does, in fact, work correctly. TODO: Allow it
+	 conditionally?  */
+      if (sym->attr.flavor == FL_NAMELIST)
+	{
+	  check_name = find_use_name (sym->name, false);
+	  if (check_name && strcmp (check_name, sym->name) != 0)
+	    gfc_error ("Namelist %s cannot be renamed by USE "
+		       "association to %s", sym->name, check_name);
+	}
+
+      m = NULL;
+      while (peek_atom () != ATOM_RPAREN)
+	{
+	  n = gfc_get_namelist ();
+	  mio_symbol_ref (&n->sym);
+
+	  if (sym->namelist == NULL)
+	    sym->namelist = n;
+	  else
+	    m->next = n;
+
+	  m = n;
+	}
+      sym->namelist_tail = m;
+    }
+
+  mio_rparen ();
+}
+
+
+/* Save/restore lists of gfc_interface structures.  When loading an
+   interface, we are really appending to the existing list of
+   interfaces.  Checking for duplicate and ambiguous interfaces has to
+   be done later when all symbols have been loaded.  */
+
+pointer_info *
+mio_interface_rest (gfc_interface **ip)
+{
+  gfc_interface *tail, *p;
+  pointer_info *pi = NULL;
+
+  if (iomode == IO_OUTPUT)
+    {
+      if (ip != NULL)
+	for (p = *ip; p; p = p->next)
+	  mio_symbol_ref (&p->sym);
+    }
+  else
+    {
+      if (*ip == NULL)
+	tail = NULL;
+      else
+	{
+	  tail = *ip;
+	  while (tail->next)
+	    tail = tail->next;
+	}
+
+      for (;;)
+	{
+	  if (peek_atom () == ATOM_RPAREN)
+	    break;
+
+	  p = gfc_get_interface ();
+	  p->where = gfc_current_locus;
+	  pi = mio_symbol_ref (&p->sym);
+
+	  if (tail == NULL)
+	    *ip = p;
+	  else
+	    tail->next = p;
+
+	  tail = p;
+	}
+    }
+
+  mio_rparen ();
+  return pi;
+}
+
+
+/* Save/restore a nameless operator interface.  */
+
+static void
+mio_interface (gfc_interface **ip)
+{
+  mio_lparen ();
+  mio_interface_rest (ip);
+}
+
+
+/* Save/restore a named operator interface.  */
+
+static void
+mio_symbol_interface (const char **name, const char **module,
+		      gfc_interface **ip)
+{
+  mio_lparen ();
+  mio_pool_string (name);
+  mio_pool_string (module);
+  mio_interface_rest (ip);
+}
+
+
+static void
+mio_namespace_ref (gfc_namespace **nsp)
+{
+  gfc_namespace *ns;
+  pointer_info *p;
+
+  p = mio_pointer_ref (nsp);
+
+  if (p->type == P_UNKNOWN)
+    p->type = P_NAMESPACE;
+
+  if (iomode == IO_INPUT && p->integer != 0)
+    {
+      ns = (gfc_namespace *) p->u.pointer;
+      if (ns == NULL)
+	{
+	  ns = gfc_get_namespace (NULL, 0);
+	  associate_integer_pointer (p, ns);
+	}
+      else
+	ns->refs++;
+    }
+}
+
+
+/* Save/restore the f2k_derived namespace of a derived-type symbol.  */
+
+static gfc_namespace* current_f2k_derived;
+
+static void
+mio_typebound_proc (gfc_typebound_proc** proc)
+{
+  int flag;
+  int overriding_flag;
+
+  if (iomode == IO_INPUT)
+    {
+      *proc = gfc_get_typebound_proc (NULL);
+      (*proc)->where = gfc_current_locus;
+    }
+  gcc_assert (*proc);
+
+  mio_lparen ();
+
+  (*proc)->access = MIO_NAME (gfc_access) ((*proc)->access, access_types);
+
+  /* IO the NON_OVERRIDABLE/DEFERRED combination.  */
+  gcc_assert (!((*proc)->deferred && (*proc)->non_overridable));
+  overriding_flag = ((*proc)->deferred << 1) | (*proc)->non_overridable;
+  overriding_flag = mio_name (overriding_flag, binding_overriding);
+  (*proc)->deferred = ((overriding_flag & 2) != 0);
+  (*proc)->non_overridable = ((overriding_flag & 1) != 0);
+  gcc_assert (!((*proc)->deferred && (*proc)->non_overridable));
+
+  (*proc)->nopass = mio_name ((*proc)->nopass, binding_passing);
+  (*proc)->is_generic = mio_name ((*proc)->is_generic, binding_generic);
+  (*proc)->ppc = mio_name((*proc)->ppc, binding_ppc);
+
+  mio_pool_string (&((*proc)->pass_arg));
+
+  flag = (int) (*proc)->pass_arg_num;
+  mio_integer (&flag);
+  (*proc)->pass_arg_num = (unsigned) flag;
+
+  if ((*proc)->is_generic)
+    {
+      gfc_tbp_generic* g;
+      int iop;
+
+      mio_lparen ();
+
+      if (iomode == IO_OUTPUT)
+	for (g = (*proc)->u.generic; g; g = g->next)
+	  {
+	    iop = (int) g->is_operator;
+	    mio_integer (&iop);
+	    mio_allocated_string (g->specific_st->name);
+	  }
+      else
+	{
+	  (*proc)->u.generic = NULL;
+	  while (peek_atom () != ATOM_RPAREN)
+	    {
+	      gfc_symtree** sym_root;
+
+	      g = gfc_get_tbp_generic ();
+	      g->specific = NULL;
+
+	      mio_integer (&iop);
+	      g->is_operator = (bool) iop;
+
+	      require_atom (ATOM_STRING);
+	      sym_root = &current_f2k_derived->tb_sym_root;
+	      g->specific_st = gfc_get_tbp_symtree (sym_root, atom_string);
+	      free (atom_string);
+
+	      g->next = (*proc)->u.generic;
+	      (*proc)->u.generic = g;
+	    }
+	}
+
+      mio_rparen ();
+    }
+  else if (!(*proc)->ppc)
+    mio_symtree_ref (&(*proc)->u.specific);
+
+  mio_rparen ();
+}
+
+/* Walker-callback function for this purpose.  */
+static void
+mio_typebound_symtree (gfc_symtree* st)
+{
+  if (iomode == IO_OUTPUT && !st->n.tb)
+    return;
+
+  if (iomode == IO_OUTPUT)
+    {
+      mio_lparen ();
+      mio_allocated_string (st->name);
+    }
+  /* For IO_INPUT, the above is done in mio_f2k_derived.  */
+
+  mio_typebound_proc (&st->n.tb);
+  mio_rparen ();
+}
+
+/* IO a full symtree (in all depth).  */
+static void
+mio_full_typebound_tree (gfc_symtree** root)
+{
+  mio_lparen ();
+
+  if (iomode == IO_OUTPUT)
+    gfc_traverse_symtree (*root, &mio_typebound_symtree);
+  else
+    {
+      while (peek_atom () == ATOM_LPAREN)
+	{
+	  gfc_symtree* st;
+
+	  mio_lparen (); 
+
+	  require_atom (ATOM_STRING);
+	  st = gfc_get_tbp_symtree (root, atom_string);
+	  free (atom_string);
+
+	  mio_typebound_symtree (st);
+	}
+    }
+
+  mio_rparen ();
+}
+
+static void
+mio_finalizer (gfc_finalizer **f)
+{
+  if (iomode == IO_OUTPUT)
+    {
+      gcc_assert (*f);
+      gcc_assert ((*f)->proc_tree); /* Should already be resolved.  */
+      mio_symtree_ref (&(*f)->proc_tree);
+    }
+  else
+    {
+      *f = gfc_get_finalizer ();
+      (*f)->where = gfc_current_locus; /* Value should not matter.  */
+      (*f)->next = NULL;
+
+      mio_symtree_ref (&(*f)->proc_tree);
+      (*f)->proc_sym = NULL;
+    }
+}
+
+static void
+mio_f2k_derived (gfc_namespace *f2k)
+{
+  current_f2k_derived = f2k;
+
+  /* Handle the list of finalizer procedures.  */
+  mio_lparen ();
+  if (iomode == IO_OUTPUT)
+    {
+      gfc_finalizer *f;
+      for (f = f2k->finalizers; f; f = f->next)
+	mio_finalizer (&f);
+    }
+  else
+    {
+      f2k->finalizers = NULL;
+      while (peek_atom () != ATOM_RPAREN)
+	{
+	  gfc_finalizer *cur = NULL;
+	  mio_finalizer (&cur);
+	  cur->next = f2k->finalizers;
+	  f2k->finalizers = cur;
+	}
+    }
+  mio_rparen ();
+
+  /* Handle type-bound procedures.  */
+  mio_full_typebound_tree (&f2k->tb_sym_root);
+
+  /* Type-bound user operators.  */
+  mio_full_typebound_tree (&f2k->tb_uop_root);
+
+  /* Type-bound intrinsic operators.  */
+  mio_lparen ();
+  if (iomode == IO_OUTPUT)
+    {
+      int op;
+      for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op)
+	{
+	  gfc_intrinsic_op realop;
+
+	  if (op == INTRINSIC_USER || !f2k->tb_op[op])
+	    continue;
+
+	  mio_lparen ();
+	  realop = (gfc_intrinsic_op) op;
+	  mio_intrinsic_op (&realop);
+	  mio_typebound_proc (&f2k->tb_op[op]);
+	  mio_rparen ();
+	}
+    }
+  else
+    while (peek_atom () != ATOM_RPAREN)
+      {
+	gfc_intrinsic_op op = GFC_INTRINSIC_BEGIN; /* Silence GCC.  */
+
+	mio_lparen ();
+	mio_intrinsic_op (&op);
+	mio_typebound_proc (&f2k->tb_op[op]);
+	mio_rparen ();
+      }
+  mio_rparen ();
+}
+
+static void
+mio_full_f2k_derived (gfc_symbol *sym)
+{
+  mio_lparen ();
+  
+  if (iomode == IO_OUTPUT)
+    {
+      if (sym->f2k_derived)
+	mio_f2k_derived (sym->f2k_derived);
+    }
+  else
+    {
+      if (peek_atom () != ATOM_RPAREN)
+	{
+	  sym->f2k_derived = gfc_get_namespace (NULL, 0);
+	  mio_f2k_derived (sym->f2k_derived);
+	}
+      else
+	gcc_assert (!sym->f2k_derived);
+    }
+
+  mio_rparen ();
+}
+
+
+/* Unlike most other routines, the address of the symbol node is already
+   fixed on input and the name/module has already been filled in.
+   If you update the symbol format here, don't forget to update read_module
+   as well (look for "seek to the symbol's component list").   */
+
+static void
+mio_symbol (gfc_symbol *sym)
+{
+  int intmod = INTMOD_NONE;
+  
+  mio_lparen ();
+
+  mio_symbol_attribute (&sym->attr);
+
+  /* Note that components are always saved, even if they are supposed
+     to be private.  Component access is checked during searching.  */
+  mio_component_list (&sym->components, sym->attr.vtype);
+  if (sym->components != NULL)
+    sym->component_access
+      = MIO_NAME (gfc_access) (sym->component_access, access_types);
+
+  mio_typespec (&sym->ts);
+  if (sym->ts.type == BT_CLASS)
+    sym->attr.class_ok = 1;
+
+  if (iomode == IO_OUTPUT)
+    mio_namespace_ref (&sym->formal_ns);
+  else
+    {
+      mio_namespace_ref (&sym->formal_ns);
+      if (sym->formal_ns)
+	sym->formal_ns->proc_name = sym;
+    }
+
+  /* Save/restore common block links.  */
+  mio_symbol_ref (&sym->common_next);
+
+  mio_formal_arglist (&sym->formal);
+
+  if (sym->attr.flavor == FL_PARAMETER)
+    mio_expr (&sym->value);
+
+  mio_array_spec (&sym->as);
+
+  mio_symbol_ref (&sym->result);
+
+  if (sym->attr.cray_pointee)
+    mio_symbol_ref (&sym->cp_pointer);
+
+  /* Load/save the f2k_derived namespace of a derived-type symbol.  */
+  mio_full_f2k_derived (sym);
+
+  mio_namelist (sym);
+
+  /* Add the fields that say whether this is from an intrinsic module,
+     and if so, what symbol it is within the module.  */
+/*   mio_integer (&(sym->from_intmod)); */
+  if (iomode == IO_OUTPUT)
+    {
+      intmod = sym->from_intmod;
+      mio_integer (&intmod);
+    }
+  else
+    {
+      mio_integer (&intmod);
+      sym->from_intmod = (intmod_id) intmod;
+    }
+  
+  mio_integer (&(sym->intmod_sym_id));
+
+  if (sym->attr.flavor == FL_DERIVED)
+    mio_integer (&(sym->hash_value));
+
+  mio_rparen ();
+}
+
+
+/************************* Top level subroutines *************************/
+
+/* Given a root symtree node and a symbol, try to find a symtree that
+   references the symbol that is not a unique name.  */
+
+static gfc_symtree *
+find_symtree_for_symbol (gfc_symtree *st, gfc_symbol *sym)
+{
+  gfc_symtree *s = NULL;
+
+  if (st == NULL)
+    return s;
+
+  s = find_symtree_for_symbol (st->right, sym);
+  if (s != NULL)
+    return s;
+  s = find_symtree_for_symbol (st->left, sym);
+  if (s != NULL)
+    return s;
+
+  if (st->n.sym == sym && !check_unique_name (st->name))
+    return st;
+
+  return s;
+}
+
+
+/* A recursive function to look for a specific symbol by name and by
+   module.  Whilst several symtrees might point to one symbol, its
+   is sufficient for the purposes here than one exist.  Note that
+   generic interfaces are distinguished as are symbols that have been
+   renamed in another module.  */
+static gfc_symtree *
+find_symbol (gfc_symtree *st, const char *name,
+	     const char *module, int generic)
+{
+  int c;
+  gfc_symtree *retval, *s;
+
+  if (st == NULL || st->n.sym == NULL)
+    return NULL;
+
+  c = strcmp (name, st->n.sym->name);
+  if (c == 0 && st->n.sym->module
+	     && strcmp (module, st->n.sym->module) == 0
+	     && !check_unique_name (st->name))
+    {
+      s = gfc_find_symtree (gfc_current_ns->sym_root, name);
+
+      /* Detect symbols that are renamed by use association in another
+	 module by the absence of a symtree and null attr.use_rename,
+	 since the latter is not transmitted in the module file.  */
+      if (((!generic && !st->n.sym->attr.generic)
+		|| (generic && st->n.sym->attr.generic))
+	    && !(s == NULL && !st->n.sym->attr.use_rename))
+	return st;
+    }
+
+  retval = find_symbol (st->left, name, module, generic);
+
+  if (retval == NULL)
+    retval = find_symbol (st->right, name, module, generic);
+
+  return retval;
+}
+
+
+/* Skip a list between balanced left and right parens.
+   By setting NEST_LEVEL one assumes that a number of NEST_LEVEL opening parens
+   have been already parsed by hand, and the remaining of the content is to be
+   skipped here.  The default value is 0 (balanced parens).  */
+
+static void
+skip_list (int nest_level = 0)
+{
+  int level;
+
+  level = nest_level;
+  do
+    {
+      switch (parse_atom ())
+	{
+	case ATOM_LPAREN:
+	  level++;
+	  break;
+
+	case ATOM_RPAREN:
+	  level--;
+	  break;
+
+	case ATOM_STRING:
+	  free (atom_string);
+	  break;
+
+	case ATOM_NAME:
+	case ATOM_INTEGER:
+	  break;
+	}
+    }
+  while (level > 0);
+}
+
+
+/* Load operator interfaces from the module.  Interfaces are unusual
+   in that they attach themselves to existing symbols.  */
+
+static void
+load_operator_interfaces (void)
+{
+  const char *p;
+  char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_user_op *uop;
+  pointer_info *pi = NULL;
+  int n, i;
+
+  mio_lparen ();
+
+  while (peek_atom () != ATOM_RPAREN)
+    {
+      mio_lparen ();
+
+      mio_internal_string (name);
+      mio_internal_string (module);
+
+      n = number_use_names (name, true);
+      n = n ? n : 1;
+
+      for (i = 1; i <= n; i++)
+	{
+	  /* Decide if we need to load this one or not.  */
+	  p = find_use_name_n (name, &i, true);
+
+	  if (p == NULL)
+	    {
+	      while (parse_atom () != ATOM_RPAREN);
+	      continue;
+	    }
+
+	  if (i == 1)
+	    {
+	      uop = gfc_get_uop (p);
+	      pi = mio_interface_rest (&uop->op);
+	    }
+	  else
+	    {
+	      if (gfc_find_uop (p, NULL))
+		continue;
+	      uop = gfc_get_uop (p);
+	      uop->op = gfc_get_interface ();
+	      uop->op->where = gfc_current_locus;
+	      add_fixup (pi->integer, &uop->op->sym);
+	    }
+	}
+    }
+
+  mio_rparen ();
+}
+
+
+/* Load interfaces from the module.  Interfaces are unusual in that
+   they attach themselves to existing symbols.  */
+
+static void
+load_generic_interfaces (void)
+{
+  const char *p;
+  char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_symbol *sym;
+  gfc_interface *generic = NULL, *gen = NULL;
+  int n, i, renamed;
+  bool ambiguous_set = false;
+
+  mio_lparen ();
+
+  while (peek_atom () != ATOM_RPAREN)
+    {
+      mio_lparen ();
+
+      mio_internal_string (name);
+      mio_internal_string (module);
+
+      n = number_use_names (name, false);
+      renamed = n ? 1 : 0;
+      n = n ? n : 1;
+
+      for (i = 1; i <= n; i++)
+	{
+	  gfc_symtree *st;
+	  /* Decide if we need to load this one or not.  */
+	  p = find_use_name_n (name, &i, false);
+
+	  st = find_symbol (gfc_current_ns->sym_root,
+			    name, module_name, 1);
+
+	  if (!p || gfc_find_symbol (p, NULL, 0, &sym))
+	    {
+	      /* Skip the specific names for these cases.  */
+	      while (i == 1 && parse_atom () != ATOM_RPAREN);
+
+	      continue;
+	    }
+
+	  /* If the symbol exists already and is being USEd without being
+	     in an ONLY clause, do not load a new symtree(11.3.2).  */
+	  if (!only_flag && st)
+	    sym = st->n.sym;
+
+	  if (!sym)
+	    {
+	      if (st)
+		{
+		  sym = st->n.sym;
+		  if (strcmp (st->name, p) != 0)
+		    {
+	              st = gfc_new_symtree (&gfc_current_ns->sym_root, p);
+		      st->n.sym = sym;
+		      sym->refs++;
+		    }
+		}
+
+	      /* Since we haven't found a valid generic interface, we had
+		 better make one.  */
+	      if (!sym)
+		{
+		  gfc_get_symbol (p, NULL, &sym);
+		  sym->name = gfc_get_string (name);
+		  sym->module = module_name;
+		  sym->attr.flavor = FL_PROCEDURE;
+		  sym->attr.generic = 1;
+		  sym->attr.use_assoc = 1;
+		}
+	    }
+	  else
+	    {
+	      /* Unless sym is a generic interface, this reference
+		 is ambiguous.  */
+	      if (st == NULL)
+	        st = gfc_find_symtree (gfc_current_ns->sym_root, p);
+
+	      sym = st->n.sym;
+
+	      if (st && !sym->attr.generic
+		     && !st->ambiguous
+		     && sym->module
+		     && strcmp (module, sym->module))
+		{
+		  ambiguous_set = true;
+		  st->ambiguous = 1;
+		}
+	    }
+
+	  sym->attr.use_only = only_flag;
+	  sym->attr.use_rename = renamed;
+
+	  if (i == 1)
+	    {
+	      mio_interface_rest (&sym->generic);
+	      generic = sym->generic;
+	    }
+	  else if (!sym->generic)
+	    {
+	      sym->generic = generic;
+	      sym->attr.generic_copy = 1;
+	    }
+
+	  /* If a procedure that is not generic has generic interfaces
+	     that include itself, it is generic! We need to take care
+	     to retain symbols ambiguous that were already so.  */
+	  if (sym->attr.use_assoc
+		&& !sym->attr.generic
+		&& sym->attr.flavor == FL_PROCEDURE)
+	    {
+	      for (gen = generic; gen; gen = gen->next)
+		{
+		  if (gen->sym == sym)
+		    {
+		      sym->attr.generic = 1;
+		      if (ambiguous_set)
+		        st->ambiguous = 0;
+		      break;
+		    }
+		}
+	    }
+
+	}
+    }
+
+  mio_rparen ();
+}
+
+
+/* Load common blocks.  */
+
+static void
+load_commons (void)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_common_head *p;
+
+  mio_lparen ();
+
+  while (peek_atom () != ATOM_RPAREN)
+    {
+      int flags;
+      char* label;
+      mio_lparen ();
+      mio_internal_string (name);
+
+      p = gfc_get_common (name, 1);
+
+      mio_symbol_ref (&p->head);
+      mio_integer (&flags);
+      if (flags & 1)
+	p->saved = 1;
+      if (flags & 2)
+	p->threadprivate = 1;
+      p->use_assoc = 1;
+
+      /* Get whether this was a bind(c) common or not.  */
+      mio_integer (&p->is_bind_c);
+      /* Get the binding label.  */
+      label = read_string ();
+      if (strlen (label))
+	p->binding_label = IDENTIFIER_POINTER (get_identifier (label));
+      XDELETEVEC (label);
+      
+      mio_rparen ();
+    }
+
+  mio_rparen ();
+}
+
+
+/* Load equivalences.  The flag in_load_equiv informs mio_expr_ref of this
+   so that unused variables are not loaded and so that the expression can
+   be safely freed.  */
+
+static void
+load_equiv (void)
+{
+  gfc_equiv *head, *tail, *end, *eq;
+  bool unused;
+
+  mio_lparen ();
+  in_load_equiv = true;
+
+  end = gfc_current_ns->equiv;
+  while (end != NULL && end->next != NULL)
+    end = end->next;
+
+  while (peek_atom () != ATOM_RPAREN) {
+    mio_lparen ();
+    head = tail = NULL;
+
+    while(peek_atom () != ATOM_RPAREN)
+      {
+	if (head == NULL)
+	  head = tail = gfc_get_equiv ();
+	else
+	  {
+	    tail->eq = gfc_get_equiv ();
+	    tail = tail->eq;
+	  }
+
+	mio_pool_string (&tail->module);
+	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)
+      {
+	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))
+	  {
+	    unused = false;
+	    break;
+	  }
+      }
+
+    if (unused)
+      {
+	for (eq = head; eq; eq = head)
+	  {
+	    head = eq->eq;
+	    gfc_free_expr (eq->expr);
+	    free (eq);
+	  }
+      }
+
+    if (end == NULL)
+      gfc_current_ns->equiv = head;
+    else
+      end->next = head;
+
+    if (head != NULL)
+      end = head;
+
+    mio_rparen ();
+  }
+
+  mio_rparen ();
+  in_load_equiv = false;
+}
+
+
+/* This function loads the sym_root of f2k_derived with the extensions to
+   the derived type.  */
+static void
+load_derived_extensions (void)
+{
+  int symbol, j;
+  gfc_symbol *derived;
+  gfc_symbol *dt;
+  gfc_symtree *st;
+  pointer_info *info;
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  char module[GFC_MAX_SYMBOL_LEN + 1];
+  const char *p;
+
+  mio_lparen ();
+  while (peek_atom () != ATOM_RPAREN)
+    {
+      mio_lparen ();
+      mio_integer (&symbol);
+      info = get_integer (symbol);
+      derived = info->u.rsym.sym;
+
+      /* This one is not being loaded.  */
+      if (!info || !derived)
+	{
+	  while (peek_atom () != ATOM_RPAREN)
+	    skip_list ();
+	  continue;
+	}
+
+      gcc_assert (derived->attr.flavor == FL_DERIVED);
+      if (derived->f2k_derived == NULL)
+	derived->f2k_derived = gfc_get_namespace (NULL, 0);
+
+      while (peek_atom () != ATOM_RPAREN)
+	{
+	  mio_lparen ();
+	  mio_internal_string (name);
+	  mio_internal_string (module);
+
+          /* Only use one use name to find the symbol.  */
+	  j = 1;
+	  p = find_use_name_n (name, &j, false);
+	  if (p)
+	    {
+	      st = gfc_find_symtree (gfc_current_ns->sym_root, p);
+	      dt = st->n.sym;
+	      st = gfc_find_symtree (derived->f2k_derived->sym_root, name);
+	      if (st == NULL)
+		{
+		  /* Only use the real name in f2k_derived to ensure a single
+		    symtree.  */
+		  st = gfc_new_symtree (&derived->f2k_derived->sym_root, name);
+		  st->n.sym = dt;
+		  st->n.sym->refs++;
+		}
+	    }
+	  mio_rparen ();
+	}
+      mio_rparen ();
+    }
+  mio_rparen ();
+}
+
+
+/* Recursive function to traverse the pointer_info tree and load a
+   needed symbol.  We return nonzero if we load a symbol and stop the
+   traversal, because the act of loading can alter the tree.  */
+
+static int
+load_needed (pointer_info *p)
+{
+  gfc_namespace *ns;
+  pointer_info *q;
+  gfc_symbol *sym;
+  int rv;
+
+  rv = 0;
+  if (p == NULL)
+    return rv;
+
+  rv |= load_needed (p->left);
+  rv |= load_needed (p->right);
+
+  if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED)
+    return rv;
+
+  p->u.rsym.state = USED;
+
+  set_module_locus (&p->u.rsym.where);
+
+  sym = p->u.rsym.sym;
+  if (sym == NULL)
+    {
+      q = get_integer (p->u.rsym.ns);
+
+      ns = (gfc_namespace *) q->u.pointer;
+      if (ns == NULL)
+	{
+	  /* Create an interface namespace if necessary.  These are
+	     the namespaces that hold the formal parameters of module
+	     procedures.  */
+
+	  ns = gfc_get_namespace (NULL, 0);
+	  associate_integer_pointer (q, ns);
+	}
+
+      /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
+	 doesn't go pear-shaped if the symbol is used.  */
+      if (!ns->proc_name)
+	gfc_find_symbol (p->u.rsym.module, gfc_current_ns,
+				 1, &ns->proc_name);
+
+      sym = gfc_new_symbol (p->u.rsym.true_name, ns);
+      sym->name = dt_lower_string (p->u.rsym.true_name);
+      sym->module = gfc_get_string (p->u.rsym.module);
+      if (p->u.rsym.binding_label)
+	sym->binding_label = IDENTIFIER_POINTER (get_identifier 
+						 (p->u.rsym.binding_label));
+
+      associate_integer_pointer (p, sym);
+    }
+
+  mio_symbol (sym);
+  sym->attr.use_assoc = 1;
+
+  /* Mark as only or rename for later diagnosis for explicitly imported
+     but not used warnings; don't mark internal symbols such as __vtab,
+     __def_init etc. Only mark them if they have been explicitly loaded.  */
+
+  if (only_flag && sym->name[0] != '_' && sym->name[1] != '_')
+    {
+      gfc_use_rename *u;
+
+      /* Search the use/rename list for the variable; if the variable is
+	 found, mark it.  */
+      for (u = gfc_rename_list; u; u = u->next)
+	{
+	  if (strcmp (u->use_name, sym->name) == 0)
+	    {
+	      sym->attr.use_only = 1;
+	      break;
+	    }
+	}
+    }
+
+  if (p->u.rsym.renamed)
+    sym->attr.use_rename = 1;
+
+  return 1;
+}
+
+
+/* Recursive function for cleaning up things after a module has been read.  */
+
+static void
+read_cleanup (pointer_info *p)
+{
+  gfc_symtree *st;
+  pointer_info *q;
+
+  if (p == NULL)
+    return;
+
+  read_cleanup (p->left);
+  read_cleanup (p->right);
+
+  if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced)
+    {
+      gfc_namespace *ns;
+      /* Add hidden symbols to the symtree.  */
+      q = get_integer (p->u.rsym.ns);
+      ns = (gfc_namespace *) q->u.pointer;
+
+      if (!p->u.rsym.sym->attr.vtype
+	    && !p->u.rsym.sym->attr.vtab)
+	st = gfc_get_unique_symtree (ns);
+      else
+	{
+	  /* There is no reason to use 'unique_symtrees' for vtabs or
+	     vtypes - their name is fine for a symtree and reduces the
+	     namespace pollution.  */
+	  st = gfc_find_symtree (ns->sym_root, p->u.rsym.sym->name);
+	  if (!st)
+	    st = gfc_new_symtree (&ns->sym_root, p->u.rsym.sym->name);
+	}
+
+      st->n.sym = p->u.rsym.sym;
+      st->n.sym->refs++;
+
+      /* Fixup any symtree references.  */
+      p->u.rsym.symtree = st;
+      resolve_fixups (p->u.rsym.stfixup, st);
+      p->u.rsym.stfixup = NULL;
+    }
+
+  /* Free unused symbols.  */
+  if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED)
+    gfc_free_symbol (p->u.rsym.sym);
+}
+
+
+/* It is not quite enough to check for ambiguity in the symbols by
+   the loaded symbol and the new symbol not being identical.  */
+static bool
+check_for_ambiguous (gfc_symbol *st_sym, pointer_info *info)
+{
+  gfc_symbol *rsym;
+  module_locus locus;
+  symbol_attribute attr;
+
+  if (gfc_current_ns->proc_name && st_sym->name == gfc_current_ns->proc_name->name)
+    {
+      gfc_error ("'%s' of module '%s', imported at %C, is also the name of the "
+		 "current program unit", st_sym->name, module_name);
+      return true;
+    }
+
+  rsym = info->u.rsym.sym;
+  if (st_sym == rsym)
+    return false;
+
+  if (st_sym->attr.vtab || st_sym->attr.vtype)
+    return false;
+
+  /* If the existing symbol is generic from a different module and
+     the new symbol is generic there can be no ambiguity.  */
+  if (st_sym->attr.generic
+	&& st_sym->module
+	&& st_sym->module != module_name)
+    {
+      /* The new symbol's attributes have not yet been read.  Since
+	 we need attr.generic, read it directly.  */
+      get_module_locus (&locus);
+      set_module_locus (&info->u.rsym.where);
+      mio_lparen ();
+      attr.generic = 0;
+      mio_symbol_attribute (&attr);
+      set_module_locus (&locus);
+      if (attr.generic)
+	return false;
+    }
+
+  return true;
+}
+
+
+/* Read a module file.  */
+
+static void
+read_module (void)
+{
+  module_locus operator_interfaces, user_operators, extensions;
+  const char *p;
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  int i;
+  int ambiguous, j, nuse, symbol;
+  pointer_info *info, *q;
+  gfc_use_rename *u = NULL;
+  gfc_symtree *st;
+  gfc_symbol *sym;
+
+  get_module_locus (&operator_interfaces);	/* Skip these for now.  */
+  skip_list ();
+
+  get_module_locus (&user_operators);
+  skip_list ();
+  skip_list ();
+
+  /* Skip commons, equivalences and derived type extensions for now.  */
+  skip_list ();
+  skip_list ();
+
+  get_module_locus (&extensions);
+  skip_list ();
+
+  mio_lparen ();
+
+  /* Create the fixup nodes for all the symbols.  */
+
+  while (peek_atom () != ATOM_RPAREN)
+    {
+      char* bind_label;
+      require_atom (ATOM_INTEGER);
+      info = get_integer (atom_int);
+
+      info->type = P_SYMBOL;
+      info->u.rsym.state = UNUSED;
+
+      info->u.rsym.true_name = read_string ();
+      info->u.rsym.module = read_string ();
+      bind_label = read_string ();
+      if (strlen (bind_label))
+	info->u.rsym.binding_label = bind_label;
+      else
+	XDELETEVEC (bind_label);
+      
+      require_atom (ATOM_INTEGER);
+      info->u.rsym.ns = atom_int;
+
+      get_module_locus (&info->u.rsym.where);
+
+      /* See if the symbol has already been loaded by a previous module.
+	 If so, we reference the existing symbol and prevent it from
+	 being loaded again.  This should not happen if the symbol being
+	 read is an index for an assumed shape dummy array (ns != 1).  */
+
+      sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
+
+      if (sym == NULL
+	  || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1))
+	{
+	  skip_list ();
+	  continue;
+	}
+
+      info->u.rsym.state = USED;
+      info->u.rsym.sym = sym;
+      /* The current symbol has already been loaded, so we can avoid loading
+	 it again.  However, if it is a derived type, some of its components
+	 can be used in expressions in the module.  To avoid the module loading
+	 failing, we need to associate the module's component pointer indexes
+	 with the existing symbol's component pointers.  */
+      if (sym->attr.flavor == FL_DERIVED)
+	{
+	  gfc_component *c;
+
+	  /* First seek to the symbol's component list.  */
+	  mio_lparen (); /* symbol opening.  */
+	  skip_list (); /* skip symbol attribute.  */
+
+	  mio_lparen (); /* component list opening.  */
+	  for (c = sym->components; c; c = c->next)
+	    {
+	      pointer_info *p;
+	      const char *comp_name;
+	      int n;
+
+	      mio_lparen (); /* component opening.  */
+	      mio_integer (&n);
+	      p = get_integer (n);
+	      if (p->u.pointer == NULL)
+		associate_integer_pointer (p, c);
+	      mio_pool_string (&comp_name);
+	      gcc_assert (comp_name == c->name);
+	      skip_list (1); /* component end.  */
+	    }
+	  mio_rparen (); /* component list closing.  */
+
+	  skip_list (1); /* symbol end.  */
+	}
+      else
+	skip_list ();
+
+      /* Some symbols do not have a namespace (eg. formal arguments),
+	 so the automatic "unique symtree" mechanism must be suppressed
+	 by marking them as referenced.  */
+      q = get_integer (info->u.rsym.ns);
+      if (q->u.pointer == NULL)
+	{
+	  info->u.rsym.referenced = 1;
+	  continue;
+	}
+
+      /* If possible recycle the symtree that references the symbol.
+	 If a symtree is not found and the module does not import one,
+	 a unique-name symtree is found by read_cleanup.  */
+      st = find_symtree_for_symbol (gfc_current_ns->sym_root, sym);
+      if (st != NULL)
+	{
+	  info->u.rsym.symtree = st;
+	  info->u.rsym.referenced = 1;
+	}
+    }
+
+  mio_rparen ();
+
+  /* Parse the symtree lists.  This lets us mark which symbols need to
+     be loaded.  Renaming is also done at this point by replacing the
+     symtree name.  */
+
+  mio_lparen ();
+
+  while (peek_atom () != ATOM_RPAREN)
+    {
+      mio_internal_string (name);
+      mio_integer (&ambiguous);
+      mio_integer (&symbol);
+
+      info = get_integer (symbol);
+
+      /* See how many use names there are.  If none, go through the start
+	 of the loop at least once.  */
+      nuse = number_use_names (name, false);
+      info->u.rsym.renamed = nuse ? 1 : 0;
+
+      if (nuse == 0)
+	nuse = 1;
+
+      for (j = 1; j <= nuse; j++)
+	{
+	  /* Get the jth local name for this symbol.  */
+	  p = find_use_name_n (name, &j, false);
+
+	  if (p == NULL && strcmp (name, module_name) == 0)
+	    p = name;
+
+	  /* Exception: Always import vtabs & vtypes.  */
+	  if (p == NULL && name[0] == '_'
+	      && (strncmp (name, "__vtab_", 5) == 0
+		  || strncmp (name, "__vtype_", 6) == 0))
+	    p = name;
+
+	  /* Skip symtree nodes not in an ONLY clause, unless there
+	     is an existing symtree loaded from another USE statement.  */
+	  if (p == NULL)
+	    {
+	      st = gfc_find_symtree (gfc_current_ns->sym_root, name);
+	      if (st != NULL
+		  && strcmp (st->n.sym->name, info->u.rsym.true_name) == 0
+		  && st->n.sym->module != NULL
+		  && strcmp (st->n.sym->module, info->u.rsym.module) == 0)
+		{
+		  info->u.rsym.symtree = st;
+		  info->u.rsym.sym = st->n.sym;
+		}
+	      continue;
+	    }
+
+	  /* If a symbol of the same name and module exists already,
+	     this symbol, which is not in an ONLY clause, must not be
+	     added to the namespace(11.3.2).  Note that find_symbol
+	     only returns the first occurrence that it finds.  */
+	  if (!only_flag && !info->u.rsym.renamed
+		&& strcmp (name, module_name) != 0
+		&& find_symbol (gfc_current_ns->sym_root, name,
+				module_name, 0))
+	    continue;
+
+	  st = gfc_find_symtree (gfc_current_ns->sym_root, p);
+
+	  if (st != NULL)
+	    {
+	      /* Check for ambiguous symbols.  */
+	      if (check_for_ambiguous (st->n.sym, info))
+		st->ambiguous = 1;
+	      else
+		info->u.rsym.symtree = st;
+	    }
+	  else
+	    {
+	      st = gfc_find_symtree (gfc_current_ns->sym_root, name);
+
+	      /* Create a symtree node in the current namespace for this
+		 symbol.  */
+	      st = check_unique_name (p)
+		   ? gfc_get_unique_symtree (gfc_current_ns)
+		   : gfc_new_symtree (&gfc_current_ns->sym_root, p);
+	      st->ambiguous = ambiguous;
+
+	      sym = info->u.rsym.sym;
+
+	      /* Create a symbol node if it doesn't already exist.  */
+	      if (sym == NULL)
+		{
+		  info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
+						     gfc_current_ns);
+		  info->u.rsym.sym->name = dt_lower_string (info->u.rsym.true_name);
+		  sym = info->u.rsym.sym;
+		  sym->module = gfc_get_string (info->u.rsym.module);
+
+		  if (info->u.rsym.binding_label)
+		    sym->binding_label = 
+		      IDENTIFIER_POINTER (get_identifier 
+					  (info->u.rsym.binding_label));
+		}
+
+	      st->n.sym = sym;
+	      st->n.sym->refs++;
+
+	      if (strcmp (name, p) != 0)
+		sym->attr.use_rename = 1;
+
+	      if (name[0] != '_'
+		  || (strncmp (name, "__vtab_", 5) != 0
+		      && strncmp (name, "__vtype_", 6) != 0))
+		sym->attr.use_only = only_flag;
+
+	      /* Store the symtree pointing to this symbol.  */
+	      info->u.rsym.symtree = st;
+
+	      if (info->u.rsym.state == UNUSED)
+		info->u.rsym.state = NEEDED;
+	      info->u.rsym.referenced = 1;
+	    }
+	}
+    }
+
+  mio_rparen ();
+
+  /* Load intrinsic operator interfaces.  */
+  set_module_locus (&operator_interfaces);
+  mio_lparen ();
+
+  for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
+    {
+      if (i == INTRINSIC_USER)
+	continue;
+
+      if (only_flag)
+	{
+	  u = find_use_operator ((gfc_intrinsic_op) i);
+
+	  if (u == NULL)
+	    {
+	      skip_list ();
+	      continue;
+	    }
+
+	  u->found = 1;
+	}
+
+      mio_interface (&gfc_current_ns->op[i]);
+      if (u && !gfc_current_ns->op[i])
+	u->found = 0;
+    }
+
+  mio_rparen ();
+
+  /* Load generic and user operator interfaces.  These must follow the
+     loading of symtree because otherwise symbols can be marked as
+     ambiguous.  */
+
+  set_module_locus (&user_operators);
+
+  load_operator_interfaces ();
+  load_generic_interfaces ();
+
+  load_commons ();
+  load_equiv ();
+
+  /* At this point, we read those symbols that are needed but haven't
+     been loaded yet.  If one symbol requires another, the other gets
+     marked as NEEDED if its previous state was UNUSED.  */
+
+  while (load_needed (pi_root));
+
+  /* Make sure all elements of the rename-list were found in the module.  */
+
+  for (u = gfc_rename_list; u; u = u->next)
+    {
+      if (u->found)
+	continue;
+
+      if (u->op == INTRINSIC_NONE)
+	{
+	  gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
+		     u->use_name, &u->where, module_name);
+	  continue;
+	}
+
+      if (u->op == INTRINSIC_USER)
+	{
+	  gfc_error ("User operator '%s' referenced at %L not found "
+		     "in module '%s'", u->use_name, &u->where, module_name);
+	  continue;
+	}
+
+      gfc_error ("Intrinsic operator '%s' referenced at %L not found "
+		 "in module '%s'", gfc_op2string (u->op), &u->where,
+		 module_name);
+    }
+
+  /* Now we should be in a position to fill f2k_derived with derived type
+     extensions, since everything has been loaded.  */
+  set_module_locus (&extensions);
+  load_derived_extensions ();
+
+  /* Clean up symbol nodes that were never loaded, create references
+     to hidden symbols.  */
+
+  read_cleanup (pi_root);
+}
+
+
+/* Given an access type that is specific to an entity and the default
+   access, return nonzero if the entity is publicly accessible.  If the
+   element is declared as PUBLIC, then it is public; if declared 
+   PRIVATE, then private, and otherwise it is public unless the default
+   access in this context has been declared PRIVATE.  */
+
+static bool
+check_access (gfc_access specific_access, gfc_access default_access)
+{
+  if (specific_access == ACCESS_PUBLIC)
+    return TRUE;
+  if (specific_access == ACCESS_PRIVATE)
+    return FALSE;
+
+  if (gfc_option.flag_module_private)
+    return default_access == ACCESS_PUBLIC;
+  else
+    return default_access != ACCESS_PRIVATE;
+}
+
+
+bool
+gfc_check_symbol_access (gfc_symbol *sym)
+{
+  if (sym->attr.vtab || sym->attr.vtype)
+    return true;
+  else
+    return check_access (sym->attr.access, sym->ns->default_access);
+}
+
+
+/* A structure to remember which commons we've already written.  */
+
+struct written_common
+{
+  BBT_HEADER(written_common);
+  const char *name, *label;
+};
+
+static struct written_common *written_commons = NULL;
+
+/* Comparison function used for balancing the binary tree.  */
+
+static int
+compare_written_commons (void *a1, void *b1)
+{
+  const char *aname = ((struct written_common *) a1)->name;
+  const char *alabel = ((struct written_common *) a1)->label;
+  const char *bname = ((struct written_common *) b1)->name;
+  const char *blabel = ((struct written_common *) b1)->label;
+  int c = strcmp (aname, bname);
+
+  return (c != 0 ? c : strcmp (alabel, blabel));
+}
+
+/* Free a list of written commons.  */
+
+static void
+free_written_common (struct written_common *w)
+{
+  if (!w)
+    return;
+
+  if (w->left)
+    free_written_common (w->left);
+  if (w->right)
+    free_written_common (w->right);
+
+  free (w);
+}
+
+/* Write a common block to the module -- recursive helper function.  */
+
+static void
+write_common_0 (gfc_symtree *st, bool this_module)
+{
+  gfc_common_head *p;
+  const char * name;
+  int flags;
+  const char *label;
+  struct written_common *w;
+  bool write_me = true;
+	      
+  if (st == NULL)
+    return;
+
+  write_common_0 (st->left, this_module);
+
+  /* We will write out the binding label, or "" if no label given.  */
+  name = st->n.common->name;
+  p = st->n.common;
+  label = (p->is_bind_c && p->binding_label) ? p->binding_label : "";
+
+  /* Check if we've already output this common.  */
+  w = written_commons;
+  while (w)
+    {
+      int c = strcmp (name, w->name);
+      c = (c != 0 ? c : strcmp (label, w->label));
+      if (c == 0)
+	write_me = false;
+
+      w = (c < 0) ? w->left : w->right;
+    }
+
+  if (this_module && p->use_assoc)
+    write_me = false;
+
+  if (write_me)
+    {
+      /* Write the common to the module.  */
+      mio_lparen ();
+      mio_pool_string (&name);
+
+      mio_symbol_ref (&p->head);
+      flags = p->saved ? 1 : 0;
+      if (p->threadprivate)
+	flags |= 2;
+      mio_integer (&flags);
+
+      /* Write out whether the common block is bind(c) or not.  */
+      mio_integer (&(p->is_bind_c));
+
+      mio_pool_string (&label);
+      mio_rparen ();
+
+      /* Record that we have written this common.  */
+      w = XCNEW (struct written_common);
+      w->name = p->name;
+      w->label = label;
+      gfc_insert_bbt (&written_commons, w, compare_written_commons);
+    }
+
+  write_common_0 (st->right, this_module);
+}
+
+
+/* Write a common, by initializing the list of written commons, calling
+   the recursive function write_common_0() and cleaning up afterwards.  */
+
+static void
+write_common (gfc_symtree *st)
+{
+  written_commons = NULL;
+  write_common_0 (st, true);
+  write_common_0 (st, false);
+  free_written_common (written_commons);
+  written_commons = NULL;
+}
+
+
+/* Write the blank common block to the module.  */
+
+static void
+write_blank_common (void)
+{
+  const char * name = BLANK_COMMON_NAME;
+  int saved;
+  /* TODO: Blank commons are not bind(c).  The F2003 standard probably says
+     this, but it hasn't been checked.  Just making it so for now.  */  
+  int is_bind_c = 0;  
+
+  if (gfc_current_ns->blank_common.head == NULL)
+    return;
+
+  mio_lparen ();
+
+  mio_pool_string (&name);
+
+  mio_symbol_ref (&gfc_current_ns->blank_common.head);
+  saved = gfc_current_ns->blank_common.saved;
+  mio_integer (&saved);
+
+  /* Write out whether the common block is bind(c) or not.  */
+  mio_integer (&is_bind_c);
+
+  /* Write out an empty binding label.  */
+  write_atom (ATOM_STRING, "");
+
+  mio_rparen ();
+}
+
+
+/* Write equivalences to the module.  */
+
+static void
+write_equiv (void)
+{
+  gfc_equiv *eq, *e;
+  int num;
+
+  num = 0;
+  for (eq = gfc_current_ns->equiv; eq; eq = eq->next)
+    {
+      mio_lparen ();
+
+      for (e = eq; e; e = e->eq)
+	{
+	  if (e->module == NULL)
+	    e->module = gfc_get_string ("%s.eq.%d", module_name, num);
+	  mio_allocated_string (e->module);
+	  mio_expr (&e->expr);
+	}
+
+      num++;
+      mio_rparen ();
+    }
+}
+
+
+/* Write derived type extensions to the module.  */
+
+static void
+write_dt_extensions (gfc_symtree *st)
+{
+  if (!gfc_check_symbol_access (st->n.sym))
+    return;
+  if (!(st->n.sym->ns && st->n.sym->ns->proc_name
+	&& st->n.sym->ns->proc_name->attr.flavor == FL_MODULE))
+    return;
+
+  mio_lparen ();
+  mio_pool_string (&st->name);
+  if (st->n.sym->module != NULL)
+    mio_pool_string (&st->n.sym->module);
+  else
+    {
+      char name[GFC_MAX_SYMBOL_LEN + 1];
+      if (iomode == IO_OUTPUT)
+	strcpy (name, module_name);
+      mio_internal_string (name);
+      if (iomode == IO_INPUT)
+	module_name = gfc_get_string (name);
+    }
+  mio_rparen ();
+}
+
+static void
+write_derived_extensions (gfc_symtree *st)
+{
+  if (!((st->n.sym->attr.flavor == FL_DERIVED)
+	  && (st->n.sym->f2k_derived != NULL)
+	  && (st->n.sym->f2k_derived->sym_root != NULL)))
+    return;
+
+  mio_lparen ();
+  mio_symbol_ref (&(st->n.sym));
+  gfc_traverse_symtree (st->n.sym->f2k_derived->sym_root,
+			write_dt_extensions);
+  mio_rparen ();
+}
+
+
+/* Write a symbol to the module.  */
+
+static void
+write_symbol (int n, gfc_symbol *sym)
+{
+  const char *label;
+
+  if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
+    gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name);
+
+  mio_integer (&n);
+
+  if (sym->attr.flavor == FL_DERIVED)
+    {
+      const char *name;
+      name = dt_upper_string (sym->name);
+      mio_pool_string (&name);
+    }
+  else
+    mio_pool_string (&sym->name);
+
+  mio_pool_string (&sym->module);
+  if ((sym->attr.is_bind_c || sym->attr.is_iso_c) && sym->binding_label)
+    {
+      label = sym->binding_label;
+      mio_pool_string (&label);
+    }
+  else
+    write_atom (ATOM_STRING, "");
+
+  mio_pointer_ref (&sym->ns);
+
+  mio_symbol (sym);
+  write_char ('\n');
+}
+
+
+/* Recursive traversal function to write the initial set of symbols to
+   the module.  We check to see if the symbol should be written
+   according to the access specification.  */
+
+static void
+write_symbol0 (gfc_symtree *st)
+{
+  gfc_symbol *sym;
+  pointer_info *p;
+  bool dont_write = false;
+
+  if (st == NULL)
+    return;
+
+  write_symbol0 (st->left);
+
+  sym = st->n.sym;
+  if (sym->module == NULL)
+    sym->module = module_name;
+
+  if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
+      && !sym->attr.subroutine && !sym->attr.function)
+    dont_write = true;
+
+  if (!gfc_check_symbol_access (sym))
+    dont_write = true;
+
+  if (!dont_write)
+    {
+      p = get_pointer (sym);
+      if (p->type == P_UNKNOWN)
+	p->type = P_SYMBOL;
+
+      if (p->u.wsym.state != WRITTEN)
+	{
+	  write_symbol (p->integer, sym);
+	  p->u.wsym.state = WRITTEN;
+	}
+    }
+
+  write_symbol0 (st->right);
+}
+
+
+/* Type for the temporary tree used when writing secondary symbols.  */
+
+struct sorted_pointer_info
+{
+  BBT_HEADER (sorted_pointer_info);
+
+  pointer_info *p;
+};
+
+#define gfc_get_sorted_pointer_info() XCNEW (sorted_pointer_info)
+
+/* Recursively traverse the temporary tree, free its contents.  */
+
+static void
+free_sorted_pointer_info_tree (sorted_pointer_info *p)
+{
+  if (!p)
+    return;
+
+  free_sorted_pointer_info_tree (p->left);
+  free_sorted_pointer_info_tree (p->right);
+
+  free (p);
+}
+
+/* Comparison function for the temporary tree.  */
+
+static int
+compare_sorted_pointer_info (void *_spi1, void *_spi2)
+{
+  sorted_pointer_info *spi1, *spi2;
+  spi1 = (sorted_pointer_info *)_spi1;
+  spi2 = (sorted_pointer_info *)_spi2;
+
+  if (spi1->p->integer < spi2->p->integer)
+    return -1;
+  if (spi1->p->integer > spi2->p->integer)
+    return 1;
+  return 0;
+}
+
+
+/* Finds the symbols that need to be written and collects them in the
+   sorted_pi tree so that they can be traversed in an order
+   independent of memory addresses.  */
+
+static void
+find_symbols_to_write(sorted_pointer_info **tree, pointer_info *p)
+{
+  if (!p)
+    return;
+
+  if (p->type == P_SYMBOL && p->u.wsym.state == NEEDS_WRITE)
+    {
+      sorted_pointer_info *sp = gfc_get_sorted_pointer_info();
+      sp->p = p; 
+ 
+      gfc_insert_bbt (tree, sp, compare_sorted_pointer_info);
+   }
+
+  find_symbols_to_write (tree, p->left);
+  find_symbols_to_write (tree, p->right);
+}
+
+
+/* Recursive function that traverses the tree of symbols that need to be
+   written and writes them in order.  */
+
+static void
+write_symbol1_recursion (sorted_pointer_info *sp)
+{
+  if (!sp)
+    return;
+
+  write_symbol1_recursion (sp->left);
+
+  pointer_info *p1 = sp->p;
+  gcc_assert (p1->type == P_SYMBOL && p1->u.wsym.state == NEEDS_WRITE);
+
+  p1->u.wsym.state = WRITTEN;
+  write_symbol (p1->integer, p1->u.wsym.sym);
+  p1->u.wsym.sym->attr.public_used = 1;
+ 
+  write_symbol1_recursion (sp->right);
+}
+
+
+/* Write the secondary set of symbols to the module file.  These are
+   symbols that were not public yet are needed by the public symbols
+   or another dependent symbol.  The act of writing a symbol can add
+   symbols to the pointer_info tree, so we return nonzero if a symbol
+   was written and pass that information upwards.  The caller will
+   then call this function again until nothing was written.  It uses
+   the utility functions and a temporary tree to ensure a reproducible
+   ordering of the symbol output and thus the module file.  */
+
+static int
+write_symbol1 (pointer_info *p)
+{
+  if (!p)
+    return 0;
+
+  /* Put symbols that need to be written into a tree sorted on the
+     integer field.  */
+
+  sorted_pointer_info *spi_root = NULL;
+  find_symbols_to_write (&spi_root, p);
+
+  /* No symbols to write, return.  */
+  if (!spi_root)
+    return 0;
+
+  /* Otherwise, write and free the tree again.  */
+  write_symbol1_recursion (spi_root);
+  free_sorted_pointer_info_tree (spi_root);
+
+  return 1;
+}
+
+
+/* Write operator interfaces associated with a symbol.  */
+
+static void
+write_operator (gfc_user_op *uop)
+{
+  static char nullstring[] = "";
+  const char *p = nullstring;
+
+  if (uop->op == NULL || !check_access (uop->access, uop->ns->default_access))
+    return;
+
+  mio_symbol_interface (&uop->name, &p, &uop->op);
+}
+
+
+/* Write generic interfaces from the namespace sym_root.  */
+
+static void
+write_generic (gfc_symtree *st)
+{
+  gfc_symbol *sym;
+
+  if (st == NULL)
+    return;
+
+  write_generic (st->left);
+
+  sym = st->n.sym;
+  if (sym && !check_unique_name (st->name)
+      && sym->generic && gfc_check_symbol_access (sym))
+    {
+      if (!sym->module)
+	sym->module = module_name;
+
+      mio_symbol_interface (&st->name, &sym->module, &sym->generic);
+    }
+
+  write_generic (st->right);
+}
+
+
+static void
+write_symtree (gfc_symtree *st)
+{
+  gfc_symbol *sym;
+  pointer_info *p;
+
+  sym = st->n.sym;
+
+  /* A symbol in an interface body must not be visible in the
+     module file.  */
+  if (sym->ns != gfc_current_ns
+	&& sym->ns->proc_name
+	&& sym->ns->proc_name->attr.if_source == IFSRC_IFBODY)
+    return;
+
+  if (!gfc_check_symbol_access (sym)
+      || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
+	  && !sym->attr.subroutine && !sym->attr.function))
+    return;
+
+  if (check_unique_name (st->name))
+    return;
+
+  p = find_pointer (sym);
+  if (p == NULL)
+    gfc_internal_error ("write_symtree(): Symbol not written");
+
+  mio_pool_string (&st->name);
+  mio_integer (&st->ambiguous);
+  mio_integer (&p->integer);
+}
+
+
+static void
+write_module (void)
+{
+  int i;
+
+  /* Write the operator interfaces.  */
+  mio_lparen ();
+
+  for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
+    {
+      if (i == INTRINSIC_USER)
+	continue;
+
+      mio_interface (check_access (gfc_current_ns->operator_access[i],
+				   gfc_current_ns->default_access)
+		     ? &gfc_current_ns->op[i] : NULL);
+    }
+
+  mio_rparen ();
+  write_char ('\n');
+  write_char ('\n');
+
+  mio_lparen ();
+  gfc_traverse_user_op (gfc_current_ns, write_operator);
+  mio_rparen ();
+  write_char ('\n');
+  write_char ('\n');
+
+  mio_lparen ();
+  write_generic (gfc_current_ns->sym_root);
+  mio_rparen ();
+  write_char ('\n');
+  write_char ('\n');
+
+  mio_lparen ();
+  write_blank_common ();
+  write_common (gfc_current_ns->common_root);
+  mio_rparen ();
+  write_char ('\n');
+  write_char ('\n');
+
+  mio_lparen ();
+  write_equiv ();
+  mio_rparen ();
+  write_char ('\n');
+  write_char ('\n');
+
+  mio_lparen ();
+  gfc_traverse_symtree (gfc_current_ns->sym_root,
+			write_derived_extensions);
+  mio_rparen ();
+  write_char ('\n');
+  write_char ('\n');
+
+  /* Write symbol information.  First we traverse all symbols in the
+     primary namespace, writing those that need to be written.
+     Sometimes writing one symbol will cause another to need to be
+     written.  A list of these symbols ends up on the write stack, and
+     we end by popping the bottom of the stack and writing the symbol
+     until the stack is empty.  */
+
+  mio_lparen ();
+
+  write_symbol0 (gfc_current_ns->sym_root);
+  while (write_symbol1 (pi_root))
+    /* Nothing.  */;
+
+  mio_rparen ();
+
+  write_char ('\n');
+  write_char ('\n');
+
+  mio_lparen ();
+  gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree);
+  mio_rparen ();
+}
+
+
+/* Read a CRC32 sum from the gzip trailer of a module file.  Returns
+   true on success, false on failure.  */
+
+static bool
+read_crc32_from_module_file (const char* filename, uLong* crc)
+{
+  FILE *file;
+  char buf[4];
+  unsigned int val;
+
+  /* Open the file in binary mode.  */
+  if ((file = fopen (filename, "rb")) == NULL)
+    return false;
+
+  /* The gzip crc32 value is found in the [END-8, END-4] bytes of the
+     file. See RFC 1952.  */
+  if (fseek (file, -8, SEEK_END) != 0)
+    {
+      fclose (file);
+      return false;
+    }
+
+  /* Read the CRC32.  */
+  if (fread (buf, 1, 4, file) != 4)
+    {
+      fclose (file);
+      return false;
+    }
+
+  /* Close the file.  */
+  fclose (file);
+
+  val = (buf[0] & 0xFF) + ((buf[1] & 0xFF) << 8) + ((buf[2] & 0xFF) << 16) 
+    + ((buf[3] & 0xFF) << 24);
+  *crc = val;
+  
+  /* For debugging, the CRC value printed in hexadecimal should match
+     the CRC printed by "zcat -l -v filename".
+     printf("CRC of file %s is %x\n", filename, val); */
+
+  return true;
+}
+
+
+/* Given module, dump it to disk.  If there was an error while
+   processing the module, dump_flag will be set to zero and we delete
+   the module file, even if it was already there.  */
+
+void
+gfc_dump_module (const char *name, int dump_flag)
+{
+  int n;
+  char *filename, *filename_tmp;
+  uLong crc, crc_old;
+
+  n = strlen (name) + strlen (MODULE_EXTENSION) + 1;
+  if (gfc_option.module_dir != NULL)
+    {
+      n += strlen (gfc_option.module_dir);
+      filename = (char *) alloca (n);
+      strcpy (filename, gfc_option.module_dir);
+      strcat (filename, name);
+    }
+  else
+    {
+      filename = (char *) alloca (n);
+      strcpy (filename, name);
+    }
+  strcat (filename, MODULE_EXTENSION);
+
+  /* Name of the temporary file used to write the module.  */
+  filename_tmp = (char *) alloca (n + 1);
+  strcpy (filename_tmp, filename);
+  strcat (filename_tmp, "0");
+
+  /* There was an error while processing the module.  We delete the
+     module file, even if it was already there.  */
+  if (!dump_flag)
+    {
+      unlink (filename);
+      return;
+    }
+
+  if (gfc_cpp_makedep ())
+    gfc_cpp_add_target (filename);
+
+  /* Write the module to the temporary file.  */
+  module_fp = gzopen (filename_tmp, "w");
+  if (module_fp == NULL)
+    gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
+		     filename_tmp, xstrerror (errno));
+
+  gzprintf (module_fp, "GFORTRAN module version '%s' created from %s\n",
+	    MOD_VERSION, gfc_source_file);
+
+  /* Write the module itself.  */
+  iomode = IO_OUTPUT;
+  module_name = gfc_get_string (name);
+
+  init_pi_tree ();
+
+  write_module ();
+
+  free_pi_tree (pi_root);
+  pi_root = NULL;
+
+  write_char ('\n');
+
+  if (gzclose (module_fp))
+    gfc_fatal_error ("Error writing module file '%s' for writing: %s",
+		     filename_tmp, xstrerror (errno));
+
+  /* Read the CRC32 from the gzip trailers of the module files and
+     compare.  */
+  if (!read_crc32_from_module_file (filename_tmp, &crc)
+      || !read_crc32_from_module_file (filename, &crc_old)
+      || crc_old != crc)
+    {
+      /* Module file have changed, replace the old one.  */
+      if (rename (filename_tmp, filename))
+	gfc_fatal_error ("Can't rename module file '%s' to '%s': %s",
+			 filename_tmp, filename, xstrerror (errno));
+    }
+  else
+    {
+      if (unlink (filename_tmp))
+	gfc_fatal_error ("Can't delete temporary module file '%s': %s",
+			 filename_tmp, xstrerror (errno));
+    }
+}
+
+
+static void
+create_intrinsic_function (const char *name, int id,
+			   const char *modname, intmod_id module,
+			   bool subroutine, gfc_symbol *result_type)
+{
+  gfc_intrinsic_sym *isym;
+  gfc_symtree *tmp_symtree;
+  gfc_symbol *sym;
+
+  tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
+  if (tmp_symtree)
+    {
+      if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
+        return;
+      gfc_error ("Symbol '%s' already declared", name);
+    }
+
+  gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
+  sym = tmp_symtree->n.sym;
+
+  if (subroutine)
+    {
+      gfc_isym_id isym_id = gfc_isym_id_by_intmod (module, id);
+      isym = gfc_intrinsic_subroutine_by_id (isym_id);
+      sym->attr.subroutine = 1;
+    }
+  else
+    {
+      gfc_isym_id isym_id = gfc_isym_id_by_intmod (module, id);
+      isym = gfc_intrinsic_function_by_id (isym_id);
+
+      sym->attr.function = 1;
+      if (result_type)
+	{
+	  sym->ts.type = BT_DERIVED;
+	  sym->ts.u.derived = result_type;
+	  sym->ts.is_c_interop = 1;
+	  isym->ts.f90_type = BT_VOID;
+	  isym->ts.type = BT_DERIVED;
+	  isym->ts.f90_type = BT_VOID;
+	  isym->ts.u.derived = result_type;
+	  isym->ts.is_c_interop = 1;
+	}
+    }
+  gcc_assert (isym);
+
+  sym->attr.flavor = FL_PROCEDURE;
+  sym->attr.intrinsic = 1;
+
+  sym->module = gfc_get_string (modname);
+  sym->attr.use_assoc = 1;
+  sym->from_intmod = module;
+  sym->intmod_sym_id = id;
+}
+
+
+/* Import the intrinsic ISO_C_BINDING module, generating symbols in
+   the current namespace for all named constants, pointer types, and
+   procedures in the module unless the only clause was used or a rename
+   list was provided.  */
+
+static void
+import_iso_c_binding_module (void)
+{
+  gfc_symbol *mod_sym = NULL, *return_type;
+  gfc_symtree *mod_symtree = NULL, *tmp_symtree;
+  gfc_symtree *c_ptr = NULL, *c_funptr = NULL;
+  const char *iso_c_module_name = "__iso_c_binding";
+  gfc_use_rename *u;
+  int i;
+  bool want_c_ptr = false, want_c_funptr = false;
+
+  /* Look only in the current namespace.  */
+  mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
+
+  if (mod_symtree == NULL)
+    {
+      /* symtree doesn't already exist in current namespace.  */
+      gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree,
+			false);
+      
+      if (mod_symtree != NULL)
+	mod_sym = mod_symtree->n.sym;
+      else
+	gfc_internal_error ("import_iso_c_binding_module(): Unable to "
+			    "create symbol for %s", iso_c_module_name);
+
+      mod_sym->attr.flavor = FL_MODULE;
+      mod_sym->attr.intrinsic = 1;
+      mod_sym->module = gfc_get_string (iso_c_module_name);
+      mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
+    }
+
+  /* Check whether C_PTR or C_FUNPTR are in the include list, if so, load it;
+     check also whether C_NULL_(FUN)PTR or C_(FUN)LOC are requested, which
+     need C_(FUN)PTR.  */
+  for (u = gfc_rename_list; u; u = u->next)
+    {
+      if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_PTR].name,
+		  u->use_name) == 0)
+        want_c_ptr = true;
+      else if (strcmp (c_interop_kinds_table[ISOCBINDING_LOC].name,
+		       u->use_name) == 0)
+        want_c_ptr = true;
+      else if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_FUNPTR].name,
+		       u->use_name) == 0)
+        want_c_funptr = true;
+      else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNLOC].name,
+		       u->use_name) == 0)
+        want_c_funptr = true;
+      else if (strcmp (c_interop_kinds_table[ISOCBINDING_PTR].name,
+                       u->use_name) == 0)
+	{
+	  c_ptr = generate_isocbinding_symbol (iso_c_module_name,
+                                               (iso_c_binding_symbol)
+							ISOCBINDING_PTR,
+                                               u->local_name[0] ? u->local_name
+                                                                : u->use_name,
+                                               NULL, false);
+	}
+      else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNPTR].name,
+                       u->use_name) == 0)
+	{
+	  c_funptr
+	     = generate_isocbinding_symbol (iso_c_module_name,
+					    (iso_c_binding_symbol)
+							ISOCBINDING_FUNPTR,
+					     u->local_name[0] ? u->local_name
+							      : u->use_name,
+					     NULL, false);
+	}
+    }
+
+  if ((want_c_ptr || !only_flag) && !c_ptr)
+    c_ptr = generate_isocbinding_symbol (iso_c_module_name,
+					 (iso_c_binding_symbol)
+							ISOCBINDING_PTR,
+					 NULL, NULL, only_flag);
+  if ((want_c_funptr || !only_flag) && !c_funptr)
+    c_funptr = generate_isocbinding_symbol (iso_c_module_name,
+					    (iso_c_binding_symbol)
+							ISOCBINDING_FUNPTR,
+					    NULL, NULL, only_flag);
+
+  /* Generate the symbols for the named constants representing
+     the kinds for intrinsic data types.  */
+  for (i = 0; i < ISOCBINDING_NUMBER; i++)
+    {
+      bool found = false;
+      for (u = gfc_rename_list; u; u = u->next)
+	if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
+	  {
+	    bool not_in_std;
+	    const char *name;
+	    u->found = 1;
+	    found = true;
+
+	    switch (i)
+	      {
+#define NAMED_FUNCTION(a,b,c,d) \
+	        case a: \
+		  not_in_std = (gfc_option.allow_std & d) == 0; \
+		  name = b; \
+		  break;
+#define NAMED_SUBROUTINE(a,b,c,d) \
+	        case a: \
+		  not_in_std = (gfc_option.allow_std & d) == 0; \
+		  name = b; \
+		  break;
+#define NAMED_INTCST(a,b,c,d) \
+	        case a: \
+		  not_in_std = (gfc_option.allow_std & d) == 0; \
+		  name = b; \
+		  break;
+#define NAMED_REALCST(a,b,c,d) \
+	        case a: \
+		  not_in_std = (gfc_option.allow_std & d) == 0; \
+		  name = b; \
+		  break;
+#define NAMED_CMPXCST(a,b,c,d) \
+	        case a: \
+		  not_in_std = (gfc_option.allow_std & d) == 0; \
+		  name = b; \
+		  break;
+#include "iso-c-binding.def"
+		default:
+		  not_in_std = false;
+		  name = "";
+	      }
+
+	    if (not_in_std)
+	      {
+		gfc_error ("The symbol '%s', referenced at %L, is not "
+			   "in the selected standard", name, &u->where);
+		continue;
+	      }
+
+	    switch (i)
+	      {
+#define NAMED_FUNCTION(a,b,c,d) \
+	        case a: \
+		  if (a == ISOCBINDING_LOC) \
+		    return_type = c_ptr->n.sym; \
+		  else if (a == ISOCBINDING_FUNLOC) \
+		    return_type = c_funptr->n.sym; \
+		  else \
+		    return_type = NULL; \
+		  create_intrinsic_function (u->local_name[0] \
+					     ? u->local_name : u->use_name, \
+					     a, iso_c_module_name, \
+					     INTMOD_ISO_C_BINDING, false, \
+					     return_type); \
+		  break;
+#define NAMED_SUBROUTINE(a,b,c,d) \
+	        case a: \
+		  create_intrinsic_function (u->local_name[0] ? u->local_name \
+							      : u->use_name, \
+                                             a, iso_c_module_name, \
+                                             INTMOD_ISO_C_BINDING, true, NULL); \
+		  break;
+#include "iso-c-binding.def"
+
+		case ISOCBINDING_PTR:
+		case ISOCBINDING_FUNPTR:
+		  /* Already handled above.  */
+		  break;
+		default:
+		  if (i == ISOCBINDING_NULL_PTR)
+		    tmp_symtree = c_ptr;
+		  else if (i == ISOCBINDING_NULL_FUNPTR)
+		    tmp_symtree = c_funptr;
+		  else
+		    tmp_symtree = NULL;
+		  generate_isocbinding_symbol (iso_c_module_name,
+					       (iso_c_binding_symbol) i,
+					       u->local_name[0]
+					       ? u->local_name : u->use_name,
+					       tmp_symtree, false);
+	      }
+	  }
+
+      if (!found && !only_flag)
+	{
+	  /* Skip, if the symbol is not in the enabled standard.  */
+	  switch (i)
+	    {
+#define NAMED_FUNCTION(a,b,c,d) \
+	      case a: \
+		if ((gfc_option.allow_std & d) == 0) \
+		  continue; \
+		break;
+#define NAMED_SUBROUTINE(a,b,c,d) \
+	      case a: \
+		if ((gfc_option.allow_std & d) == 0) \
+		  continue; \
+		break;
+#define NAMED_INTCST(a,b,c,d) \
+	      case a: \
+		if ((gfc_option.allow_std & d) == 0) \
+		  continue; \
+		break;
+#define NAMED_REALCST(a,b,c,d) \
+	      case a: \
+		if ((gfc_option.allow_std & d) == 0) \
+		  continue; \
+		break;
+#define NAMED_CMPXCST(a,b,c,d) \
+	      case a: \
+		if ((gfc_option.allow_std & d) == 0) \
+		  continue; \
+		break;
+#include "iso-c-binding.def"
+	      default:
+		; /* Not GFC_STD_* versioned. */
+	    }
+
+	  switch (i)
+	    {
+#define NAMED_FUNCTION(a,b,c,d) \
+	      case a: \
+		if (a == ISOCBINDING_LOC) \
+		  return_type = c_ptr->n.sym; \
+		else if (a == ISOCBINDING_FUNLOC) \
+		  return_type = c_funptr->n.sym; \
+		else \
+		  return_type = NULL; \
+		create_intrinsic_function (b, a, iso_c_module_name, \
+					   INTMOD_ISO_C_BINDING, false, \
+					   return_type); \
+		break;
+#define NAMED_SUBROUTINE(a,b,c,d) \
+	      case a: \
+		create_intrinsic_function (b, a, iso_c_module_name, \
+					   INTMOD_ISO_C_BINDING, true, NULL); \
+		  break;
+#include "iso-c-binding.def"
+
+	      case ISOCBINDING_PTR:
+	      case ISOCBINDING_FUNPTR:
+		/* Already handled above.  */
+		break;
+	      default:
+		if (i == ISOCBINDING_NULL_PTR)
+		  tmp_symtree = c_ptr;
+		else if (i == ISOCBINDING_NULL_FUNPTR)
+		  tmp_symtree = c_funptr;
+		else
+		  tmp_symtree = NULL;
+		generate_isocbinding_symbol (iso_c_module_name,
+					     (iso_c_binding_symbol) i, NULL,
+					     tmp_symtree, false);
+	    }
+	}
+   }
+
+   for (u = gfc_rename_list; u; u = u->next)
+     {
+      if (u->found)
+	continue;
+
+      gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
+		 "module ISO_C_BINDING", u->use_name, &u->where);
+     }
+}
+
+
+/* Add an integer named constant from a given module.  */
+
+static void
+create_int_parameter (const char *name, int value, const char *modname,
+		      intmod_id module, int id)
+{
+  gfc_symtree *tmp_symtree;
+  gfc_symbol *sym;
+
+  tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
+  if (tmp_symtree != NULL)
+    {
+      if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
+	return;
+      else
+	gfc_error ("Symbol '%s' already declared", name);
+    }
+
+  gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
+  sym = tmp_symtree->n.sym;
+
+  sym->module = gfc_get_string (modname);
+  sym->attr.flavor = FL_PARAMETER;
+  sym->ts.type = BT_INTEGER;
+  sym->ts.kind = gfc_default_integer_kind;
+  sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL, value);
+  sym->attr.use_assoc = 1;
+  sym->from_intmod = module;
+  sym->intmod_sym_id = id;
+}
+
+
+/* Value is already contained by the array constructor, but not
+   yet the shape.  */
+
+static void
+create_int_parameter_array (const char *name, int size, gfc_expr *value,
+			    const char *modname, intmod_id module, int id)
+{
+  gfc_symtree *tmp_symtree;
+  gfc_symbol *sym;
+
+  tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
+  if (tmp_symtree != NULL)
+    {
+      if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
+	return;
+      else
+	gfc_error ("Symbol '%s' already declared", name);
+    }
+
+  gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
+  sym = tmp_symtree->n.sym;
+
+  sym->module = gfc_get_string (modname);
+  sym->attr.flavor = FL_PARAMETER;
+  sym->ts.type = BT_INTEGER;
+  sym->ts.kind = gfc_default_integer_kind;
+  sym->attr.use_assoc = 1;
+  sym->from_intmod = module;
+  sym->intmod_sym_id = id;
+  sym->attr.dimension = 1;
+  sym->as = gfc_get_array_spec ();
+  sym->as->rank = 1;
+  sym->as->type = AS_EXPLICIT;
+  sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+  sym->as->upper[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, size); 
+
+  sym->value = value;
+  sym->value->shape = gfc_get_shape (1);
+  mpz_init_set_ui (sym->value->shape[0], size);
+}
+
+
+/* Add an derived type for a given module.  */
+
+static void
+create_derived_type (const char *name, const char *modname,
+		      intmod_id module, int id)
+{
+  gfc_symtree *tmp_symtree;
+  gfc_symbol *sym, *dt_sym;
+  gfc_interface *intr, *head;
+
+  tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
+  if (tmp_symtree != NULL)
+    {
+      if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
+	return;
+      else
+	gfc_error ("Symbol '%s' already declared", name);
+    }
+
+  gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
+  sym = tmp_symtree->n.sym;
+  sym->module = gfc_get_string (modname);
+  sym->from_intmod = module;
+  sym->intmod_sym_id = id;
+  sym->attr.flavor = FL_PROCEDURE;
+  sym->attr.function = 1;
+  sym->attr.generic = 1;
+
+  gfc_get_sym_tree (dt_upper_string (sym->name),
+		    gfc_current_ns, &tmp_symtree, false);
+  dt_sym = tmp_symtree->n.sym;
+  dt_sym->name = gfc_get_string (sym->name);
+  dt_sym->attr.flavor = FL_DERIVED;
+  dt_sym->attr.private_comp = 1;
+  dt_sym->attr.zero_comp = 1;
+  dt_sym->attr.use_assoc = 1;
+  dt_sym->module = gfc_get_string (modname);
+  dt_sym->from_intmod = module;
+  dt_sym->intmod_sym_id = id;
+
+  head = sym->generic;
+  intr = gfc_get_interface ();
+  intr->sym = dt_sym;
+  intr->where = gfc_current_locus;
+  intr->next = head;
+  sym->generic = intr;
+  sym->attr.if_source = IFSRC_DECL;
+}
+
+
+/* Read the contents of the module file into a temporary buffer.  */
+
+static void
+read_module_to_tmpbuf ()
+{
+  /* We don't know the uncompressed size, so enlarge the buffer as
+     needed.  */
+  int cursz = 4096;
+  int rsize = cursz;
+  int len = 0;
+
+  module_content = XNEWVEC (char, cursz);
+
+  while (1)
+    {
+      int nread = gzread (module_fp, module_content + len, rsize);
+      len += nread;
+      if (nread < rsize)
+	break;
+      cursz *= 2;
+      module_content = XRESIZEVEC (char, module_content, cursz);
+      rsize = cursz - len;
+    }
+
+  module_content = XRESIZEVEC (char, module_content, len + 1);
+  module_content[len] = '\0';
+
+  module_pos = 0;
+}
+
+
+/* USE the ISO_FORTRAN_ENV intrinsic module.  */
+
+static void
+use_iso_fortran_env_module (void)
+{
+  static char mod[] = "iso_fortran_env";
+  gfc_use_rename *u;
+  gfc_symbol *mod_sym;
+  gfc_symtree *mod_symtree;
+  gfc_expr *expr;
+  int i, j;
+
+  intmod_sym symbol[] = {
+#define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
+#define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
+#define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
+#define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
+#define NAMED_SUBROUTINE(a,b,c,d) { a, b, c, d },
+#include "iso-fortran-env.def"
+    { ISOFORTRANENV_INVALID, NULL, -1234, 0 } };
+
+  i = 0;
+#define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
+#include "iso-fortran-env.def"
+
+  /* Generate the symbol for the module itself.  */
+  mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod);
+  if (mod_symtree == NULL)
+    {
+      gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree, false);
+      gcc_assert (mod_symtree);
+      mod_sym = mod_symtree->n.sym;
+
+      mod_sym->attr.flavor = FL_MODULE;
+      mod_sym->attr.intrinsic = 1;
+      mod_sym->module = gfc_get_string (mod);
+      mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV;
+    }
+  else
+    if (!mod_symtree->n.sym->attr.intrinsic)
+      gfc_error ("Use of intrinsic module '%s' at %C conflicts with "
+		 "non-intrinsic module name used previously", mod);
+
+  /* Generate the symbols for the module integer named constants.  */
+
+  for (i = 0; symbol[i].name; i++)
+    {
+      bool found = false;
+      for (u = gfc_rename_list; u; u = u->next)
+	{
+	  if (strcmp (symbol[i].name, u->use_name) == 0)
+	    {
+	      found = true;
+	      u->found = 1;
+
+	      if (!gfc_notify_std (symbol[i].standard, "The symbol '%s', "
+				   "referenced at %L, is not in the selected "
+				   "standard", symbol[i].name, &u->where))
+	        continue;
+
+	      if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
+		  && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
+		gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named "
+				 "constant from intrinsic module "
+				 "ISO_FORTRAN_ENV at %L is incompatible with "
+				 "option %s", &u->where,
+				 gfc_option.flag_default_integer
+				   ? "-fdefault-integer-8"
+				   : "-fdefault-real-8");
+	      switch (symbol[i].id)
+		{
+#define NAMED_INTCST(a,b,c,d) \
+		case a:
+#include "iso-fortran-env.def"
+		  create_int_parameter (u->local_name[0] ? u->local_name
+							 : u->use_name,
+					symbol[i].value, mod,
+					INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
+		  break;
+
+#define NAMED_KINDARRAY(a,b,KINDS,d) \
+		case a:\
+		  expr = gfc_get_array_expr (BT_INTEGER, \
+					     gfc_default_integer_kind,\
+					     NULL); \
+		  for (j = 0; KINDS[j].kind != 0; j++) \
+		    gfc_constructor_append_expr (&expr->value.constructor, \
+			gfc_get_int_expr (gfc_default_integer_kind, NULL, \
+					  KINDS[j].kind), NULL); \
+		  create_int_parameter_array (u->local_name[0] ? u->local_name \
+							 : u->use_name, \
+					      j, expr, mod, \
+					      INTMOD_ISO_FORTRAN_ENV, \
+					      symbol[i].id); \
+		  break;
+#include "iso-fortran-env.def"
+
+#define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
+		case a:
+#include "iso-fortran-env.def"
+                  create_derived_type (u->local_name[0] ? u->local_name
+							: u->use_name,
+				       mod, INTMOD_ISO_FORTRAN_ENV,
+				       symbol[i].id);
+		  break;
+
+#define NAMED_FUNCTION(a,b,c,d) \
+		case a:
+#include "iso-fortran-env.def"
+		  create_intrinsic_function (u->local_name[0] ? u->local_name
+							      : u->use_name,
+					     symbol[i].id, mod,
+					     INTMOD_ISO_FORTRAN_ENV, false,
+					     NULL);
+		  break;
+
+		default:
+		  gcc_unreachable ();
+		}
+	    }
+	}
+
+      if (!found && !only_flag)
+	{
+	  if ((gfc_option.allow_std & symbol[i].standard) == 0)
+	    continue;
+
+	  if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
+	      && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
+	    gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
+			     "from intrinsic module ISO_FORTRAN_ENV at %C is "
+			     "incompatible with option %s",
+			     gfc_option.flag_default_integer
+				? "-fdefault-integer-8" : "-fdefault-real-8");
+
+	  switch (symbol[i].id)
+	    {
+#define NAMED_INTCST(a,b,c,d) \
+	    case a:
+#include "iso-fortran-env.def"
+	      create_int_parameter (symbol[i].name, symbol[i].value, mod,
+				    INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
+	      break;
+
+#define NAMED_KINDARRAY(a,b,KINDS,d) \
+	    case a:\
+	      expr = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, \
+					 NULL); \
+	      for (j = 0; KINDS[j].kind != 0; j++) \
+		gfc_constructor_append_expr (&expr->value.constructor, \
+                      gfc_get_int_expr (gfc_default_integer_kind, NULL, \
+                                        KINDS[j].kind), NULL); \
+            create_int_parameter_array (symbol[i].name, j, expr, mod, \
+                                        INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\
+            break;
+#include "iso-fortran-env.def"
+
+#define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
+	  case a:
+#include "iso-fortran-env.def"
+	    create_derived_type (symbol[i].name, mod, INTMOD_ISO_FORTRAN_ENV,
+				 symbol[i].id);
+	    break;
+
+#define NAMED_FUNCTION(a,b,c,d) \
+		case a:
+#include "iso-fortran-env.def"
+		  create_intrinsic_function (symbol[i].name, symbol[i].id, mod,
+					     INTMOD_ISO_FORTRAN_ENV, false,
+					     NULL);
+		  break;
+
+	  default:
+	    gcc_unreachable ();
+	  }
+	}
+    }
+
+  for (u = gfc_rename_list; u; u = u->next)
+    {
+      if (u->found)
+	continue;
+
+      gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
+		     "module ISO_FORTRAN_ENV", u->use_name, &u->where);
+    }
+}
+
+
+/* Process a USE directive.  */
+
+static void
+gfc_use_module (gfc_use_list *module)
+{
+  char *filename;
+  gfc_state_data *p;
+  int c, line, start;
+  gfc_symtree *mod_symtree;
+  gfc_use_list *use_stmt;
+  locus old_locus = gfc_current_locus;
+
+  gfc_current_locus = module->where;
+  module_name = module->module_name;
+  gfc_rename_list = module->rename;
+  only_flag = module->only_flag;
+
+  filename = XALLOCAVEC (char, strlen (module_name) + strlen (MODULE_EXTENSION)
+			       + 1);
+  strcpy (filename, module_name);
+  strcat (filename, MODULE_EXTENSION);
+
+  /* First, try to find an non-intrinsic module, unless the USE statement
+     specified that the module is intrinsic.  */
+  module_fp = NULL;
+  if (!module->intrinsic)
+    module_fp = gzopen_included_file (filename, true, true);
+
+  /* Then, see if it's an intrinsic one, unless the USE statement
+     specified that the module is non-intrinsic.  */
+  if (module_fp == NULL && !module->non_intrinsic)
+    {
+      if (strcmp (module_name, "iso_fortran_env") == 0
+	  && gfc_notify_std (GFC_STD_F2003, "ISO_FORTRAN_ENV "
+			     "intrinsic module at %C"))
+       {
+	 use_iso_fortran_env_module ();
+	 free_rename (module->rename);
+	 module->rename = NULL;
+	 gfc_current_locus = old_locus;
+	 module->intrinsic = true;
+	 return;
+       }
+
+      if (strcmp (module_name, "iso_c_binding") == 0
+	  && gfc_notify_std (GFC_STD_F2003, "ISO_C_BINDING module at %C"))
+	{
+	  import_iso_c_binding_module();
+	  free_rename (module->rename);
+	  module->rename = NULL;
+	  gfc_current_locus = old_locus;
+	  module->intrinsic = true;
+	  return;
+	}
+
+      module_fp = gzopen_intrinsic_module (filename);
+
+      if (module_fp == NULL && module->intrinsic)
+	gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
+			 module_name);
+    }
+
+  if (module_fp == NULL)
+    gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
+		     filename, xstrerror (errno));
+
+  /* Check that we haven't already USEd an intrinsic module with the
+     same name.  */
+
+  mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, module_name);
+  if (mod_symtree && mod_symtree->n.sym->attr.intrinsic)
+    gfc_error ("Use of non-intrinsic module '%s' at %C conflicts with "
+	       "intrinsic module name used previously", module_name);
+
+  iomode = IO_INPUT;
+  module_line = 1;
+  module_column = 1;
+  start = 0;
+
+  read_module_to_tmpbuf ();
+  gzclose (module_fp);
+
+  /* Skip the first line of the module, after checking that this is
+     a gfortran module file.  */
+  line = 0;
+  while (line < 1)
+    {
+      c = module_char ();
+      if (c == EOF)
+	bad_module ("Unexpected end of module");
+      if (start++ < 3)
+	parse_name (c);
+      if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0)
+	  || (start == 2 && strcmp (atom_name, " module") != 0))
+	gfc_fatal_error ("File '%s' opened at %C is not a GNU Fortran"
+			 " module file", filename);
+      if (start == 3)
+	{
+	  if (strcmp (atom_name, " version") != 0
+	      || module_char () != ' '
+	      || parse_atom () != ATOM_STRING
+	      || strcmp (atom_string, MOD_VERSION))
+	    gfc_fatal_error ("Cannot read module file '%s' opened at %C,"
+			     " because it was created by a different"
+			     " version of GNU Fortran", filename);
+
+	  free (atom_string);
+	}
+
+      if (c == '\n')
+	line++;
+    }
+
+  /* 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!");
+
+  init_pi_tree ();
+  init_true_name_tree ();
+
+  read_module ();
+
+  free_true_name (true_name_root);
+  true_name_root = NULL;
+
+  free_pi_tree (pi_root);
+  pi_root = NULL;
+
+  XDELETEVEC (module_content);
+  module_content = NULL;
+
+  use_stmt = gfc_get_use_list ();
+  *use_stmt = *module;
+  use_stmt->next = gfc_current_ns->use_stmts;
+  gfc_current_ns->use_stmts = use_stmt;
+
+  gfc_current_locus = old_locus;
+}
+
+
+/* Remove duplicated intrinsic operators from the rename list. */
+
+static void
+rename_list_remove_duplicate (gfc_use_rename *list)
+{
+  gfc_use_rename *seek, *last;
+
+  for (; list; list = list->next)
+    if (list->op != INTRINSIC_USER && list->op != INTRINSIC_NONE)
+      {
+	last = list;
+	for (seek = list->next; seek; seek = last->next)
+	  {
+	    if (list->op == seek->op)
+	      {
+		last->next = seek->next;
+		free (seek);
+	      }
+	    else
+	      last = seek;
+	  }
+      }
+}
+
+
+/* Process all USE directives.  */
+
+void
+gfc_use_modules (void)
+{
+  gfc_use_list *next, *seek, *last;
+
+  for (next = module_list; next; next = next->next)
+    {
+      bool non_intrinsic = next->non_intrinsic;
+      bool intrinsic = next->intrinsic;
+      bool neither = !non_intrinsic && !intrinsic;
+
+      for (seek = next->next; seek; seek = seek->next)
+	{
+	  if (next->module_name != seek->module_name)
+	    continue;
+
+	  if (seek->non_intrinsic)
+	    non_intrinsic = true;
+	  else if (seek->intrinsic)
+	    intrinsic = true;
+	  else
+	    neither = true;
+	}
+
+      if (intrinsic && neither && !non_intrinsic)
+	{
+	  char *filename;
+          FILE *fp;
+
+	  filename = XALLOCAVEC (char,
+				 strlen (next->module_name)
+				 + strlen (MODULE_EXTENSION) + 1);
+	  strcpy (filename, next->module_name);
+	  strcat (filename, MODULE_EXTENSION);
+	  fp = gfc_open_included_file (filename, true, true);
+	  if (fp != NULL)
+	    {
+	      non_intrinsic = true;
+	      fclose (fp);
+	    }
+	}
+
+      last = next;
+      for (seek = next->next; seek; seek = last->next)
+	{
+	  if (next->module_name != seek->module_name)
+	    {
+	      last = seek;
+	      continue;
+	    }
+
+	  if ((!next->intrinsic && !seek->intrinsic)
+	      || (next->intrinsic && seek->intrinsic)
+	      || !non_intrinsic)
+	    {
+	      if (!seek->only_flag)
+		next->only_flag = false;
+	      if (seek->rename)
+		{
+		  gfc_use_rename *r = seek->rename;
+		  while (r->next)
+		    r = r->next;
+		  r->next = next->rename;
+		  next->rename = seek->rename;
+		}
+	      last->next = seek->next; 
+	      free (seek);
+	    }
+	  else
+	    last = seek;
+	}
+    }
+
+  for (; module_list; module_list = next)
+    {
+      next = module_list->next;
+      rename_list_remove_duplicate (module_list->rename);
+      gfc_use_module (module_list);
+      free (module_list);
+    }
+  gfc_rename_list = NULL;
+}
+
+
+void
+gfc_free_use_stmts (gfc_use_list *use_stmts)
+{
+  gfc_use_list *next;
+  for (; use_stmts; use_stmts = next)
+    {
+      gfc_use_rename *next_rename;
+
+      for (; use_stmts->rename; use_stmts->rename = next_rename)
+	{
+	  next_rename = use_stmts->rename->next;
+	  free (use_stmts->rename);
+	}
+      next = use_stmts->next;
+      free (use_stmts);
+    }
+}
+
+
+void
+gfc_module_init_2 (void)
+{
+  last_atom = ATOM_LPAREN;
+  gfc_rename_list = NULL;
+  module_list = NULL;
+}
+
+
+void
+gfc_module_done_2 (void)
+{
+  free_rename (gfc_rename_list);
+  gfc_rename_list = NULL;
+}
diff --git a/gcc-4.9/gcc/fortran/openmp.c b/gcc-4.9/gcc/fortran/openmp.c
new file mode 100644
index 000000000..dff3ab1ad
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/openmp.c
@@ -0,0 +1,1762 @@
+/* OpenMP directive matching and resolving.
+   Copyright (C) 2005-2014 Free Software Foundation, Inc.
+   Contributed by Jakub Jelinek
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "flags.h"
+#include "gfortran.h"
+#include "match.h"
+#include "parse.h"
+#include "pointer-set.h"
+
+/* Match an end of OpenMP directive.  End of OpenMP directive is optional
+   whitespace, followed by '\n' or comment '!'.  */
+
+match
+gfc_match_omp_eos (void)
+{
+  locus old_loc;
+  char c;
+
+  old_loc = gfc_current_locus;
+  gfc_gobble_whitespace ();
+
+  c = gfc_next_ascii_char ();
+  switch (c)
+    {
+    case '!':
+      do
+	c = gfc_next_ascii_char ();
+      while (c != '\n');
+      /* Fall through */
+
+    case '\n':
+      return MATCH_YES;
+    }
+
+  gfc_current_locus = old_loc;
+  return MATCH_NO;
+}
+
+/* Free an omp_clauses structure.  */
+
+void
+gfc_free_omp_clauses (gfc_omp_clauses *c)
+{
+  int i;
+  if (c == NULL)
+    return;
+
+  gfc_free_expr (c->if_expr);
+  gfc_free_expr (c->final_expr);
+  gfc_free_expr (c->num_threads);
+  gfc_free_expr (c->chunk_size);
+  for (i = 0; i < OMP_LIST_NUM; i++)
+    gfc_free_namelist (c->lists[i]);
+  free (c);
+}
+
+/* Match a variable/common block list and construct a namelist from it.  */
+
+static match
+gfc_match_omp_variable_list (const char *str, gfc_namelist **list,
+			     bool allow_common)
+{
+  gfc_namelist *head, *tail, *p;
+  locus old_loc;
+  char n[GFC_MAX_SYMBOL_LEN+1];
+  gfc_symbol *sym;
+  match m;
+  gfc_symtree *st;
+
+  head = tail = NULL;
+
+  old_loc = gfc_current_locus;
+
+  m = gfc_match (str);
+  if (m != MATCH_YES)
+    return m;
+
+  for (;;)
+    {
+      m = gfc_match_symbol (&sym, 1);
+      switch (m)
+	{
+	case MATCH_YES:
+	  gfc_set_sym_referenced (sym);
+	  p = gfc_get_namelist ();
+	  if (head == NULL)
+	    head = tail = p;
+	  else
+	    {
+	      tail->next = p;
+	      tail = tail->next;
+	    }
+	  tail->sym = sym;
+	  goto next_item;
+	case MATCH_NO:
+	  break;
+	case MATCH_ERROR:
+	  goto cleanup;
+	}
+
+      if (!allow_common)
+	goto syntax;
+
+      m = gfc_match (" / %n /", n);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_NO)
+	goto syntax;
+
+      st = gfc_find_symtree (gfc_current_ns->common_root, n);
+      if (st == NULL)
+	{
+	  gfc_error ("COMMON block /%s/ not found at %C", n);
+	  goto cleanup;
+	}
+      for (sym = st->n.common->head; sym; sym = sym->common_next)
+	{
+	  gfc_set_sym_referenced (sym);
+	  p = gfc_get_namelist ();
+	  if (head == NULL)
+	    head = tail = p;
+	  else
+	    {
+	      tail->next = p;
+	      tail = tail->next;
+	    }
+	  tail->sym = sym;
+	}
+
+    next_item:
+      if (gfc_match_char (')') == MATCH_YES)
+	break;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+    }
+
+  while (*list)
+    list = &(*list)->next;
+
+  *list = head;
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in OpenMP variable list at %C");
+
+cleanup:
+  gfc_free_namelist (head);
+  gfc_current_locus = old_loc;
+  return MATCH_ERROR;
+}
+
+#define OMP_CLAUSE_PRIVATE	(1 << 0)
+#define OMP_CLAUSE_FIRSTPRIVATE	(1 << 1)
+#define OMP_CLAUSE_LASTPRIVATE	(1 << 2)
+#define OMP_CLAUSE_COPYPRIVATE	(1 << 3)
+#define OMP_CLAUSE_SHARED	(1 << 4)
+#define OMP_CLAUSE_COPYIN	(1 << 5)
+#define OMP_CLAUSE_REDUCTION	(1 << 6)
+#define OMP_CLAUSE_IF		(1 << 7)
+#define OMP_CLAUSE_NUM_THREADS	(1 << 8)
+#define OMP_CLAUSE_SCHEDULE	(1 << 9)
+#define OMP_CLAUSE_DEFAULT	(1 << 10)
+#define OMP_CLAUSE_ORDERED	(1 << 11)
+#define OMP_CLAUSE_COLLAPSE	(1 << 12)
+#define OMP_CLAUSE_UNTIED	(1 << 13)
+#define OMP_CLAUSE_FINAL	(1 << 14)
+#define OMP_CLAUSE_MERGEABLE	(1 << 15)
+
+/* Match OpenMP directive clauses. MASK is a bitmask of
+   clauses that are allowed for a particular directive.  */
+
+static match
+gfc_match_omp_clauses (gfc_omp_clauses **cp, int mask)
+{
+  gfc_omp_clauses *c = gfc_get_omp_clauses ();
+  locus old_loc;
+  bool needs_space = true, first = true;
+
+  *cp = NULL;
+  while (1)
+    {
+      if ((first || gfc_match_char (',') != MATCH_YES)
+	  && (needs_space && gfc_match_space () != MATCH_YES))
+	break;
+      needs_space = false;
+      first = false;
+      gfc_gobble_whitespace ();
+      if ((mask & OMP_CLAUSE_IF) && c->if_expr == NULL
+	  && gfc_match ("if ( %e )", &c->if_expr) == MATCH_YES)
+	continue;
+      if ((mask & OMP_CLAUSE_FINAL) && c->final_expr == NULL
+	  && gfc_match ("final ( %e )", &c->final_expr) == MATCH_YES)
+	continue;
+      if ((mask & OMP_CLAUSE_NUM_THREADS) && c->num_threads == NULL
+	  && gfc_match ("num_threads ( %e )", &c->num_threads) == MATCH_YES)
+	continue;
+      if ((mask & OMP_CLAUSE_PRIVATE)
+	  && gfc_match_omp_variable_list ("private (",
+					  &c->lists[OMP_LIST_PRIVATE], true)
+	     == MATCH_YES)
+	continue;
+      if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
+	  && gfc_match_omp_variable_list ("firstprivate (",
+					  &c->lists[OMP_LIST_FIRSTPRIVATE],
+					  true)
+	     == MATCH_YES)
+	continue;
+      if ((mask & OMP_CLAUSE_LASTPRIVATE)
+	  && gfc_match_omp_variable_list ("lastprivate (",
+					  &c->lists[OMP_LIST_LASTPRIVATE],
+					  true)
+	     == MATCH_YES)
+	continue;
+      if ((mask & OMP_CLAUSE_COPYPRIVATE)
+	  && gfc_match_omp_variable_list ("copyprivate (",
+					  &c->lists[OMP_LIST_COPYPRIVATE],
+					  true)
+	     == MATCH_YES)
+	continue;
+      if ((mask & OMP_CLAUSE_SHARED)
+	  && gfc_match_omp_variable_list ("shared (",
+					  &c->lists[OMP_LIST_SHARED], true)
+	     == MATCH_YES)
+	continue;
+      if ((mask & OMP_CLAUSE_COPYIN)
+	  && gfc_match_omp_variable_list ("copyin (",
+					  &c->lists[OMP_LIST_COPYIN], true)
+	     == MATCH_YES)
+	continue;
+      old_loc = gfc_current_locus;
+      if ((mask & OMP_CLAUSE_REDUCTION)
+	  && gfc_match ("reduction ( ") == MATCH_YES)
+	{
+	  int reduction = OMP_LIST_NUM;
+	  char buffer[GFC_MAX_SYMBOL_LEN + 1];
+	  if (gfc_match_char ('+') == MATCH_YES)
+	    reduction = OMP_LIST_PLUS;
+	  else if (gfc_match_char ('*') == MATCH_YES)
+	    reduction = OMP_LIST_MULT;
+	  else if (gfc_match_char ('-') == MATCH_YES)
+	    reduction = OMP_LIST_SUB;
+	  else if (gfc_match (".and.") == MATCH_YES)
+	    reduction = OMP_LIST_AND;
+	  else if (gfc_match (".or.") == MATCH_YES)
+	    reduction = OMP_LIST_OR;
+	  else if (gfc_match (".eqv.") == MATCH_YES)
+	    reduction = OMP_LIST_EQV;
+	  else if (gfc_match (".neqv.") == MATCH_YES)
+	    reduction = OMP_LIST_NEQV;
+	  else if (gfc_match_name (buffer) == MATCH_YES)
+	    {
+	      gfc_symbol *sym;
+	      const char *n = buffer;
+
+	      gfc_find_symbol (buffer, NULL, 1, &sym);
+	      if (sym != NULL)
+		{
+		  if (sym->attr.intrinsic)
+		    n = sym->name;
+		  else if ((sym->attr.flavor != FL_UNKNOWN
+			    && sym->attr.flavor != FL_PROCEDURE)
+			   || sym->attr.external
+			   || sym->attr.generic
+			   || sym->attr.entry
+			   || sym->attr.result
+			   || sym->attr.dummy
+			   || sym->attr.subroutine
+			   || sym->attr.pointer
+			   || sym->attr.target
+			   || sym->attr.cray_pointer
+			   || sym->attr.cray_pointee
+			   || (sym->attr.proc != PROC_UNKNOWN
+			       && sym->attr.proc != PROC_INTRINSIC)
+			   || sym->attr.if_source != IFSRC_UNKNOWN
+			   || sym == sym->ns->proc_name)
+		    {
+		      gfc_error_now ("%s is not INTRINSIC procedure name "
+				     "at %C", buffer);
+		      sym = NULL;
+		    }
+		  else
+		    n = sym->name;
+		}
+	      if (strcmp (n, "max") == 0)
+		reduction = OMP_LIST_MAX;
+	      else if (strcmp (n, "min") == 0)
+		reduction = OMP_LIST_MIN;
+	      else if (strcmp (n, "iand") == 0)
+		reduction = OMP_LIST_IAND;
+	      else if (strcmp (n, "ior") == 0)
+		reduction = OMP_LIST_IOR;
+	      else if (strcmp (n, "ieor") == 0)
+		reduction = OMP_LIST_IEOR;
+	      if (reduction != OMP_LIST_NUM
+		  && sym != NULL
+		  && ! sym->attr.intrinsic
+		  && ! sym->attr.use_assoc
+		  && ((sym->attr.flavor == FL_UNKNOWN
+		       && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
+		      || !gfc_add_intrinsic (&sym->attr, NULL)))
+		{
+		  gfc_free_omp_clauses (c);
+		  return MATCH_ERROR;
+		}
+	    }
+	  if (reduction != OMP_LIST_NUM
+	      && gfc_match_omp_variable_list (" :", &c->lists[reduction],
+					      false)
+		 == MATCH_YES)
+	    continue;
+	  else
+	    gfc_current_locus = old_loc;
+	}
+      if ((mask & OMP_CLAUSE_DEFAULT)
+	  && c->default_sharing == OMP_DEFAULT_UNKNOWN)
+	{
+	  if (gfc_match ("default ( shared )") == MATCH_YES)
+	    c->default_sharing = OMP_DEFAULT_SHARED;
+	  else if (gfc_match ("default ( private )") == MATCH_YES)
+	    c->default_sharing = OMP_DEFAULT_PRIVATE;
+	  else if (gfc_match ("default ( none )") == MATCH_YES)
+	    c->default_sharing = OMP_DEFAULT_NONE;
+	  else if (gfc_match ("default ( firstprivate )") == MATCH_YES)
+	    c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
+	  if (c->default_sharing != OMP_DEFAULT_UNKNOWN)
+	    continue;
+	}
+      old_loc = gfc_current_locus;
+      if ((mask & OMP_CLAUSE_SCHEDULE)
+	  && c->sched_kind == OMP_SCHED_NONE
+	  && gfc_match ("schedule ( ") == MATCH_YES)
+	{
+	  if (gfc_match ("static") == MATCH_YES)
+	    c->sched_kind = OMP_SCHED_STATIC;
+	  else if (gfc_match ("dynamic") == MATCH_YES)
+	    c->sched_kind = OMP_SCHED_DYNAMIC;
+	  else if (gfc_match ("guided") == MATCH_YES)
+	    c->sched_kind = OMP_SCHED_GUIDED;
+	  else if (gfc_match ("runtime") == MATCH_YES)
+	    c->sched_kind = OMP_SCHED_RUNTIME;
+	  else if (gfc_match ("auto") == MATCH_YES)
+	    c->sched_kind = OMP_SCHED_AUTO;
+	  if (c->sched_kind != OMP_SCHED_NONE)
+	    {
+	      match m = MATCH_NO;
+	      if (c->sched_kind != OMP_SCHED_RUNTIME
+		  && c->sched_kind != OMP_SCHED_AUTO)
+		m = gfc_match (" , %e )", &c->chunk_size);
+	      if (m != MATCH_YES)
+		m = gfc_match_char (')');
+	      if (m != MATCH_YES)
+		c->sched_kind = OMP_SCHED_NONE;
+	    }
+	  if (c->sched_kind != OMP_SCHED_NONE)
+	    continue;
+	  else
+	    gfc_current_locus = old_loc;
+	}
+      if ((mask & OMP_CLAUSE_ORDERED) && !c->ordered
+	  && gfc_match ("ordered") == MATCH_YES)
+	{
+	  c->ordered = needs_space = true;
+	  continue;
+	}
+      if ((mask & OMP_CLAUSE_UNTIED) && !c->untied
+	  && gfc_match ("untied") == MATCH_YES)
+	{
+	  c->untied = needs_space = true;
+	  continue;
+	}
+      if ((mask & OMP_CLAUSE_MERGEABLE) && !c->mergeable
+	  && gfc_match ("mergeable") == MATCH_YES)
+	{
+	  c->mergeable = needs_space = true;
+	  continue;
+	}
+      if ((mask & OMP_CLAUSE_COLLAPSE) && !c->collapse)
+	{
+	  gfc_expr *cexpr = NULL;
+	  match m = gfc_match ("collapse ( %e )", &cexpr);
+
+	  if (m == MATCH_YES)
+	    {
+	      int collapse;
+	      const char *p = gfc_extract_int (cexpr, &collapse);
+	      if (p)
+		{
+		  gfc_error_now (p);
+		  collapse = 1;
+		}
+	      else if (collapse <= 0)
+		{
+		  gfc_error_now ("COLLAPSE clause argument not"
+				 " constant positive integer at %C");
+		  collapse = 1;
+		}
+	      c->collapse = collapse;
+	      gfc_free_expr (cexpr);
+	      continue;
+	    }
+	}
+
+      break;
+    }
+
+  if (gfc_match_omp_eos () != MATCH_YES)
+    {
+      gfc_free_omp_clauses (c);
+      return MATCH_ERROR;
+    }
+
+  *cp = c;
+  return MATCH_YES;
+}
+
+#define OMP_PARALLEL_CLAUSES \
+  (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED	\
+   | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IF		\
+   | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT)
+#define OMP_DO_CLAUSES \
+  (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE				\
+   | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION			\
+   | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE)
+#define OMP_SECTIONS_CLAUSES \
+  (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE				\
+   | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
+#define OMP_TASK_CLAUSES \
+  (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED	\
+   | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED		\
+   | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE)
+
+match
+gfc_match_omp_parallel (void)
+{
+  gfc_omp_clauses *c;
+  if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES) != MATCH_YES)
+    return MATCH_ERROR;
+  new_st.op = EXEC_OMP_PARALLEL;
+  new_st.ext.omp_clauses = c;
+  return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_task (void)
+{
+  gfc_omp_clauses *c;
+  if (gfc_match_omp_clauses (&c, OMP_TASK_CLAUSES) != MATCH_YES)
+    return MATCH_ERROR;
+  new_st.op = EXEC_OMP_TASK;
+  new_st.ext.omp_clauses = c;
+  return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_taskwait (void)
+{
+  if (gfc_match_omp_eos () != MATCH_YES)
+    {
+      gfc_error ("Unexpected junk after TASKWAIT clause at %C");
+      return MATCH_ERROR;
+    }
+  new_st.op = EXEC_OMP_TASKWAIT;
+  new_st.ext.omp_clauses = NULL;
+  return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_taskyield (void)
+{
+  if (gfc_match_omp_eos () != MATCH_YES)
+    {
+      gfc_error ("Unexpected junk after TASKYIELD clause at %C");
+      return MATCH_ERROR;
+    }
+  new_st.op = EXEC_OMP_TASKYIELD;
+  new_st.ext.omp_clauses = NULL;
+  return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_critical (void)
+{
+  char n[GFC_MAX_SYMBOL_LEN+1];
+
+  if (gfc_match (" ( %n )", n) != MATCH_YES)
+    n[0] = '\0';
+  if (gfc_match_omp_eos () != MATCH_YES)
+    {
+      gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
+      return MATCH_ERROR;
+    }
+  new_st.op = EXEC_OMP_CRITICAL;
+  new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
+  return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_do (void)
+{
+  gfc_omp_clauses *c;
+  if (gfc_match_omp_clauses (&c, OMP_DO_CLAUSES) != MATCH_YES)
+    return MATCH_ERROR;
+  new_st.op = EXEC_OMP_DO;
+  new_st.ext.omp_clauses = c;
+  return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_flush (void)
+{
+  gfc_namelist *list = NULL;
+  gfc_match_omp_variable_list (" (", &list, true);
+  if (gfc_match_omp_eos () != MATCH_YES)
+    {
+      gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
+      gfc_free_namelist (list);
+      return MATCH_ERROR;
+    }
+  new_st.op = EXEC_OMP_FLUSH;
+  new_st.ext.omp_namelist = list;
+  return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_threadprivate (void)
+{
+  locus old_loc;
+  char n[GFC_MAX_SYMBOL_LEN+1];
+  gfc_symbol *sym;
+  match m;
+  gfc_symtree *st;
+
+  old_loc = gfc_current_locus;
+
+  m = gfc_match (" (");
+  if (m != MATCH_YES)
+    return m;
+
+  for (;;)
+    {
+      m = gfc_match_symbol (&sym, 0);
+      switch (m)
+	{
+	case MATCH_YES:
+	  if (sym->attr.in_common)
+	    gfc_error_now ("Threadprivate variable at %C is an element of "
+			   "a COMMON block");
+	  else if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at))
+	    goto cleanup;
+	  goto next_item;
+	case MATCH_NO:
+	  break;
+	case MATCH_ERROR:
+	  goto cleanup;
+	}
+
+      m = gfc_match (" / %n /", n);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_NO || n[0] == '\0')
+	goto syntax;
+
+      st = gfc_find_symtree (gfc_current_ns->common_root, n);
+      if (st == NULL)
+	{
+	  gfc_error ("COMMON block /%s/ not found at %C", n);
+	  goto cleanup;
+	}
+      st->n.common->threadprivate = 1;
+      for (sym = st->n.common->head; sym; sym = sym->common_next)
+	if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at))
+	  goto cleanup;
+
+    next_item:
+      if (gfc_match_char (')') == MATCH_YES)
+	break;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+    }
+
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C");
+
+cleanup:
+  gfc_current_locus = old_loc;
+  return MATCH_ERROR;
+}
+
+
+match
+gfc_match_omp_parallel_do (void)
+{
+  gfc_omp_clauses *c;
+  if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
+      != MATCH_YES)
+    return MATCH_ERROR;
+  new_st.op = EXEC_OMP_PARALLEL_DO;
+  new_st.ext.omp_clauses = c;
+  return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_parallel_sections (void)
+{
+  gfc_omp_clauses *c;
+  if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES)
+      != MATCH_YES)
+    return MATCH_ERROR;
+  new_st.op = EXEC_OMP_PARALLEL_SECTIONS;
+  new_st.ext.omp_clauses = c;
+  return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_parallel_workshare (void)
+{
+  gfc_omp_clauses *c;
+  if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES) != MATCH_YES)
+    return MATCH_ERROR;
+  new_st.op = EXEC_OMP_PARALLEL_WORKSHARE;
+  new_st.ext.omp_clauses = c;
+  return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_sections (void)
+{
+  gfc_omp_clauses *c;
+  if (gfc_match_omp_clauses (&c, OMP_SECTIONS_CLAUSES) != MATCH_YES)
+    return MATCH_ERROR;
+  new_st.op = EXEC_OMP_SECTIONS;
+  new_st.ext.omp_clauses = c;
+  return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_single (void)
+{
+  gfc_omp_clauses *c;
+  if (gfc_match_omp_clauses (&c, OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE)
+      != MATCH_YES)
+    return MATCH_ERROR;
+  new_st.op = EXEC_OMP_SINGLE;
+  new_st.ext.omp_clauses = c;
+  return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_workshare (void)
+{
+  if (gfc_match_omp_eos () != MATCH_YES)
+    {
+      gfc_error ("Unexpected junk after $OMP WORKSHARE statement at %C");
+      return MATCH_ERROR;
+    }
+  new_st.op = EXEC_OMP_WORKSHARE;
+  new_st.ext.omp_clauses = gfc_get_omp_clauses ();
+  return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_master (void)
+{
+  if (gfc_match_omp_eos () != MATCH_YES)
+    {
+      gfc_error ("Unexpected junk after $OMP MASTER statement at %C");
+      return MATCH_ERROR;
+    }
+  new_st.op = EXEC_OMP_MASTER;
+  new_st.ext.omp_clauses = NULL;
+  return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_ordered (void)
+{
+  if (gfc_match_omp_eos () != MATCH_YES)
+    {
+      gfc_error ("Unexpected junk after $OMP ORDERED statement at %C");
+      return MATCH_ERROR;
+    }
+  new_st.op = EXEC_OMP_ORDERED;
+  new_st.ext.omp_clauses = NULL;
+  return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_atomic (void)
+{
+  gfc_omp_atomic_op op = GFC_OMP_ATOMIC_UPDATE;
+  if (gfc_match ("% update") == MATCH_YES)
+    op = GFC_OMP_ATOMIC_UPDATE;
+  else if (gfc_match ("% read") == MATCH_YES)
+    op = GFC_OMP_ATOMIC_READ;
+  else if (gfc_match ("% write") == MATCH_YES)
+    op = GFC_OMP_ATOMIC_WRITE;
+  else if (gfc_match ("% capture") == MATCH_YES)
+    op = GFC_OMP_ATOMIC_CAPTURE;
+  if (gfc_match_omp_eos () != MATCH_YES)
+    {
+      gfc_error ("Unexpected junk after $OMP ATOMIC statement at %C");
+      return MATCH_ERROR;
+    }
+  new_st.op = EXEC_OMP_ATOMIC;
+  new_st.ext.omp_atomic = op;
+  return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_barrier (void)
+{
+  if (gfc_match_omp_eos () != MATCH_YES)
+    {
+      gfc_error ("Unexpected junk after $OMP BARRIER statement at %C");
+      return MATCH_ERROR;
+    }
+  new_st.op = EXEC_OMP_BARRIER;
+  new_st.ext.omp_clauses = NULL;
+  return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_end_nowait (void)
+{
+  bool nowait = false;
+  if (gfc_match ("% nowait") == MATCH_YES)
+    nowait = true;
+  if (gfc_match_omp_eos () != MATCH_YES)
+    {
+      gfc_error ("Unexpected junk after NOWAIT clause at %C");
+      return MATCH_ERROR;
+    }
+  new_st.op = EXEC_OMP_END_NOWAIT;
+  new_st.ext.omp_bool = nowait;
+  return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_end_single (void)
+{
+  gfc_omp_clauses *c;
+  if (gfc_match ("% nowait") == MATCH_YES)
+    {
+      new_st.op = EXEC_OMP_END_NOWAIT;
+      new_st.ext.omp_bool = true;
+      return MATCH_YES;
+    }
+  if (gfc_match_omp_clauses (&c, OMP_CLAUSE_COPYPRIVATE) != MATCH_YES)
+    return MATCH_ERROR;
+  new_st.op = EXEC_OMP_END_SINGLE;
+  new_st.ext.omp_clauses = c;
+  return MATCH_YES;
+}
+
+
+/* OpenMP directive resolving routines.  */
+
+static void
+resolve_omp_clauses (gfc_code *code)
+{
+  gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
+  gfc_namelist *n;
+  int list;
+  static const char *clause_names[]
+    = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
+	"COPYIN", "REDUCTION" };
+
+  if (omp_clauses == NULL)
+    return;
+
+  if (omp_clauses->if_expr)
+    {
+      gfc_expr *expr = omp_clauses->if_expr;
+      if (!gfc_resolve_expr (expr)
+	  || expr->ts.type != BT_LOGICAL || expr->rank != 0)
+	gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
+		   &expr->where);
+    }
+  if (omp_clauses->final_expr)
+    {
+      gfc_expr *expr = omp_clauses->final_expr;
+      if (!gfc_resolve_expr (expr)
+	  || expr->ts.type != BT_LOGICAL || expr->rank != 0)
+	gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression",
+		   &expr->where);
+    }
+  if (omp_clauses->num_threads)
+    {
+      gfc_expr *expr = omp_clauses->num_threads;
+      if (!gfc_resolve_expr (expr)
+	  || expr->ts.type != BT_INTEGER || expr->rank != 0)
+	gfc_error ("NUM_THREADS clause at %L requires a scalar "
+		   "INTEGER expression", &expr->where);
+    }
+  if (omp_clauses->chunk_size)
+    {
+      gfc_expr *expr = omp_clauses->chunk_size;
+      if (!gfc_resolve_expr (expr)
+	  || expr->ts.type != BT_INTEGER || expr->rank != 0)
+	gfc_error ("SCHEDULE clause's chunk_size at %L requires "
+		   "a scalar INTEGER expression", &expr->where);
+    }
+
+  /* Check that no symbol appears on multiple clauses, except that
+     a symbol can appear on both firstprivate and lastprivate.  */
+  for (list = 0; list < OMP_LIST_NUM; list++)
+    for (n = omp_clauses->lists[list]; n; n = n->next)
+      {
+	n->sym->mark = 0;
+	if (n->sym->attr.flavor == FL_VARIABLE || n->sym->attr.proc_pointer)
+	  continue;
+	if (n->sym->attr.flavor == FL_PROCEDURE
+	    && n->sym->result == n->sym
+	    && n->sym->attr.function)
+	  {
+	    if (gfc_current_ns->proc_name == n->sym
+		|| (gfc_current_ns->parent
+		    && gfc_current_ns->parent->proc_name == n->sym))
+	      continue;
+	    if (gfc_current_ns->proc_name->attr.entry_master)
+	      {
+		gfc_entry_list *el = gfc_current_ns->entries;
+		for (; el; el = el->next)
+		  if (el->sym == n->sym)
+		    break;
+		if (el)
+		  continue;
+	      }
+	    if (gfc_current_ns->parent
+		&& gfc_current_ns->parent->proc_name->attr.entry_master)
+	      {
+		gfc_entry_list *el = gfc_current_ns->parent->entries;
+		for (; el; el = el->next)
+		  if (el->sym == n->sym)
+		    break;
+		if (el)
+		  continue;
+	      }
+	  }
+	gfc_error ("Object '%s' is not a variable at %L", n->sym->name,
+		   &code->loc);
+      }
+
+  for (list = 0; list < OMP_LIST_NUM; list++)
+    if (list != OMP_LIST_FIRSTPRIVATE && list != OMP_LIST_LASTPRIVATE)
+      for (n = omp_clauses->lists[list]; n; n = n->next)
+	{
+	  if (n->sym->mark)
+	    gfc_error ("Symbol '%s' present on multiple clauses at %L",
+		       n->sym->name, &code->loc);
+	  else
+	    n->sym->mark = 1;
+	}
+
+  gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
+  for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++)
+    for (n = omp_clauses->lists[list]; n; n = n->next)
+      if (n->sym->mark)
+	{
+	  gfc_error ("Symbol '%s' present on multiple clauses at %L",
+		     n->sym->name, &code->loc);
+	  n->sym->mark = 0;
+	}
+
+  for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
+    {
+      if (n->sym->mark)
+	gfc_error ("Symbol '%s' present on multiple clauses at %L",
+		   n->sym->name, &code->loc);
+      else
+	n->sym->mark = 1;
+    }
+  for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
+    n->sym->mark = 0;
+
+  for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
+    {
+      if (n->sym->mark)
+	gfc_error ("Symbol '%s' present on multiple clauses at %L",
+		   n->sym->name, &code->loc);
+      else
+	n->sym->mark = 1;
+    }
+  for (list = 0; list < OMP_LIST_NUM; list++)
+    if ((n = omp_clauses->lists[list]) != NULL)
+      {
+	const char *name;
+
+	if (list < OMP_LIST_REDUCTION_FIRST)
+	  name = clause_names[list];
+	else if (list <= OMP_LIST_REDUCTION_LAST)
+	  name = clause_names[OMP_LIST_REDUCTION_FIRST];
+	else
+	  gcc_unreachable ();
+
+	switch (list)
+	  {
+	  case OMP_LIST_COPYIN:
+	    for (; n != NULL; n = n->next)
+	      {
+		if (!n->sym->attr.threadprivate)
+		  gfc_error ("Non-THREADPRIVATE object '%s' in COPYIN clause"
+			     " at %L", n->sym->name, &code->loc);
+		if (n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp)
+		  gfc_error ("COPYIN clause object '%s' at %L has ALLOCATABLE components",
+			     n->sym->name, &code->loc);
+	      }
+	    break;
+	  case OMP_LIST_COPYPRIVATE:
+	    for (; n != NULL; n = n->next)
+	      {
+		if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
+		  gfc_error ("Assumed size array '%s' in COPYPRIVATE clause "
+			     "at %L", n->sym->name, &code->loc);
+		if (n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp)
+		  gfc_error ("COPYPRIVATE clause object '%s' at %L has ALLOCATABLE components",
+			     n->sym->name, &code->loc);
+	      }
+	    break;
+	  case OMP_LIST_SHARED:
+	    for (; n != NULL; n = n->next)
+	      {
+		if (n->sym->attr.threadprivate)
+		  gfc_error ("THREADPRIVATE object '%s' in SHARED clause at "
+			     "%L", n->sym->name, &code->loc);
+		if (n->sym->attr.cray_pointee)
+		  gfc_error ("Cray pointee '%s' in SHARED clause at %L",
+			    n->sym->name, &code->loc);
+	      }
+	    break;
+	  default:
+	    for (; n != NULL; n = n->next)
+	      {
+		if (n->sym->attr.threadprivate)
+		  gfc_error ("THREADPRIVATE object '%s' in %s clause at %L",
+			     n->sym->name, name, &code->loc);
+		if (n->sym->attr.cray_pointee)
+		  gfc_error ("Cray pointee '%s' in %s clause at %L",
+			    n->sym->name, name, &code->loc);
+		if (list != OMP_LIST_PRIVATE)
+		  {
+		    if (n->sym->attr.pointer
+			&& list >= OMP_LIST_REDUCTION_FIRST
+			&& list <= OMP_LIST_REDUCTION_LAST)
+		      gfc_error ("POINTER object '%s' in %s clause at %L",
+				 n->sym->name, name, &code->loc);
+		    /* Variables in REDUCTION-clauses must be of intrinsic type (flagged below).  */
+		    if ((list < OMP_LIST_REDUCTION_FIRST || list > OMP_LIST_REDUCTION_LAST)
+			 && n->sym->ts.type == BT_DERIVED
+			 && n->sym->ts.u.derived->attr.alloc_comp)
+		      gfc_error ("%s clause object '%s' has ALLOCATABLE components at %L",
+				 name, n->sym->name, &code->loc);
+		    if (n->sym->attr.cray_pointer
+			&& list >= OMP_LIST_REDUCTION_FIRST
+			&& list <= OMP_LIST_REDUCTION_LAST)
+		      gfc_error ("Cray pointer '%s' in %s clause at %L",
+				 n->sym->name, name, &code->loc);
+		  }
+		if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
+		  gfc_error ("Assumed size array '%s' in %s clause at %L",
+			     n->sym->name, name, &code->loc);
+		if (n->sym->attr.in_namelist
+		    && (list < OMP_LIST_REDUCTION_FIRST
+			|| list > OMP_LIST_REDUCTION_LAST))
+		  gfc_error ("Variable '%s' in %s clause is used in "
+			     "NAMELIST statement at %L",
+			     n->sym->name, name, &code->loc);
+		switch (list)
+		  {
+		  case OMP_LIST_PLUS:
+		  case OMP_LIST_MULT:
+		  case OMP_LIST_SUB:
+		    if (!gfc_numeric_ts (&n->sym->ts))
+		      gfc_error ("%c REDUCTION variable '%s' at %L must be of numeric type, got %s",
+				 list == OMP_LIST_PLUS ? '+'
+				 : list == OMP_LIST_MULT ? '*' : '-',
+				 n->sym->name, &code->loc,
+				 gfc_typename (&n->sym->ts));
+		    break;
+		  case OMP_LIST_AND:
+		  case OMP_LIST_OR:
+		  case OMP_LIST_EQV:
+		  case OMP_LIST_NEQV:
+		    if (n->sym->ts.type != BT_LOGICAL)
+		      gfc_error ("%s REDUCTION variable '%s' must be LOGICAL "
+				 "at %L",
+				 list == OMP_LIST_AND ? ".AND."
+				 : list == OMP_LIST_OR ? ".OR."
+				 : list == OMP_LIST_EQV ? ".EQV." : ".NEQV.",
+				 n->sym->name, &code->loc);
+		    break;
+		  case OMP_LIST_MAX:
+		  case OMP_LIST_MIN:
+		    if (n->sym->ts.type != BT_INTEGER
+			&& n->sym->ts.type != BT_REAL)
+		      gfc_error ("%s REDUCTION variable '%s' must be "
+				 "INTEGER or REAL at %L",
+				 list == OMP_LIST_MAX ? "MAX" : "MIN",
+				 n->sym->name, &code->loc);
+		    break;
+		  case OMP_LIST_IAND:
+		  case OMP_LIST_IOR:
+		  case OMP_LIST_IEOR:
+		    if (n->sym->ts.type != BT_INTEGER)
+		      gfc_error ("%s REDUCTION variable '%s' must be INTEGER "
+				 "at %L",
+				 list == OMP_LIST_IAND ? "IAND"
+				 : list == OMP_LIST_MULT ? "IOR" : "IEOR",
+				 n->sym->name, &code->loc);
+		    break;
+		  /* Workaround for PR middle-end/26316, nothing really needs
+		     to be done here for OMP_LIST_PRIVATE.  */
+		  case OMP_LIST_PRIVATE:
+		    gcc_assert (code->op != EXEC_NOP);
+		  default:
+		    break;
+		  }
+	      }
+	    break;
+	  }
+      }
+}
+
+
+/* Return true if SYM is ever referenced in EXPR except in the SE node.  */
+
+static bool
+expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
+{
+  gfc_actual_arglist *arg;
+  if (e == NULL || e == se)
+    return false;
+  switch (e->expr_type)
+    {
+    case EXPR_CONSTANT:
+    case EXPR_NULL:
+    case EXPR_VARIABLE:
+    case EXPR_STRUCTURE:
+    case EXPR_ARRAY:
+      if (e->symtree != NULL
+	  && e->symtree->n.sym == s)
+	return true;
+      return false;
+    case EXPR_SUBSTRING:
+      if (e->ref != NULL
+	  && (expr_references_sym (e->ref->u.ss.start, s, se)
+	      || expr_references_sym (e->ref->u.ss.end, s, se)))
+	return true;
+      return false;
+    case EXPR_OP:
+      if (expr_references_sym (e->value.op.op2, s, se))
+	return true;
+      return expr_references_sym (e->value.op.op1, s, se);
+    case EXPR_FUNCTION:
+      for (arg = e->value.function.actual; arg; arg = arg->next)
+	if (expr_references_sym (arg->expr, s, se))
+	  return true;
+      return false;
+    default:
+      gcc_unreachable ();
+    }
+}
+
+
+/* If EXPR is a conversion function that widens the type
+   if WIDENING is true or narrows the type if WIDENING is false,
+   return the inner expression, otherwise return NULL.  */
+
+static gfc_expr *
+is_conversion (gfc_expr *expr, bool widening)
+{
+  gfc_typespec *ts1, *ts2;
+
+  if (expr->expr_type != EXPR_FUNCTION
+      || expr->value.function.isym == NULL
+      || expr->value.function.esym != NULL
+      || expr->value.function.isym->id != GFC_ISYM_CONVERSION)
+    return NULL;
+
+  if (widening)
+    {
+      ts1 = &expr->ts;
+      ts2 = &expr->value.function.actual->expr->ts;
+    }
+  else
+    {
+      ts1 = &expr->value.function.actual->expr->ts;
+      ts2 = &expr->ts;
+    }
+
+  if (ts1->type > ts2->type
+      || (ts1->type == ts2->type && ts1->kind > ts2->kind))
+    return expr->value.function.actual->expr;
+
+  return NULL;
+}
+
+
+static void
+resolve_omp_atomic (gfc_code *code)
+{
+  gfc_code *atomic_code = code;
+  gfc_symbol *var;
+  gfc_expr *expr2, *expr2_tmp;
+
+  code = code->block->next;
+  gcc_assert (code->op == EXEC_ASSIGN);
+  gcc_assert ((atomic_code->ext.omp_atomic != GFC_OMP_ATOMIC_CAPTURE
+	       && code->next == NULL)
+	      || (atomic_code->ext.omp_atomic == GFC_OMP_ATOMIC_CAPTURE
+		  && code->next != NULL
+		  && code->next->op == EXEC_ASSIGN
+		  && code->next->next == NULL));
+
+  if (code->expr1->expr_type != EXPR_VARIABLE
+      || code->expr1->symtree == NULL
+      || code->expr1->rank != 0
+      || (code->expr1->ts.type != BT_INTEGER
+	  && code->expr1->ts.type != BT_REAL
+	  && code->expr1->ts.type != BT_COMPLEX
+	  && code->expr1->ts.type != BT_LOGICAL))
+    {
+      gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
+		 "intrinsic type at %L", &code->loc);
+      return;
+    }
+
+  var = code->expr1->symtree->n.sym;
+  expr2 = is_conversion (code->expr2, false);
+  if (expr2 == NULL)
+    {
+      if (atomic_code->ext.omp_atomic == GFC_OMP_ATOMIC_READ
+	  || atomic_code->ext.omp_atomic == GFC_OMP_ATOMIC_WRITE)
+	expr2 = is_conversion (code->expr2, true);
+      if (expr2 == NULL)
+	expr2 = code->expr2;
+    }
+
+  switch (atomic_code->ext.omp_atomic)
+    {
+    case GFC_OMP_ATOMIC_READ:
+      if (expr2->expr_type != EXPR_VARIABLE
+	  || expr2->symtree == NULL
+	  || expr2->rank != 0
+	  || (expr2->ts.type != BT_INTEGER
+	      && expr2->ts.type != BT_REAL
+	      && expr2->ts.type != BT_COMPLEX
+	      && expr2->ts.type != BT_LOGICAL))
+	gfc_error ("!$OMP ATOMIC READ statement must read from a scalar "
+		   "variable of intrinsic type at %L", &expr2->where);
+      return;
+    case GFC_OMP_ATOMIC_WRITE:
+      if (expr2->rank != 0 || expr_references_sym (code->expr2, var, NULL))
+	gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr "
+		   "must be scalar and cannot reference var at %L",
+		   &expr2->where);
+      return;
+    case GFC_OMP_ATOMIC_CAPTURE:
+      expr2_tmp = expr2;
+      if (expr2 == code->expr2)
+	{
+	  expr2_tmp = is_conversion (code->expr2, true);
+	  if (expr2_tmp == NULL)
+	    expr2_tmp = expr2;
+	}
+      if (expr2_tmp->expr_type == EXPR_VARIABLE)
+	{
+	  if (expr2_tmp->symtree == NULL
+	      || expr2_tmp->rank != 0
+	      || (expr2_tmp->ts.type != BT_INTEGER
+		  && expr2_tmp->ts.type != BT_REAL
+		  && expr2_tmp->ts.type != BT_COMPLEX
+		  && expr2_tmp->ts.type != BT_LOGICAL)
+	      || expr2_tmp->symtree->n.sym == var)
+	    {
+	      gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read from "
+			 "a scalar variable of intrinsic type at %L",
+			 &expr2_tmp->where);
+	      return;
+	    }
+	  var = expr2_tmp->symtree->n.sym;
+	  code = code->next;
+	  if (code->expr1->expr_type != EXPR_VARIABLE
+	      || code->expr1->symtree == NULL
+	      || code->expr1->rank != 0
+	      || (code->expr1->ts.type != BT_INTEGER
+		  && code->expr1->ts.type != BT_REAL
+		  && code->expr1->ts.type != BT_COMPLEX
+		  && code->expr1->ts.type != BT_LOGICAL))
+	    {
+	      gfc_error ("!$OMP ATOMIC CAPTURE update statement must set "
+			 "a scalar variable of intrinsic type at %L",
+			 &code->expr1->where);
+	      return;
+	    }
+	  if (code->expr1->symtree->n.sym != var)
+	    {
+	      gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
+			 "different variable than update statement writes "
+			 "into at %L", &code->expr1->where);
+	      return;
+	    }
+	  expr2 = is_conversion (code->expr2, false);
+	  if (expr2 == NULL)
+	    expr2 = code->expr2;
+	}
+      break;
+    default:
+      break;
+    }
+
+  if (expr2->expr_type == EXPR_OP)
+    {
+      gfc_expr *v = NULL, *e, *c;
+      gfc_intrinsic_op op = expr2->value.op.op;
+      gfc_intrinsic_op alt_op = INTRINSIC_NONE;
+
+      switch (op)
+	{
+	case INTRINSIC_PLUS:
+	  alt_op = INTRINSIC_MINUS;
+	  break;
+	case INTRINSIC_TIMES:
+	  alt_op = INTRINSIC_DIVIDE;
+	  break;
+	case INTRINSIC_MINUS:
+	  alt_op = INTRINSIC_PLUS;
+	  break;
+	case INTRINSIC_DIVIDE:
+	  alt_op = INTRINSIC_TIMES;
+	  break;
+	case INTRINSIC_AND:
+	case INTRINSIC_OR:
+	  break;
+	case INTRINSIC_EQV:
+	  alt_op = INTRINSIC_NEQV;
+	  break;
+	case INTRINSIC_NEQV:
+	  alt_op = INTRINSIC_EQV;
+	  break;
+	default:
+	  gfc_error ("!$OMP ATOMIC assignment operator must be binary "
+		     "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
+		     &expr2->where);
+	  return;
+	}
+
+      /* Check for var = var op expr resp. var = expr op var where
+	 expr doesn't reference var and var op expr is mathematically
+	 equivalent to var op (expr) resp. expr op var equivalent to
+	 (expr) op var.  We rely here on the fact that the matcher
+	 for x op1 y op2 z where op1 and op2 have equal precedence
+	 returns (x op1 y) op2 z.  */
+      e = expr2->value.op.op2;
+      if (e->expr_type == EXPR_VARIABLE
+	  && e->symtree != NULL
+	  && e->symtree->n.sym == var)
+	v = e;
+      else if ((c = is_conversion (e, true)) != NULL
+	       && c->expr_type == EXPR_VARIABLE
+	       && c->symtree != NULL
+	       && c->symtree->n.sym == var)
+	v = c;
+      else
+	{
+	  gfc_expr **p = NULL, **q;
+	  for (q = &expr2->value.op.op1; (e = *q) != NULL; )
+	    if (e->expr_type == EXPR_VARIABLE
+		&& e->symtree != NULL
+		&& e->symtree->n.sym == var)
+	      {
+		v = e;
+		break;
+	      }
+	    else if ((c = is_conversion (e, true)) != NULL)
+	      q = &e->value.function.actual->expr;
+	    else if (e->expr_type != EXPR_OP
+		     || (e->value.op.op != op
+			 && e->value.op.op != alt_op)
+		     || e->rank != 0)
+	      break;
+	    else
+	      {
+		p = q;
+		q = &e->value.op.op1;
+	      }
+
+	  if (v == NULL)
+	    {
+	      gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
+			 "or var = expr op var at %L", &expr2->where);
+	      return;
+	    }
+
+	  if (p != NULL)
+	    {
+	      e = *p;
+	      switch (e->value.op.op)
+		{
+		case INTRINSIC_MINUS:
+		case INTRINSIC_DIVIDE:
+		case INTRINSIC_EQV:
+		case INTRINSIC_NEQV:
+		  gfc_error ("!$OMP ATOMIC var = var op expr not "
+			     "mathematically equivalent to var = var op "
+			     "(expr) at %L", &expr2->where);
+		  break;
+		default:
+		  break;
+		}
+
+	      /* Canonicalize into var = var op (expr).  */
+	      *p = e->value.op.op2;
+	      e->value.op.op2 = expr2;
+	      e->ts = expr2->ts;
+	      if (code->expr2 == expr2)
+		code->expr2 = expr2 = e;
+	      else
+		code->expr2->value.function.actual->expr = expr2 = e;
+
+	      if (!gfc_compare_types (&expr2->value.op.op1->ts, &expr2->ts))
+		{
+		  for (p = &expr2->value.op.op1; *p != v;
+		       p = &(*p)->value.function.actual->expr)
+		    ;
+		  *p = NULL;
+		  gfc_free_expr (expr2->value.op.op1);
+		  expr2->value.op.op1 = v;
+		  gfc_convert_type (v, &expr2->ts, 2);
+		}
+	    }
+	}
+
+      if (e->rank != 0 || expr_references_sym (code->expr2, var, v))
+	{
+	  gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
+		     "must be scalar and cannot reference var at %L",
+		     &expr2->where);
+	  return;
+	}
+    }
+  else if (expr2->expr_type == EXPR_FUNCTION
+	   && expr2->value.function.isym != NULL
+	   && expr2->value.function.esym == NULL
+	   && expr2->value.function.actual != NULL
+	   && expr2->value.function.actual->next != NULL)
+    {
+      gfc_actual_arglist *arg, *var_arg;
+
+      switch (expr2->value.function.isym->id)
+	{
+	case GFC_ISYM_MIN:
+	case GFC_ISYM_MAX:
+	  break;
+	case GFC_ISYM_IAND:
+	case GFC_ISYM_IOR:
+	case GFC_ISYM_IEOR:
+	  if (expr2->value.function.actual->next->next != NULL)
+	    {
+	      gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
+			 "or IEOR must have two arguments at %L",
+			 &expr2->where);
+	      return;
+	    }
+	  break;
+	default:
+	  gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
+		     "MIN, MAX, IAND, IOR or IEOR at %L",
+		     &expr2->where);
+	  return;
+	}
+
+      var_arg = NULL;
+      for (arg = expr2->value.function.actual; arg; arg = arg->next)
+	{
+	  if ((arg == expr2->value.function.actual
+	       || (var_arg == NULL && arg->next == NULL))
+	      && arg->expr->expr_type == EXPR_VARIABLE
+	      && arg->expr->symtree != NULL
+	      && arg->expr->symtree->n.sym == var)
+	    var_arg = arg;
+	  else if (expr_references_sym (arg->expr, var, NULL))
+	    gfc_error ("!$OMP ATOMIC intrinsic arguments except one must not "
+		       "reference '%s' at %L", var->name, &arg->expr->where);
+	  if (arg->expr->rank != 0)
+	    gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
+		       "at %L", &arg->expr->where);
+	}
+
+      if (var_arg == NULL)
+	{
+	  gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
+		     "be '%s' at %L", var->name, &expr2->where);
+	  return;
+	}
+
+      if (var_arg != expr2->value.function.actual)
+	{
+	  /* Canonicalize, so that var comes first.  */
+	  gcc_assert (var_arg->next == NULL);
+	  for (arg = expr2->value.function.actual;
+	       arg->next != var_arg; arg = arg->next)
+	    ;
+	  var_arg->next = expr2->value.function.actual;
+	  expr2->value.function.actual = var_arg;
+	  arg->next = NULL;
+	}
+    }
+  else
+    gfc_error ("!$OMP ATOMIC assignment must have an operator or intrinsic "
+	       "on right hand side at %L", &expr2->where);
+
+  if (atomic_code->ext.omp_atomic == GFC_OMP_ATOMIC_CAPTURE && code->next)
+    {
+      code = code->next;
+      if (code->expr1->expr_type != EXPR_VARIABLE
+	  || code->expr1->symtree == NULL
+	  || code->expr1->rank != 0
+	  || (code->expr1->ts.type != BT_INTEGER
+	      && code->expr1->ts.type != BT_REAL
+	      && code->expr1->ts.type != BT_COMPLEX
+	      && code->expr1->ts.type != BT_LOGICAL))
+	{
+	  gfc_error ("!$OMP ATOMIC CAPTURE capture statement must set "
+		     "a scalar variable of intrinsic type at %L",
+		     &code->expr1->where);
+	  return;
+	}
+
+      expr2 = is_conversion (code->expr2, false);
+      if (expr2 == NULL)
+	{
+	  expr2 = is_conversion (code->expr2, true);
+	  if (expr2 == NULL)
+	    expr2 = code->expr2;
+	}
+
+      if (expr2->expr_type != EXPR_VARIABLE
+	  || expr2->symtree == NULL
+	  || expr2->rank != 0
+	  || (expr2->ts.type != BT_INTEGER
+	      && expr2->ts.type != BT_REAL
+	      && expr2->ts.type != BT_COMPLEX
+	      && expr2->ts.type != BT_LOGICAL))
+	{
+	  gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read "
+		     "from a scalar variable of intrinsic type at %L",
+		     &expr2->where);
+	  return;
+	}
+      if (expr2->symtree->n.sym != var)
+	{
+	  gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
+		     "different variable than update statement writes "
+		     "into at %L", &expr2->where);
+	  return;
+	}
+    }
+}
+
+
+struct omp_context
+{
+  gfc_code *code;
+  struct pointer_set_t *sharing_clauses;
+  struct pointer_set_t *private_iterators;
+  struct omp_context *previous;
+} *omp_current_ctx;
+static gfc_code *omp_current_do_code;
+static int omp_current_do_collapse;
+
+void
+gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
+{
+  if (code->block->next && code->block->next->op == EXEC_DO)
+    {
+      int i;
+      gfc_code *c;
+
+      omp_current_do_code = code->block->next;
+      omp_current_do_collapse = code->ext.omp_clauses->collapse;
+      for (i = 1, c = omp_current_do_code; i < omp_current_do_collapse; i++)
+	{
+	  c = c->block;
+	  if (c->op != EXEC_DO || c->next == NULL)
+	    break;
+	  c = c->next;
+	  if (c->op != EXEC_DO)
+	    break;
+	}
+      if (i < omp_current_do_collapse || omp_current_do_collapse <= 0)
+	omp_current_do_collapse = 1;
+    }
+  gfc_resolve_blocks (code->block, ns);
+  omp_current_do_collapse = 0;
+  omp_current_do_code = NULL;
+}
+
+
+void
+gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
+{
+  struct omp_context ctx;
+  gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
+  gfc_namelist *n;
+  int list;
+
+  ctx.code = code;
+  ctx.sharing_clauses = pointer_set_create ();
+  ctx.private_iterators = pointer_set_create ();
+  ctx.previous = omp_current_ctx;
+  omp_current_ctx = &ctx;
+
+  for (list = 0; list < OMP_LIST_NUM; list++)
+    for (n = omp_clauses->lists[list]; n; n = n->next)
+      pointer_set_insert (ctx.sharing_clauses, n->sym);
+
+  if (code->op == EXEC_OMP_PARALLEL_DO)
+    gfc_resolve_omp_do_blocks (code, ns);
+  else
+    gfc_resolve_blocks (code->block, ns);
+
+  omp_current_ctx = ctx.previous;
+  pointer_set_destroy (ctx.sharing_clauses);
+  pointer_set_destroy (ctx.private_iterators);
+}
+
+
+/* Save and clear openmp.c private state.  */
+
+void
+gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *state)
+{
+  state->ptrs[0] = omp_current_ctx;
+  state->ptrs[1] = omp_current_do_code;
+  state->ints[0] = omp_current_do_collapse;
+  omp_current_ctx = NULL;
+  omp_current_do_code = NULL;
+  omp_current_do_collapse = 0;
+}
+
+
+/* Restore openmp.c private state from the saved state.  */
+
+void
+gfc_omp_restore_state (struct gfc_omp_saved_state *state)
+{
+  omp_current_ctx = (struct omp_context *) state->ptrs[0];
+  omp_current_do_code = (gfc_code *) state->ptrs[1];
+  omp_current_do_collapse = state->ints[0];
+}
+
+
+/* Note a DO iterator variable.  This is special in !$omp parallel
+   construct, where they are predetermined private.  */
+
+void
+gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym)
+{
+  int i = omp_current_do_collapse;
+  gfc_code *c = omp_current_do_code;
+
+  if (sym->attr.threadprivate)
+    return;
+
+  /* !$omp do and !$omp parallel do iteration variable is predetermined
+     private just in the !$omp do resp. !$omp parallel do construct,
+     with no implications for the outer parallel constructs.  */
+
+  while (i-- >= 1)
+    {
+      if (code == c)
+	return;
+
+      c = c->block->next;
+    }
+
+  if (omp_current_ctx == NULL)
+    return;
+
+  if (pointer_set_contains (omp_current_ctx->sharing_clauses, sym))
+    return;
+
+  if (! pointer_set_insert (omp_current_ctx->private_iterators, sym))
+    {
+      gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
+      gfc_namelist *p;
+
+      p = gfc_get_namelist ();
+      p->sym = sym;
+      p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
+      omp_clauses->lists[OMP_LIST_PRIVATE] = p;
+    }
+}
+
+
+static void
+resolve_omp_do (gfc_code *code)
+{
+  gfc_code *do_code, *c;
+  int list, i, collapse;
+  gfc_namelist *n;
+  gfc_symbol *dovar;
+
+  if (code->ext.omp_clauses)
+    resolve_omp_clauses (code);
+
+  do_code = code->block->next;
+  collapse = code->ext.omp_clauses->collapse;
+  if (collapse <= 0)
+    collapse = 1;
+  for (i = 1; i <= collapse; i++)
+    {
+      if (do_code->op == EXEC_DO_WHILE)
+	{
+	  gfc_error ("!$OMP DO cannot be a DO WHILE or DO without loop control "
+		     "at %L", &do_code->loc);
+	  break;
+	}
+      gcc_assert (do_code->op == EXEC_DO);
+      if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
+	gfc_error ("!$OMP DO iteration variable must be of type integer at %L",
+		   &do_code->loc);
+      dovar = do_code->ext.iterator->var->symtree->n.sym;
+      if (dovar->attr.threadprivate)
+	gfc_error ("!$OMP DO iteration variable must not be THREADPRIVATE "
+		   "at %L", &do_code->loc);
+      if (code->ext.omp_clauses)
+	for (list = 0; list < OMP_LIST_NUM; list++)
+	  if (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE)
+	    for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
+	      if (dovar == n->sym)
+		{
+		  gfc_error ("!$OMP DO iteration variable present on clause "
+			     "other than PRIVATE or LASTPRIVATE at %L",
+			     &do_code->loc);
+		  break;
+		}
+      if (i > 1)
+	{
+	  gfc_code *do_code2 = code->block->next;
+	  int j;
+
+	  for (j = 1; j < i; j++)
+	    {
+	      gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
+	      if (dovar == ivar
+		  || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
+		  || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
+		  || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
+		{
+		  gfc_error ("!$OMP DO collapsed loops don't form rectangular iteration space at %L",
+			     &do_code->loc);
+		  break;
+		}
+	      if (j < i)
+		break;
+	      do_code2 = do_code2->block->next;
+	    }
+	}
+      if (i == collapse)
+	break;
+      for (c = do_code->next; c; c = c->next)
+	if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
+	  {
+	    gfc_error ("collapsed !$OMP DO loops not perfectly nested at %L",
+		       &c->loc);
+	    break;
+	  }
+      if (c)
+	break;
+      do_code = do_code->block;
+      if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE)
+	{
+	  gfc_error ("not enough DO loops for collapsed !$OMP DO at %L",
+		     &code->loc);
+	  break;
+	}
+      do_code = do_code->next;
+      if (do_code == NULL
+	  || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE))
+	{
+	  gfc_error ("not enough DO loops for collapsed !$OMP DO at %L",
+		     &code->loc);
+	  break;
+	}
+    }
+}
+
+
+/* Resolve OpenMP directive clauses and check various requirements
+   of each directive.  */
+
+void
+gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
+{
+  if (code->op != EXEC_OMP_ATOMIC)
+    gfc_maybe_initialize_eh ();
+
+  switch (code->op)
+    {
+    case EXEC_OMP_DO:
+    case EXEC_OMP_PARALLEL_DO:
+      resolve_omp_do (code);
+      break;
+    case EXEC_OMP_WORKSHARE:
+    case EXEC_OMP_PARALLEL_WORKSHARE:
+    case EXEC_OMP_PARALLEL:
+    case EXEC_OMP_PARALLEL_SECTIONS:
+    case EXEC_OMP_SECTIONS:
+    case EXEC_OMP_SINGLE:
+    case EXEC_OMP_TASK:
+      if (code->ext.omp_clauses)
+	resolve_omp_clauses (code);
+      break;
+    case EXEC_OMP_ATOMIC:
+      resolve_omp_atomic (code);
+      break;
+    default:
+      break;
+    }
+}
diff --git a/gcc-4.9/gcc/fortran/options.c b/gcc-4.9/gcc/fortran/options.c
new file mode 100644
index 000000000..a2b91ca0a
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/options.c
@@ -0,0 +1,1235 @@
+/* Parse and display command line options.
+   Copyright (C) 2000-2014 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "tree.h"
+#include "flags.h"
+#include "intl.h"
+#include "opts.h"
+#include "toplev.h"  /* For save_decoded_options.  */
+#include "options.h"
+#include "params.h"
+#include "tree-inline.h"
+#include "gfortran.h"
+#include "target.h"
+#include "cpp.h"
+#include "diagnostic.h"	/* For global_dc.  */
+#include "tm.h"
+
+gfc_option_t gfc_option;
+
+
+/* Set flags that control warnings and errors for different
+   Fortran standards to their default values.  Keep in sync with
+   libgfortran/runtime/compile_options.c (init_compile_options).  */
+
+static void
+set_default_std_flags (void)
+{
+  gfc_option.allow_std = GFC_STD_F95_OBS | GFC_STD_F95_DEL
+    | GFC_STD_F2003 | GFC_STD_F2008 | GFC_STD_F95 | GFC_STD_F77
+    | GFC_STD_F2008_OBS | GFC_STD_F2008_TS | GFC_STD_GNU | GFC_STD_LEGACY;
+  gfc_option.warn_std = GFC_STD_F95_DEL | GFC_STD_LEGACY;
+}
+
+
+/* Return language mask for Fortran options.  */
+
+unsigned int
+gfc_option_lang_mask (void)
+{
+  return CL_Fortran;
+}
+
+/* Initialize options structure OPTS.  */
+
+void
+gfc_init_options_struct (struct gcc_options *opts)
+{
+  opts->x_flag_errno_math = 0;
+  opts->x_flag_associative_math = -1;
+}
+
+/* Get ready for options handling. Keep in sync with
+   libgfortran/runtime/compile_options.c (init_compile_options). */
+
+void
+gfc_init_options (unsigned int decoded_options_count,
+		  struct cl_decoded_option *decoded_options)
+{
+  gfc_source_file = NULL;
+  gfc_option.module_dir = NULL;
+  gfc_option.source_form = FORM_UNKNOWN;
+  gfc_option.fixed_line_length = 72;
+  gfc_option.free_line_length = 132;
+  gfc_option.max_continue_fixed = 255;
+  gfc_option.max_continue_free = 255;
+  gfc_option.max_identifier_length = GFC_MAX_SYMBOL_LEN;
+  gfc_option.max_subrecord_length = 0;
+  gfc_option.flag_max_array_constructor = 65535;
+  gfc_option.convert = GFC_CONVERT_NATIVE;
+  gfc_option.record_marker = 0;
+  gfc_option.dump_fortran_original = 0;
+  gfc_option.dump_fortran_optimized = 0;
+
+  gfc_option.warn_aliasing = 0;
+  gfc_option.warn_ampersand = 0;
+  gfc_option.warn_character_truncation = 0;
+  gfc_option.warn_array_temp = 0;
+  gfc_option.warn_c_binding_type = 0;
+  gfc_option.gfc_warn_conversion = 0;
+  gfc_option.warn_conversion_extra = 0;
+  gfc_option.warn_function_elimination = 0;
+  gfc_option.warn_implicit_interface = 0;
+  gfc_option.warn_line_truncation = 0;
+  gfc_option.warn_surprising = 0;
+  gfc_option.warn_tabs = 1;
+  gfc_option.warn_underflow = 1;
+  gfc_option.warn_intrinsic_shadow = 0;
+  gfc_option.warn_intrinsics_std = 0;
+  gfc_option.warn_align_commons = 1;
+  gfc_option.warn_real_q_constant = 0;
+  gfc_option.warn_unused_dummy_argument = 0;
+  gfc_option.warn_zerotrip = 0;
+  gfc_option.warn_realloc_lhs = 0;
+  gfc_option.warn_realloc_lhs_all = 0;
+  gfc_option.warn_compare_reals = 0;
+  gfc_option.warn_target_lifetime = 0;
+  gfc_option.max_errors = 25;
+
+  gfc_option.flag_all_intrinsics = 0;
+  gfc_option.flag_default_double = 0;
+  gfc_option.flag_default_integer = 0;
+  gfc_option.flag_default_real = 0;
+  gfc_option.flag_integer4_kind = 0;
+  gfc_option.flag_real4_kind = 0;
+  gfc_option.flag_real8_kind = 0;
+  gfc_option.flag_dollar_ok = 0;
+  gfc_option.flag_underscoring = 1;
+  gfc_option.flag_f2c = 0;
+  gfc_option.flag_second_underscore = -1;
+  gfc_option.flag_implicit_none = 0;
+
+  /* Default value of flag_max_stack_var_size is set in gfc_post_options.  */
+  gfc_option.flag_max_stack_var_size = -2;
+  gfc_option.flag_stack_arrays = -1;
+
+  gfc_option.flag_range_check = 1;
+  gfc_option.flag_pack_derived = 0;
+  gfc_option.flag_repack_arrays = 0;
+  gfc_option.flag_preprocessed = 0;
+  gfc_option.flag_automatic = 1;
+  gfc_option.flag_backslash = 0;
+  gfc_option.flag_module_private = 0;
+  gfc_option.flag_backtrace = 1;
+  gfc_option.flag_allow_leading_underscore = 0;
+  gfc_option.flag_external_blas = 0;
+  gfc_option.blas_matmul_limit = 30;
+  gfc_option.flag_cray_pointer = 0;
+  gfc_option.flag_d_lines = -1;
+  gfc_option.gfc_flag_openmp = 0;
+  gfc_option.flag_sign_zero = 1;
+  gfc_option.flag_recursive = 0;
+  gfc_option.flag_init_integer = GFC_INIT_INTEGER_OFF;
+  gfc_option.flag_init_integer_value = 0;
+  gfc_option.flag_init_real = GFC_INIT_REAL_OFF;
+  gfc_option.flag_init_logical = GFC_INIT_LOGICAL_OFF;
+  gfc_option.flag_init_character = GFC_INIT_CHARACTER_OFF;
+  gfc_option.flag_init_character_value = (char)0;
+  gfc_option.flag_align_commons = 1;
+  gfc_option.flag_protect_parens = -1;
+  gfc_option.flag_realloc_lhs = -1;
+  gfc_option.flag_aggressive_function_elimination = 0;
+  gfc_option.flag_frontend_optimize = -1;
+  
+  gfc_option.fpe = 0;
+  /* All except GFC_FPE_INEXACT.  */
+  gfc_option.fpe_summary = GFC_FPE_INVALID | GFC_FPE_DENORMAL
+			   | GFC_FPE_ZERO | GFC_FPE_OVERFLOW
+			   | GFC_FPE_UNDERFLOW;
+  gfc_option.rtcheck = 0;
+  gfc_option.coarray = GFC_FCOARRAY_NONE;
+
+  set_default_std_flags ();
+
+  /* Initialize cpp-related options.  */
+  gfc_cpp_init_options (decoded_options_count, decoded_options);
+}
+
+
+/* Determine the source form from the filename extension.  We assume
+   case insensitivity.  */
+
+static gfc_source_form
+form_from_filename (const char *filename)
+{
+  static const struct
+  {
+    const char *extension;
+    gfc_source_form form;
+  }
+  exttype[] =
+  {
+    {
+    ".f90", FORM_FREE}
+    ,
+    {
+    ".f95", FORM_FREE}
+    ,
+    {
+    ".f03", FORM_FREE}
+    ,
+    {
+    ".f08", FORM_FREE}
+    ,
+    {
+    ".f", FORM_FIXED}
+    ,
+    {
+    ".for", FORM_FIXED}
+    ,
+    {
+    ".ftn", FORM_FIXED}
+    ,
+    {
+    "", FORM_UNKNOWN}
+  };		/* sentinel value */
+
+  gfc_source_form f_form;
+  const char *fileext;
+  int i;
+
+  /* Find end of file name.  Note, filename is either a NULL pointer or
+     a NUL terminated string.  */
+  i = 0;
+  while (filename[i] != '\0')
+    i++;
+
+  /* Find last period.  */
+  while (i >= 0 && (filename[i] != '.'))
+    i--;
+
+  /* Did we see a file extension?  */
+  if (i < 0)
+    return FORM_UNKNOWN; /* Nope  */
+
+  /* Get file extension and compare it to others.  */
+  fileext = &(filename[i]);
+
+  i = -1;
+  f_form = FORM_UNKNOWN;
+  do
+    {
+      i++;
+      if (strcasecmp (fileext, exttype[i].extension) == 0)
+	{
+	  f_form = exttype[i].form;
+	  break;
+	}
+    }
+  while (exttype[i].form != FORM_UNKNOWN);
+
+  return f_form;
+}
+
+
+/* Finalize commandline options.  */
+
+bool
+gfc_post_options (const char **pfilename)
+{
+  const char *filename = *pfilename, *canon_source_file = NULL;
+  char *source_path;
+  int i;
+
+  /* Excess precision other than "fast" requires front-end
+     support.  */
+  if (flag_excess_precision_cmdline == EXCESS_PRECISION_STANDARD
+      && TARGET_FLT_EVAL_METHOD_NON_DEFAULT)
+    sorry ("-fexcess-precision=standard for Fortran");
+  flag_excess_precision_cmdline = EXCESS_PRECISION_FAST;
+
+  /* Fortran allows associative math - but we cannot reassociate if
+     we want traps or signed zeros. Cf. also flag_protect_parens.  */
+  if (flag_associative_math == -1)
+    flag_associative_math = (!flag_trapping_math && !flag_signed_zeros);
+
+  if (gfc_option.flag_protect_parens == -1)
+    gfc_option.flag_protect_parens = !optimize_fast;
+
+  if (gfc_option.flag_stack_arrays == -1)
+    gfc_option.flag_stack_arrays = optimize_fast;
+
+  /* By default, disable (re)allocation during assignment for -std=f95,
+     and enable it for F2003/F2008/GNU/Legacy. */
+  if (gfc_option.flag_realloc_lhs == -1)
+    {
+      if (gfc_option.allow_std & GFC_STD_F2003)
+	gfc_option.flag_realloc_lhs = 1;
+      else
+	gfc_option.flag_realloc_lhs = 0;
+    }
+
+  /* -fbounds-check is equivalent to -fcheck=bounds */
+  if (flag_bounds_check)
+    gfc_option.rtcheck |= GFC_RTCHECK_BOUNDS;
+
+  if (flag_compare_debug)
+    gfc_option.dump_fortran_original = 0;
+
+  /* Make -fmax-errors visible to gfortran's diagnostic machinery.  */
+  if (global_options_set.x_flag_max_errors)
+    gfc_option.max_errors = flag_max_errors;
+
+  /* Verify the input file name.  */
+  if (!filename || strcmp (filename, "-") == 0)
+    {
+      filename = "";
+    }
+
+  if (gfc_option.flag_preprocessed)
+    {
+      /* For preprocessed files, if the first tokens are of the form # NUM.
+	 handle the directives so we know the original file name.  */
+      gfc_source_file = gfc_read_orig_filename (filename, &canon_source_file);
+      if (gfc_source_file == NULL)
+	gfc_source_file = filename;
+      else
+	*pfilename = gfc_source_file;
+    }
+  else
+    gfc_source_file = filename;
+
+  if (canon_source_file == NULL)
+    canon_source_file = gfc_source_file;
+
+  /* Adds the path where the source file is to the list of include files.  */
+
+  i = strlen (canon_source_file);
+  while (i > 0 && !IS_DIR_SEPARATOR (canon_source_file[i]))
+    i--;
+
+  if (i != 0)
+    {
+      source_path = (char *) alloca (i + 1);
+      memcpy (source_path, canon_source_file, i);
+      source_path[i] = 0;
+      gfc_add_include_path (source_path, true, true, true);
+    }
+  else
+    gfc_add_include_path (".", true, true, true);
+
+  if (canon_source_file != gfc_source_file)
+    free (CONST_CAST (char *, canon_source_file));
+
+  /* Decide which form the file will be read in as.  */
+
+  if (gfc_option.source_form != FORM_UNKNOWN)
+    gfc_current_form = gfc_option.source_form;
+  else
+    {
+      gfc_current_form = form_from_filename (filename);
+
+      if (gfc_current_form == FORM_UNKNOWN)
+	{
+	  gfc_current_form = FORM_FREE;
+	  gfc_warning_now ("Reading file '%s' as free form", 
+			   (filename[0] == '\0') ? "<stdin>" : filename);
+	}
+    }
+
+  /* If the user specified -fd-lines-as-{code|comments} verify that we're
+     in fixed form.  */
+  if (gfc_current_form == FORM_FREE)
+    {
+      if (gfc_option.flag_d_lines == 0)
+	gfc_warning_now ("'-fd-lines-as-comments' has no effect "
+			 "in free form");
+      else if (gfc_option.flag_d_lines == 1)
+	gfc_warning_now ("'-fd-lines-as-code' has no effect in free form");
+    }
+
+  /* If -pedantic, warn about the use of GNU extensions.  */
+  if (pedantic && (gfc_option.allow_std & GFC_STD_GNU) != 0)
+    gfc_option.warn_std |= GFC_STD_GNU;
+  /* -std=legacy -pedantic is effectively -std=gnu.  */
+  if (pedantic && (gfc_option.allow_std & GFC_STD_LEGACY) != 0)
+    gfc_option.warn_std |= GFC_STD_F95_OBS | GFC_STD_F95_DEL | GFC_STD_LEGACY;
+
+  /* If the user didn't explicitly specify -f(no)-second-underscore we
+     use it if we're trying to be compatible with f2c, and not
+     otherwise.  */
+  if (gfc_option.flag_second_underscore == -1)
+    gfc_option.flag_second_underscore = gfc_option.flag_f2c;
+
+  if (!gfc_option.flag_automatic && gfc_option.flag_max_stack_var_size != -2
+      && gfc_option.flag_max_stack_var_size != 0)
+    gfc_warning_now ("Flag -fno-automatic overwrites -fmax-stack-var-size=%d",
+		     gfc_option.flag_max_stack_var_size);
+  else if (!gfc_option.flag_automatic && gfc_option.flag_recursive)
+    gfc_warning_now ("Flag -fno-automatic overwrites -frecursive");
+  else if (!gfc_option.flag_automatic && gfc_option.gfc_flag_openmp)
+    gfc_warning_now ("Flag -fno-automatic overwrites -frecursive implied by "
+		     "-fopenmp");
+  else if (gfc_option.flag_max_stack_var_size != -2
+	   && gfc_option.flag_recursive)
+    gfc_warning_now ("Flag -frecursive overwrites -fmax-stack-var-size=%d",
+		     gfc_option.flag_max_stack_var_size);
+  else if (gfc_option.flag_max_stack_var_size != -2
+	   && gfc_option.gfc_flag_openmp)
+    gfc_warning_now ("Flag -fmax-stack-var-size=%d overwrites -frecursive "
+		     "implied by -fopenmp", 
+		     gfc_option.flag_max_stack_var_size);
+
+  /* Implement -frecursive as -fmax-stack-var-size=-1.  */
+  if (gfc_option.flag_recursive)
+    gfc_option.flag_max_stack_var_size = -1;
+
+  /* Implied -frecursive; implemented as -fmax-stack-var-size=-1.  */
+  if (gfc_option.flag_max_stack_var_size == -2 && gfc_option.gfc_flag_openmp
+      && gfc_option.flag_automatic)
+    {
+      gfc_option.flag_recursive = 1;
+      gfc_option.flag_max_stack_var_size = -1;
+    }
+
+  /* Set default.  */
+  if (gfc_option.flag_max_stack_var_size == -2)
+    gfc_option.flag_max_stack_var_size = 32768;
+
+  /* Implement -fno-automatic as -fmax-stack-var-size=0.  */
+  if (!gfc_option.flag_automatic)
+    gfc_option.flag_max_stack_var_size = 0;
+  
+  if (pedantic)
+    { 
+      gfc_option.warn_ampersand = 1;
+      gfc_option.warn_tabs = 0;
+    }
+
+  /* Optimization implies front end optimization, unless the user
+     specified it directly.  */
+
+  if (gfc_option.flag_frontend_optimize == -1)
+    gfc_option.flag_frontend_optimize = optimize;
+
+  if (gfc_option.warn_realloc_lhs_all)
+    gfc_option.warn_realloc_lhs = 1;
+
+  gfc_cpp_post_options ();
+
+  return gfc_cpp_preprocess_only ();
+}
+
+
+/* Set the options for -Wall.  */
+
+static void
+set_Wall (int setting)
+{
+  gfc_option.warn_aliasing = setting;
+  gfc_option.warn_ampersand = setting;
+  gfc_option.warn_c_binding_type = setting;
+  gfc_option.gfc_warn_conversion = setting;
+  gfc_option.warn_line_truncation = setting;
+  gfc_option.warn_surprising = setting;
+  gfc_option.warn_tabs = !setting;
+  gfc_option.warn_underflow = setting;
+  gfc_option.warn_intrinsic_shadow = setting;
+  gfc_option.warn_intrinsics_std = setting;
+  gfc_option.warn_character_truncation = setting;
+  gfc_option.warn_real_q_constant = setting;
+  gfc_option.warn_unused_dummy_argument = setting;
+  gfc_option.warn_target_lifetime = setting;
+  gfc_option.warn_zerotrip = setting;
+
+  warn_return_type = setting;
+  warn_uninitialized = setting;
+  warn_maybe_uninitialized = setting;
+}
+
+/* Set the options for -Wextra.  */
+
+static void
+set_Wextra (int setting)
+{
+  gfc_option.warn_compare_reals = setting;
+}
+
+static void
+gfc_handle_module_path_options (const char *arg)
+{
+
+  if (gfc_option.module_dir != NULL)
+    gfc_fatal_error ("gfortran: Only one -J option allowed");
+
+  gfc_option.module_dir = XCNEWVEC (char, strlen (arg) + 2);
+  strcpy (gfc_option.module_dir, arg);
+
+  gfc_add_include_path (gfc_option.module_dir, true, false, true);
+
+  strcat (gfc_option.module_dir, "/");
+}
+
+
+/* Handle options -ffpe-trap= and -ffpe-summary=.  */
+
+static void
+gfc_handle_fpe_option (const char *arg, bool trap)
+{
+  int result, pos = 0, n;
+  /* precision is a backwards compatibility alias for inexact.  */
+  static const char * const exception[] = { "invalid", "denormal", "zero",
+					    "overflow", "underflow",
+					    "inexact", "precision", NULL };
+  static const int opt_exception[] = { GFC_FPE_INVALID, GFC_FPE_DENORMAL,
+				       GFC_FPE_ZERO, GFC_FPE_OVERFLOW,
+				       GFC_FPE_UNDERFLOW, GFC_FPE_INEXACT,
+				       GFC_FPE_INEXACT,
+				       0 };
+
+  /* As the default for -ffpe-summary= is nonzero, set it to 0. */
+  if (!trap)
+    gfc_option.fpe_summary = 0;
+
+  while (*arg)
+    {
+      while (*arg == ',')
+	arg++;
+
+      while (arg[pos] && arg[pos] != ',')
+	pos++;
+
+      result = 0;
+      if (!trap && strncmp ("none", arg, pos) == 0)
+	{
+	  gfc_option.fpe_summary = 0;
+	  arg += pos;
+	  pos = 0;
+	  continue;
+	}
+      else if (!trap && strncmp ("all", arg, pos) == 0)
+	{
+	  gfc_option.fpe_summary = GFC_FPE_INVALID | GFC_FPE_DENORMAL
+				   | GFC_FPE_ZERO | GFC_FPE_OVERFLOW
+				   | GFC_FPE_UNDERFLOW | GFC_FPE_INEXACT;
+	  arg += pos;
+	  pos = 0;
+	  continue;
+	}
+      else
+	for (n = 0; exception[n] != NULL; n++)
+	  {
+	  if (exception[n] && strncmp (exception[n], arg, pos) == 0)
+	    {
+	      if (trap)
+		gfc_option.fpe |= opt_exception[n];
+	      else
+		gfc_option.fpe_summary |= opt_exception[n];
+	      arg += pos;
+	      pos = 0;
+	      result = 1;
+	      break;
+	    }
+	  }
+      if (!result && !trap)
+	gfc_fatal_error ("Argument to -ffpe-trap is not valid: %s", arg);
+      else if (!result)
+	gfc_fatal_error ("Argument to -ffpe-summary is not valid: %s", arg);
+
+    }
+}
+
+
+static void
+gfc_handle_coarray_option (const char *arg)
+{
+  if (strcmp (arg, "none") == 0)
+    gfc_option.coarray = GFC_FCOARRAY_NONE;
+  else if (strcmp (arg, "single") == 0)
+    gfc_option.coarray = GFC_FCOARRAY_SINGLE;
+  else if (strcmp (arg, "lib") == 0)
+    gfc_option.coarray = GFC_FCOARRAY_LIB;
+  else
+    gfc_fatal_error ("Argument to -fcoarray is not valid: %s", arg);
+}
+
+
+static void
+gfc_handle_runtime_check_option (const char *arg)
+{
+  int result, pos = 0, n;
+  static const char * const optname[] = { "all", "bounds", "array-temps",
+					  "recursion", "do", "pointer",
+					  "mem", NULL };
+  static const int optmask[] = { GFC_RTCHECK_ALL, GFC_RTCHECK_BOUNDS,
+				 GFC_RTCHECK_ARRAY_TEMPS,
+				 GFC_RTCHECK_RECURSION, GFC_RTCHECK_DO,
+				 GFC_RTCHECK_POINTER, GFC_RTCHECK_MEM,
+				 0 };
+ 
+  while (*arg)
+    {
+      while (*arg == ',')
+	arg++;
+
+      while (arg[pos] && arg[pos] != ',')
+	pos++;
+
+      result = 0;
+      for (n = 0; optname[n] != NULL; n++)
+	{
+	  if (optname[n] && strncmp (optname[n], arg, pos) == 0)
+	    {
+	      gfc_option.rtcheck |= optmask[n];
+	      arg += pos;
+	      pos = 0;
+	      result = 1;
+	      break;
+	    }
+	}
+      if (!result)
+	gfc_fatal_error ("Argument to -fcheck is not valid: %s", arg);
+    }
+}
+
+
+/* Handle command-line options.  Returns 0 if unrecognized, 1 if
+   recognized and handled.  */
+
+bool
+gfc_handle_option (size_t scode, const char *arg, int value,
+		   int kind ATTRIBUTE_UNUSED, location_t loc ATTRIBUTE_UNUSED,
+		   const struct cl_option_handlers *handlers ATTRIBUTE_UNUSED)
+{
+  bool result = true;
+  enum opt_code code = (enum opt_code) scode;
+
+  if (gfc_cpp_handle_option (scode, arg, value) == 1)
+    return true;
+
+  switch (code)
+    {
+    default:
+      result = false;
+      break;
+
+    case OPT_Wall:
+      handle_generated_option (&global_options, &global_options_set,
+			       OPT_Wunused, NULL, value,
+			       gfc_option_lang_mask (), kind, loc,
+			       handlers, global_dc);
+      set_Wall (value);
+      break;
+
+    case OPT_Waliasing:
+      gfc_option.warn_aliasing = value;
+      break;
+
+    case OPT_Wampersand:
+      gfc_option.warn_ampersand = value;
+      break;
+
+    case OPT_Warray_temporaries:
+      gfc_option.warn_array_temp = value;
+      break;
+
+    case OPT_Wc_binding_type:
+      gfc_option.warn_c_binding_type = value;
+      break;
+
+    case OPT_Wcharacter_truncation:
+      gfc_option.warn_character_truncation = value;
+      break;
+
+    case OPT_Wcompare_reals:
+      gfc_option.warn_compare_reals = value;
+      break;
+
+    case OPT_Wconversion:
+      gfc_option.gfc_warn_conversion = value;
+      break;
+
+    case OPT_Wconversion_extra:
+      gfc_option.warn_conversion_extra = value;
+      break;
+
+    case OPT_Wextra:
+      handle_generated_option (&global_options, &global_options_set,
+			       OPT_Wunused_parameter, NULL, value,
+			       gfc_option_lang_mask (), kind, loc,
+			       handlers, global_dc);
+      set_Wextra (value);
+
+      break;
+
+    case OPT_Wfunction_elimination:
+      gfc_option.warn_function_elimination = value;
+      break;
+
+    case OPT_Wimplicit_interface:
+      gfc_option.warn_implicit_interface = value;
+      break;
+
+    case OPT_Wimplicit_procedure:
+      gfc_option.warn_implicit_procedure = value;
+      break;
+
+    case OPT_Wline_truncation:
+      gfc_option.warn_line_truncation = value;
+      break;
+
+    case OPT_Wrealloc_lhs:
+      gfc_option.warn_realloc_lhs = value;
+      break;
+
+    case OPT_Wrealloc_lhs_all:
+      gfc_option.warn_realloc_lhs_all = value;
+      break;
+
+    case OPT_Wreturn_type:
+      warn_return_type = value;
+      break;
+
+    case OPT_Wsurprising:
+      gfc_option.warn_surprising = value;
+      break;
+
+    case OPT_Wtabs:
+      gfc_option.warn_tabs = value;
+      break;
+
+    case OPT_Wtarget_lifetime:
+      gfc_option.warn_target_lifetime = value;
+      break;
+
+    case OPT_Wunderflow:
+      gfc_option.warn_underflow = value;
+      break;
+
+    case OPT_Wintrinsic_shadow:
+      gfc_option.warn_intrinsic_shadow = value;
+      break;
+
+    case OPT_Walign_commons:
+      gfc_option.warn_align_commons = value;
+      break;
+
+    case OPT_Wreal_q_constant:
+      gfc_option.warn_real_q_constant = value;
+      break;
+
+    case OPT_Wunused_dummy_argument:
+      gfc_option.warn_unused_dummy_argument = value;
+      break;
+
+    case OPT_Wzerotrip:
+      gfc_option.warn_zerotrip = value;
+      break;
+
+    case OPT_fall_intrinsics:
+      gfc_option.flag_all_intrinsics = 1;
+      break;
+
+    case OPT_fautomatic:
+      gfc_option.flag_automatic = value;
+      break;
+
+    case OPT_fallow_leading_underscore:
+      gfc_option.flag_allow_leading_underscore = value;
+      break;
+      
+    case OPT_fbackslash:
+      gfc_option.flag_backslash = value;
+      break;
+      
+    case OPT_fbacktrace:
+      gfc_option.flag_backtrace = value;
+      break;
+      
+    case OPT_fcheck_array_temporaries:
+      gfc_option.rtcheck |= GFC_RTCHECK_ARRAY_TEMPS;
+      break;
+      
+    case OPT_fcray_pointer:
+      gfc_option.flag_cray_pointer = value;
+      break;
+
+    case OPT_ff2c:
+      gfc_option.flag_f2c = value;
+      break;
+
+    case OPT_fdollar_ok:
+      gfc_option.flag_dollar_ok = value;
+      break;
+
+    case OPT_fexternal_blas:
+      gfc_option.flag_external_blas = value;
+      break;
+
+    case OPT_fblas_matmul_limit_:
+      gfc_option.blas_matmul_limit = value;
+      break;
+
+    case OPT_fd_lines_as_code:
+      gfc_option.flag_d_lines = 1;
+      break;
+
+    case OPT_fd_lines_as_comments:
+      gfc_option.flag_d_lines = 0;
+      break;
+
+    case OPT_fdump_fortran_original:
+    case OPT_fdump_parse_tree:
+      gfc_option.dump_fortran_original = value;
+      break;
+
+    case OPT_fdump_fortran_optimized:
+      gfc_option.dump_fortran_optimized = value;
+      break;
+
+    case OPT_ffixed_form:
+      gfc_option.source_form = FORM_FIXED;
+      break;
+
+    case OPT_ffixed_line_length_none:
+      gfc_option.fixed_line_length = 0;
+      break;
+
+    case OPT_ffixed_line_length_:
+      if (value != 0 && value < 7)
+	gfc_fatal_error ("Fixed line length must be at least seven.");
+      gfc_option.fixed_line_length = value;
+      break;
+
+    case OPT_ffree_form:
+      gfc_option.source_form = FORM_FREE;
+      break;
+
+    case OPT_fopenmp:
+      gfc_option.gfc_flag_openmp = value;
+      break;
+
+    case OPT_fopenmp_simd:
+      gfc_option.gfc_flag_openmp_simd = value;
+      break;
+
+    case OPT_ffree_line_length_none:
+      gfc_option.free_line_length = 0;
+      break;
+
+    case OPT_ffree_line_length_:
+      if (value != 0 && value < 4)
+	gfc_fatal_error ("Free line length must be at least three.");
+      gfc_option.free_line_length = value;
+      break;
+
+    case OPT_funderscoring:
+      gfc_option.flag_underscoring = value;
+      break;
+
+    case OPT_fsecond_underscore:
+      gfc_option.flag_second_underscore = value;
+      break;
+
+    case OPT_static_libgfortran:
+#ifndef HAVE_LD_STATIC_DYNAMIC
+      gfc_fatal_error ("-static-libgfortran is not supported in this "
+		       "configuration");
+#endif
+      break;
+
+    case OPT_fimplicit_none:
+      gfc_option.flag_implicit_none = value;
+      break;
+
+    case OPT_fintrinsic_modules_path:
+    case OPT_fintrinsic_modules_path_:
+
+      /* This is needed because omp_lib.h is in a directory together
+	 with intrinsic modules.  Do no warn because during testing
+	 without an installed compiler, we would get lots of bogus
+	 warnings for a missing include directory.  */
+      gfc_add_include_path (arg, false, false, false);
+
+      gfc_add_intrinsic_modules_path (arg);
+      break;
+
+    case OPT_fmax_array_constructor_:
+      gfc_option.flag_max_array_constructor = value > 65535 ? value : 65535;
+      break;
+
+    case OPT_fmax_stack_var_size_:
+      gfc_option.flag_max_stack_var_size = value;
+      break;
+
+    case OPT_fstack_arrays:
+      gfc_option.flag_stack_arrays = value;
+      break;
+
+    case OPT_fmodule_private:
+      gfc_option.flag_module_private = value;
+      break;
+      
+    case OPT_frange_check:
+      gfc_option.flag_range_check = value;
+      break;
+
+    case OPT_fpack_derived:
+      gfc_option.flag_pack_derived = value;
+      break;
+
+    case OPT_frepack_arrays:
+      gfc_option.flag_repack_arrays = value;
+      break;
+
+    case OPT_fpreprocessed:
+      gfc_option.flag_preprocessed = value;
+      break;
+
+    case OPT_fmax_identifier_length_:
+      if (value > GFC_MAX_SYMBOL_LEN)
+	gfc_fatal_error ("Maximum supported identifier length is %d",
+			 GFC_MAX_SYMBOL_LEN);
+      gfc_option.max_identifier_length = value;
+      break;
+
+    case OPT_fdefault_integer_8:
+      gfc_option.flag_default_integer = value;
+      break;
+
+    case OPT_fdefault_real_8:
+      gfc_option.flag_default_real = value;
+      break;
+
+    case OPT_fdefault_double_8:
+      gfc_option.flag_default_double = value;
+      break;
+
+    case OPT_finteger_4_integer_8:
+      gfc_option.flag_integer4_kind = 8;
+      break;
+
+    case OPT_freal_4_real_8:
+      gfc_option.flag_real4_kind = 8;
+      break;
+
+    case OPT_freal_4_real_10:
+      gfc_option.flag_real4_kind = 10;
+      break;
+
+    case OPT_freal_4_real_16:
+      gfc_option.flag_real4_kind = 16;
+      break;
+
+    case OPT_freal_8_real_4:
+      gfc_option.flag_real8_kind = 4;
+      break;
+
+    case OPT_freal_8_real_10:
+      gfc_option.flag_real8_kind = 10;
+      break;
+
+    case OPT_freal_8_real_16:
+      gfc_option.flag_real8_kind = 16;
+      break;
+
+    case OPT_finit_local_zero:
+      gfc_option.flag_init_integer = GFC_INIT_INTEGER_ON;
+      gfc_option.flag_init_integer_value = 0;
+      gfc_option.flag_init_real = GFC_INIT_REAL_ZERO;
+      gfc_option.flag_init_logical = GFC_INIT_LOGICAL_FALSE;
+      gfc_option.flag_init_character = GFC_INIT_CHARACTER_ON;
+      gfc_option.flag_init_character_value = (char)0;
+      break;
+
+    case OPT_finit_logical_:
+      if (!strcasecmp (arg, "false"))
+	gfc_option.flag_init_logical = GFC_INIT_LOGICAL_FALSE;
+      else if (!strcasecmp (arg, "true"))
+	gfc_option.flag_init_logical = GFC_INIT_LOGICAL_TRUE;
+      else
+	gfc_fatal_error ("Unrecognized option to -finit-logical: %s",
+			 arg);
+      break;
+
+    case OPT_finit_real_:
+      if (!strcasecmp (arg, "zero"))
+	gfc_option.flag_init_real = GFC_INIT_REAL_ZERO;
+      else if (!strcasecmp (arg, "nan"))
+	gfc_option.flag_init_real = GFC_INIT_REAL_NAN;
+      else if (!strcasecmp (arg, "snan"))
+	gfc_option.flag_init_real = GFC_INIT_REAL_SNAN;
+      else if (!strcasecmp (arg, "inf"))
+	gfc_option.flag_init_real = GFC_INIT_REAL_INF;
+      else if (!strcasecmp (arg, "-inf"))
+	gfc_option.flag_init_real = GFC_INIT_REAL_NEG_INF;
+      else
+	gfc_fatal_error ("Unrecognized option to -finit-real: %s",
+			 arg);
+      break;
+
+    case OPT_finit_integer_:
+      gfc_option.flag_init_integer = GFC_INIT_INTEGER_ON;
+      gfc_option.flag_init_integer_value = atoi (arg);
+      break;
+
+    case OPT_finit_character_:
+      if (value >= 0 && value <= 127)
+	{
+	  gfc_option.flag_init_character = GFC_INIT_CHARACTER_ON;
+	  gfc_option.flag_init_character_value = (char)value;
+	}
+      else
+	gfc_fatal_error ("The value of n in -finit-character=n must be "
+			 "between 0 and 127");
+      break;
+
+    case OPT_I:
+      gfc_add_include_path (arg, true, false, true);
+      break;
+
+    case OPT_J:
+      gfc_handle_module_path_options (arg);
+      break;
+
+    case OPT_fsign_zero:
+      gfc_option.flag_sign_zero = value;
+      break;
+
+    case OPT_ffpe_trap_:
+      gfc_handle_fpe_option (arg, true);
+      break;
+
+    case OPT_ffpe_summary_:
+      gfc_handle_fpe_option (arg, false);
+      break;
+
+    case OPT_std_f95:
+      gfc_option.allow_std = GFC_STD_F95_OBS | GFC_STD_F95 | GFC_STD_F77
+			     | GFC_STD_F2008_OBS;
+      gfc_option.warn_std = GFC_STD_F95_OBS;
+      gfc_option.max_continue_fixed = 19;
+      gfc_option.max_continue_free = 39;
+      gfc_option.max_identifier_length = 31;
+      gfc_option.warn_ampersand = 1;
+      gfc_option.warn_tabs = 0;
+      break;
+
+    case OPT_std_f2003:
+      gfc_option.allow_std = GFC_STD_F95_OBS | GFC_STD_F77 
+	| GFC_STD_F2003 | GFC_STD_F95 | GFC_STD_F2008_OBS;
+      gfc_option.warn_std = GFC_STD_F95_OBS;
+      gfc_option.max_identifier_length = 63;
+      gfc_option.warn_ampersand = 1;
+      gfc_option.warn_tabs = 0;
+      break;
+
+    case OPT_std_f2008:
+      gfc_option.allow_std = GFC_STD_F95_OBS | GFC_STD_F77 
+	| GFC_STD_F2003 | GFC_STD_F95 | GFC_STD_F2008 | GFC_STD_F2008_OBS;
+      gfc_option.warn_std = GFC_STD_F95_OBS | GFC_STD_F2008_OBS;
+      gfc_option.max_identifier_length = 63;
+      gfc_option.warn_ampersand = 1;
+      gfc_option.warn_tabs = 0;
+      break;
+
+    case OPT_std_f2008ts:
+      gfc_option.allow_std = GFC_STD_F95_OBS | GFC_STD_F77 
+	| GFC_STD_F2003 | GFC_STD_F95 | GFC_STD_F2008 | GFC_STD_F2008_OBS
+	| GFC_STD_F2008_TS;
+      gfc_option.warn_std = GFC_STD_F95_OBS | GFC_STD_F2008_OBS;
+      gfc_option.max_identifier_length = 63;
+      gfc_option.warn_ampersand = 1;
+      gfc_option.warn_tabs = 0;
+      break;
+
+    case OPT_std_gnu:
+      set_default_std_flags ();
+      break;
+
+    case OPT_std_legacy:
+      set_default_std_flags ();
+      gfc_option.warn_std = 0;
+      break;
+
+    case OPT_Wintrinsics_std:
+      gfc_option.warn_intrinsics_std = value;
+      break;
+
+    case OPT_fshort_enums:
+      /* Handled in language-independent code.  */
+      break;
+
+    case OPT_fconvert_little_endian:
+      gfc_option.convert = GFC_CONVERT_LITTLE;
+      break;
+
+    case OPT_fconvert_big_endian:
+      gfc_option.convert = GFC_CONVERT_BIG;
+      break;
+
+    case OPT_fconvert_native:
+      gfc_option.convert = GFC_CONVERT_NATIVE;
+      break;
+
+    case OPT_fconvert_swap:
+      gfc_option.convert = GFC_CONVERT_SWAP;
+      break;
+
+    case OPT_frecord_marker_4:
+      gfc_option.record_marker = 4;
+      break;
+
+    case OPT_frecord_marker_8:
+      gfc_option.record_marker = 8;
+      break;
+
+    case OPT_fmax_subrecord_length_:
+      if (value > MAX_SUBRECORD_LENGTH)
+	gfc_fatal_error ("Maximum subrecord length cannot exceed %d",
+			 MAX_SUBRECORD_LENGTH);
+
+      gfc_option.max_subrecord_length = value;
+      break;
+
+    case OPT_frecursive:
+      gfc_option.flag_recursive = value;
+      break;
+
+    case OPT_falign_commons:
+      gfc_option.flag_align_commons = value;
+      break;
+
+    case  OPT_faggressive_function_elimination:
+      gfc_option.flag_aggressive_function_elimination = value;
+      break;
+
+    case OPT_ffrontend_optimize:
+      gfc_option.flag_frontend_optimize = value;
+      break;
+
+    case OPT_fprotect_parens:
+      gfc_option.flag_protect_parens = value;
+      break;
+
+    case OPT_frealloc_lhs:
+      gfc_option.flag_realloc_lhs = value;
+      break;
+
+    case OPT_fcheck_:
+      gfc_handle_runtime_check_option (arg);
+      break;
+
+    case OPT_fcoarray_:
+      gfc_handle_coarray_option (arg);
+      break;
+    }
+
+  Fortran_handle_option_auto (&global_options, &global_options_set, 
+                              scode, arg, value, 
+                              gfc_option_lang_mask (), kind,
+                              loc, handlers, global_dc);
+  return result;
+}
+
+
+/* Return a string with the options passed to the compiler; used for
+   Fortran's compiler_options() intrinsic.  */
+
+char *
+gfc_get_option_string (void)
+{
+  unsigned j;
+  size_t len, pos;
+  char *result;
+
+  /* Allocate and return a one-character string with '\0'.  */
+  if (!save_decoded_options_count)
+    return XCNEWVEC (char, 1);
+
+  /* Determine required string length.  */
+
+  len = 0;
+  for (j = 1; j < save_decoded_options_count; j++)
+    {
+      switch (save_decoded_options[j].opt_index)
+        {
+        case OPT_o:
+        case OPT_d:
+        case OPT_dumpbase:
+        case OPT_dumpdir:
+        case OPT_auxbase:
+        case OPT_quiet:
+        case OPT_version:
+        case OPT_fintrinsic_modules_path:
+        case OPT_fintrinsic_modules_path_:
+          /* Ignore these.  */
+          break;
+	default:
+	  /* Ignore file names. */
+	  if (save_decoded_options[j].orig_option_with_args_text[0] == '-')
+	    len += 1
+		 + strlen (save_decoded_options[j].orig_option_with_args_text);
+        }
+    }
+
+  result = XCNEWVEC (char, len);
+
+  pos = 0; 
+  for (j = 1; j < save_decoded_options_count; j++)
+    {
+      switch (save_decoded_options[j].opt_index)
+        {
+        case OPT_o:
+        case OPT_d:
+        case OPT_dumpbase:
+        case OPT_dumpdir:
+        case OPT_auxbase:
+        case OPT_quiet:
+        case OPT_version:
+        case OPT_fintrinsic_modules_path:
+        case OPT_fintrinsic_modules_path_:
+          /* Ignore these.  */
+	  continue;
+
+        case OPT_cpp_:
+	  /* Use "-cpp" rather than "-cpp=<temporary file>".  */
+	  len = 4;
+	  break;
+
+        default:
+	  /* Ignore file names. */
+	  if (save_decoded_options[j].orig_option_with_args_text[0] != '-')
+	    continue;
+
+	  len = strlen (save_decoded_options[j].orig_option_with_args_text);
+        }
+
+      memcpy (&result[pos], save_decoded_options[j].orig_option_with_args_text, len);
+      pos += len;
+      result[pos++] = ' ';
+    }
+
+  result[--pos] = '\0';
+  return result;
+}
diff --git a/gcc-4.9/gcc/fortran/parse.c b/gcc-4.9/gcc/fortran/parse.c
new file mode 100644
index 000000000..0faf47a00
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/parse.c
@@ -0,0 +1,4745 @@
+/* Main parser.
+   Copyright (C) 2000-2014 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+#include "config.h"
+#include "system.h"
+#include <setjmp.h>
+#include "coretypes.h"
+#include "gfortran.h"
+#include "match.h"
+#include "parse.h"
+#include "debug.h"
+
+/* Current statement label.  Zero means no statement label.  Because new_st
+   can get wiped during statement matching, we have to keep it separate.  */
+
+gfc_st_label *gfc_statement_label;
+
+static locus label_locus;
+static jmp_buf eof_buf;
+
+gfc_state_data *gfc_state_stack;
+static bool last_was_use_stmt = false;
+
+/* TODO: Re-order functions to kill these forward decls.  */
+static void check_statement_label (gfc_statement);
+static void undo_new_statement (void);
+static void reject_statement (void);
+
+
+/* A sort of half-matching function.  We try to match the word on the
+   input with the passed string.  If this succeeds, we call the
+   keyword-dependent matching function that will match the rest of the
+   statement.  For single keywords, the matching subroutine is
+   gfc_match_eos().  */
+
+static match
+match_word (const char *str, match (*subr) (void), locus *old_locus)
+{
+  match m;
+
+  if (str != NULL)
+    {
+      m = gfc_match (str);
+      if (m != MATCH_YES)
+	return m;
+    }
+
+  m = (*subr) ();
+
+  if (m != MATCH_YES)
+    {
+      gfc_current_locus = *old_locus;
+      reject_statement ();
+    }
+
+  return m;
+}
+
+
+/* Load symbols from all USE statements encountered in this scoping unit.  */
+
+static void
+use_modules (void)
+{
+  gfc_error_buf old_error;
+
+  gfc_push_error (&old_error);
+  gfc_buffer_error (0);
+  gfc_use_modules ();
+  gfc_buffer_error (1);
+  gfc_pop_error (&old_error);
+  gfc_commit_symbols ();
+  gfc_warning_check ();
+  gfc_current_ns->old_cl_list = gfc_current_ns->cl_list;
+  gfc_current_ns->old_equiv = gfc_current_ns->equiv;
+  last_was_use_stmt = false;
+}
+
+
+/* Figure out what the next statement is, (mostly) regardless of
+   proper ordering.  The do...while(0) is there to prevent if/else
+   ambiguity.  */
+
+#define match(keyword, subr, st)				\
+    do {							\
+      if (match_word (keyword, subr, &old_locus) == MATCH_YES)	\
+	return st;						\
+      else							\
+	undo_new_statement ();				  \
+    } while (0);
+
+
+/* This is a specialist version of decode_statement that is used
+   for the specification statements in a function, whose
+   characteristics are deferred into the specification statements.
+   eg.:  INTEGER (king = mykind) foo ()
+	 USE mymodule, ONLY mykind..... 
+   The KIND parameter needs a return after USE or IMPORT, whereas
+   derived type declarations can occur anywhere, up the executable
+   block.  ST_GET_FCN_CHARACTERISTICS is returned when we have run
+   out of the correct kind of specification statements.  */
+static gfc_statement
+decode_specification_statement (void)
+{
+  gfc_statement st;
+  locus old_locus;
+  char c;
+
+  if (gfc_match_eos () == MATCH_YES)
+    return ST_NONE;
+
+  old_locus = gfc_current_locus;
+
+  if (match_word ("use", gfc_match_use, &old_locus) == MATCH_YES)
+    {
+      last_was_use_stmt = true;
+      return ST_USE;
+    }
+  else
+    {
+      undo_new_statement ();
+      if (last_was_use_stmt)
+	use_modules ();
+    }
+
+  match ("import", gfc_match_import, ST_IMPORT);
+
+  if (gfc_current_block ()->result->ts.type != BT_DERIVED)
+    goto end_of_block;
+
+  match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
+  match (NULL, gfc_match_data_decl, ST_DATA_DECL);
+  match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
+
+  /* General statement matching: Instead of testing every possible
+     statement, we eliminate most possibilities by peeking at the
+     first character.  */
+
+  c = gfc_peek_ascii_char ();
+
+  switch (c)
+    {
+    case 'a':
+      match ("abstract% interface", gfc_match_abstract_interface,
+	     ST_INTERFACE);
+      match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
+      match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL);
+      break;
+
+    case 'b':
+      match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL);
+      break;
+
+    case 'c':
+      match ("codimension", gfc_match_codimension, ST_ATTR_DECL);
+      match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL);
+      break;
+
+    case 'd':
+      match ("data", gfc_match_data, ST_DATA);
+      match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
+      break;
+
+    case 'e':
+      match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
+      match ("entry% ", gfc_match_entry, ST_ENTRY);
+      match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
+      match ("external", gfc_match_external, ST_ATTR_DECL);
+      break;
+
+    case 'f':
+      match ("format", gfc_match_format, ST_FORMAT);
+      break;
+
+    case 'g':
+      break;
+
+    case 'i':
+      match ("implicit", gfc_match_implicit, ST_IMPLICIT);
+      match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
+      match ("interface", gfc_match_interface, ST_INTERFACE);
+      match ("intent", gfc_match_intent, ST_ATTR_DECL);
+      match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
+      break;
+
+    case 'm':
+      break;
+
+    case 'n':
+      match ("namelist", gfc_match_namelist, ST_NAMELIST);
+      break;
+
+    case 'o':
+      match ("optional", gfc_match_optional, ST_ATTR_DECL);
+      break;
+
+    case 'p':
+      match ("parameter", gfc_match_parameter, ST_PARAMETER);
+      match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
+      if (gfc_match_private (&st) == MATCH_YES)
+	return st;
+      match ("procedure", gfc_match_procedure, ST_PROCEDURE);
+      if (gfc_match_public (&st) == MATCH_YES)
+	return st;
+      match ("protected", gfc_match_protected, ST_ATTR_DECL);
+      break;
+
+    case 'r':
+      break;
+
+    case 's':
+      match ("save", gfc_match_save, ST_ATTR_DECL);
+      break;
+
+    case 't':
+      match ("target", gfc_match_target, ST_ATTR_DECL);
+      match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
+      break;
+
+    case 'u':
+      break;
+
+    case 'v':
+      match ("value", gfc_match_value, ST_ATTR_DECL);
+      match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
+      break;
+
+    case 'w':
+      break;
+    }
+
+  /* This is not a specification statement.  See if any of the matchers
+     has stored an error message of some sort.  */
+
+end_of_block:
+  gfc_clear_error ();
+  gfc_buffer_error (0);
+  gfc_current_locus = old_locus;
+
+  return ST_GET_FCN_CHARACTERISTICS;
+}
+
+
+/* This is the primary 'decode_statement'.  */
+static gfc_statement
+decode_statement (void)
+{
+  gfc_namespace *ns;
+  gfc_statement st;
+  locus old_locus;
+  match m;
+  char c;
+
+  gfc_enforce_clean_symbol_state ();
+
+  gfc_clear_error ();	/* Clear any pending errors.  */
+  gfc_clear_warning ();	/* Clear any pending warnings.  */
+
+  gfc_matching_function = false;
+
+  if (gfc_match_eos () == MATCH_YES)
+    return ST_NONE;
+
+  if (gfc_current_state () == COMP_FUNCTION
+	&& gfc_current_block ()->result->ts.kind == -1)
+    return decode_specification_statement ();
+
+  old_locus = gfc_current_locus;
+
+  c = gfc_peek_ascii_char ();
+
+  if (c == 'u')
+    {
+      if (match_word ("use", gfc_match_use, &old_locus) == MATCH_YES)
+	{
+	  last_was_use_stmt = true;
+	  return ST_USE;
+	}
+      else
+	undo_new_statement ();
+    }
+
+  if (last_was_use_stmt)
+    use_modules ();
+
+  /* Try matching a data declaration or function declaration. The
+      input "REALFUNCTIONA(N)" can mean several things in different
+      contexts, so it (and its relatives) get special treatment.  */
+
+  if (gfc_current_state () == COMP_NONE
+      || gfc_current_state () == COMP_INTERFACE
+      || gfc_current_state () == COMP_CONTAINS)
+    {
+      gfc_matching_function = true;
+      m = gfc_match_function_decl ();
+      if (m == MATCH_YES)
+	return ST_FUNCTION;
+      else if (m == MATCH_ERROR)
+	reject_statement ();
+      else 
+	gfc_undo_symbols ();
+      gfc_current_locus = old_locus;
+    }
+  gfc_matching_function = false;
+
+
+  /* Match statements whose error messages are meant to be overwritten
+     by something better.  */
+
+  match (NULL, gfc_match_assignment, ST_ASSIGNMENT);
+  match (NULL, gfc_match_pointer_assignment, ST_POINTER_ASSIGNMENT);
+  match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
+
+  match (NULL, gfc_match_data_decl, ST_DATA_DECL);
+  match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
+
+  /* Try to match a subroutine statement, which has the same optional
+     prefixes that functions can have.  */
+
+  if (gfc_match_subroutine () == MATCH_YES)
+    return ST_SUBROUTINE;
+  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
+     the matcher is called.  */
+
+  if (gfc_match_if (&st) == MATCH_YES)
+    return st;
+  gfc_undo_symbols ();
+  gfc_current_locus = old_locus;
+
+  if (gfc_match_where (&st) == MATCH_YES)
+    return st;
+  gfc_undo_symbols ();
+  gfc_current_locus = old_locus;
+
+  if (gfc_match_forall (&st) == MATCH_YES)
+    return st;
+  gfc_undo_symbols ();
+  gfc_current_locus = old_locus;
+
+  match (NULL, gfc_match_do, ST_DO);
+  match (NULL, gfc_match_block, ST_BLOCK);
+  match (NULL, gfc_match_associate, ST_ASSOCIATE);
+  match (NULL, gfc_match_critical, ST_CRITICAL);
+  match (NULL, gfc_match_select, ST_SELECT_CASE);
+
+  gfc_current_ns = gfc_build_block_ns (gfc_current_ns);
+  match (NULL, gfc_match_select_type, ST_SELECT_TYPE);
+  ns = gfc_current_ns;
+  gfc_current_ns = gfc_current_ns->parent;
+  gfc_free_namespace (ns);
+
+  /* General statement matching: Instead of testing every possible
+     statement, we eliminate most possibilities by peeking at the
+     first character.  */
+
+  switch (c)
+    {
+    case 'a':
+      match ("abstract% interface", gfc_match_abstract_interface,
+	     ST_INTERFACE);
+      match ("allocate", gfc_match_allocate, ST_ALLOCATE);
+      match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
+      match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT);
+      match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL);
+      break;
+
+    case 'b':
+      match ("backspace", gfc_match_backspace, ST_BACKSPACE);
+      match ("block data", gfc_match_block_data, ST_BLOCK_DATA);
+      match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL);
+      break;
+
+    case 'c':
+      match ("call", gfc_match_call, ST_CALL);
+      match ("close", gfc_match_close, ST_CLOSE);
+      match ("continue", gfc_match_continue, ST_CONTINUE);
+      match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL);
+      match ("cycle", gfc_match_cycle, ST_CYCLE);
+      match ("case", gfc_match_case, ST_CASE);
+      match ("common", gfc_match_common, ST_COMMON);
+      match ("contains", gfc_match_eos, ST_CONTAINS);
+      match ("class", gfc_match_class_is, ST_CLASS_IS);
+      match ("codimension", gfc_match_codimension, ST_ATTR_DECL);
+      break;
+
+    case 'd':
+      match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE);
+      match ("data", gfc_match_data, ST_DATA);
+      match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
+      break;
+
+    case 'e':
+      match ("end file", gfc_match_endfile, ST_END_FILE);
+      match ("exit", gfc_match_exit, ST_EXIT);
+      match ("else", gfc_match_else, ST_ELSE);
+      match ("else where", gfc_match_elsewhere, ST_ELSEWHERE);
+      match ("else if", gfc_match_elseif, ST_ELSEIF);
+      match ("error stop", gfc_match_error_stop, ST_ERROR_STOP);
+      match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
+
+      if (gfc_match_end (&st) == MATCH_YES)
+	return st;
+
+      match ("entry% ", gfc_match_entry, ST_ENTRY);
+      match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
+      match ("external", gfc_match_external, ST_ATTR_DECL);
+      break;
+
+    case 'f':
+      match ("final", gfc_match_final_decl, ST_FINAL);
+      match ("flush", gfc_match_flush, ST_FLUSH);
+      match ("format", gfc_match_format, ST_FORMAT);
+      break;
+
+    case 'g':
+      match ("generic", gfc_match_generic, ST_GENERIC);
+      match ("go to", gfc_match_goto, ST_GOTO);
+      break;
+
+    case 'i':
+      match ("inquire", gfc_match_inquire, ST_INQUIRE);
+      match ("implicit", gfc_match_implicit, ST_IMPLICIT);
+      match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
+      match ("import", gfc_match_import, ST_IMPORT);
+      match ("interface", gfc_match_interface, ST_INTERFACE);
+      match ("intent", gfc_match_intent, ST_ATTR_DECL);
+      match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
+      break;
+
+    case 'l':
+      match ("lock", gfc_match_lock, ST_LOCK);
+      break;
+
+    case 'm':
+      match ("module% procedure", gfc_match_modproc, ST_MODULE_PROC);
+      match ("module", gfc_match_module, ST_MODULE);
+      break;
+
+    case 'n':
+      match ("nullify", gfc_match_nullify, ST_NULLIFY);
+      match ("namelist", gfc_match_namelist, ST_NAMELIST);
+      break;
+
+    case 'o':
+      match ("open", gfc_match_open, ST_OPEN);
+      match ("optional", gfc_match_optional, ST_ATTR_DECL);
+      break;
+
+    case 'p':
+      match ("print", gfc_match_print, ST_WRITE);
+      match ("parameter", gfc_match_parameter, ST_PARAMETER);
+      match ("pause", gfc_match_pause, ST_PAUSE);
+      match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
+      if (gfc_match_private (&st) == MATCH_YES)
+	return st;
+      match ("procedure", gfc_match_procedure, ST_PROCEDURE);
+      match ("program", gfc_match_program, ST_PROGRAM);
+      if (gfc_match_public (&st) == MATCH_YES)
+	return st;
+      match ("protected", gfc_match_protected, ST_ATTR_DECL);
+      break;
+
+    case 'r':
+      match ("read", gfc_match_read, ST_READ);
+      match ("return", gfc_match_return, ST_RETURN);
+      match ("rewind", gfc_match_rewind, ST_REWIND);
+      break;
+
+    case 's':
+      match ("sequence", gfc_match_eos, ST_SEQUENCE);
+      match ("stop", gfc_match_stop, ST_STOP);
+      match ("save", gfc_match_save, ST_ATTR_DECL);
+      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);
+      break;
+
+    case 't':
+      match ("target", gfc_match_target, ST_ATTR_DECL);
+      match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
+      match ("type is", gfc_match_type_is, ST_TYPE_IS);
+      break;
+
+    case 'u':
+      match ("unlock", gfc_match_unlock, ST_UNLOCK);
+      break;
+
+    case 'v':
+      match ("value", gfc_match_value, ST_ATTR_DECL);
+      match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
+      break;
+
+    case 'w':
+      match ("wait", gfc_match_wait, ST_WAIT);
+      match ("write", gfc_match_write, ST_WRITE);
+      break;
+    }
+
+  /* All else has failed, so give up.  See if any of the matchers has
+     stored an error message of some sort.  */
+
+  if (gfc_error_check () == 0)
+    gfc_error_now ("Unclassifiable statement at %C");
+
+  reject_statement ();
+
+  gfc_error_recovery ();
+
+  return ST_NONE;
+}
+
+static gfc_statement
+decode_omp_directive (void)
+{
+  locus old_locus;
+  char c;
+
+  gfc_enforce_clean_symbol_state ();
+
+  gfc_clear_error ();	/* Clear any pending errors.  */
+  gfc_clear_warning ();	/* Clear any pending warnings.  */
+
+  if (gfc_pure (NULL))
+    {
+      gfc_error_now ("OpenMP directives at %C may not appear in PURE "
+		     "or ELEMENTAL procedures");
+      gfc_error_recovery ();
+      return ST_NONE;
+    }
+
+  gfc_unset_implicit_pure (NULL);
+
+  old_locus = gfc_current_locus;
+
+  /* General OpenMP directive matching: Instead of testing every possible
+     statement, we eliminate most possibilities by peeking at the
+     first character.  */
+
+  c = gfc_peek_ascii_char ();
+
+  switch (c)
+    {
+    case 'a':
+      match ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC);
+      break;
+    case 'b':
+      match ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER);
+      break;
+    case 'c':
+      match ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL);
+      break;
+    case 'd':
+      match ("do", gfc_match_omp_do, ST_OMP_DO);
+      break;
+    case 'e':
+      match ("end atomic", gfc_match_omp_eos, ST_OMP_END_ATOMIC);
+      match ("end critical", gfc_match_omp_critical, ST_OMP_END_CRITICAL);
+      match ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO);
+      match ("end master", gfc_match_omp_eos, ST_OMP_END_MASTER);
+      match ("end ordered", gfc_match_omp_eos, ST_OMP_END_ORDERED);
+      match ("end parallel do", gfc_match_omp_eos, ST_OMP_END_PARALLEL_DO);
+      match ("end parallel sections", gfc_match_omp_eos,
+	     ST_OMP_END_PARALLEL_SECTIONS);
+      match ("end parallel workshare", gfc_match_omp_eos,
+	     ST_OMP_END_PARALLEL_WORKSHARE);
+      match ("end parallel", gfc_match_omp_eos, ST_OMP_END_PARALLEL);
+      match ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS);
+      match ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE);
+      match ("end task", gfc_match_omp_eos, ST_OMP_END_TASK);
+      match ("end workshare", gfc_match_omp_end_nowait,
+	     ST_OMP_END_WORKSHARE);
+      break;
+    case 'f':
+      match ("flush", gfc_match_omp_flush, ST_OMP_FLUSH);
+      break;
+    case 'm':
+      match ("master", gfc_match_omp_master, ST_OMP_MASTER);
+      break;
+    case 'o':
+      match ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED);
+      break;
+    case 'p':
+      match ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO);
+      match ("parallel sections", gfc_match_omp_parallel_sections,
+	     ST_OMP_PARALLEL_SECTIONS);
+      match ("parallel workshare", gfc_match_omp_parallel_workshare,
+	     ST_OMP_PARALLEL_WORKSHARE);
+      match ("parallel", gfc_match_omp_parallel, ST_OMP_PARALLEL);
+      break;
+    case 's':
+      match ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS);
+      match ("section", gfc_match_omp_eos, ST_OMP_SECTION);
+      match ("single", gfc_match_omp_single, ST_OMP_SINGLE);
+      break;
+    case 't':
+      match ("task", gfc_match_omp_task, ST_OMP_TASK);
+      match ("taskwait", gfc_match_omp_taskwait, ST_OMP_TASKWAIT);
+      match ("taskyield", gfc_match_omp_taskyield, ST_OMP_TASKYIELD);
+      match ("threadprivate", gfc_match_omp_threadprivate,
+	     ST_OMP_THREADPRIVATE);
+      break;
+    case 'w':
+      match ("workshare", gfc_match_omp_workshare, ST_OMP_WORKSHARE);
+      break;
+    }
+
+  /* All else has failed, so give up.  See if any of the matchers has
+     stored an error message of some sort.  */
+
+  if (gfc_error_check () == 0)
+    gfc_error_now ("Unclassifiable OpenMP directive at %C");
+
+  reject_statement ();
+
+  gfc_error_recovery ();
+
+  return ST_NONE;
+}
+
+static gfc_statement
+decode_gcc_attribute (void)
+{
+  locus old_locus;
+
+  gfc_enforce_clean_symbol_state ();
+
+  gfc_clear_error ();	/* Clear any pending errors.  */
+  gfc_clear_warning ();	/* Clear any pending warnings.  */
+  old_locus = gfc_current_locus;
+
+  match ("attributes", gfc_match_gcc_attributes, ST_ATTR_DECL);
+
+  /* All else has failed, so give up.  See if any of the matchers has
+     stored an error message of some sort.  */
+
+  if (gfc_error_check () == 0)
+    gfc_error_now ("Unclassifiable GCC directive at %C");
+
+  reject_statement ();
+
+  gfc_error_recovery ();
+
+  return ST_NONE;
+}
+
+#undef match
+
+
+/* Get the next statement in free form source.  */
+
+static gfc_statement
+next_free (void)
+{
+  match m;
+  int i, cnt, at_bol;
+  char c;
+
+  at_bol = gfc_at_bol ();
+  gfc_gobble_whitespace ();
+
+  c = gfc_peek_ascii_char ();
+
+  if (ISDIGIT (c))
+    {
+      char d;
+
+      /* Found a statement label?  */
+      m = gfc_match_st_label (&gfc_statement_label);
+
+      d = gfc_peek_ascii_char ();
+      if (m != MATCH_YES || !gfc_is_whitespace (d))
+	{
+	  gfc_match_small_literal_int (&i, &cnt);
+
+	  if (cnt > 5)
+	    gfc_error_now ("Too many digits in statement label at %C");
+
+	  if (i == 0)
+	    gfc_error_now ("Zero is not a valid statement label at %C");
+
+	  do
+	    c = gfc_next_ascii_char ();
+	  while (ISDIGIT(c));
+
+	  if (!gfc_is_whitespace (c))
+	    gfc_error_now ("Non-numeric character in statement label at %C");
+
+	  return ST_NONE;
+	}
+      else
+	{
+	  label_locus = gfc_current_locus;
+
+	  gfc_gobble_whitespace ();
+
+	  if (at_bol && gfc_peek_ascii_char () == ';')
+	    {
+	      gfc_error_now ("Semicolon at %C needs to be preceded by "
+			     "statement");
+	      gfc_next_ascii_char (); /* Eat up the semicolon.  */
+	      return ST_NONE;
+	    }
+
+	  if (gfc_match_eos () == MATCH_YES)
+	    {
+	      gfc_warning_now ("Ignoring statement label in empty statement "
+			       "at %L", &label_locus);
+	      gfc_free_st_label (gfc_statement_label);
+	      gfc_statement_label = NULL;
+	      return ST_NONE;
+	    }
+	}
+    }
+  else if (c == '!')
+    {
+      /* Comments have already been skipped by the time we get here,
+	 except for GCC attributes and OpenMP directives.  */
+
+      gfc_next_ascii_char (); /* Eat up the exclamation sign.  */
+      c = gfc_peek_ascii_char ();
+
+      if (c == 'g')
+	{
+	  int i;
+
+	  c = gfc_next_ascii_char ();
+	  for (i = 0; i < 4; i++, c = gfc_next_ascii_char ())
+	    gcc_assert (c == "gcc$"[i]);
+
+	  gfc_gobble_whitespace ();
+	  return decode_gcc_attribute ();
+
+	}
+      else if (c == '$' && gfc_option.gfc_flag_openmp)
+	{
+	  int i;
+
+	  c = gfc_next_ascii_char ();
+	  for (i = 0; i < 4; i++, c = gfc_next_ascii_char ())
+	    gcc_assert (c == "$omp"[i]);
+
+	  gcc_assert (c == ' ' || c == '\t');
+	  gfc_gobble_whitespace ();
+	  if (last_was_use_stmt)
+	    use_modules ();
+	  return decode_omp_directive ();
+	}
+
+      gcc_unreachable (); 
+    }
+ 
+  if (at_bol && c == ';')
+    {
+      if (!(gfc_option.allow_std & GFC_STD_F2008))
+	gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
+		       "statement");
+      gfc_next_ascii_char (); /* Eat up the semicolon.  */
+      return ST_NONE;
+    }
+
+  return decode_statement ();
+}
+
+
+/* Get the next statement in fixed-form source.  */
+
+static gfc_statement
+next_fixed (void)
+{
+  int label, digit_flag, i;
+  locus loc;
+  gfc_char_t c;
+
+  if (!gfc_at_bol ())
+    return decode_statement ();
+
+  /* Skip past the current label field, parsing a statement label if
+     one is there.  This is a weird number parser, since the number is
+     contained within five columns and can have any kind of embedded
+     spaces.  We also check for characters that make the rest of the
+     line a comment.  */
+
+  label = 0;
+  digit_flag = 0;
+
+  for (i = 0; i < 5; i++)
+    {
+      c = gfc_next_char_literal (NONSTRING);
+
+      switch (c)
+	{
+	case ' ':
+	  break;
+
+	case '0':
+	case '1':
+	case '2':
+	case '3':
+	case '4':
+	case '5':
+	case '6':
+	case '7':
+	case '8':
+	case '9':
+	  label = label * 10 + ((unsigned char) c - '0');
+	  label_locus = gfc_current_locus;
+	  digit_flag = 1;
+	  break;
+
+	  /* Comments have already been skipped by the time we get
+	     here, except for GCC attributes and OpenMP directives.  */
+
+	case '*':
+	  c = gfc_next_char_literal (NONSTRING);
+	  
+	  if (TOLOWER (c) == 'g')
+	    {
+	      for (i = 0; i < 4; i++, c = gfc_next_char_literal (NONSTRING))
+		gcc_assert (TOLOWER (c) == "gcc$"[i]);
+
+	      return decode_gcc_attribute ();
+	    }
+	  else if (c == '$' && gfc_option.gfc_flag_openmp)
+	    {
+	      for (i = 0; i < 4; i++, c = gfc_next_char_literal (NONSTRING))
+		gcc_assert ((char) gfc_wide_tolower (c) == "$omp"[i]);
+
+	      if (c != ' ' && c != '0')
+		{
+		  gfc_buffer_error (0);
+		  gfc_error ("Bad continuation line at %C");
+		  return ST_NONE;
+		}
+	      if (last_was_use_stmt)
+		use_modules ();
+	      return decode_omp_directive ();
+	    }
+	  /* FALLTHROUGH */
+
+	  /* Comments have already been skipped by the time we get
+	     here so don't bother checking for them.  */
+
+	default:
+	  gfc_buffer_error (0);
+	  gfc_error ("Non-numeric character in statement label at %C");
+	  return ST_NONE;
+	}
+    }
+
+  if (digit_flag)
+    {
+      if (label == 0)
+	gfc_warning_now ("Zero is not a valid statement label at %C");
+      else
+	{
+	  /* We've found a valid statement label.  */
+	  gfc_statement_label = gfc_get_st_label (label);
+	}
+    }
+
+  /* Since this line starts a statement, it cannot be a continuation
+     of a previous statement.  If we see something here besides a
+     space or zero, it must be a bad continuation line.  */
+
+  c = gfc_next_char_literal (NONSTRING);
+  if (c == '\n')
+    goto blank_line;
+
+  if (c != ' ' && c != '0')
+    {
+      gfc_buffer_error (0);
+      gfc_error ("Bad continuation line at %C");
+      return ST_NONE;
+    }
+
+  /* Now that we've taken care of the statement label columns, we have
+     to make sure that the first nonblank character is not a '!'.  If
+     it is, the rest of the line is a comment.  */
+
+  do
+    {
+      loc = gfc_current_locus;
+      c = gfc_next_char_literal (NONSTRING);
+    }
+  while (gfc_is_whitespace (c));
+
+  if (c == '!')
+    goto blank_line;
+  gfc_current_locus = loc;
+
+  if (c == ';')
+    {
+      if (digit_flag)
+	gfc_error_now ("Semicolon at %C needs to be preceded by statement");
+      else if (!(gfc_option.allow_std & GFC_STD_F2008))
+	gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
+		       "statement");
+      return ST_NONE;
+    }
+
+  if (gfc_match_eos () == MATCH_YES)
+    goto blank_line;
+
+  /* At this point, we've got a nonblank statement to parse.  */
+  return decode_statement ();
+
+blank_line:
+  if (digit_flag)
+    gfc_warning_now ("Ignoring statement label in empty statement at %L",
+		     &label_locus);
+    
+  gfc_current_locus.lb->truncated = 0;
+  gfc_advance_line ();
+  return ST_NONE;
+}
+
+
+/* Return the next non-ST_NONE statement to the caller.  We also worry
+   about including files and the ends of include files at this stage.  */
+
+static gfc_statement
+next_statement (void)
+{
+  gfc_statement st;
+  locus old_locus;
+
+  gfc_enforce_clean_symbol_state ();
+
+  gfc_new_block = NULL;
+
+  gfc_current_ns->old_cl_list = gfc_current_ns->cl_list;
+  gfc_current_ns->old_equiv = gfc_current_ns->equiv;
+  for (;;)
+    {
+      gfc_statement_label = NULL;
+      gfc_buffer_error (1);
+
+      if (gfc_at_eol ())
+	gfc_advance_line ();
+
+      gfc_skip_comments ();
+
+      if (gfc_at_end ())
+	{
+	  st = ST_NONE;
+	  break;
+	}
+
+      if (gfc_define_undef_line ())
+	continue;
+
+      old_locus = gfc_current_locus;
+
+      st = (gfc_current_form == FORM_FIXED) ? next_fixed () : next_free ();
+
+      if (st != ST_NONE)
+	break;
+    }
+
+  gfc_buffer_error (0);
+
+  if (st == ST_GET_FCN_CHARACTERISTICS && gfc_statement_label != NULL)
+    {
+      gfc_free_st_label (gfc_statement_label);
+      gfc_statement_label = NULL;
+      gfc_current_locus = old_locus;
+    }
+
+  if (st != ST_NONE)
+    check_statement_label (st);
+
+  return st;
+}
+
+
+/****************************** Parser ***********************************/
+
+/* The parser subroutines are of type 'try' that fail if the file ends
+   unexpectedly.  */
+
+/* Macros that expand to case-labels for various classes of
+   statements.  Start with executable statements that directly do
+   things.  */
+
+#define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
+  case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
+  case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
+  case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
+  case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
+  case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
+  case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
+  case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
+  case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \
+  case ST_ERROR_STOP: case ST_SYNC_ALL: case ST_SYNC_IMAGES: \
+  case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK
+
+/* Statements that mark other executable statements.  */
+
+#define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
+  case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
+  case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
+  case ST_OMP_PARALLEL: \
+  case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
+  case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
+  case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
+  case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
+  case ST_OMP_TASK: case ST_CRITICAL
+
+/* Declaration statements */
+
+#define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
+  case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
+  case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \
+  case ST_PROCEDURE
+
+/* Block end statements.  Errors associated with interchanging these
+   are detected in gfc_match_end().  */
+
+#define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
+		 case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
+		 case ST_END_BLOCK: case ST_END_ASSOCIATE
+
+
+/* Push a new state onto the stack.  */
+
+static void
+push_state (gfc_state_data *p, gfc_compile_state new_state, gfc_symbol *sym)
+{
+  p->state = new_state;
+  p->previous = gfc_state_stack;
+  p->sym = sym;
+  p->head = p->tail = NULL;
+  p->do_variable = NULL;
+
+  /* If this the state of a construct like BLOCK, DO or IF, the corresponding
+     construct statement was accepted right before pushing the state.  Thus,
+     the construct's gfc_code is available as tail of the parent state.  */
+  gcc_assert (gfc_state_stack);
+  p->construct = gfc_state_stack->tail;
+
+  gfc_state_stack = p;
+}
+
+
+/* Pop the current state.  */
+static void
+pop_state (void)
+{
+  gfc_state_stack = gfc_state_stack->previous;
+}
+
+
+/* Try to find the given state in the state stack.  */
+
+bool
+gfc_find_state (gfc_compile_state state)
+{
+  gfc_state_data *p;
+
+  for (p = gfc_state_stack; p; p = p->previous)
+    if (p->state == state)
+      break;
+
+  return (p == NULL) ? false : true;
+}
+
+
+/* Starts a new level in the statement list.  */
+
+static gfc_code *
+new_level (gfc_code *q)
+{
+  gfc_code *p;
+
+  p = q->block = gfc_get_code (EXEC_NOP);
+
+  gfc_state_stack->head = gfc_state_stack->tail = p;
+
+  return p;
+}
+
+
+/* Add the current new_st code structure and adds it to the current
+   program unit.  As a side-effect, it zeroes the new_st.  */
+
+static gfc_code *
+add_statement (void)
+{
+  gfc_code *p;
+
+  p = XCNEW (gfc_code);
+  *p = new_st;
+
+  p->loc = gfc_current_locus;
+
+  if (gfc_state_stack->head == NULL)
+    gfc_state_stack->head = p;
+  else
+    gfc_state_stack->tail->next = p;
+
+  while (p->next != NULL)
+    p = p->next;
+
+  gfc_state_stack->tail = p;
+
+  gfc_clear_new_st ();
+
+  return p;
+}
+
+
+/* Frees everything associated with the current statement.  */
+
+static void
+undo_new_statement (void)
+{
+  gfc_free_statements (new_st.block);
+  gfc_free_statements (new_st.next);
+  gfc_free_statement (&new_st);
+  gfc_clear_new_st ();
+}
+
+
+/* If the current statement has a statement label, make sure that it
+   is allowed to, or should have one.  */
+
+static void
+check_statement_label (gfc_statement st)
+{
+  gfc_sl_type type;
+
+  if (gfc_statement_label == NULL)
+    {
+      if (st == ST_FORMAT)
+	gfc_error ("FORMAT statement at %L does not have a statement label",
+		   &new_st.loc);
+      return;
+    }
+
+  switch (st)
+    {
+    case ST_END_PROGRAM:
+    case ST_END_FUNCTION:
+    case ST_END_SUBROUTINE:
+    case ST_ENDDO:
+    case ST_ENDIF:
+    case ST_END_SELECT:
+    case ST_END_CRITICAL:
+    case ST_END_BLOCK:
+    case ST_END_ASSOCIATE:
+    case_executable:
+    case_exec_markers:
+      if (st == ST_ENDDO || st == ST_CONTINUE)
+	type = ST_LABEL_DO_TARGET;
+      else
+	type = ST_LABEL_TARGET;
+      break;
+
+    case ST_FORMAT:
+      type = ST_LABEL_FORMAT;
+      break;
+
+      /* Statement labels are not restricted from appearing on a
+	 particular line.  However, there are plenty of situations
+	 where the resulting label can't be referenced.  */
+
+    default:
+      type = ST_LABEL_BAD_TARGET;
+      break;
+    }
+
+  gfc_define_st_label (gfc_statement_label, type, &label_locus);
+
+  new_st.here = gfc_statement_label;
+}
+
+
+/* Figures out what the enclosing program unit is.  This will be a
+   function, subroutine, program, block data or module.  */
+
+gfc_state_data *
+gfc_enclosing_unit (gfc_compile_state * result)
+{
+  gfc_state_data *p;
+
+  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)
+      {
+
+	if (result != NULL)
+	  *result = p->state;
+	return p;
+      }
+
+  if (result != NULL)
+    *result = COMP_PROGRAM;
+  return NULL;
+}
+
+
+/* Translate a statement enum to a string.  */
+
+const char *
+gfc_ascii_statement (gfc_statement st)
+{
+  const char *p;
+
+  switch (st)
+    {
+    case ST_ARITHMETIC_IF:
+      p = _("arithmetic IF");
+      break;
+    case ST_ALLOCATE:
+      p = "ALLOCATE";
+      break;
+    case ST_ASSOCIATE:
+      p = "ASSOCIATE";
+      break;
+    case ST_ATTR_DECL:
+      p = _("attribute declaration");
+      break;
+    case ST_BACKSPACE:
+      p = "BACKSPACE";
+      break;
+    case ST_BLOCK:
+      p = "BLOCK";
+      break;
+    case ST_BLOCK_DATA:
+      p = "BLOCK DATA";
+      break;
+    case ST_CALL:
+      p = "CALL";
+      break;
+    case ST_CASE:
+      p = "CASE";
+      break;
+    case ST_CLOSE:
+      p = "CLOSE";
+      break;
+    case ST_COMMON:
+      p = "COMMON";
+      break;
+    case ST_CONTINUE:
+      p = "CONTINUE";
+      break;
+    case ST_CONTAINS:
+      p = "CONTAINS";
+      break;
+    case ST_CRITICAL:
+      p = "CRITICAL";
+      break;
+    case ST_CYCLE:
+      p = "CYCLE";
+      break;
+    case ST_DATA_DECL:
+      p = _("data declaration");
+      break;
+    case ST_DATA:
+      p = "DATA";
+      break;
+    case ST_DEALLOCATE:
+      p = "DEALLOCATE";
+      break;
+    case ST_DERIVED_DECL:
+      p = _("derived type declaration");
+      break;
+    case ST_DO:
+      p = "DO";
+      break;
+    case ST_ELSE:
+      p = "ELSE";
+      break;
+    case ST_ELSEIF:
+      p = "ELSE IF";
+      break;
+    case ST_ELSEWHERE:
+      p = "ELSEWHERE";
+      break;
+    case ST_END_ASSOCIATE:
+      p = "END ASSOCIATE";
+      break;
+    case ST_END_BLOCK:
+      p = "END BLOCK";
+      break;
+    case ST_END_BLOCK_DATA:
+      p = "END BLOCK DATA";
+      break;
+    case ST_END_CRITICAL:
+      p = "END CRITICAL";
+      break;
+    case ST_ENDDO:
+      p = "END DO";
+      break;
+    case ST_END_FILE:
+      p = "END FILE";
+      break;
+    case ST_END_FORALL:
+      p = "END FORALL";
+      break;
+    case ST_END_FUNCTION:
+      p = "END FUNCTION";
+      break;
+    case ST_ENDIF:
+      p = "END IF";
+      break;
+    case ST_END_INTERFACE:
+      p = "END INTERFACE";
+      break;
+    case ST_END_MODULE:
+      p = "END MODULE";
+      break;
+    case ST_END_PROGRAM:
+      p = "END PROGRAM";
+      break;
+    case ST_END_SELECT:
+      p = "END SELECT";
+      break;
+    case ST_END_SUBROUTINE:
+      p = "END SUBROUTINE";
+      break;
+    case ST_END_WHERE:
+      p = "END WHERE";
+      break;
+    case ST_END_TYPE:
+      p = "END TYPE";
+      break;
+    case ST_ENTRY:
+      p = "ENTRY";
+      break;
+    case ST_EQUIVALENCE:
+      p = "EQUIVALENCE";
+      break;
+    case ST_ERROR_STOP:
+      p = "ERROR STOP";
+      break;
+    case ST_EXIT:
+      p = "EXIT";
+      break;
+    case ST_FLUSH:
+      p = "FLUSH";
+      break;
+    case ST_FORALL_BLOCK:	/* Fall through */
+    case ST_FORALL:
+      p = "FORALL";
+      break;
+    case ST_FORMAT:
+      p = "FORMAT";
+      break;
+    case ST_FUNCTION:
+      p = "FUNCTION";
+      break;
+    case ST_GENERIC:
+      p = "GENERIC";
+      break;
+    case ST_GOTO:
+      p = "GOTO";
+      break;
+    case ST_IF_BLOCK:
+      p = _("block IF");
+      break;
+    case ST_IMPLICIT:
+      p = "IMPLICIT";
+      break;
+    case ST_IMPLICIT_NONE:
+      p = "IMPLICIT NONE";
+      break;
+    case ST_IMPLIED_ENDDO:
+      p = _("implied END DO");
+      break;
+    case ST_IMPORT:
+      p = "IMPORT";
+      break;
+    case ST_INQUIRE:
+      p = "INQUIRE";
+      break;
+    case ST_INTERFACE:
+      p = "INTERFACE";
+      break;
+    case ST_LOCK:
+      p = "LOCK";
+      break;
+    case ST_PARAMETER:
+      p = "PARAMETER";
+      break;
+    case ST_PRIVATE:
+      p = "PRIVATE";
+      break;
+    case ST_PUBLIC:
+      p = "PUBLIC";
+      break;
+    case ST_MODULE:
+      p = "MODULE";
+      break;
+    case ST_PAUSE:
+      p = "PAUSE";
+      break;
+    case ST_MODULE_PROC:
+      p = "MODULE PROCEDURE";
+      break;
+    case ST_NAMELIST:
+      p = "NAMELIST";
+      break;
+    case ST_NULLIFY:
+      p = "NULLIFY";
+      break;
+    case ST_OPEN:
+      p = "OPEN";
+      break;
+    case ST_PROGRAM:
+      p = "PROGRAM";
+      break;
+    case ST_PROCEDURE:
+      p = "PROCEDURE";
+      break;
+    case ST_READ:
+      p = "READ";
+      break;
+    case ST_RETURN:
+      p = "RETURN";
+      break;
+    case ST_REWIND:
+      p = "REWIND";
+      break;
+    case ST_STOP:
+      p = "STOP";
+      break;
+    case ST_SYNC_ALL:
+      p = "SYNC ALL";
+      break;
+    case ST_SYNC_IMAGES:
+      p = "SYNC IMAGES";
+      break;
+    case ST_SYNC_MEMORY:
+      p = "SYNC MEMORY";
+      break;
+    case ST_SUBROUTINE:
+      p = "SUBROUTINE";
+      break;
+    case ST_TYPE:
+      p = "TYPE";
+      break;
+    case ST_UNLOCK:
+      p = "UNLOCK";
+      break;
+    case ST_USE:
+      p = "USE";
+      break;
+    case ST_WHERE_BLOCK:	/* Fall through */
+    case ST_WHERE:
+      p = "WHERE";
+      break;
+    case ST_WAIT:
+      p = "WAIT";
+      break;
+    case ST_WRITE:
+      p = "WRITE";
+      break;
+    case ST_ASSIGNMENT:
+      p = _("assignment");
+      break;
+    case ST_POINTER_ASSIGNMENT:
+      p = _("pointer assignment");
+      break;
+    case ST_SELECT_CASE:
+      p = "SELECT CASE";
+      break;
+    case ST_SELECT_TYPE:
+      p = "SELECT TYPE";
+      break;
+    case ST_TYPE_IS:
+      p = "TYPE IS";
+      break;
+    case ST_CLASS_IS:
+      p = "CLASS IS";
+      break;
+    case ST_SEQUENCE:
+      p = "SEQUENCE";
+      break;
+    case ST_SIMPLE_IF:
+      p = _("simple IF");
+      break;
+    case ST_STATEMENT_FUNCTION:
+      p = "STATEMENT FUNCTION";
+      break;
+    case ST_LABEL_ASSIGNMENT:
+      p = "LABEL ASSIGNMENT";
+      break;
+    case ST_ENUM:
+      p = "ENUM DEFINITION";
+      break;
+    case ST_ENUMERATOR:
+      p = "ENUMERATOR DEFINITION";
+      break;
+    case ST_END_ENUM:
+      p = "END ENUM";
+      break;
+    case ST_OMP_ATOMIC:
+      p = "!$OMP ATOMIC";
+      break;
+    case ST_OMP_BARRIER:
+      p = "!$OMP BARRIER";
+      break;
+    case ST_OMP_CRITICAL:
+      p = "!$OMP CRITICAL";
+      break;
+    case ST_OMP_DO:
+      p = "!$OMP DO";
+      break;
+    case ST_OMP_END_ATOMIC:
+      p = "!$OMP END ATOMIC";
+      break;
+    case ST_OMP_END_CRITICAL:
+      p = "!$OMP END CRITICAL";
+      break;
+    case ST_OMP_END_DO:
+      p = "!$OMP END DO";
+      break;
+    case ST_OMP_END_MASTER:
+      p = "!$OMP END MASTER";
+      break;
+    case ST_OMP_END_ORDERED:
+      p = "!$OMP END ORDERED";
+      break;
+    case ST_OMP_END_PARALLEL:
+      p = "!$OMP END PARALLEL";
+      break;
+    case ST_OMP_END_PARALLEL_DO:
+      p = "!$OMP END PARALLEL DO";
+      break;
+    case ST_OMP_END_PARALLEL_SECTIONS:
+      p = "!$OMP END PARALLEL SECTIONS";
+      break;
+    case ST_OMP_END_PARALLEL_WORKSHARE:
+      p = "!$OMP END PARALLEL WORKSHARE";
+      break;
+    case ST_OMP_END_SECTIONS:
+      p = "!$OMP END SECTIONS";
+      break;
+    case ST_OMP_END_SINGLE:
+      p = "!$OMP END SINGLE";
+      break;
+    case ST_OMP_END_TASK:
+      p = "!$OMP END TASK";
+      break;
+    case ST_OMP_END_WORKSHARE:
+      p = "!$OMP END WORKSHARE";
+      break;
+    case ST_OMP_FLUSH:
+      p = "!$OMP FLUSH";
+      break;
+    case ST_OMP_MASTER:
+      p = "!$OMP MASTER";
+      break;
+    case ST_OMP_ORDERED:
+      p = "!$OMP ORDERED";
+      break;
+    case ST_OMP_PARALLEL:
+      p = "!$OMP PARALLEL";
+      break;
+    case ST_OMP_PARALLEL_DO:
+      p = "!$OMP PARALLEL DO";
+      break;
+    case ST_OMP_PARALLEL_SECTIONS:
+      p = "!$OMP PARALLEL SECTIONS";
+      break;
+    case ST_OMP_PARALLEL_WORKSHARE:
+      p = "!$OMP PARALLEL WORKSHARE";
+      break;
+    case ST_OMP_SECTIONS:
+      p = "!$OMP SECTIONS";
+      break;
+    case ST_OMP_SECTION:
+      p = "!$OMP SECTION";
+      break;
+    case ST_OMP_SINGLE:
+      p = "!$OMP SINGLE";
+      break;
+    case ST_OMP_TASK:
+      p = "!$OMP TASK";
+      break;
+    case ST_OMP_TASKWAIT:
+      p = "!$OMP TASKWAIT";
+      break;
+    case ST_OMP_TASKYIELD:
+      p = "!$OMP TASKYIELD";
+      break;
+    case ST_OMP_THREADPRIVATE:
+      p = "!$OMP THREADPRIVATE";
+      break;
+    case ST_OMP_WORKSHARE:
+      p = "!$OMP WORKSHARE";
+      break;
+    default:
+      gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
+    }
+
+  return p;
+}
+
+
+/* Create a symbol for the main program and assign it to ns->proc_name.  */
+ 
+static void 
+main_program_symbol (gfc_namespace *ns, const char *name)
+{
+  gfc_symbol *main_program;
+  symbol_attribute attr;
+
+  gfc_get_symbol (name, ns, &main_program);
+  gfc_clear_attr (&attr);
+  attr.flavor = FL_PROGRAM;
+  attr.proc = PROC_UNKNOWN;
+  attr.subroutine = 1;
+  attr.access = ACCESS_PUBLIC;
+  attr.is_main_program = 1;
+  main_program->attr = attr;
+  main_program->declared_at = gfc_current_locus;
+  ns->proc_name = main_program;
+  gfc_commit_symbols ();
+}
+
+
+/* Do whatever is necessary to accept the last statement.  */
+
+static void
+accept_statement (gfc_statement st)
+{
+  switch (st)
+    {
+    case ST_IMPLICIT_NONE:
+      gfc_set_implicit_none ();
+      break;
+
+    case ST_IMPLICIT:
+      break;
+
+    case ST_FUNCTION:
+    case ST_SUBROUTINE:
+    case ST_MODULE:
+      gfc_current_ns->proc_name = gfc_new_block;
+      break;
+
+      /* If the statement is the end of a block, lay down a special code
+	 that allows a branch to the end of the block from within the
+	 construct.  IF and SELECT are treated differently from DO
+	 (where EXEC_NOP is added inside the loop) for two
+	 reasons:
+         1. END DO has a meaning in the sense that after a GOTO to
+	    it, the loop counter must be increased.
+         2. IF blocks and SELECT blocks can consist of multiple
+	    parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
+	    Putting the label before the END IF would make the jump
+	    from, say, the ELSE IF block to the END IF illegal.  */
+
+    case ST_ENDIF:
+    case ST_END_SELECT:
+    case ST_END_CRITICAL:
+      if (gfc_statement_label != NULL)
+	{
+	  new_st.op = EXEC_END_NESTED_BLOCK;
+	  add_statement ();
+	}
+      break;
+
+      /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than
+	 one parallel block.  Thus, we add the special code to the nested block
+	 itself, instead of the parent one.  */
+    case ST_END_BLOCK:
+    case ST_END_ASSOCIATE:
+      if (gfc_statement_label != NULL)
+	{
+	  new_st.op = EXEC_END_BLOCK;
+	  add_statement ();
+	}
+      break;
+
+      /* The end-of-program unit statements do not get the special
+	 marker and require a statement of some sort if they are a
+	 branch target.  */
+
+    case ST_END_PROGRAM:
+    case ST_END_FUNCTION:
+    case ST_END_SUBROUTINE:
+      if (gfc_statement_label != NULL)
+	{
+	  new_st.op = EXEC_RETURN;
+	  add_statement ();
+	}
+      else
+	{
+	  new_st.op = EXEC_END_PROCEDURE;
+	  add_statement ();
+	}
+
+      break;
+
+    case ST_ENTRY:
+    case_executable:
+    case_exec_markers:
+      add_statement ();
+      break;
+
+    default:
+      break;
+    }
+
+  gfc_commit_symbols ();
+  gfc_warning_check ();
+  gfc_clear_new_st ();
+}
+
+
+/* Undo anything tentative that has been built for the current
+   statement.  */
+
+static void
+reject_statement (void)
+{
+  /* Revert to the previous charlen chain.  */
+  gfc_free_charlen (gfc_current_ns->cl_list, gfc_current_ns->old_cl_list);
+  gfc_current_ns->cl_list = gfc_current_ns->old_cl_list;
+
+  gfc_free_equiv_until (gfc_current_ns->equiv, gfc_current_ns->old_equiv);
+  gfc_current_ns->equiv = gfc_current_ns->old_equiv;
+
+  gfc_new_block = NULL;
+  gfc_undo_symbols ();
+  gfc_clear_warning ();
+  undo_new_statement ();
+}
+
+
+/* Generic complaint about an out of order statement.  We also do
+   whatever is necessary to clean up.  */
+
+static void
+unexpected_statement (gfc_statement st)
+{
+  gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st));
+
+  reject_statement ();
+}
+
+
+/* Given the next statement seen by the matcher, make sure that it is
+   in proper order with the last.  This subroutine is initialized by
+   calling it with an argument of ST_NONE.  If there is a problem, we
+   issue an error and return false.  Otherwise we return true.
+
+   Individual parsers need to verify that the statements seen are
+   valid before calling here, i.e., ENTRY statements are not allowed in
+   INTERFACE blocks.  The following diagram is taken from the standard:
+
+	    +---------------------------------------+
+	    | program  subroutine  function  module |
+	    +---------------------------------------+
+	    |		 use		   |
+	    +---------------------------------------+
+	    |		 import		|
+	    +---------------------------------------+
+	    |	|	implicit none	 |
+	    |	+-----------+------------------+
+	    |	| parameter |  implicit	|
+	    |	+-----------+------------------+
+	    | format |	   |  derived type    |
+	    | entry  | parameter |  interface       |
+	    |	|   data    |  specification   |
+	    |	|	   |  statement func  |
+	    |	+-----------+------------------+
+	    |	|   data    |    executable    |
+	    +--------+-----------+------------------+
+	    |		contains	       |
+	    +---------------------------------------+
+	    |      internal module/subprogram       |
+	    +---------------------------------------+
+	    |		   end		 |
+	    +---------------------------------------+
+
+*/
+
+enum state_order
+{
+  ORDER_START,
+  ORDER_USE,
+  ORDER_IMPORT,
+  ORDER_IMPLICIT_NONE,
+  ORDER_IMPLICIT,
+  ORDER_SPEC,
+  ORDER_EXEC
+};
+
+typedef struct
+{
+  enum state_order state;
+  gfc_statement last_statement;
+  locus where;
+}
+st_state;
+
+static bool
+verify_st_order (st_state *p, gfc_statement st, bool silent)
+{
+
+  switch (st)
+    {
+    case ST_NONE:
+      p->state = ORDER_START;
+      break;
+
+    case ST_USE:
+      if (p->state > ORDER_USE)
+	goto order;
+      p->state = ORDER_USE;
+      break;
+
+    case ST_IMPORT:
+      if (p->state > ORDER_IMPORT)
+	goto order;
+      p->state = ORDER_IMPORT;
+      break;
+
+    case ST_IMPLICIT_NONE:
+      if (p->state > ORDER_IMPLICIT_NONE)
+	goto order;
+
+      /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
+	 statement disqualifies a USE but not an IMPLICIT NONE.
+	 Duplicate IMPLICIT NONEs are caught when the implicit types
+	 are set.  */
+
+      p->state = ORDER_IMPLICIT_NONE;
+      break;
+
+    case ST_IMPLICIT:
+      if (p->state > ORDER_IMPLICIT)
+	goto order;
+      p->state = ORDER_IMPLICIT;
+      break;
+
+    case ST_FORMAT:
+    case ST_ENTRY:
+      if (p->state < ORDER_IMPLICIT_NONE)
+	p->state = ORDER_IMPLICIT_NONE;
+      break;
+
+    case ST_PARAMETER:
+      if (p->state >= ORDER_EXEC)
+	goto order;
+      if (p->state < ORDER_IMPLICIT)
+	p->state = ORDER_IMPLICIT;
+      break;
+
+    case ST_DATA:
+      if (p->state < ORDER_SPEC)
+	p->state = ORDER_SPEC;
+      break;
+
+    case ST_PUBLIC:
+    case ST_PRIVATE:
+    case ST_DERIVED_DECL:
+    case_decl:
+      if (p->state >= ORDER_EXEC)
+	goto order;
+      if (p->state < ORDER_SPEC)
+	p->state = ORDER_SPEC;
+      break;
+
+    case_executable:
+    case_exec_markers:
+      if (p->state < ORDER_EXEC)
+	p->state = ORDER_EXEC;
+      break;
+
+    default:
+      gfc_internal_error ("Unexpected %s statement in verify_st_order() at %C",
+			  gfc_ascii_statement (st));
+    }
+
+  /* All is well, record the statement in case we need it next time.  */
+  p->where = gfc_current_locus;
+  p->last_statement = st;
+  return true;
+
+order:
+  if (!silent)
+    gfc_error ("%s statement at %C cannot follow %s statement at %L",
+	       gfc_ascii_statement (st),
+	       gfc_ascii_statement (p->last_statement), &p->where);
+
+  return false;
+}
+
+
+/* Handle an unexpected end of file.  This is a show-stopper...  */
+
+static void unexpected_eof (void) ATTRIBUTE_NORETURN;
+
+static void
+unexpected_eof (void)
+{
+  gfc_state_data *p;
+
+  gfc_error ("Unexpected end of file in '%s'", gfc_source_file);
+
+  /* Memory cleanup.  Move to "second to last".  */
+  for (p = gfc_state_stack; p && p->previous && p->previous->previous;
+       p = p->previous);
+
+  gfc_current_ns->code = (p && p->previous) ? p->head : NULL;
+  gfc_done_2 ();
+
+  longjmp (eof_buf, 1);
+}
+
+
+/* Parse the CONTAINS section of a derived type definition.  */
+
+gfc_access gfc_typebound_default_access;
+
+static bool
+parse_derived_contains (void)
+{
+  gfc_state_data s;
+  bool seen_private = false;
+  bool seen_comps = false;
+  bool error_flag = false;
+  bool to_finish;
+
+  gcc_assert (gfc_current_state () == COMP_DERIVED);
+  gcc_assert (gfc_current_block ());
+
+  /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
+     section.  */
+  if (gfc_current_block ()->attr.sequence)
+    gfc_error ("Derived-type '%s' with SEQUENCE must not have a CONTAINS"
+	       " section at %C", gfc_current_block ()->name);
+  if (gfc_current_block ()->attr.is_bind_c)
+    gfc_error ("Derived-type '%s' with BIND(C) must not have a CONTAINS"
+	       " section at %C", gfc_current_block ()->name);
+
+  accept_statement (ST_CONTAINS);
+  push_state (&s, COMP_DERIVED_CONTAINS, NULL);
+
+  gfc_typebound_default_access = ACCESS_PUBLIC;
+
+  to_finish = false;
+  while (!to_finish)
+    {
+      gfc_statement st;
+      st = next_statement ();
+      switch (st)
+	{
+	case ST_NONE:
+	  unexpected_eof ();
+	  break;
+
+	case ST_DATA_DECL:
+	  gfc_error ("Components in TYPE at %C must precede CONTAINS");
+	  goto error;
+
+	case ST_PROCEDURE:
+	  if (!gfc_notify_std (GFC_STD_F2003, "Type-bound procedure at %C"))
+	    goto error;
+
+	  accept_statement (ST_PROCEDURE);
+	  seen_comps = true;
+	  break;
+
+	case ST_GENERIC:
+	  if (!gfc_notify_std (GFC_STD_F2003, "GENERIC binding at %C"))
+	    goto error;
+
+	  accept_statement (ST_GENERIC);
+	  seen_comps = true;
+	  break;
+
+	case ST_FINAL:
+	  if (!gfc_notify_std (GFC_STD_F2003, "FINAL procedure declaration"
+			       " at %C"))
+	    goto error;
+
+	  accept_statement (ST_FINAL);
+	  seen_comps = true;
+	  break;
+
+	case ST_END_TYPE:
+	  to_finish = true;
+
+	  if (!seen_comps
+	      && (!gfc_notify_std(GFC_STD_F2008, "Derived type definition "
+				  "at %C with empty CONTAINS section")))
+	    goto error;
+
+	  /* ST_END_TYPE is accepted by parse_derived after return.  */
+	  break;
+
+	case ST_PRIVATE:
+	  if (!gfc_find_state (COMP_MODULE))
+	    {
+	      gfc_error ("PRIVATE statement in TYPE at %C must be inside "
+			 "a MODULE");
+	      goto error;
+	    }
+
+	  if (seen_comps)
+	    {
+	      gfc_error ("PRIVATE statement at %C must precede procedure"
+			 " bindings");
+	      goto error;
+	    }
+
+	  if (seen_private)
+	    {
+	      gfc_error ("Duplicate PRIVATE statement at %C");
+	      goto error;
+	    }
+
+	  accept_statement (ST_PRIVATE);
+	  gfc_typebound_default_access = ACCESS_PRIVATE;
+	  seen_private = true;
+	  break;
+
+	case ST_SEQUENCE:
+	  gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
+	  goto error;
+
+	case ST_CONTAINS:
+	  gfc_error ("Already inside a CONTAINS block at %C");
+	  goto error;
+
+	default:
+	  unexpected_statement (st);
+	  break;
+	}
+
+      continue;
+
+error:
+      error_flag = true;
+      reject_statement ();
+    }
+
+  pop_state ();
+  gcc_assert (gfc_current_state () == COMP_DERIVED);
+
+  return error_flag;
+}
+
+
+/* Parse a derived type.  */
+
+static void
+parse_derived (void)
+{
+  int compiling_type, seen_private, seen_sequence, seen_component;
+  gfc_statement st;
+  gfc_state_data s;
+  gfc_symbol *sym;
+  gfc_component *c, *lock_comp = NULL;
+
+  accept_statement (ST_DERIVED_DECL);
+  push_state (&s, COMP_DERIVED, gfc_new_block);
+
+  gfc_new_block->component_access = ACCESS_PUBLIC;
+  seen_private = 0;
+  seen_sequence = 0;
+  seen_component = 0;
+
+  compiling_type = 1;
+
+  while (compiling_type)
+    {
+      st = next_statement ();
+      switch (st)
+	{
+	case ST_NONE:
+	  unexpected_eof ();
+
+	case ST_DATA_DECL:
+	case ST_PROCEDURE:
+	  accept_statement (st);
+	  seen_component = 1;
+	  break;
+
+	case ST_FINAL:
+	  gfc_error ("FINAL declaration at %C must be inside CONTAINS");
+	  break;
+
+	case ST_END_TYPE:
+endType:
+	  compiling_type = 0;
+
+	  if (!seen_component)
+	    gfc_notify_std (GFC_STD_F2003, "Derived type "
+			    "definition at %C without components");
+
+	  accept_statement (ST_END_TYPE);
+	  break;
+
+	case ST_PRIVATE:
+	  if (!gfc_find_state (COMP_MODULE))
+	    {
+	      gfc_error ("PRIVATE statement in TYPE at %C must be inside "
+			 "a MODULE");
+	      break;
+	    }
+
+	  if (seen_component)
+	    {
+	      gfc_error ("PRIVATE statement at %C must precede "
+			 "structure components");
+	      break;
+	    }
+
+	  if (seen_private)
+	    gfc_error ("Duplicate PRIVATE statement at %C");
+
+	  s.sym->component_access = ACCESS_PRIVATE;
+
+	  accept_statement (ST_PRIVATE);
+	  seen_private = 1;
+	  break;
+
+	case ST_SEQUENCE:
+	  if (seen_component)
+	    {
+	      gfc_error ("SEQUENCE statement at %C must precede "
+			 "structure components");
+	      break;
+	    }
+
+	  if (gfc_current_block ()->attr.sequence)
+	    gfc_warning ("SEQUENCE attribute at %C already specified in "
+			 "TYPE statement");
+
+	  if (seen_sequence)
+	    {
+	      gfc_error ("Duplicate SEQUENCE statement at %C");
+	    }
+
+	  seen_sequence = 1;
+	  gfc_add_sequence (&gfc_current_block ()->attr, 
+			    gfc_current_block ()->name, NULL);
+	  break;
+
+	case ST_CONTAINS:
+	  gfc_notify_std (GFC_STD_F2003,
+			  "CONTAINS block in derived type"
+			  " definition at %C");
+
+	  accept_statement (ST_CONTAINS);
+	  parse_derived_contains ();
+	  goto endType;
+
+	default:
+	  unexpected_statement (st);
+	  break;
+	}
+    }
+
+  /* need to verify that all fields of the derived type are
+   * interoperable with C if the type is declared to be bind(c)
+   */
+  sym = gfc_current_block ();
+  for (c = sym->components; c; c = c->next)
+    {
+      bool coarray, lock_type, allocatable, pointer;
+      coarray = lock_type = allocatable = pointer = false;
+
+      /* Look for allocatable components.  */
+      if (c->attr.allocatable
+	  || (c->ts.type == BT_CLASS && c->attr.class_ok
+	      && CLASS_DATA (c)->attr.allocatable)
+	  || (c->ts.type == BT_DERIVED && !c->attr.pointer
+	      && c->ts.u.derived->attr.alloc_comp))
+	{
+	  allocatable = true;
+	  sym->attr.alloc_comp = 1;
+	}
+
+      /* Look for pointer components.  */
+      if (c->attr.pointer
+	  || (c->ts.type == BT_CLASS && c->attr.class_ok
+	      && CLASS_DATA (c)->attr.class_pointer)
+	  || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp))
+	{
+	  pointer = true;
+	  sym->attr.pointer_comp = 1;
+	}
+
+      /* Look for procedure pointer components.  */
+      if (c->attr.proc_pointer
+	  || (c->ts.type == BT_DERIVED
+	      && c->ts.u.derived->attr.proc_pointer_comp))
+	sym->attr.proc_pointer_comp = 1;
+
+      /* Looking for coarray components.  */
+      if (c->attr.codimension
+	  || (c->ts.type == BT_CLASS && c->attr.class_ok
+	      && CLASS_DATA (c)->attr.codimension))
+	{
+	  coarray = true;
+	  sym->attr.coarray_comp = 1;
+	}
+     
+      if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
+	  && !c->attr.pointer)
+	{
+	  coarray = true;
+	  sym->attr.coarray_comp = 1;
+	}
+
+      /* Looking for lock_type components.  */
+      if ((c->ts.type == BT_DERIVED
+	      && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+	      && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
+	  || (c->ts.type == BT_CLASS && c->attr.class_ok
+	      && CLASS_DATA (c)->ts.u.derived->from_intmod
+		 == INTMOD_ISO_FORTRAN_ENV
+	      && CLASS_DATA (c)->ts.u.derived->intmod_sym_id
+		 == ISOFORTRAN_LOCK_TYPE)
+	  || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.lock_comp
+	      && !allocatable && !pointer))
+	{
+	  lock_type = 1;
+	  lock_comp = c;
+	  sym->attr.lock_comp = 1;
+	}
+
+      /* Check for F2008, C1302 - and recall that pointers may not be coarrays
+	 (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
+	 unless there are nondirect [allocatable or pointer] components
+	 involved (cf. 1.3.33.1 and 1.3.33.3).  */
+
+      if (pointer && !coarray && lock_type)
+	gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
+		   "codimension or be a subcomponent of a coarray, "
+		   "which is not possible as the component has the "
+		   "pointer attribute", c->name, &c->loc);
+      else if (pointer && !coarray && c->ts.type == BT_DERIVED
+	       && c->ts.u.derived->attr.lock_comp)
+	gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
+		   "of type LOCK_TYPE, which must have a codimension or be a "
+		   "subcomponent of a coarray", c->name, &c->loc);
+
+      if (lock_type && allocatable && !coarray)
+	gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have "
+		   "a codimension", c->name, &c->loc);
+      else if (lock_type && allocatable && c->ts.type == BT_DERIVED
+	       && c->ts.u.derived->attr.lock_comp)
+	gfc_error ("Allocatable component %s at %L must have a codimension as "
+		   "it has a noncoarray subcomponent of type LOCK_TYPE",
+		   c->name, &c->loc);
+
+      if (sym->attr.coarray_comp && !coarray && lock_type)
+	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 already a coarray "
+		   "subcomponent exists)", c->name, &c->loc, sym->name);
+
+      if (sym->attr.lock_comp && coarray && !lock_type)
+	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 "
+		   "coarray subcomponent)", lock_comp->name, &lock_comp->loc,
+		   sym->name, c->name, &c->loc);
+
+      /* Look for private components.  */
+      if (sym->component_access == ACCESS_PRIVATE
+	  || c->attr.access == ACCESS_PRIVATE
+	  || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp))
+	sym->attr.private_comp = 1;
+    }
+
+  if (!seen_component)
+    sym->attr.zero_comp = 1;
+
+  pop_state ();
+}
+
+
+/* Parse an ENUM.  */
+ 
+static void
+parse_enum (void)
+{
+  gfc_statement st;
+  int compiling_enum;
+  gfc_state_data s;
+  int seen_enumerator = 0;
+
+  push_state (&s, COMP_ENUM, gfc_new_block);
+
+  compiling_enum = 1;
+
+  while (compiling_enum)
+    {
+      st = next_statement ();
+      switch (st)
+	{
+	case ST_NONE:
+	  unexpected_eof ();
+	  break;
+
+	case ST_ENUMERATOR:
+	  seen_enumerator = 1;
+	  accept_statement (st);
+	  break;
+
+	case ST_END_ENUM:
+	  compiling_enum = 0;
+	  if (!seen_enumerator)
+	    gfc_error ("ENUM declaration at %C has no ENUMERATORS");
+	  accept_statement (st);
+	  break;
+
+	default:
+	  gfc_free_enum_history ();
+	  unexpected_statement (st);
+	  break;
+	}
+    }
+  pop_state ();
+}
+
+
+/* Parse an interface.  We must be able to deal with the possibility
+   of recursive interfaces.  The parse_spec() subroutine is mutually
+   recursive with parse_interface().  */
+
+static gfc_statement parse_spec (gfc_statement);
+
+static void
+parse_interface (void)
+{
+  gfc_compile_state new_state = COMP_NONE, current_state;
+  gfc_symbol *prog_unit, *sym;
+  gfc_interface_info save;
+  gfc_state_data s1, s2;
+  gfc_statement st;
+
+  accept_statement (ST_INTERFACE);
+
+  current_interface.ns = gfc_current_ns;
+  save = current_interface;
+
+  sym = (current_interface.type == INTERFACE_GENERIC
+	 || current_interface.type == INTERFACE_USER_OP)
+	? gfc_new_block : NULL;
+
+  push_state (&s1, COMP_INTERFACE, sym);
+  current_state = COMP_NONE;
+
+loop:
+  gfc_current_ns = gfc_get_namespace (current_interface.ns, 0);
+
+  st = next_statement ();
+  switch (st)
+    {
+    case ST_NONE:
+      unexpected_eof ();
+
+    case ST_SUBROUTINE:
+    case ST_FUNCTION:
+      if (st == ST_SUBROUTINE)
+	new_state = COMP_SUBROUTINE;
+      else if (st == ST_FUNCTION)
+	new_state = COMP_FUNCTION;
+      if (gfc_new_block->attr.pointer)
+	{
+	  gfc_new_block->attr.pointer = 0;
+	  gfc_new_block->attr.proc_pointer = 1;
+	}
+      if (!gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY, 
+				       gfc_new_block->formal, NULL))
+	{
+	  reject_statement ();
+	  gfc_free_namespace (gfc_current_ns);
+	  goto loop;
+	}
+      break;
+
+    case ST_PROCEDURE:
+    case ST_MODULE_PROC:	/* The module procedure matcher makes
+				   sure the context is correct.  */
+      accept_statement (st);
+      gfc_free_namespace (gfc_current_ns);
+      goto loop;
+
+    case ST_END_INTERFACE:
+      gfc_free_namespace (gfc_current_ns);
+      gfc_current_ns = current_interface.ns;
+      goto done;
+
+    default:
+      gfc_error ("Unexpected %s statement in INTERFACE block at %C",
+		 gfc_ascii_statement (st));
+      reject_statement ();
+      gfc_free_namespace (gfc_current_ns);
+      goto loop;
+    }
+
+
+  /* Make sure that the generic name has the right attribute.  */
+  if (current_interface.type == INTERFACE_GENERIC
+      && current_state == COMP_NONE)
+    {
+      if (new_state == COMP_FUNCTION && sym)
+	gfc_add_function (&sym->attr, sym->name, NULL);
+      else if (new_state == COMP_SUBROUTINE && sym)
+	gfc_add_subroutine (&sym->attr, sym->name, NULL);
+
+      current_state = new_state;
+    }
+
+  if (current_interface.type == INTERFACE_ABSTRACT)
+    {
+      gfc_add_abstract (&gfc_new_block->attr, &gfc_current_locus);
+      if (gfc_is_intrinsic_typename (gfc_new_block->name))
+	gfc_error ("Name '%s' of ABSTRACT INTERFACE at %C "
+		   "cannot be the same as an intrinsic type",
+		   gfc_new_block->name);
+    }
+
+  push_state (&s2, new_state, gfc_new_block);
+  accept_statement (st);
+  prog_unit = gfc_new_block;
+  prog_unit->formal_ns = gfc_current_ns;
+  if (prog_unit == prog_unit->formal_ns->proc_name
+      && prog_unit->ns != prog_unit->formal_ns)
+    prog_unit->refs++;
+
+decl:
+  /* Read data declaration statements.  */
+  st = parse_spec (ST_NONE);
+
+  /* Since the interface block does not permit an IMPLICIT statement,
+     the default type for the function or the result must be taken
+     from the formal namespace.  */
+  if (new_state == COMP_FUNCTION)
+    {
+	if (prog_unit->result == prog_unit
+	      && prog_unit->ts.type == BT_UNKNOWN)
+	  gfc_set_default_type (prog_unit, 1, prog_unit->formal_ns);
+	else if (prog_unit->result != prog_unit
+		   && prog_unit->result->ts.type == BT_UNKNOWN)
+	  gfc_set_default_type (prog_unit->result, 1,
+				prog_unit->formal_ns);
+    }
+
+  if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION)
+    {
+      gfc_error ("Unexpected %s statement at %C in INTERFACE body",
+		 gfc_ascii_statement (st));
+      reject_statement ();
+      goto decl;
+    }
+
+  /* Add EXTERNAL attribute to function or subroutine.  */
+  if (current_interface.type != INTERFACE_ABSTRACT && !prog_unit->attr.dummy)
+    gfc_add_external (&prog_unit->attr, &gfc_current_locus);
+
+  current_interface = save;
+  gfc_add_interface (prog_unit);
+  pop_state ();
+
+  if (current_interface.ns
+	&& current_interface.ns->proc_name
+	&& strcmp (current_interface.ns->proc_name->name,
+		   prog_unit->name) == 0)
+    gfc_error ("INTERFACE procedure '%s' at %L has the same name as the "
+	       "enclosing procedure", prog_unit->name,
+	       &current_interface.ns->proc_name->declared_at);
+
+  goto loop;
+
+done:
+  pop_state ();
+}
+
+
+/* Associate function characteristics by going back to the function
+   declaration and rematching the prefix.  */
+
+static match
+match_deferred_characteristics (gfc_typespec * ts)
+{
+  locus loc;
+  match m = MATCH_ERROR;
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+
+  loc = gfc_current_locus;
+
+  gfc_current_locus = gfc_current_block ()->declared_at;
+
+  gfc_clear_error ();
+  gfc_buffer_error (1);
+  m = gfc_match_prefix (ts);
+  gfc_buffer_error (0);
+
+  if (ts->type == BT_DERIVED)
+    {
+      ts->kind = 0;
+
+      if (!ts->u.derived)
+	m = MATCH_ERROR;
+    }
+
+  /* Only permit one go at the characteristic association.  */
+  if (ts->kind == -1)
+    ts->kind = 0;
+
+  /* Set the function locus correctly.  If we have not found the
+     function name, there is an error.  */
+  if (m == MATCH_YES
+      && gfc_match ("function% %n", name) == MATCH_YES
+      && strcmp (name, gfc_current_block ()->name) == 0)
+    {
+      gfc_current_block ()->declared_at = gfc_current_locus;
+      gfc_commit_symbols ();
+    }
+  else
+    {
+      gfc_error_check ();
+      gfc_undo_symbols ();
+    }
+
+  gfc_current_locus =loc;
+  return m;
+}
+
+
+/* Check specification-expressions in the function result of the currently
+   parsed block and ensure they are typed (give an IMPLICIT type if necessary).
+   For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
+   scope are not yet parsed so this has to be delayed up to parse_spec.  */
+
+static void
+check_function_result_typed (void)
+{
+  gfc_typespec* ts = &gfc_current_ns->proc_name->result->ts;
+
+  gcc_assert (gfc_current_state () == COMP_FUNCTION);
+  gcc_assert (ts->type != BT_UNKNOWN);
+
+  /* Check type-parameters, at the moment only CHARACTER lengths possible.  */
+  /* TODO:  Extend when KIND type parameters are implemented.  */
+  if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length)
+    gfc_expr_check_typed (ts->u.cl->length, gfc_current_ns, true);
+}
+
+
+/* Parse a set of specification statements.  Returns the statement
+   that doesn't fit.  */
+
+static gfc_statement
+parse_spec (gfc_statement st)
+{
+  st_state ss;
+  bool function_result_typed = false;
+  bool bad_characteristic = false;
+  gfc_typespec *ts;
+
+  verify_st_order (&ss, ST_NONE, false);
+  if (st == ST_NONE)
+    st = next_statement ();
+
+  /* If we are not inside a function or don't have a result specified so far,
+     do nothing special about it.  */
+  if (gfc_current_state () != COMP_FUNCTION)
+    function_result_typed = true;
+  else
+    {
+      gfc_symbol* proc = gfc_current_ns->proc_name;
+      gcc_assert (proc);
+
+      if (proc->result->ts.type == BT_UNKNOWN)
+	function_result_typed = true;
+    }
+
+loop:
+
+  /* If we're inside a BLOCK construct, some statements are disallowed.
+     Check this here.  Attribute declaration statements like INTENT, OPTIONAL
+     or VALUE are also disallowed, but they don't have a particular ST_*
+     key so we have to check for them individually in their matcher routine.  */
+  if (gfc_current_state () == COMP_BLOCK)
+    switch (st)
+      {
+	case ST_IMPLICIT:
+	case ST_IMPLICIT_NONE:
+	case ST_NAMELIST:
+	case ST_COMMON:
+	case ST_EQUIVALENCE:
+	case ST_STATEMENT_FUNCTION:
+	  gfc_error ("%s statement is not allowed inside of BLOCK at %C",
+		     gfc_ascii_statement (st));
+	  reject_statement ();
+	  break;
+
+	default:
+	  break;
+      }
+  else if (gfc_current_state () == COMP_BLOCK_DATA)
+    /* Fortran 2008, C1116.  */
+    switch (st)
+      {
+        case ST_DATA_DECL:
+	case ST_COMMON:
+	case ST_DATA:
+	case ST_TYPE:
+	case ST_END_BLOCK_DATA:
+	case ST_ATTR_DECL:
+	case ST_EQUIVALENCE:
+	case ST_PARAMETER:
+	case ST_IMPLICIT:
+	case ST_IMPLICIT_NONE:
+	case ST_DERIVED_DECL:
+	case ST_USE:
+	  break;
+
+	case ST_NONE:
+	  break;
+	  
+	default:
+	  gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C",
+		     gfc_ascii_statement (st));
+	  reject_statement ();
+	  break;
+      }
+  
+  /* If we find a statement that can not be followed by an IMPLICIT statement
+     (and thus we can expect to see none any further), type the function result
+     if it has not yet been typed.  Be careful not to give the END statement
+     to verify_st_order!  */
+  if (!function_result_typed && st != ST_GET_FCN_CHARACTERISTICS)
+    {
+      bool verify_now = false;
+
+      if (st == ST_END_FUNCTION || st == ST_CONTAINS)
+	verify_now = true;
+      else
+	{
+	  st_state dummyss;
+	  verify_st_order (&dummyss, ST_NONE, false);
+	  verify_st_order (&dummyss, st, false);
+
+	  if (!verify_st_order (&dummyss, ST_IMPLICIT, true))
+	    verify_now = true;
+	}
+
+      if (verify_now)
+	{
+	  check_function_result_typed ();
+	  function_result_typed = true;
+	}
+    }
+
+  switch (st)
+    {
+    case ST_NONE:
+      unexpected_eof ();
+
+    case ST_IMPLICIT_NONE:
+    case ST_IMPLICIT:
+      if (!function_result_typed)
+	{
+	  check_function_result_typed ();
+	  function_result_typed = true;
+	}
+      goto declSt;
+
+    case ST_FORMAT:
+    case ST_ENTRY:
+    case ST_DATA:	/* Not allowed in interfaces */
+      if (gfc_current_state () == COMP_INTERFACE)
+	break;
+
+      /* Fall through */
+
+    case ST_USE:
+    case ST_IMPORT:
+    case ST_PARAMETER:
+    case ST_PUBLIC:
+    case ST_PRIVATE:
+    case ST_DERIVED_DECL:
+    case_decl:
+declSt:
+      if (!verify_st_order (&ss, st, false))
+	{
+	  reject_statement ();
+	  st = next_statement ();
+	  goto loop;
+	}
+
+      switch (st)
+	{
+	case ST_INTERFACE:
+	  parse_interface ();
+	  break;
+
+	case ST_DERIVED_DECL:
+	  parse_derived ();
+	  break;
+
+	case ST_PUBLIC:
+	case ST_PRIVATE:
+	  if (gfc_current_state () != COMP_MODULE)
+	    {
+	      gfc_error ("%s statement must appear in a MODULE",
+			 gfc_ascii_statement (st));
+	      reject_statement ();
+	      break;
+	    }
+
+	  if (gfc_current_ns->default_access != ACCESS_UNKNOWN)
+	    {
+	      gfc_error ("%s statement at %C follows another accessibility "
+			 "specification", gfc_ascii_statement (st));
+	      reject_statement ();
+	      break;
+	    }
+
+	  gfc_current_ns->default_access = (st == ST_PUBLIC)
+	    ? ACCESS_PUBLIC : ACCESS_PRIVATE;
+
+	  break;
+
+	case ST_STATEMENT_FUNCTION:
+	  if (gfc_current_state () == COMP_MODULE)
+	    {
+	      unexpected_statement (st);
+	      break;
+	    }
+
+	default:
+	  break;
+	}
+
+      accept_statement (st);
+      st = next_statement ();
+      goto loop;
+
+    case ST_ENUM:
+      accept_statement (st);
+      parse_enum();
+      st = next_statement ();
+      goto loop;
+
+    case ST_GET_FCN_CHARACTERISTICS:
+      /* This statement triggers the association of a function's result
+	 characteristics.  */
+      ts = &gfc_current_block ()->result->ts;
+      if (match_deferred_characteristics (ts) != MATCH_YES)
+	bad_characteristic = true;
+
+      st = next_statement ();
+      goto loop;
+
+    default:
+      break;
+    }
+
+  /* If match_deferred_characteristics failed, then there is an error. */
+  if (bad_characteristic)
+    {
+      ts = &gfc_current_block ()->result->ts;
+      if (ts->type != BT_DERIVED)
+	gfc_error ("Bad kind expression for function '%s' at %L",
+		   gfc_current_block ()->name,
+		   &gfc_current_block ()->declared_at);
+      else
+	gfc_error ("The type for function '%s' at %L is not accessible",
+		   gfc_current_block ()->name,
+		   &gfc_current_block ()->declared_at);
+
+      gfc_current_block ()->ts.kind = 0;
+      /* Keep the derived type; if it's bad, it will be discovered later.  */
+      if (!(ts->type == BT_DERIVED && ts->u.derived))
+	ts->type = BT_UNKNOWN;
+    }
+
+  return st;
+}
+
+
+/* Parse a WHERE block, (not a simple WHERE statement).  */
+
+static void
+parse_where_block (void)
+{
+  int seen_empty_else;
+  gfc_code *top, *d;
+  gfc_state_data s;
+  gfc_statement st;
+
+  accept_statement (ST_WHERE_BLOCK);
+  top = gfc_state_stack->tail;
+
+  push_state (&s, COMP_WHERE, gfc_new_block);
+
+  d = add_statement ();
+  d->expr1 = top->expr1;
+  d->op = EXEC_WHERE;
+
+  top->expr1 = NULL;
+  top->block = d;
+
+  seen_empty_else = 0;
+
+  do
+    {
+      st = next_statement ();
+      switch (st)
+	{
+	case ST_NONE:
+	  unexpected_eof ();
+
+	case ST_WHERE_BLOCK:
+	  parse_where_block ();
+	  break;
+
+	case ST_ASSIGNMENT:
+	case ST_WHERE:
+	  accept_statement (st);
+	  break;
+
+	case ST_ELSEWHERE:
+	  if (seen_empty_else)
+	    {
+	      gfc_error ("ELSEWHERE statement at %C follows previous "
+			 "unmasked ELSEWHERE");
+	      reject_statement ();
+	      break;
+	    }
+
+	  if (new_st.expr1 == NULL)
+	    seen_empty_else = 1;
+
+	  d = new_level (gfc_state_stack->head);
+	  d->op = EXEC_WHERE;
+	  d->expr1 = new_st.expr1;
+
+	  accept_statement (st);
+
+	  break;
+
+	case ST_END_WHERE:
+	  accept_statement (st);
+	  break;
+
+	default:
+	  gfc_error ("Unexpected %s statement in WHERE block at %C",
+		     gfc_ascii_statement (st));
+	  reject_statement ();
+	  break;
+	}
+    }
+  while (st != ST_END_WHERE);
+
+  pop_state ();
+}
+
+
+/* Parse a FORALL block (not a simple FORALL statement).  */
+
+static void
+parse_forall_block (void)
+{
+  gfc_code *top, *d;
+  gfc_state_data s;
+  gfc_statement st;
+
+  accept_statement (ST_FORALL_BLOCK);
+  top = gfc_state_stack->tail;
+
+  push_state (&s, COMP_FORALL, gfc_new_block);
+
+  d = add_statement ();
+  d->op = EXEC_FORALL;
+  top->block = d;
+
+  do
+    {
+      st = next_statement ();
+      switch (st)
+	{
+
+	case ST_ASSIGNMENT:
+	case ST_POINTER_ASSIGNMENT:
+	case ST_WHERE:
+	case ST_FORALL:
+	  accept_statement (st);
+	  break;
+
+	case ST_WHERE_BLOCK:
+	  parse_where_block ();
+	  break;
+
+	case ST_FORALL_BLOCK:
+	  parse_forall_block ();
+	  break;
+
+	case ST_END_FORALL:
+	  accept_statement (st);
+	  break;
+
+	case ST_NONE:
+	  unexpected_eof ();
+
+	default:
+	  gfc_error ("Unexpected %s statement in FORALL block at %C",
+		     gfc_ascii_statement (st));
+
+	  reject_statement ();
+	  break;
+	}
+    }
+  while (st != ST_END_FORALL);
+
+  pop_state ();
+}
+
+
+static gfc_statement parse_executable (gfc_statement);
+
+/* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block.  */
+
+static void
+parse_if_block (void)
+{
+  gfc_code *top, *d;
+  gfc_statement st;
+  locus else_locus;
+  gfc_state_data s;
+  int seen_else;
+
+  seen_else = 0;
+  accept_statement (ST_IF_BLOCK);
+
+  top = gfc_state_stack->tail;
+  push_state (&s, COMP_IF, gfc_new_block);
+
+  new_st.op = EXEC_IF;
+  d = add_statement ();
+
+  d->expr1 = top->expr1;
+  top->expr1 = NULL;
+  top->block = d;
+
+  do
+    {
+      st = parse_executable (ST_NONE);
+
+      switch (st)
+	{
+	case ST_NONE:
+	  unexpected_eof ();
+
+	case ST_ELSEIF:
+	  if (seen_else)
+	    {
+	      gfc_error ("ELSE IF statement at %C cannot follow ELSE "
+			 "statement at %L", &else_locus);
+
+	      reject_statement ();
+	      break;
+	    }
+
+	  d = new_level (gfc_state_stack->head);
+	  d->op = EXEC_IF;
+	  d->expr1 = new_st.expr1;
+
+	  accept_statement (st);
+
+	  break;
+
+	case ST_ELSE:
+	  if (seen_else)
+	    {
+	      gfc_error ("Duplicate ELSE statements at %L and %C",
+			 &else_locus);
+	      reject_statement ();
+	      break;
+	    }
+
+	  seen_else = 1;
+	  else_locus = gfc_current_locus;
+
+	  d = new_level (gfc_state_stack->head);
+	  d->op = EXEC_IF;
+
+	  accept_statement (st);
+
+	  break;
+
+	case ST_ENDIF:
+	  break;
+
+	default:
+	  unexpected_statement (st);
+	  break;
+	}
+    }
+  while (st != ST_ENDIF);
+
+  pop_state ();
+  accept_statement (st);
+}
+
+
+/* Parse a SELECT block.  */
+
+static void
+parse_select_block (void)
+{
+  gfc_statement st;
+  gfc_code *cp;
+  gfc_state_data s;
+
+  accept_statement (ST_SELECT_CASE);
+
+  cp = gfc_state_stack->tail;
+  push_state (&s, COMP_SELECT, gfc_new_block);
+
+  /* Make sure that the next statement is a CASE or END SELECT.  */
+  for (;;)
+    {
+      st = next_statement ();
+      if (st == ST_NONE)
+	unexpected_eof ();
+      if (st == ST_END_SELECT)
+	{
+	  /* Empty SELECT CASE is OK.  */
+	  accept_statement (st);
+	  pop_state ();
+	  return;
+	}
+      if (st == ST_CASE)
+	break;
+
+      gfc_error ("Expected a CASE or END SELECT statement following SELECT "
+		 "CASE at %C");
+
+      reject_statement ();
+    }
+
+  /* At this point, we're got a nonempty select block.  */
+  cp = new_level (cp);
+  *cp = new_st;
+
+  accept_statement (st);
+
+  do
+    {
+      st = parse_executable (ST_NONE);
+      switch (st)
+	{
+	case ST_NONE:
+	  unexpected_eof ();
+
+	case ST_CASE:
+	  cp = new_level (gfc_state_stack->head);
+	  *cp = new_st;
+	  gfc_clear_new_st ();
+
+	  accept_statement (st);
+	  /* Fall through */
+
+	case ST_END_SELECT:
+	  break;
+
+	/* Can't have an executable statement because of
+	   parse_executable().  */
+	default:
+	  unexpected_statement (st);
+	  break;
+	}
+    }
+  while (st != ST_END_SELECT);
+
+  pop_state ();
+  accept_statement (st);
+}
+
+
+/* Pop the current selector from the SELECT TYPE stack.  */
+
+static void
+select_type_pop (void)
+{
+  gfc_select_type_stack *old = select_type_stack;
+  select_type_stack = old->prev;
+  free (old);
+}
+
+
+/* Parse a SELECT TYPE construct (F03:R821).  */
+
+static void
+parse_select_type_block (void)
+{
+  gfc_statement st;
+  gfc_code *cp;
+  gfc_state_data s;
+
+  accept_statement (ST_SELECT_TYPE);
+
+  cp = gfc_state_stack->tail;
+  push_state (&s, COMP_SELECT_TYPE, gfc_new_block);
+
+  /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
+     or END SELECT.  */
+  for (;;)
+    {
+      st = next_statement ();
+      if (st == ST_NONE)
+	unexpected_eof ();
+      if (st == ST_END_SELECT)
+	/* Empty SELECT CASE is OK.  */
+	goto done;
+      if (st == ST_TYPE_IS || st == ST_CLASS_IS)
+	break;
+
+      gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
+		 "following SELECT TYPE at %C");
+
+      reject_statement ();
+    }
+
+  /* At this point, we're got a nonempty select block.  */
+  cp = new_level (cp);
+  *cp = new_st;
+
+  accept_statement (st);
+
+  do
+    {
+      st = parse_executable (ST_NONE);
+      switch (st)
+	{
+	case ST_NONE:
+	  unexpected_eof ();
+
+	case ST_TYPE_IS:
+	case ST_CLASS_IS:
+	  cp = new_level (gfc_state_stack->head);
+	  *cp = new_st;
+	  gfc_clear_new_st ();
+
+	  accept_statement (st);
+	  /* Fall through */
+
+	case ST_END_SELECT:
+	  break;
+
+	/* Can't have an executable statement because of
+	   parse_executable().  */
+	default:
+	  unexpected_statement (st);
+	  break;
+	}
+    }
+  while (st != ST_END_SELECT);
+
+done:
+  pop_state ();
+  accept_statement (st);
+  gfc_current_ns = gfc_current_ns->parent;
+  select_type_pop ();
+}
+
+
+/* Given a symbol, make sure it is not an iteration variable for a DO
+   statement.  This subroutine is called when the symbol is seen in a
+   context that causes it to become redefined.  If the symbol is an
+   iterator, we generate an error message and return nonzero.  */
+
+int 
+gfc_check_do_variable (gfc_symtree *st)
+{
+  gfc_state_data *s;
+
+  for (s=gfc_state_stack; s; s = s->previous)
+    if (s->do_variable == st)
+      {
+	gfc_error_now("Variable '%s' at %C cannot be redefined inside "
+		      "loop beginning at %L", st->name, &s->head->loc);
+	return 1;
+      }
+
+  return 0;
+}
+  
+
+/* Checks to see if the current statement label closes an enddo.
+   Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
+   an error) if it incorrectly closes an ENDDO.  */
+
+static int
+check_do_closure (void)
+{
+  gfc_state_data *p;
+
+  if (gfc_statement_label == NULL)
+    return 0;
+
+  for (p = gfc_state_stack; p; p = p->previous)
+    if (p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
+      break;
+
+  if (p == NULL)
+    return 0;		/* No loops to close */
+
+  if (p->ext.end_do_label == gfc_statement_label)
+    {
+      if (p == gfc_state_stack)
+	return 1;
+
+      gfc_error ("End of nonblock DO statement at %C is within another block");
+      return 2;
+    }
+
+  /* At this point, the label doesn't terminate the innermost loop.
+     Make sure it doesn't terminate another one.  */
+  for (; p; p = p->previous)
+    if ((p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
+	&& p->ext.end_do_label == gfc_statement_label)
+      {
+	gfc_error ("End of nonblock DO statement at %C is interwoven "
+		   "with another DO loop");
+	return 2;
+      }
+
+  return 0;
+}
+
+
+/* Parse a series of contained program units.  */
+
+static void parse_progunit (gfc_statement);
+
+
+/* Parse a CRITICAL block.  */
+
+static void
+parse_critical_block (void)
+{
+  gfc_code *top, *d;
+  gfc_state_data s;
+  gfc_statement st;
+
+  s.ext.end_do_label = new_st.label1;
+
+  accept_statement (ST_CRITICAL);
+  top = gfc_state_stack->tail;
+
+  push_state (&s, COMP_CRITICAL, gfc_new_block);
+
+  d = add_statement ();
+  d->op = EXEC_CRITICAL;
+  top->block = d;
+
+  do
+    {
+      st = parse_executable (ST_NONE);
+
+      switch (st)
+	{
+	  case ST_NONE:
+	    unexpected_eof ();
+	    break;
+
+	  case ST_END_CRITICAL:
+	    if (s.ext.end_do_label != NULL
+		&& s.ext.end_do_label != gfc_statement_label)
+	      gfc_error_now ("Statement label in END CRITICAL at %C does not "
+			     "match CRITICAL label");
+
+	    if (gfc_statement_label != NULL)
+	      {
+		new_st.op = EXEC_NOP;
+		add_statement ();
+	      }
+	    break;
+
+	  default:
+	    unexpected_statement (st);
+	    break;
+	}
+    }
+  while (st != ST_END_CRITICAL);
+
+  pop_state ();
+  accept_statement (st);
+}
+
+
+/* Set up the local namespace for a BLOCK construct.  */
+
+gfc_namespace*
+gfc_build_block_ns (gfc_namespace *parent_ns)
+{
+  gfc_namespace* my_ns;
+  static int numblock = 1;
+
+  my_ns = gfc_get_namespace (parent_ns, 1);
+  my_ns->construct_entities = 1;
+
+  /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
+     code generation (so it must not be NULL).
+     We set its recursive argument if our container procedure is recursive, so
+     that local variables are accordingly placed on the stack when it
+     will be necessary.  */
+  if (gfc_new_block)
+    my_ns->proc_name = gfc_new_block;
+  else
+    {
+      bool t;
+      char buffer[20];  /* Enough to hold "block@2147483648\n".  */
+
+      snprintf(buffer, sizeof(buffer), "block@%d", numblock++);
+      gfc_get_symbol (buffer, my_ns, &my_ns->proc_name);
+      t = gfc_add_flavor (&my_ns->proc_name->attr, FL_LABEL,
+			  my_ns->proc_name->name, NULL);
+      gcc_assert (t);
+      gfc_commit_symbol (my_ns->proc_name);
+    }
+
+  if (parent_ns->proc_name)
+    my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
+
+  return my_ns;
+}
+
+
+/* Parse a BLOCK construct.  */
+
+static void
+parse_block_construct (void)
+{
+  gfc_namespace* my_ns;
+  gfc_state_data s;
+
+  gfc_notify_std (GFC_STD_F2008, "BLOCK construct at %C");
+
+  my_ns = gfc_build_block_ns (gfc_current_ns);
+
+  new_st.op = EXEC_BLOCK;
+  new_st.ext.block.ns = my_ns;
+  new_st.ext.block.assoc = NULL;
+  accept_statement (ST_BLOCK);
+
+  push_state (&s, COMP_BLOCK, my_ns->proc_name);
+  gfc_current_ns = my_ns;
+
+  parse_progunit (ST_NONE);
+
+  gfc_current_ns = gfc_current_ns->parent;
+  pop_state ();
+}
+
+
+/* Parse an ASSOCIATE construct.  This is essentially a BLOCK construct
+   behind the scenes with compiler-generated variables.  */
+
+static void
+parse_associate (void)
+{
+  gfc_namespace* my_ns;
+  gfc_state_data s;
+  gfc_statement st;
+  gfc_association_list* a;
+
+  gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C");
+
+  my_ns = gfc_build_block_ns (gfc_current_ns);
+
+  new_st.op = EXEC_BLOCK;
+  new_st.ext.block.ns = my_ns;
+  gcc_assert (new_st.ext.block.assoc);
+
+  /* Add all associate-names as BLOCK variables.  Creating them is enough
+     for now, they'll get their values during trans-* phase.  */
+  gfc_current_ns = my_ns;
+  for (a = new_st.ext.block.assoc; a; a = a->next)
+    {
+      gfc_symbol* sym;
+
+      if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
+	gcc_unreachable ();
+
+      sym = a->st->n.sym;
+      sym->attr.flavor = FL_VARIABLE;
+      sym->assoc = a;
+      sym->declared_at = a->where;
+      gfc_set_sym_referenced (sym);
+
+      /* Initialize the typespec.  It is not available in all cases,
+	 however, as it may only be set on the target during resolution.
+	 Still, sometimes it helps to have it right now -- especially
+	 for parsing component references on the associate-name
+	 in case of association to a derived-type.  */
+      sym->ts = a->target->ts;
+    }
+
+  accept_statement (ST_ASSOCIATE);
+  push_state (&s, COMP_ASSOCIATE, my_ns->proc_name);
+
+loop:
+  st = parse_executable (ST_NONE);
+  switch (st)
+    {
+    case ST_NONE:
+      unexpected_eof ();
+
+    case_end:
+      accept_statement (st);
+      my_ns->code = gfc_state_stack->head;
+      break;
+
+    default:
+      unexpected_statement (st);
+      goto loop;
+    }
+
+  gfc_current_ns = gfc_current_ns->parent;
+  pop_state ();
+}
+
+
+/* Parse a DO loop.  Note that the ST_CYCLE and ST_EXIT statements are
+   handled inside of parse_executable(), because they aren't really
+   loop statements.  */
+
+static void
+parse_do_block (void)
+{
+  gfc_statement st;
+  gfc_code *top;
+  gfc_state_data s;
+  gfc_symtree *stree;
+  gfc_exec_op do_op;
+
+  do_op = new_st.op;
+  s.ext.end_do_label = new_st.label1;
+
+  if (new_st.ext.iterator != NULL)
+    stree = new_st.ext.iterator->var->symtree;
+  else
+    stree = NULL;
+
+  accept_statement (ST_DO);
+
+  top = gfc_state_stack->tail;
+  push_state (&s, do_op == EXEC_DO_CONCURRENT ? COMP_DO_CONCURRENT : COMP_DO,
+	      gfc_new_block);
+
+  s.do_variable = stree;
+
+  top->block = new_level (top);
+  top->block->op = EXEC_DO;
+
+loop:
+  st = parse_executable (ST_NONE);
+
+  switch (st)
+    {
+    case ST_NONE:
+      unexpected_eof ();
+
+    case ST_ENDDO:
+      if (s.ext.end_do_label != NULL
+	  && s.ext.end_do_label != gfc_statement_label)
+	gfc_error_now ("Statement label in ENDDO at %C doesn't match "
+		       "DO label");
+
+      if (gfc_statement_label != NULL)
+	{
+	  new_st.op = EXEC_NOP;
+	  add_statement ();
+	}
+      break;
+
+    case ST_IMPLIED_ENDDO:
+     /* If the do-stmt of this DO construct has a do-construct-name,
+	the corresponding end-do must be an end-do-stmt (with a matching
+	name, but in that case we must have seen ST_ENDDO first).
+	We only complain about this in pedantic mode.  */
+     if (gfc_current_block () != NULL)
+	gfc_error_now ("Named block DO at %L requires matching ENDDO name",
+		       &gfc_current_block()->declared_at);
+
+      break;
+
+    default:
+      unexpected_statement (st);
+      goto loop;
+    }
+
+  pop_state ();
+  accept_statement (st);
+}
+
+
+/* Parse the statements of OpenMP do/parallel do.  */
+
+static gfc_statement
+parse_omp_do (gfc_statement omp_st)
+{
+  gfc_statement st;
+  gfc_code *cp, *np;
+  gfc_state_data s;
+
+  accept_statement (omp_st);
+
+  cp = gfc_state_stack->tail;
+  push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
+  np = new_level (cp);
+  np->op = cp->op;
+  np->block = NULL;
+
+  for (;;)
+    {
+      st = next_statement ();
+      if (st == ST_NONE)
+	unexpected_eof ();
+      else if (st == ST_DO)
+	break;
+      else
+	unexpected_statement (st);
+    }
+
+  parse_do_block ();
+  if (gfc_statement_label != NULL
+      && gfc_state_stack->previous != NULL
+      && gfc_state_stack->previous->state == COMP_DO
+      && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
+    {
+      /* In
+	 DO 100 I=1,10
+	   !$OMP DO
+	     DO J=1,10
+	     ...
+	     100 CONTINUE
+	 there should be no !$OMP END DO.  */
+      pop_state ();
+      return ST_IMPLIED_ENDDO;
+    }
+
+  check_do_closure ();
+  pop_state ();
+
+  st = next_statement ();
+  if (st == (omp_st == ST_OMP_DO ? ST_OMP_END_DO : ST_OMP_END_PARALLEL_DO))
+    {
+      if (new_st.op == EXEC_OMP_END_NOWAIT)
+	cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
+      else
+	gcc_assert (new_st.op == EXEC_NOP);
+      gfc_clear_new_st ();
+      gfc_commit_symbols ();
+      gfc_warning_check ();
+      st = next_statement ();
+    }
+  return st;
+}
+
+
+/* Parse the statements of OpenMP atomic directive.  */
+
+static gfc_statement
+parse_omp_atomic (void)
+{
+  gfc_statement st;
+  gfc_code *cp, *np;
+  gfc_state_data s;
+  int count;
+
+  accept_statement (ST_OMP_ATOMIC);
+
+  cp = gfc_state_stack->tail;
+  push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
+  np = new_level (cp);
+  np->op = cp->op;
+  np->block = NULL;
+  count = 1 + (cp->ext.omp_atomic == GFC_OMP_ATOMIC_CAPTURE);
+
+  while (count)
+    {
+      st = next_statement ();
+      if (st == ST_NONE)
+	unexpected_eof ();
+      else if (st == ST_ASSIGNMENT)
+	{
+	  accept_statement (st);
+	  count--;
+	}
+      else
+	unexpected_statement (st);
+    }
+
+  pop_state ();
+
+  st = next_statement ();
+  if (st == ST_OMP_END_ATOMIC)
+    {
+      gfc_clear_new_st ();
+      gfc_commit_symbols ();
+      gfc_warning_check ();
+      st = next_statement ();
+    }
+  else if (cp->ext.omp_atomic == GFC_OMP_ATOMIC_CAPTURE)
+    gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C");
+  return st;
+}
+
+
+/* Parse the statements of an OpenMP structured block.  */
+
+static void
+parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
+{
+  gfc_statement st, omp_end_st;
+  gfc_code *cp, *np;
+  gfc_state_data s;
+
+  accept_statement (omp_st);
+
+  cp = gfc_state_stack->tail;
+  push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
+  np = new_level (cp);
+  np->op = cp->op;
+  np->block = NULL;
+
+  switch (omp_st)
+    {
+    case ST_OMP_PARALLEL:
+      omp_end_st = ST_OMP_END_PARALLEL;
+      break;
+    case ST_OMP_PARALLEL_SECTIONS:
+      omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
+      break;
+    case ST_OMP_SECTIONS:
+      omp_end_st = ST_OMP_END_SECTIONS;
+      break;
+    case ST_OMP_ORDERED:
+      omp_end_st = ST_OMP_END_ORDERED;
+      break;
+    case ST_OMP_CRITICAL:
+      omp_end_st = ST_OMP_END_CRITICAL;
+      break;
+    case ST_OMP_MASTER:
+      omp_end_st = ST_OMP_END_MASTER;
+      break;
+    case ST_OMP_SINGLE:
+      omp_end_st = ST_OMP_END_SINGLE;
+      break;
+    case ST_OMP_TASK:
+      omp_end_st = ST_OMP_END_TASK;
+      break;
+    case ST_OMP_WORKSHARE:
+      omp_end_st = ST_OMP_END_WORKSHARE;
+      break;
+    case ST_OMP_PARALLEL_WORKSHARE:
+      omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
+      break;
+    default:
+      gcc_unreachable ();
+    }
+
+  do
+    {
+      if (workshare_stmts_only)
+	{
+	  /* Inside of !$omp workshare, only
+	     scalar assignments
+	     array assignments
+	     where statements and constructs
+	     forall statements and constructs
+	     !$omp atomic
+	     !$omp critical
+	     !$omp parallel
+	     are allowed.  For !$omp critical these
+	     restrictions apply recursively.  */
+	  bool cycle = true;
+
+	  st = next_statement ();
+	  for (;;)
+	    {
+	      switch (st)
+		{
+		case ST_NONE:
+		  unexpected_eof ();
+
+		case ST_ASSIGNMENT:
+		case ST_WHERE:
+		case ST_FORALL:
+		  accept_statement (st);
+		  break;
+
+		case ST_WHERE_BLOCK:
+		  parse_where_block ();
+		  break;
+
+		case ST_FORALL_BLOCK:
+		  parse_forall_block ();
+		  break;
+
+		case ST_OMP_PARALLEL:
+		case ST_OMP_PARALLEL_SECTIONS:
+		  parse_omp_structured_block (st, false);
+		  break;
+
+		case ST_OMP_PARALLEL_WORKSHARE:
+		case ST_OMP_CRITICAL:
+		  parse_omp_structured_block (st, true);
+		  break;
+
+		case ST_OMP_PARALLEL_DO:
+		  st = parse_omp_do (st);
+		  continue;
+
+		case ST_OMP_ATOMIC:
+		  st = parse_omp_atomic ();
+		  continue;
+
+		default:
+		  cycle = false;
+		  break;
+		}
+
+	      if (!cycle)
+		break;
+
+	      st = next_statement ();
+	    }
+	}
+      else
+	st = parse_executable (ST_NONE);
+      if (st == ST_NONE)
+	unexpected_eof ();
+      else if (st == ST_OMP_SECTION
+	       && (omp_st == ST_OMP_SECTIONS
+		   || omp_st == ST_OMP_PARALLEL_SECTIONS))
+	{
+	  np = new_level (np);
+	  np->op = cp->op;
+	  np->block = NULL;
+	}
+      else if (st != omp_end_st)
+	unexpected_statement (st);
+    }
+  while (st != omp_end_st);
+
+  switch (new_st.op)
+    {
+    case EXEC_OMP_END_NOWAIT:
+      cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
+      break;
+    case EXEC_OMP_CRITICAL:
+      if (((cp->ext.omp_name == NULL) ^ (new_st.ext.omp_name == NULL))
+	  || (new_st.ext.omp_name != NULL
+	      && strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0))
+	gfc_error ("Name after !$omp critical and !$omp end critical does "
+		   "not match at %C");
+      free (CONST_CAST (char *, new_st.ext.omp_name));
+      break;
+    case EXEC_OMP_END_SINGLE:
+      cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
+	= new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
+      new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
+      gfc_free_omp_clauses (new_st.ext.omp_clauses);
+      break;
+    case EXEC_NOP:
+      break;
+    default:
+      gcc_unreachable ();
+    }
+
+  gfc_clear_new_st ();
+  gfc_commit_symbols ();
+  gfc_warning_check ();
+  pop_state ();
+}
+
+
+/* Accept a series of executable statements.  We return the first
+   statement that doesn't fit to the caller.  Any block statements are
+   passed on to the correct handler, which usually passes the buck
+   right back here.  */
+
+static gfc_statement
+parse_executable (gfc_statement st)
+{
+  int close_flag;
+
+  if (st == ST_NONE)
+    st = next_statement ();
+
+  for (;;)
+    {
+      close_flag = check_do_closure ();
+      if (close_flag)
+	switch (st)
+	  {
+	  case ST_GOTO:
+	  case ST_END_PROGRAM:
+	  case ST_RETURN:
+	  case ST_EXIT:
+	  case ST_END_FUNCTION:
+	  case ST_CYCLE:
+	  case ST_PAUSE:
+	  case ST_STOP:
+	  case ST_ERROR_STOP:
+	  case ST_END_SUBROUTINE:
+
+	  case ST_DO:
+	  case ST_FORALL:
+	  case ST_WHERE:
+	  case ST_SELECT_CASE:
+	    gfc_error ("%s statement at %C cannot terminate a non-block "
+		       "DO loop", gfc_ascii_statement (st));
+	    break;
+
+	  default:
+	    break;
+	  }
+
+      switch (st)
+	{
+	case ST_NONE:
+	  unexpected_eof ();
+
+	case ST_DATA:
+	  gfc_notify_std (GFC_STD_F95_OBS, "DATA statement at %C after the "
+			  "first executable statement");
+	  /* Fall through.  */
+
+	case ST_FORMAT:
+	case ST_ENTRY:
+	case_executable:
+	  accept_statement (st);
+	  if (close_flag == 1)
+	    return ST_IMPLIED_ENDDO;
+	  break;
+
+	case ST_BLOCK:
+	  parse_block_construct ();
+	  break;
+
+	case ST_ASSOCIATE:
+	  parse_associate ();
+	  break;
+
+	case ST_IF_BLOCK:
+	  parse_if_block ();
+	  break;
+
+	case ST_SELECT_CASE:
+	  parse_select_block ();
+	  break;
+
+	case ST_SELECT_TYPE:
+	  parse_select_type_block();
+	  break;
+
+	case ST_DO:
+	  parse_do_block ();
+	  if (check_do_closure () == 1)
+	    return ST_IMPLIED_ENDDO;
+	  break;
+
+	case ST_CRITICAL:
+	  parse_critical_block ();
+	  break;
+
+	case ST_WHERE_BLOCK:
+	  parse_where_block ();
+	  break;
+
+	case ST_FORALL_BLOCK:
+	  parse_forall_block ();
+	  break;
+
+	case ST_OMP_PARALLEL:
+	case ST_OMP_PARALLEL_SECTIONS:
+	case ST_OMP_SECTIONS:
+	case ST_OMP_ORDERED:
+	case ST_OMP_CRITICAL:
+	case ST_OMP_MASTER:
+	case ST_OMP_SINGLE:
+	case ST_OMP_TASK:
+	  parse_omp_structured_block (st, false);
+	  break;
+
+	case ST_OMP_WORKSHARE:
+	case ST_OMP_PARALLEL_WORKSHARE:
+	  parse_omp_structured_block (st, true);
+	  break;
+
+	case ST_OMP_DO:
+	case ST_OMP_PARALLEL_DO:
+	  st = parse_omp_do (st);
+	  if (st == ST_IMPLIED_ENDDO)
+	    return st;
+	  continue;
+
+	case ST_OMP_ATOMIC:
+	  st = parse_omp_atomic ();
+	  continue;
+
+	default:
+	  return st;
+	}
+
+      st = next_statement ();
+    }
+}
+
+
+/* Fix the symbols for sibling functions.  These are incorrectly added to
+   the child namespace as the parser didn't know about this procedure.  */
+
+static void
+gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
+{
+  gfc_namespace *ns;
+  gfc_symtree *st;
+  gfc_symbol *old_sym;
+
+  for (ns = siblings; ns; ns = ns->sibling)
+    {
+      st = gfc_find_symtree (ns->sym_root, sym->name);
+
+      if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
+	goto fixup_contained;
+
+      if ((st->n.sym->attr.flavor == FL_DERIVED
+	   && sym->attr.generic && sym->attr.function)
+	  ||(sym->attr.flavor == FL_DERIVED
+	     && st->n.sym->attr.generic && st->n.sym->attr.function))
+	goto fixup_contained;
+
+      old_sym = st->n.sym;
+      if (old_sym->ns == ns
+	    && !old_sym->attr.contained
+
+	    /* By 14.6.1.3, host association should be excluded
+	       for the following.  */
+	    && !(old_sym->attr.external
+		  || (old_sym->ts.type != BT_UNKNOWN
+			&& !old_sym->attr.implicit_type)
+		  || old_sym->attr.flavor == FL_PARAMETER
+		  || old_sym->attr.use_assoc
+		  || old_sym->attr.in_common
+		  || old_sym->attr.in_equivalence
+		  || old_sym->attr.data
+		  || old_sym->attr.dummy
+		  || old_sym->attr.result
+		  || old_sym->attr.dimension
+		  || old_sym->attr.allocatable
+		  || old_sym->attr.intrinsic
+		  || old_sym->attr.generic
+		  || old_sym->attr.flavor == FL_NAMELIST
+		  || old_sym->attr.flavor == FL_LABEL
+		  || old_sym->attr.proc == PROC_ST_FUNCTION))
+	{
+	  /* Replace it with the symbol from the parent namespace.  */
+	  st->n.sym = sym;
+	  sym->refs++;
+
+	  gfc_release_symbol (old_sym);
+	}
+
+fixup_contained:
+      /* Do the same for any contained procedures.  */
+      gfc_fixup_sibling_symbols (sym, ns->contained);
+    }
+}
+
+static void
+parse_contained (int module)
+{
+  gfc_namespace *ns, *parent_ns, *tmp;
+  gfc_state_data s1, s2;
+  gfc_statement st;
+  gfc_symbol *sym;
+  gfc_entry_list *el;
+  int contains_statements = 0;
+  int seen_error = 0;
+
+  push_state (&s1, COMP_CONTAINS, NULL);
+  parent_ns = gfc_current_ns;
+
+  do
+    {
+      gfc_current_ns = gfc_get_namespace (parent_ns, 1);
+
+      gfc_current_ns->sibling = parent_ns->contained;
+      parent_ns->contained = gfc_current_ns;
+
+ next:
+      /* Process the next available statement.  We come here if we got an error
+	 and rejected the last statement.  */
+      st = next_statement ();
+
+      switch (st)
+	{
+	case ST_NONE:
+	  unexpected_eof ();
+
+	case ST_FUNCTION:
+	case ST_SUBROUTINE:
+	  contains_statements = 1;
+	  accept_statement (st);
+
+	  push_state (&s2,
+		      (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
+		      gfc_new_block);
+
+	  /* For internal procedures, create/update the symbol in the
+	     parent namespace.  */
+
+	  if (!module)
+	    {
+	      if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
+		gfc_error ("Contained procedure '%s' at %C is already "
+			   "ambiguous", gfc_new_block->name);
+	      else
+		{
+		  if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, 
+					 sym->name, 
+					 &gfc_new_block->declared_at))
+		    {
+		      if (st == ST_FUNCTION)
+			gfc_add_function (&sym->attr, sym->name,
+					  &gfc_new_block->declared_at);
+		      else
+			gfc_add_subroutine (&sym->attr, sym->name,
+					    &gfc_new_block->declared_at);
+		    }
+		}
+
+	      gfc_commit_symbols ();
+	    }
+	  else
+	    sym = gfc_new_block;
+
+	  /* Mark this as a contained function, so it isn't replaced
+	     by other module functions.  */
+	  sym->attr.contained = 1;
+
+	  /* Set implicit_pure so that it can be reset if any of the
+	     tests for purity fail.  This is used for some optimisation
+	     during translation.  */
+	  if (!sym->attr.pure)
+	    sym->attr.implicit_pure = 1;
+
+	  parse_progunit (ST_NONE);
+
+	  /* Fix up any sibling functions that refer to this one.  */
+	  gfc_fixup_sibling_symbols (sym, gfc_current_ns);
+	  /* Or refer to any of its alternate entry points.  */
+	  for (el = gfc_current_ns->entries; el; el = el->next)
+	    gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
+
+	  gfc_current_ns->code = s2.head;
+	  gfc_current_ns = parent_ns;
+
+	  pop_state ();
+	  break;
+
+	/* These statements are associated with the end of the host unit.  */
+	case ST_END_FUNCTION:
+	case ST_END_MODULE:
+	case ST_END_PROGRAM:
+	case ST_END_SUBROUTINE:
+	  accept_statement (st);
+	  gfc_current_ns->code = s1.head;
+	  break;
+
+	default:
+	  gfc_error ("Unexpected %s statement in CONTAINS section at %C",
+		     gfc_ascii_statement (st));
+	  reject_statement ();
+	  seen_error = 1;
+	  goto next;
+	  break;
+	}
+    }
+  while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
+	 && st != ST_END_MODULE && st != ST_END_PROGRAM);
+
+  /* The first namespace in the list is guaranteed to not have
+     anything (worthwhile) in it.  */
+  tmp = gfc_current_ns;
+  gfc_current_ns = parent_ns;
+  if (seen_error && tmp->refs > 1)
+    gfc_free_namespace (tmp);
+
+  ns = gfc_current_ns->contained;
+  gfc_current_ns->contained = ns->sibling;
+  gfc_free_namespace (ns);
+
+  pop_state ();
+  if (!contains_statements)
+    gfc_notify_std (GFC_STD_F2008, "CONTAINS statement without "
+		    "FUNCTION or SUBROUTINE statement at %C");
+}
+
+
+/* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct.  */
+
+static void
+parse_progunit (gfc_statement st)
+{
+  gfc_state_data *p;
+  int n;
+
+  st = parse_spec (st);
+  switch (st)
+    {
+    case ST_NONE:
+      unexpected_eof ();
+
+    case ST_CONTAINS:
+      /* This is not allowed within BLOCK!  */
+      if (gfc_current_state () != COMP_BLOCK)
+	goto contains;
+      break;
+
+    case_end:
+      accept_statement (st);
+      goto done;
+
+    default:
+      break;
+    }
+
+  if (gfc_current_state () == COMP_FUNCTION)
+    gfc_check_function_type (gfc_current_ns);
+
+loop:
+  for (;;)
+    {
+      st = parse_executable (st);
+
+      switch (st)
+	{
+	case ST_NONE:
+	  unexpected_eof ();
+
+	case ST_CONTAINS:
+	  /* This is not allowed within BLOCK!  */
+	  if (gfc_current_state () != COMP_BLOCK)
+	    goto contains;
+	  break;
+
+	case_end:
+	  accept_statement (st);
+	  goto done;
+
+	default:
+	  break;
+	}
+
+      unexpected_statement (st);
+      reject_statement ();
+      st = next_statement ();
+    }
+
+contains:
+  n = 0;
+
+  for (p = gfc_state_stack; p; p = p->previous)
+    if (p->state == COMP_CONTAINS)
+      n++;
+
+  if (gfc_find_state (COMP_MODULE) == true)
+    n--;
+
+  if (n > 0)
+    {
+      gfc_error ("CONTAINS statement at %C is already in a contained "
+		 "program unit");
+      reject_statement ();
+      st = next_statement ();
+      goto loop;
+    }
+
+  parse_contained (0);
+
+done:
+  gfc_current_ns->code = gfc_state_stack->head;
+}
+
+
+/* Come here to complain about a global symbol already in use as
+   something else.  */
+
+void
+gfc_global_used (gfc_gsymbol *sym, locus *where)
+{
+  const char *name;
+
+  if (where == NULL)
+    where = &gfc_current_locus;
+
+  switch(sym->type)
+    {
+    case GSYM_PROGRAM:
+      name = "PROGRAM";
+      break;
+    case GSYM_FUNCTION:
+      name = "FUNCTION";
+      break;
+    case GSYM_SUBROUTINE:
+      name = "SUBROUTINE";
+      break;
+    case GSYM_COMMON:
+      name = "COMMON";
+      break;
+    case GSYM_BLOCK_DATA:
+      name = "BLOCK DATA";
+      break;
+    case GSYM_MODULE:
+      name = "MODULE";
+      break;
+    default:
+      gfc_internal_error ("gfc_global_used(): Bad type");
+      name = NULL;
+    }
+
+  if (sym->binding_label)
+    gfc_error ("Global binding name '%s' at %L is already being used as a %s "
+	       "at %L", sym->binding_label, where, name, &sym->where);
+  else
+    gfc_error ("Global name '%s' at %L is already being used as a %s at %L",
+	       sym->name, where, name, &sym->where);
+}
+
+
+/* Parse a block data program unit.  */
+
+static void
+parse_block_data (void)
+{
+  gfc_statement st;
+  static locus blank_locus;
+  static int blank_block=0;
+  gfc_gsymbol *s;
+
+  gfc_current_ns->proc_name = gfc_new_block;
+  gfc_current_ns->is_block_data = 1;
+
+  if (gfc_new_block == NULL)
+    {
+      if (blank_block)
+       gfc_error ("Blank BLOCK DATA at %C conflicts with "
+		  "prior BLOCK DATA at %L", &blank_locus);
+      else
+       {
+	 blank_block = 1;
+	 blank_locus = gfc_current_locus;
+       }
+    }
+  else
+    {
+      s = gfc_get_gsymbol (gfc_new_block->name);
+      if (s->defined
+	  || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
+       gfc_global_used (s, &gfc_new_block->declared_at);
+      else
+       {
+	 s->type = GSYM_BLOCK_DATA;
+	 s->where = gfc_new_block->declared_at;
+	 s->defined = 1;
+       }
+    }
+
+  st = parse_spec (ST_NONE);
+
+  while (st != ST_END_BLOCK_DATA)
+    {
+      gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
+		 gfc_ascii_statement (st));
+      reject_statement ();
+      st = next_statement ();
+    }
+}
+
+
+/* Parse a module subprogram.  */
+
+static void
+parse_module (void)
+{
+  gfc_statement st;
+  gfc_gsymbol *s;
+  bool error;
+
+  s = gfc_get_gsymbol (gfc_new_block->name);
+  if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
+    gfc_global_used (s, &gfc_new_block->declared_at);
+  else
+    {
+      s->type = GSYM_MODULE;
+      s->where = gfc_new_block->declared_at;
+      s->defined = 1;
+    }
+
+  st = parse_spec (ST_NONE);
+
+  error = false;
+loop:
+  switch (st)
+    {
+    case ST_NONE:
+      unexpected_eof ();
+
+    case ST_CONTAINS:
+      parse_contained (1);
+      break;
+
+    case ST_END_MODULE:
+      accept_statement (st);
+      break;
+
+    default:
+      gfc_error ("Unexpected %s statement in MODULE at %C",
+		 gfc_ascii_statement (st));
+
+      error = true;
+      reject_statement ();
+      st = next_statement ();
+      goto loop;
+    }
+
+  /* Make sure not to free the namespace twice on error.  */
+  if (!error)
+    s->ns = gfc_current_ns;
+}
+
+
+/* Add a procedure name to the global symbol table.  */
+
+static void
+add_global_procedure (bool sub)
+{
+  gfc_gsymbol *s;
+
+  /* Only in Fortran 2003: For procedures with a binding label also the Fortran
+     name is a global identifier.  */
+  if (!gfc_new_block->binding_label || gfc_notification_std (GFC_STD_F2008))
+    {
+      s = gfc_get_gsymbol (gfc_new_block->name);
+
+      if (s->defined
+	  || (s->type != GSYM_UNKNOWN
+	      && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
+	{
+	  gfc_global_used (s, &gfc_new_block->declared_at);
+	  /* Silence follow-up errors.  */
+	  gfc_new_block->binding_label = NULL;
+	}
+      else
+	{
+	  s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
+	  s->sym_name = gfc_new_block->name;
+	  s->where = gfc_new_block->declared_at;
+	  s->defined = 1;
+	  s->ns = gfc_current_ns;
+	}
+    }
+
+  /* Don't add the symbol multiple times.  */
+  if (gfc_new_block->binding_label
+      && (!gfc_notification_std (GFC_STD_F2008)
+          || strcmp (gfc_new_block->name, gfc_new_block->binding_label) != 0))
+    {
+      s = gfc_get_gsymbol (gfc_new_block->binding_label);
+
+      if (s->defined
+	  || (s->type != GSYM_UNKNOWN
+	      && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
+	{
+	  gfc_global_used (s, &gfc_new_block->declared_at);
+	  /* Silence follow-up errors.  */
+	  gfc_new_block->binding_label = NULL;
+	}
+      else
+	{
+	  s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
+	  s->sym_name = gfc_new_block->name;
+	  s->binding_label = gfc_new_block->binding_label;
+	  s->where = gfc_new_block->declared_at;
+	  s->defined = 1;
+	  s->ns = gfc_current_ns;
+	}
+    }
+}
+
+
+/* Add a program to the global symbol table.  */
+
+static void
+add_global_program (void)
+{
+  gfc_gsymbol *s;
+
+  if (gfc_new_block == NULL)
+    return;
+  s = gfc_get_gsymbol (gfc_new_block->name);
+
+  if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
+    gfc_global_used (s, &gfc_new_block->declared_at);
+  else
+    {
+      s->type = GSYM_PROGRAM;
+      s->where = gfc_new_block->declared_at;
+      s->defined = 1;
+      s->ns = gfc_current_ns;
+    }
+}
+
+
+/* Resolve all the program units. */
+static void
+resolve_all_program_units (gfc_namespace *gfc_global_ns_list)
+{
+  gfc_free_dt_list ();
+  gfc_current_ns = gfc_global_ns_list;
+  for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
+    {
+      if (gfc_current_ns->proc_name
+	  && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
+	continue; /* Already resolved.  */
+
+      if (gfc_current_ns->proc_name)
+	gfc_current_locus = gfc_current_ns->proc_name->declared_at;
+      gfc_resolve (gfc_current_ns);
+      gfc_current_ns->derived_types = gfc_derived_types;
+      gfc_derived_types = NULL;
+    }
+}
+
+
+static void
+clean_up_modules (gfc_gsymbol *gsym)
+{
+  if (gsym == NULL)
+    return;
+
+  clean_up_modules (gsym->left);
+  clean_up_modules (gsym->right);
+
+  if (gsym->type != GSYM_MODULE || !gsym->ns)
+    return;
+
+  gfc_current_ns = gsym->ns;
+  gfc_derived_types = gfc_current_ns->derived_types;
+  gfc_done_2 ();
+  gsym->ns = NULL;
+  return;
+}
+
+
+/* Translate all the program units. This could be in a different order
+   to resolution if there are forward references in the file.  */
+static void
+translate_all_program_units (gfc_namespace *gfc_global_ns_list,
+			     bool main_in_tu)
+{
+  int errors;
+
+  gfc_current_ns = gfc_global_ns_list;
+  gfc_get_errors (NULL, &errors);
+
+  /* If the main program is in the translation unit and we have
+     -fcoarray=libs, generate the static variables.  */
+  if (gfc_option.coarray == GFC_FCOARRAY_LIB && main_in_tu)
+    gfc_init_coarray_decl (true);
+
+  /* We first translate all modules to make sure that later parts
+     of the program can use the decl. Then we translate the nonmodules.  */
+
+  for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
+    {
+      if (!gfc_current_ns->proc_name
+	  || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
+	continue;
+
+      gfc_current_locus = gfc_current_ns->proc_name->declared_at;
+      gfc_derived_types = gfc_current_ns->derived_types;
+      gfc_generate_module_code (gfc_current_ns);
+      gfc_current_ns->translated = 1;
+    }
+
+  gfc_current_ns = gfc_global_ns_list;
+  for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
+    {
+      if (gfc_current_ns->proc_name
+	  && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
+	continue;
+
+      gfc_current_locus = gfc_current_ns->proc_name->declared_at;
+      gfc_derived_types = gfc_current_ns->derived_types;
+      gfc_generate_code (gfc_current_ns);
+      gfc_current_ns->translated = 1;
+    }
+
+  /* Clean up all the namespaces after translation.  */
+  gfc_current_ns = gfc_global_ns_list;
+  for (;gfc_current_ns;)
+    {
+      gfc_namespace *ns;
+
+      if (gfc_current_ns->proc_name
+	  && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
+	{
+	  gfc_current_ns = gfc_current_ns->sibling;
+	  continue;
+	}
+
+      ns = gfc_current_ns->sibling;
+      gfc_derived_types = gfc_current_ns->derived_types;
+      gfc_done_2 ();
+      gfc_current_ns = ns;
+    }
+
+  clean_up_modules (gfc_gsym_root);
+}
+
+
+/* Top level parser.  */
+
+bool
+gfc_parse_file (void)
+{
+  int seen_program, errors_before, errors;
+  gfc_state_data top, s;
+  gfc_statement st;
+  locus prog_locus;
+  gfc_namespace *next;
+
+  gfc_start_source_files ();
+
+  top.state = COMP_NONE;
+  top.sym = NULL;
+  top.previous = NULL;
+  top.head = top.tail = NULL;
+  top.do_variable = NULL;
+
+  gfc_state_stack = &top;
+
+  gfc_clear_new_st ();
+
+  gfc_statement_label = NULL;
+
+  if (setjmp (eof_buf))
+    return false;	/* Come here on unexpected EOF */
+
+  /* Prepare the global namespace that will contain the
+     program units.  */
+  gfc_global_ns_list = next = NULL;
+
+  seen_program = 0;
+  errors_before = 0;
+
+  /* Exit early for empty files.  */
+  if (gfc_at_eof ())
+    goto done;
+
+loop:
+  gfc_init_2 ();
+  st = next_statement ();
+  switch (st)
+    {
+    case ST_NONE:
+      gfc_done_2 ();
+      goto done;
+
+    case ST_PROGRAM:
+      if (seen_program)
+	goto duplicate_main;
+      seen_program = 1;
+      prog_locus = gfc_current_locus;
+
+      push_state (&s, COMP_PROGRAM, gfc_new_block);
+      main_program_symbol(gfc_current_ns, gfc_new_block->name);
+      accept_statement (st);
+      add_global_program ();
+      parse_progunit (ST_NONE);
+      goto prog_units;
+      break;
+
+    case ST_SUBROUTINE:
+      add_global_procedure (true);
+      push_state (&s, COMP_SUBROUTINE, gfc_new_block);
+      accept_statement (st);
+      parse_progunit (ST_NONE);
+      goto prog_units;
+      break;
+
+    case ST_FUNCTION:
+      add_global_procedure (false);
+      push_state (&s, COMP_FUNCTION, gfc_new_block);
+      accept_statement (st);
+      parse_progunit (ST_NONE);
+      goto prog_units;
+      break;
+
+    case ST_BLOCK_DATA:
+      push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
+      accept_statement (st);
+      parse_block_data ();
+      break;
+
+    case ST_MODULE:
+      push_state (&s, COMP_MODULE, 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)
+	goto duplicate_main;
+      seen_program = 1;
+      prog_locus = gfc_current_locus;
+
+      push_state (&s, COMP_PROGRAM, gfc_new_block);
+      main_program_symbol (gfc_current_ns, "MAIN__");
+      parse_progunit (st);
+      goto prog_units;
+      break;
+    }
+
+  /* Handle the non-program units.  */
+  gfc_current_ns->code = s.head;
+
+  gfc_resolve (gfc_current_ns);
+
+  /* Dump the parse tree if requested.  */
+  if (gfc_option.dump_fortran_original)
+    gfc_dump_parse_tree (gfc_current_ns, stdout);
+
+  gfc_get_errors (NULL, &errors);
+  if (s.state == COMP_MODULE)
+    {
+      gfc_dump_module (s.sym->name, errors_before == errors);
+      gfc_current_ns->derived_types = gfc_derived_types;
+      gfc_derived_types = NULL;
+      goto prog_units;
+    }
+  else
+    {
+      if (errors == 0)
+	gfc_generate_code (gfc_current_ns);
+      pop_state ();
+      gfc_done_2 ();
+    }
+
+  goto loop;
+
+prog_units:
+  /* The main program and non-contained procedures are put
+     in the global namespace list, so that they can be processed
+     later and all their interfaces resolved.  */
+  gfc_current_ns->code = s.head;
+  if (next)
+    {
+      for (; next->sibling; next = next->sibling)
+	;
+      next->sibling = gfc_current_ns;
+    }
+  else
+    gfc_global_ns_list = gfc_current_ns;
+
+  next = gfc_current_ns;
+
+  pop_state ();
+  goto loop;
+
+  done:
+
+  /* Do the resolution.  */
+  resolve_all_program_units (gfc_global_ns_list);
+
+  /* Do the parse tree dump.  */ 
+  gfc_current_ns
+	= gfc_option.dump_fortran_original ? gfc_global_ns_list : NULL;
+
+  for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
+    if (!gfc_current_ns->proc_name
+	|| gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
+      {
+	gfc_dump_parse_tree (gfc_current_ns, stdout);
+	fputs ("------------------------------------------\n\n", stdout);
+      }
+
+  /* Do the translation.  */
+  translate_all_program_units (gfc_global_ns_list, seen_program);
+
+  gfc_end_source_files ();
+  return true;
+
+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 ("Two main PROGRAMs at %L and %C", &prog_locus);
+  reject_statement ();
+  gfc_done_2 ();
+  return true;
+}
diff --git a/gcc-4.9/gcc/fortran/parse.h b/gcc-4.9/gcc/fortran/parse.h
new file mode 100644
index 000000000..44b8f8bd1
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/parse.h
@@ -0,0 +1,71 @@
+/* Parser header
+   Copyright (C) 2003-2014 Free Software Foundation, Inc.
+   Contributed by Steven Bosscher
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+
+#ifndef GFC_PARSE_H
+#define GFC_PARSE_H
+
+/* Enum for what the compiler is currently doing.  */
+typedef enum
+{
+  COMP_NONE, COMP_PROGRAM, COMP_MODULE, COMP_SUBROUTINE, COMP_FUNCTION,
+  COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_DERIVED_CONTAINS,
+  COMP_BLOCK, COMP_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
+}
+gfc_compile_state;
+
+/* Stack element for the current compilation state.  These structures
+   are allocated as automatic variables.  */
+typedef struct gfc_state_data
+{
+  gfc_compile_state state;
+  gfc_symbol *sym;              /* Block name associated with this level */
+  gfc_symtree *do_variable;     /* For DO blocks the iterator variable.  */
+
+  struct gfc_code *construct;
+  struct gfc_code *head, *tail;
+  struct gfc_state_data *previous;
+
+  /* Block-specific state data.  */
+  union
+  {
+    gfc_st_label *end_do_label;
+  }
+  ext;
+}
+gfc_state_data;
+
+extern gfc_state_data *gfc_state_stack;
+
+#define gfc_current_block() (gfc_state_stack->sym)
+#define gfc_current_state() (gfc_state_stack->state)
+
+int gfc_check_do_variable (gfc_symtree *);
+bool gfc_find_state (gfc_compile_state);
+gfc_state_data *gfc_enclosing_unit (gfc_compile_state *);
+const char *gfc_ascii_statement (gfc_statement);
+match gfc_match_enum (void);
+match gfc_match_enumerator_def (void);
+void gfc_free_enum_history (void);
+extern bool gfc_matching_function;
+match gfc_match_prefix (gfc_typespec *);
+#endif  /* GFC_PARSE_H  */
diff --git a/gcc-4.9/gcc/fortran/primary.c b/gcc-4.9/gcc/fortran/primary.c
new file mode 100644
index 000000000..e2eb46748
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/primary.c
@@ -0,0 +1,3328 @@
+/* Primary expression subroutines
+   Copyright (C) 2000-2014 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "flags.h"
+#include "gfortran.h"
+#include "arith.h"
+#include "match.h"
+#include "parse.h"
+#include "constructor.h"
+
+int matching_actual_arglist = 0;
+
+/* Matches a kind-parameter expression, which is either a named
+   symbolic constant or a nonnegative integer constant.  If
+   successful, sets the kind value to the correct integer.
+   The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING
+   symbol like e.g. 'c_int'.  */
+
+static match
+match_kind_param (int *kind, int *is_iso_c)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_symbol *sym;
+  const char *p;
+  match m;
+
+  *is_iso_c = 0;
+
+  m = gfc_match_small_literal_int (kind, NULL);
+  if (m != MATCH_NO)
+    return m;
+
+  m = gfc_match_name (name);
+  if (m != MATCH_YES)
+    return m;
+
+  if (gfc_find_symbol (name, NULL, 1, &sym))
+    return MATCH_ERROR;
+
+  if (sym == NULL)
+    return MATCH_NO;
+
+  *is_iso_c = sym->attr.is_iso_c;
+
+  if (sym->attr.flavor != FL_PARAMETER)
+    return MATCH_NO;
+
+  if (sym->value == NULL)
+    return MATCH_NO;
+
+  p = gfc_extract_int (sym->value, kind);
+  if (p != NULL)
+    return MATCH_NO;
+
+  gfc_set_sym_referenced (sym);
+
+  if (*kind < 0)
+    return MATCH_NO;
+
+  return MATCH_YES;
+}
+
+
+/* Get a trailing kind-specification for non-character variables.
+   Returns:
+     * the integer kind value or
+     * -1 if an error was generated,
+     * -2 if no kind was found.
+   The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING
+   symbol like e.g. 'c_int'.  */
+
+static int
+get_kind (int *is_iso_c)
+{
+  int kind;
+  match m;
+
+  *is_iso_c = 0;
+
+  if (gfc_match_char ('_') != MATCH_YES)
+    return -2;
+
+  m = match_kind_param (&kind, is_iso_c);
+  if (m == MATCH_NO)
+    gfc_error ("Missing kind-parameter at %C");
+
+  return (m == MATCH_YES) ? kind : -1;
+}
+
+
+/* Given a character and a radix, see if the character is a valid
+   digit in that radix.  */
+
+int
+gfc_check_digit (char c, int radix)
+{
+  int r;
+
+  switch (radix)
+    {
+    case 2:
+      r = ('0' <= c && c <= '1');
+      break;
+
+    case 8:
+      r = ('0' <= c && c <= '7');
+      break;
+
+    case 10:
+      r = ('0' <= c && c <= '9');
+      break;
+
+    case 16:
+      r = ISXDIGIT (c);
+      break;
+
+    default:
+      gfc_internal_error ("gfc_check_digit(): bad radix");
+    }
+
+  return r;
+}
+
+
+/* Match the digit string part of an integer if signflag is not set,
+   the signed digit string part if signflag is set.  If the buffer 
+   is NULL, we just count characters for the resolution pass.  Returns 
+   the number of characters matched, -1 for no match.  */
+
+static int
+match_digits (int signflag, int radix, char *buffer)
+{
+  locus old_loc;
+  int length;
+  char c;
+
+  length = 0;
+  c = gfc_next_ascii_char ();
+
+  if (signflag && (c == '+' || c == '-'))
+    {
+      if (buffer != NULL)
+	*buffer++ = c;
+      gfc_gobble_whitespace ();
+      c = gfc_next_ascii_char ();
+      length++;
+    }
+
+  if (!gfc_check_digit (c, radix))
+    return -1;
+
+  length++;
+  if (buffer != NULL)
+    *buffer++ = c;
+
+  for (;;)
+    {
+      old_loc = gfc_current_locus;
+      c = gfc_next_ascii_char ();
+
+      if (!gfc_check_digit (c, radix))
+	break;
+
+      if (buffer != NULL)
+	*buffer++ = c;
+      length++;
+    }
+
+  gfc_current_locus = old_loc;
+
+  return length;
+}
+
+
+/* Match an integer (digit string and optional kind).  
+   A sign will be accepted if signflag is set.  */
+
+static match
+match_integer_constant (gfc_expr **result, int signflag)
+{
+  int length, kind, is_iso_c;
+  locus old_loc;
+  char *buffer;
+  gfc_expr *e;
+
+  old_loc = gfc_current_locus;
+  gfc_gobble_whitespace ();
+
+  length = match_digits (signflag, 10, NULL);
+  gfc_current_locus = old_loc;
+  if (length == -1)
+    return MATCH_NO;
+
+  buffer = (char *) alloca (length + 1);
+  memset (buffer, '\0', length + 1);
+
+  gfc_gobble_whitespace ();
+
+  match_digits (signflag, 10, buffer);
+
+  kind = get_kind (&is_iso_c);
+  if (kind == -2)
+    kind = gfc_default_integer_kind;
+  if (kind == -1)
+    return MATCH_ERROR;
+
+  if (kind == 4 && gfc_option.flag_integer4_kind == 8)
+    kind = 8;
+
+  if (gfc_validate_kind (BT_INTEGER, kind, true) < 0)
+    {
+      gfc_error ("Integer kind %d at %C not available", kind);
+      return MATCH_ERROR;
+    }
+
+  e = gfc_convert_integer (buffer, kind, 10, &gfc_current_locus);
+  e->ts.is_c_interop = is_iso_c;
+
+  if (gfc_range_check (e) != ARITH_OK)
+    {
+      gfc_error ("Integer too big for its kind at %C. This check can be "
+		 "disabled with the option -fno-range-check");
+
+      gfc_free_expr (e);
+      return MATCH_ERROR;
+    }
+
+  *result = e;
+  return MATCH_YES;
+}
+
+
+/* Match a Hollerith constant.  */
+
+static match
+match_hollerith_constant (gfc_expr **result)
+{
+  locus old_loc;
+  gfc_expr *e = NULL;
+  const char *msg;
+  int num, pad;
+  int i;  
+
+  old_loc = gfc_current_locus;
+  gfc_gobble_whitespace ();
+
+  if (match_integer_constant (&e, 0) == MATCH_YES
+      && gfc_match_char ('h') == MATCH_YES)
+    {
+      if (!gfc_notify_std (GFC_STD_LEGACY, "Hollerith constant at %C"))
+	goto cleanup;
+
+      msg = gfc_extract_int (e, &num);
+      if (msg != NULL)
+	{
+	  gfc_error (msg);
+	  goto cleanup;
+	}
+      if (num == 0)
+	{
+	  gfc_error ("Invalid Hollerith constant: %L must contain at least "
+		     "one character", &old_loc);
+	  goto cleanup;
+	}
+      if (e->ts.kind != gfc_default_integer_kind)
+	{
+	  gfc_error ("Invalid Hollerith constant: Integer kind at %L "
+		     "should be default", &old_loc);
+	  goto cleanup;
+	}
+      else
+	{
+	  gfc_free_expr (e);
+	  e = gfc_get_constant_expr (BT_HOLLERITH, gfc_default_character_kind,
+				     &gfc_current_locus);
+
+	  /* Calculate padding needed to fit default integer memory.  */
+	  pad = gfc_default_integer_kind - (num % gfc_default_integer_kind);
+
+	  e->representation.string = XCNEWVEC (char, num + pad + 1);
+
+	  for (i = 0; i < num; i++)
+	    {
+	      gfc_char_t c = gfc_next_char_literal (INSTRING_WARN);
+	      if (! gfc_wide_fits_in_byte (c))
+		{
+		  gfc_error ("Invalid Hollerith constant at %L contains a "
+			     "wide character", &old_loc);
+		  goto cleanup;
+		}
+
+	      e->representation.string[i] = (unsigned char) c;
+	    }
+
+	  /* Now pad with blanks and end with a null char.  */
+	  for (i = 0; i < pad; i++)
+	    e->representation.string[num + i] = ' ';
+
+	  e->representation.string[num + i] = '\0';
+	  e->representation.length = num + pad;
+	  e->ts.u.pad = pad;
+
+	  *result = e;
+	  return MATCH_YES;
+	}
+    }
+
+  gfc_free_expr (e);
+  gfc_current_locus = old_loc;
+  return MATCH_NO;
+
+cleanup:
+  gfc_free_expr (e);
+  return MATCH_ERROR;
+}
+
+
+/* Match a binary, octal or hexadecimal constant that can be found in
+   a DATA statement.  The standard permits b'010...', o'73...', and
+   z'a1...' where b, o, and z can be capital letters.  This function
+   also accepts postfixed forms of the constants: '01...'b, '73...'o,
+   and 'a1...'z.  An additional extension is the use of x for z.  */
+
+static match
+match_boz_constant (gfc_expr **result)
+{
+  int radix, length, x_hex, kind;
+  locus old_loc, start_loc;
+  char *buffer, post, delim;
+  gfc_expr *e;
+
+  start_loc = old_loc = gfc_current_locus;
+  gfc_gobble_whitespace ();
+
+  x_hex = 0;
+  switch (post = gfc_next_ascii_char ())
+    {
+    case 'b':
+      radix = 2;
+      post = 0;
+      break;
+    case 'o':
+      radix = 8;
+      post = 0;
+      break;
+    case 'x':
+      x_hex = 1;
+      /* Fall through.  */
+    case 'z':
+      radix = 16;
+      post = 0;
+      break;
+    case '\'':
+      /* Fall through.  */
+    case '\"':
+      delim = post;
+      post = 1;
+      radix = 16;  /* Set to accept any valid digit string.  */
+      break;
+    default:
+      goto backup;
+    }
+
+  /* No whitespace allowed here.  */
+
+  if (post == 0)
+    delim = gfc_next_ascii_char ();
+
+  if (delim != '\'' && delim != '\"')
+    goto backup;
+
+  if (x_hex
+      && (!gfc_notify_std(GFC_STD_GNU, "Hexadecimal "
+			  "constant at %C uses non-standard syntax")))
+      return MATCH_ERROR;
+
+  old_loc = gfc_current_locus;
+
+  length = match_digits (0, radix, NULL);
+  if (length == -1)
+    {
+      gfc_error ("Empty set of digits in BOZ constant at %C");
+      return MATCH_ERROR;
+    }
+
+  if (gfc_next_ascii_char () != delim)
+    {
+      gfc_error ("Illegal character in BOZ constant at %C");
+      return MATCH_ERROR;
+    }
+
+  if (post == 1)
+    {
+      switch (gfc_next_ascii_char ())
+	{
+	case 'b':
+	  radix = 2;
+	  break;
+	case 'o':
+	  radix = 8;
+	  break;
+	case 'x':
+	  /* Fall through.  */
+	case 'z':
+	  radix = 16;
+	  break;
+	default:
+	  goto backup;
+	}
+
+      if (!gfc_notify_std (GFC_STD_GNU, "BOZ constant "
+			   "at %C uses non-standard postfix syntax"))
+	return MATCH_ERROR;
+    }
+
+  gfc_current_locus = old_loc;
+
+  buffer = (char *) alloca (length + 1);
+  memset (buffer, '\0', length + 1);
+
+  match_digits (0, radix, buffer);
+  gfc_next_ascii_char ();    /* Eat delimiter.  */
+  if (post == 1)
+    gfc_next_ascii_char ();  /* Eat postfixed b, o, z, or x.  */
+
+  /* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find
+     "If a data-stmt-constant is a boz-literal-constant, the corresponding
+     variable shall be of type integer.  The boz-literal-constant is treated
+     as if it were an int-literal-constant with a kind-param that specifies
+     the representation method with the largest decimal exponent range
+     supported by the processor."  */
+
+  kind = gfc_max_integer_kind;
+  e = gfc_convert_integer (buffer, kind, radix, &gfc_current_locus);
+
+  /* Mark as boz variable.  */
+  e->is_boz = 1;
+
+  if (gfc_range_check (e) != ARITH_OK)
+    {
+      gfc_error ("Integer too big for integer kind %i at %C", kind);
+      gfc_free_expr (e);
+      return MATCH_ERROR;
+    }
+
+  if (!gfc_in_match_data ()
+      && (!gfc_notify_std(GFC_STD_F2003, "BOZ used outside a DATA "
+			  "statement at %C")))
+      return MATCH_ERROR;
+
+  *result = e;
+  return MATCH_YES;
+
+backup:
+  gfc_current_locus = start_loc;
+  return MATCH_NO;
+}
+
+
+/* Match a real constant of some sort.  Allow a signed constant if signflag
+   is nonzero.  */
+
+static match
+match_real_constant (gfc_expr **result, int signflag)
+{
+  int kind, count, seen_dp, seen_digits, is_iso_c;
+  locus old_loc, temp_loc;
+  char *p, *buffer, c, exp_char;
+  gfc_expr *e;
+  bool negate;
+
+  old_loc = gfc_current_locus;
+  gfc_gobble_whitespace ();
+
+  e = NULL;
+
+  count = 0;
+  seen_dp = 0;
+  seen_digits = 0;
+  exp_char = ' ';
+  negate = FALSE;
+
+  c = gfc_next_ascii_char ();
+  if (signflag && (c == '+' || c == '-'))
+    {
+      if (c == '-')
+	negate = TRUE;
+
+      gfc_gobble_whitespace ();
+      c = gfc_next_ascii_char ();
+    }
+
+  /* Scan significand.  */
+  for (;; c = gfc_next_ascii_char (), count++)
+    {
+      if (c == '.')
+	{
+	  if (seen_dp)
+	    goto done;
+
+	  /* Check to see if "." goes with a following operator like 
+	     ".eq.".  */
+	  temp_loc = gfc_current_locus;
+	  c = gfc_next_ascii_char ();
+
+	  if (c == 'e' || c == 'd' || c == 'q')
+	    {
+	      c = gfc_next_ascii_char ();
+	      if (c == '.')
+		goto done;	/* Operator named .e. or .d.  */
+	    }
+
+	  if (ISALPHA (c))
+	    goto done;		/* Distinguish 1.e9 from 1.eq.2 */
+
+	  gfc_current_locus = temp_loc;
+	  seen_dp = 1;
+	  continue;
+	}
+
+      if (ISDIGIT (c))
+	{
+	  seen_digits = 1;
+	  continue;
+	}
+
+      break;
+    }
+
+  if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
+    goto done;
+  exp_char = c;
+
+
+  if (c == 'q')
+    {
+      if (!gfc_notify_std (GFC_STD_GNU, "exponent-letter 'q' in "
+			   "real-literal-constant at %C"))
+	return MATCH_ERROR;
+      else if (gfc_option.warn_real_q_constant)
+	gfc_warning("Extension: exponent-letter 'q' in real-literal-constant "
+		    "at %C");
+    }
+
+  /* Scan exponent.  */
+  c = gfc_next_ascii_char ();
+  count++;
+
+  if (c == '+' || c == '-')
+    {				/* optional sign */
+      c = gfc_next_ascii_char ();
+      count++;
+    }
+
+  if (!ISDIGIT (c))
+    {
+      gfc_error ("Missing exponent in real number at %C");
+      return MATCH_ERROR;
+    }
+
+  while (ISDIGIT (c))
+    {
+      c = gfc_next_ascii_char ();
+      count++;
+    }
+
+done:
+  /* Check that we have a numeric constant.  */
+  if (!seen_digits || (!seen_dp && exp_char == ' '))
+    {
+      gfc_current_locus = old_loc;
+      return MATCH_NO;
+    }
+
+  /* Convert the number.  */
+  gfc_current_locus = old_loc;
+  gfc_gobble_whitespace ();
+
+  buffer = (char *) alloca (count + 1);
+  memset (buffer, '\0', count + 1);
+
+  p = buffer;
+  c = gfc_next_ascii_char ();
+  if (c == '+' || c == '-')
+    {
+      gfc_gobble_whitespace ();
+      c = gfc_next_ascii_char ();
+    }
+
+  /* Hack for mpfr_set_str().  */
+  for (;;)
+    {
+      if (c == 'd' || c == 'q')
+	*p = 'e';
+      else
+	*p = c;
+      p++;
+      if (--count == 0)
+	break;
+
+      c = gfc_next_ascii_char ();
+    }
+
+  kind = get_kind (&is_iso_c);
+  if (kind == -1)
+    goto cleanup;
+
+  switch (exp_char)
+    {
+    case 'd':
+      if (kind != -2)
+	{
+	  gfc_error ("Real number at %C has a 'd' exponent and an explicit "
+		     "kind");
+	  goto cleanup;
+	}
+      kind = gfc_default_double_kind;
+
+      if (kind == 4)
+	{
+	  if (gfc_option.flag_real4_kind == 8)
+	    kind = 8;
+	  if (gfc_option.flag_real4_kind == 10)
+	    kind = 10;
+	  if (gfc_option.flag_real4_kind == 16)
+	    kind = 16;
+	}
+
+      if (kind == 8)
+	{
+	  if (gfc_option.flag_real8_kind == 4)
+	    kind = 4;
+	  if (gfc_option.flag_real8_kind == 10)
+	    kind = 10;
+	  if (gfc_option.flag_real8_kind == 16)
+	    kind = 16;
+	}
+      break;
+
+    case 'q':
+      if (kind != -2)
+	{
+	  gfc_error ("Real number at %C has a 'q' exponent and an explicit "
+		     "kind");
+	  goto cleanup;
+	}
+
+      /* The maximum possible real kind type parameter is 16.  First, try
+	 that for the kind, then fallback to trying kind=10 (Intel 80 bit)
+	 extended precision.  If neither value works, just given up.  */
+      kind = 16;
+      if (gfc_validate_kind (BT_REAL, kind, true) < 0)
+	{
+	  kind = 10;
+          if (gfc_validate_kind (BT_REAL, kind, true) < 0)
+	    {
+	      gfc_error ("Invalid exponent-letter 'q' in "
+			 "real-literal-constant at %C");
+	      goto cleanup;
+	    }
+	}
+      break;
+
+    default:
+      if (kind == -2)
+	kind = gfc_default_real_kind;
+
+      if (kind == 4)
+	{
+	  if (gfc_option.flag_real4_kind == 8)
+	    kind = 8;
+	  if (gfc_option.flag_real4_kind == 10)
+	    kind = 10;
+	  if (gfc_option.flag_real4_kind == 16)
+	    kind = 16;
+	}
+
+      if (kind == 8)
+	{
+	  if (gfc_option.flag_real8_kind == 4)
+	    kind = 4;
+	  if (gfc_option.flag_real8_kind == 10)
+	    kind = 10;
+	  if (gfc_option.flag_real8_kind == 16)
+	    kind = 16;
+	}
+
+      if (gfc_validate_kind (BT_REAL, kind, true) < 0)
+	{
+	  gfc_error ("Invalid real kind %d at %C", kind);
+	  goto cleanup;
+	}
+    }
+
+  e = gfc_convert_real (buffer, kind, &gfc_current_locus);
+  if (negate)
+    mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
+  e->ts.is_c_interop = is_iso_c;
+
+  switch (gfc_range_check (e))
+    {
+    case ARITH_OK:
+      break;
+    case ARITH_OVERFLOW:
+      gfc_error ("Real constant overflows its kind at %C");
+      goto cleanup;
+
+    case ARITH_UNDERFLOW:
+      if (gfc_option.warn_underflow)
+	gfc_warning ("Real constant underflows its kind at %C");
+      mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
+      break;
+
+    default:
+      gfc_internal_error ("gfc_range_check() returned bad value");
+    }
+
+  *result = e;
+  return MATCH_YES;
+
+cleanup:
+  gfc_free_expr (e);
+  return MATCH_ERROR;
+}
+
+
+/* Match a substring reference.  */
+
+static match
+match_substring (gfc_charlen *cl, int init, gfc_ref **result)
+{
+  gfc_expr *start, *end;
+  locus old_loc;
+  gfc_ref *ref;
+  match m;
+
+  start = NULL;
+  end = NULL;
+
+  old_loc = gfc_current_locus;
+
+  m = gfc_match_char ('(');
+  if (m != MATCH_YES)
+    return MATCH_NO;
+
+  if (gfc_match_char (':') != MATCH_YES)
+    {
+      if (init)
+	m = gfc_match_init_expr (&start);
+      else
+	m = gfc_match_expr (&start);
+
+      if (m != MATCH_YES)
+	{
+	  m = MATCH_NO;
+	  goto cleanup;
+	}
+
+      m = gfc_match_char (':');
+      if (m != MATCH_YES)
+	goto cleanup;
+    }
+
+  if (gfc_match_char (')') != MATCH_YES)
+    {
+      if (init)
+	m = gfc_match_init_expr (&end);
+      else
+	m = gfc_match_expr (&end);
+
+      if (m == MATCH_NO)
+	goto syntax;
+      if (m == MATCH_ERROR)
+	goto cleanup;
+
+      m = gfc_match_char (')');
+      if (m == MATCH_NO)
+	goto syntax;
+    }
+
+  /* Optimize away the (:) reference.  */
+  if (start == NULL && end == NULL)
+    ref = NULL;
+  else
+    {
+      ref = gfc_get_ref ();
+
+      ref->type = REF_SUBSTRING;
+      if (start == NULL)
+	start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+      ref->u.ss.start = start;
+      if (end == NULL && cl)
+	end = gfc_copy_expr (cl->length);
+      ref->u.ss.end = end;
+      ref->u.ss.length = cl;
+    }
+
+  *result = ref;
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in SUBSTRING specification at %C");
+  m = MATCH_ERROR;
+
+cleanup:
+  gfc_free_expr (start);
+  gfc_free_expr (end);
+
+  gfc_current_locus = old_loc;
+  return m;
+}
+
+
+/* Reads the next character of a string constant, taking care to
+   return doubled delimiters on the input as a single instance of
+   the delimiter.
+
+   Special return values for "ret" argument are:
+     -1   End of the string, as determined by the delimiter
+     -2   Unterminated string detected
+
+   Backslash codes are also expanded at this time.  */
+
+static gfc_char_t
+next_string_char (gfc_char_t delimiter, int *ret)
+{
+  locus old_locus;
+  gfc_char_t c;
+
+  c = gfc_next_char_literal (INSTRING_WARN);
+  *ret = 0;
+
+  if (c == '\n')
+    {
+      *ret = -2;
+      return 0;
+    }
+
+  if (gfc_option.flag_backslash && c == '\\')
+    {
+      old_locus = gfc_current_locus;
+
+      if (gfc_match_special_char (&c) == MATCH_NO)
+	gfc_current_locus = old_locus;
+
+      if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
+	gfc_warning ("Extension: backslash character at %C");
+    }
+
+  if (c != delimiter)
+    return c;
+
+  old_locus = gfc_current_locus;
+  c = gfc_next_char_literal (NONSTRING);
+
+  if (c == delimiter)
+    return c;
+  gfc_current_locus = old_locus;
+
+  *ret = -1;
+  return 0;
+}
+
+
+/* Special case of gfc_match_name() that matches a parameter kind name
+   before a string constant.  This takes case of the weird but legal
+   case of:
+
+     kind_____'string'
+
+   where kind____ is a parameter. gfc_match_name() will happily slurp
+   up all the underscores, which leads to problems.  If we return
+   MATCH_YES, the parse pointer points to the final underscore, which
+   is not part of the name.  We never return MATCH_ERROR-- errors in
+   the name will be detected later.  */
+
+static match
+match_charkind_name (char *name)
+{
+  locus old_loc;
+  char c, peek;
+  int len;
+
+  gfc_gobble_whitespace ();
+  c = gfc_next_ascii_char ();
+  if (!ISALPHA (c))
+    return MATCH_NO;
+
+  *name++ = c;
+  len = 1;
+
+  for (;;)
+    {
+      old_loc = gfc_current_locus;
+      c = gfc_next_ascii_char ();
+
+      if (c == '_')
+	{
+	  peek = gfc_peek_ascii_char ();
+
+	  if (peek == '\'' || peek == '\"')
+	    {
+	      gfc_current_locus = old_loc;
+	      *name = '\0';
+	      return MATCH_YES;
+	    }
+	}
+
+      if (!ISALNUM (c)
+	  && c != '_'
+	  && (c != '$' || !gfc_option.flag_dollar_ok))
+	break;
+
+      *name++ = c;
+      if (++len > GFC_MAX_SYMBOL_LEN)
+	break;
+    }
+
+  return MATCH_NO;
+}
+
+
+/* See if the current input matches a character constant.  Lots of
+   contortions have to be done to match the kind parameter which comes
+   before the actual string.  The main consideration is that we don't
+   want to error out too quickly.  For example, we don't actually do
+   any validation of the kinds until we have actually seen a legal
+   delimiter.  Using match_kind_param() generates errors too quickly.  */
+
+static match
+match_string_constant (gfc_expr **result)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1], peek;
+  int i, kind, length, warn_ampersand, ret;
+  locus old_locus, start_locus;
+  gfc_symbol *sym;
+  gfc_expr *e;
+  const char *q;
+  match m;
+  gfc_char_t c, delimiter, *p;
+
+  old_locus = gfc_current_locus;
+
+  gfc_gobble_whitespace ();
+
+  c = gfc_next_char ();
+  if (c == '\'' || c == '"')
+    {
+      kind = gfc_default_character_kind;
+      start_locus = gfc_current_locus;
+      goto got_delim;
+    }
+
+  if (gfc_wide_is_digit (c))
+    {
+      kind = 0;
+
+      while (gfc_wide_is_digit (c))
+	{
+	  kind = kind * 10 + c - '0';
+	  if (kind > 9999999)
+	    goto no_match;
+	  c = gfc_next_char ();
+	}
+
+    }
+  else
+    {
+      gfc_current_locus = old_locus;
+
+      m = match_charkind_name (name);
+      if (m != MATCH_YES)
+	goto no_match;
+
+      if (gfc_find_symbol (name, NULL, 1, &sym)
+	  || sym == NULL
+	  || sym->attr.flavor != FL_PARAMETER)
+	goto no_match;
+
+      kind = -1;
+      c = gfc_next_char ();
+    }
+
+  if (c == ' ')
+    {
+      gfc_gobble_whitespace ();
+      c = gfc_next_char ();
+    }
+
+  if (c != '_')
+    goto no_match;
+
+  gfc_gobble_whitespace ();
+
+  c = gfc_next_char ();
+  if (c != '\'' && c != '"')
+    goto no_match;
+
+  start_locus = gfc_current_locus;
+
+  if (kind == -1)
+    {
+      q = gfc_extract_int (sym->value, &kind);
+      if (q != NULL)
+	{
+	  gfc_error (q);
+	  return MATCH_ERROR;
+	}
+      gfc_set_sym_referenced (sym);
+    }
+
+  if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
+    {
+      gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
+      return MATCH_ERROR;
+    }
+
+got_delim:
+  /* Scan the string into a block of memory by first figuring out how
+     long it is, allocating the structure, then re-reading it.  This
+     isn't particularly efficient, but string constants aren't that
+     common in most code.  TODO: Use obstacks?  */
+
+  delimiter = c;
+  length = 0;
+
+  for (;;)
+    {
+      c = next_string_char (delimiter, &ret);
+      if (ret == -1)
+	break;
+      if (ret == -2)
+	{
+	  gfc_current_locus = start_locus;
+	  gfc_error ("Unterminated character constant beginning at %C");
+	  return MATCH_ERROR;
+	}
+
+      length++;
+    }
+
+  /* Peek at the next character to see if it is a b, o, z, or x for the
+     postfixed BOZ literal constants.  */
+  peek = gfc_peek_ascii_char ();
+  if (peek == 'b' || peek == 'o' || peek =='z' || peek == 'x')
+    goto no_match;
+
+  e = gfc_get_character_expr (kind, &start_locus, NULL, length);
+
+  gfc_current_locus = start_locus;
+
+  /* We disable the warning for the following loop as the warning has already
+     been printed in the loop above.  */
+  warn_ampersand = gfc_option.warn_ampersand;
+  gfc_option.warn_ampersand = 0;
+
+  p = e->value.character.string;
+  for (i = 0; i < length; i++)
+    {
+      c = next_string_char (delimiter, &ret);
+
+      if (!gfc_check_character_range (c, kind))
+	{
+	  gfc_free_expr (e);
+	  gfc_error ("Character '%s' in string at %C is not representable "
+		     "in character kind %d", gfc_print_wide_char (c), kind);
+	  return MATCH_ERROR;
+	}
+
+      *p++ = c;
+    }
+
+  *p = '\0';	/* TODO: C-style string is for development/debug purposes.  */
+  gfc_option.warn_ampersand = warn_ampersand;
+
+  next_string_char (delimiter, &ret);
+  if (ret != -1)
+    gfc_internal_error ("match_string_constant(): Delimiter not found");
+
+  if (match_substring (NULL, 0, &e->ref) != MATCH_NO)
+    e->expr_type = EXPR_SUBSTRING;
+
+  *result = e;
+
+  return MATCH_YES;
+
+no_match:
+  gfc_current_locus = old_locus;
+  return MATCH_NO;
+}
+
+
+/* Match a .true. or .false.  Returns 1 if a .true. was found,
+   0 if a .false. was found, and -1 otherwise.  */
+static int
+match_logical_constant_string (void)
+{
+  locus orig_loc = gfc_current_locus;
+
+  gfc_gobble_whitespace ();
+  if (gfc_next_ascii_char () == '.')
+    {
+      char ch = gfc_next_ascii_char ();
+      if (ch == 'f')
+	{
+	  if (gfc_next_ascii_char () == 'a'
+	      && gfc_next_ascii_char () == 'l'
+	      && gfc_next_ascii_char () == 's'
+	      && gfc_next_ascii_char () == 'e'
+	      && gfc_next_ascii_char () == '.')
+	    /* Matched ".false.".  */
+	    return 0;
+	}
+      else if (ch == 't')
+	{
+	  if (gfc_next_ascii_char () == 'r'
+	      && gfc_next_ascii_char () == 'u'
+	      && gfc_next_ascii_char () == 'e'
+	      && gfc_next_ascii_char () == '.')
+	    /* Matched ".true.".  */
+	    return 1;
+	}
+    }
+  gfc_current_locus = orig_loc;
+  return -1;
+}
+
+/* Match a .true. or .false.  */
+
+static match
+match_logical_constant (gfc_expr **result)
+{
+  gfc_expr *e;
+  int i, kind, is_iso_c;
+
+  i = match_logical_constant_string ();
+  if (i == -1)
+    return MATCH_NO;
+
+  kind = get_kind (&is_iso_c);
+  if (kind == -1)
+    return MATCH_ERROR;
+  if (kind == -2)
+    kind = gfc_default_logical_kind;
+
+  if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
+    {
+      gfc_error ("Bad kind for logical constant at %C");
+      return MATCH_ERROR;
+    }
+
+  e = gfc_get_logical_expr (kind, &gfc_current_locus, i);
+  e->ts.is_c_interop = is_iso_c;
+
+  *result = e;
+  return MATCH_YES;
+}
+
+
+/* Match a real or imaginary part of a complex constant that is a
+   symbolic constant.  */
+
+static match
+match_sym_complex_part (gfc_expr **result)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_symbol *sym;
+  gfc_expr *e;
+  match m;
+
+  m = gfc_match_name (name);
+  if (m != MATCH_YES)
+    return m;
+
+  if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
+    return MATCH_NO;
+
+  if (sym->attr.flavor != FL_PARAMETER)
+    {
+      gfc_error ("Expected PARAMETER symbol in complex constant at %C");
+      return MATCH_ERROR;
+    }
+
+  if (!gfc_numeric_ts (&sym->value->ts))
+    {
+      gfc_error ("Numeric PARAMETER required in complex constant at %C");
+      return MATCH_ERROR;
+    }
+
+  if (sym->value->rank != 0)
+    {
+      gfc_error ("Scalar PARAMETER required in complex constant at %C");
+      return MATCH_ERROR;
+    }
+
+  if (!gfc_notify_std (GFC_STD_F2003, "PARAMETER symbol in "
+		       "complex constant at %C"))
+    return MATCH_ERROR;
+
+  switch (sym->value->ts.type)
+    {
+    case BT_REAL:
+      e = gfc_copy_expr (sym->value);
+      break;
+
+    case BT_COMPLEX:
+      e = gfc_complex2real (sym->value, sym->value->ts.kind);
+      if (e == NULL)
+	goto error;
+      break;
+
+    case BT_INTEGER:
+      e = gfc_int2real (sym->value, gfc_default_real_kind);
+      if (e == NULL)
+	goto error;
+      break;
+
+    default:
+      gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
+    }
+
+  *result = e;		/* e is a scalar, real, constant expression.  */
+  return MATCH_YES;
+
+error:
+  gfc_error ("Error converting PARAMETER constant in complex constant at %C");
+  return MATCH_ERROR;
+}
+
+
+/* Match a real or imaginary part of a complex number.  */
+
+static match
+match_complex_part (gfc_expr **result)
+{
+  match m;
+
+  m = match_sym_complex_part (result);
+  if (m != MATCH_NO)
+    return m;
+
+  m = match_real_constant (result, 1);
+  if (m != MATCH_NO)
+    return m;
+
+  return match_integer_constant (result, 1);
+}
+
+
+/* Try to match a complex constant.  */
+
+static match
+match_complex_constant (gfc_expr **result)
+{
+  gfc_expr *e, *real, *imag;
+  gfc_error_buf old_error;
+  gfc_typespec target;
+  locus old_loc;
+  int kind;
+  match m;
+
+  old_loc = gfc_current_locus;
+  real = imag = e = NULL;
+
+  m = gfc_match_char ('(');
+  if (m != MATCH_YES)
+    return m;
+
+  gfc_push_error (&old_error);
+
+  m = match_complex_part (&real);
+  if (m == MATCH_NO)
+    {
+      gfc_free_error (&old_error);
+      goto cleanup;
+    }
+
+  if (gfc_match_char (',') == MATCH_NO)
+    {
+      gfc_pop_error (&old_error);
+      m = MATCH_NO;
+      goto cleanup;
+    }
+
+  /* If m is error, then something was wrong with the real part and we
+     assume we have a complex constant because we've seen the ','.  An
+     ambiguous case here is the start of an iterator list of some
+     sort. These sort of lists are matched prior to coming here.  */
+
+  if (m == MATCH_ERROR)
+    {
+      gfc_free_error (&old_error);
+      goto cleanup;
+    }
+  gfc_pop_error (&old_error);
+
+  m = match_complex_part (&imag);
+  if (m == MATCH_NO)
+    goto syntax;
+  if (m == MATCH_ERROR)
+    goto cleanup;
+
+  m = gfc_match_char (')');
+  if (m == MATCH_NO)
+    {
+      /* Give the matcher for implied do-loops a chance to run.  This
+	 yields a much saner error message for (/ (i, 4=i, 6) /).  */
+      if (gfc_peek_ascii_char () == '=')
+	{
+	  m = MATCH_ERROR;
+	  goto cleanup;
+	}
+      else
+    goto syntax;
+    }
+
+  if (m == MATCH_ERROR)
+    goto cleanup;
+
+  /* Decide on the kind of this complex number.  */
+  if (real->ts.type == BT_REAL)
+    {
+      if (imag->ts.type == BT_REAL)
+	kind = gfc_kind_max (real, imag);
+      else
+	kind = real->ts.kind;
+    }
+  else
+    {
+      if (imag->ts.type == BT_REAL)
+	kind = imag->ts.kind;
+      else
+	kind = gfc_default_real_kind;
+    }
+  gfc_clear_ts (&target);
+  target.type = BT_REAL;
+  target.kind = kind;
+
+  if (real->ts.type != BT_REAL || kind != real->ts.kind)
+    gfc_convert_type (real, &target, 2);
+  if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
+    gfc_convert_type (imag, &target, 2);
+
+  e = gfc_convert_complex (real, imag, kind);
+  e->where = gfc_current_locus;
+
+  gfc_free_expr (real);
+  gfc_free_expr (imag);
+
+  *result = e;
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in COMPLEX constant at %C");
+  m = MATCH_ERROR;
+
+cleanup:
+  gfc_free_expr (e);
+  gfc_free_expr (real);
+  gfc_free_expr (imag);
+  gfc_current_locus = old_loc;
+
+  return m;
+}
+
+
+/* Match constants in any of several forms.  Returns nonzero for a
+   match, zero for no match.  */
+
+match
+gfc_match_literal_constant (gfc_expr **result, int signflag)
+{
+  match m;
+
+  m = match_complex_constant (result);
+  if (m != MATCH_NO)
+    return m;
+
+  m = match_string_constant (result);
+  if (m != MATCH_NO)
+    return m;
+
+  m = match_boz_constant (result);
+  if (m != MATCH_NO)
+    return m;
+
+  m = match_real_constant (result, signflag);
+  if (m != MATCH_NO)
+    return m;
+
+  m = match_hollerith_constant (result);
+  if (m != MATCH_NO)
+    return m;
+
+  m = match_integer_constant (result, signflag);
+  if (m != MATCH_NO)
+    return m;
+
+  m = match_logical_constant (result);
+  if (m != MATCH_NO)
+    return m;
+
+  return MATCH_NO;
+}
+
+
+/* This checks if a symbol is the return value of an encompassing function.
+   Function nesting can be maximally two levels deep, but we may have
+   additional local namespaces like BLOCK etc.  */
+
+bool
+gfc_is_function_return_value (gfc_symbol *sym, gfc_namespace *ns)
+{
+  if (!sym->attr.function || (sym->result != sym))
+    return false;
+  while (ns)
+    {
+      if (ns->proc_name == sym)
+	return true;
+      ns = ns->parent;
+    }
+  return false;
+}
+
+
+/* Match a single actual argument value.  An actual argument is
+   usually an expression, but can also be a procedure name.  If the
+   argument is a single name, it is not always possible to tell
+   whether the name is a dummy procedure or not.  We treat these cases
+   by creating an argument that looks like a dummy procedure and
+   fixing things later during resolution.  */
+
+static match
+match_actual_arg (gfc_expr **result)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_symtree *symtree;
+  locus where, w;
+  gfc_expr *e;
+  char c;
+
+  gfc_gobble_whitespace ();
+  where = gfc_current_locus;
+
+  switch (gfc_match_name (name))
+    {
+    case MATCH_ERROR:
+      return MATCH_ERROR;
+
+    case MATCH_NO:
+      break;
+
+    case MATCH_YES:
+      w = gfc_current_locus;
+      gfc_gobble_whitespace ();
+      c = gfc_next_ascii_char ();
+      gfc_current_locus = w;
+
+      if (c != ',' && c != ')')
+	break;
+
+      if (gfc_find_sym_tree (name, NULL, 1, &symtree))
+	break;
+      /* Handle error elsewhere.  */
+
+      /* Eliminate a couple of common cases where we know we don't
+	 have a function argument.  */
+      if (symtree == NULL)
+	{
+	  gfc_get_sym_tree (name, NULL, &symtree, false);
+	  gfc_set_sym_referenced (symtree->n.sym);
+	}
+      else
+	{
+	  gfc_symbol *sym;
+
+	  sym = symtree->n.sym;
+	  gfc_set_sym_referenced (sym);
+	  if (sym->attr.flavor != FL_PROCEDURE
+	      && sym->attr.flavor != FL_UNKNOWN)
+	    break;
+
+	  if (sym->attr.in_common && !sym->attr.proc_pointer)
+	    {
+	      if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, 
+				   sym->name, &sym->declared_at))
+		return MATCH_ERROR;
+	      break;
+	    }
+
+	  /* If the symbol is a function with itself as the result and
+	     is being defined, then we have a variable.  */
+	  if (sym->attr.function && sym->result == sym)
+	    {
+	      if (gfc_is_function_return_value (sym, gfc_current_ns))
+		break;
+
+	      if (sym->attr.entry
+		  && (sym->ns == gfc_current_ns
+		      || sym->ns == gfc_current_ns->parent))
+		{
+		  gfc_entry_list *el = NULL;
+
+		  for (el = sym->ns->entries; el; el = el->next)
+		    if (sym == el->sym)
+		      break;
+
+		  if (el)
+		    break;
+		}
+	    }
+	}
+
+      e = gfc_get_expr ();	/* Leave it unknown for now */
+      e->symtree = symtree;
+      e->expr_type = EXPR_VARIABLE;
+      e->ts.type = BT_PROCEDURE;
+      e->where = where;
+
+      *result = e;
+      return MATCH_YES;
+    }
+
+  gfc_current_locus = where;
+  return gfc_match_expr (result);
+}
+
+
+/* Match a keyword argument.  */
+
+static match
+match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_actual_arglist *a;
+  locus name_locus;
+  match m;
+
+  name_locus = gfc_current_locus;
+  m = gfc_match_name (name);
+
+  if (m != MATCH_YES)
+    goto cleanup;
+  if (gfc_match_char ('=') != MATCH_YES)
+    {
+      m = MATCH_NO;
+      goto cleanup;
+    }
+
+  m = match_actual_arg (&actual->expr);
+  if (m != MATCH_YES)
+    goto cleanup;
+
+  /* Make sure this name has not appeared yet.  */
+
+  if (name[0] != '\0')
+    {
+      for (a = base; a; a = a->next)
+	if (a->name != NULL && strcmp (a->name, name) == 0)
+	  {
+	    gfc_error ("Keyword '%s' at %C has already appeared in the "
+		       "current argument list", name);
+	    return MATCH_ERROR;
+	  }
+    }
+
+  actual->name = gfc_get_string (name);
+  return MATCH_YES;
+
+cleanup:
+  gfc_current_locus = name_locus;
+  return m;
+}
+
+
+/* Match an argument list function, such as %VAL.  */
+
+static match
+match_arg_list_function (gfc_actual_arglist *result)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  locus old_locus;
+  match m;
+
+  old_locus = gfc_current_locus;
+
+  if (gfc_match_char ('%') != MATCH_YES)
+    {
+      m = MATCH_NO;
+      goto cleanup;
+    }
+
+  m = gfc_match ("%n (", name);
+  if (m != MATCH_YES)
+    goto cleanup;
+
+  if (name[0] != '\0')
+    {
+      switch (name[0])
+	{
+	case 'l':
+	  if (strncmp (name, "loc", 3) == 0)
+	    {
+	      result->name = "%LOC";
+	      break;
+	    }
+	case 'r':
+	  if (strncmp (name, "ref", 3) == 0)
+	    {
+	      result->name = "%REF";
+	      break;
+	    }
+	case 'v':
+	  if (strncmp (name, "val", 3) == 0)
+	    {
+	      result->name = "%VAL";
+	      break;
+	    }
+	default:
+	  m = MATCH_ERROR;
+	  goto cleanup;
+	}
+    }
+
+  if (!gfc_notify_std (GFC_STD_GNU, "argument list function at %C"))
+    {
+      m = MATCH_ERROR;
+      goto cleanup;
+    }
+
+  m = match_actual_arg (&result->expr);
+  if (m != MATCH_YES)
+    goto cleanup;
+
+  if (gfc_match_char (')') != MATCH_YES)
+    {
+      m = MATCH_NO;
+      goto cleanup;
+    }
+
+  return MATCH_YES;
+
+cleanup:
+  gfc_current_locus = old_locus;
+  return m;
+}
+
+
+/* Matches an actual argument list of a function or subroutine, from
+   the opening parenthesis to the closing parenthesis.  The argument
+   list is assumed to allow keyword arguments because we don't know if
+   the symbol associated with the procedure has an implicit interface
+   or not.  We make sure keywords are unique. If sub_flag is set,
+   we're matching the argument list of a subroutine.  */
+
+match
+gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp)
+{
+  gfc_actual_arglist *head, *tail;
+  int seen_keyword;
+  gfc_st_label *label;
+  locus old_loc;
+  match m;
+
+  *argp = tail = NULL;
+  old_loc = gfc_current_locus;
+
+  seen_keyword = 0;
+
+  if (gfc_match_char ('(') == MATCH_NO)
+    return (sub_flag) ? MATCH_YES : MATCH_NO;
+
+  if (gfc_match_char (')') == MATCH_YES)
+    return MATCH_YES;
+  head = NULL;
+
+  matching_actual_arglist++;
+
+  for (;;)
+    {
+      if (head == NULL)
+	head = tail = gfc_get_actual_arglist ();
+      else
+	{
+	  tail->next = gfc_get_actual_arglist ();
+	  tail = tail->next;
+	}
+
+      if (sub_flag && gfc_match_char ('*') == MATCH_YES)
+	{
+	  m = gfc_match_st_label (&label);
+	  if (m == MATCH_NO)
+	    gfc_error ("Expected alternate return label at %C");
+	  if (m != MATCH_YES)
+	    goto cleanup;
+
+	  if (!gfc_notify_std (GFC_STD_F95_OBS, "Alternate-return argument "
+			       "at %C"))
+	    goto cleanup;
+
+	  tail->label = label;
+	  goto next;
+	}
+
+      /* After the first keyword argument is seen, the following
+	 arguments must also have keywords.  */
+      if (seen_keyword)
+	{
+	  m = match_keyword_arg (tail, head);
+
+	  if (m == MATCH_ERROR)
+	    goto cleanup;
+	  if (m == MATCH_NO)
+	    {
+	      gfc_error ("Missing keyword name in actual argument list at %C");
+	      goto cleanup;
+	    }
+
+	}
+      else
+	{
+	  /* Try an argument list function, like %VAL.  */
+	  m = match_arg_list_function (tail);
+	  if (m == MATCH_ERROR)
+	    goto cleanup;
+
+	  /* See if we have the first keyword argument.  */
+	  if (m == MATCH_NO)
+	    {
+	      m = match_keyword_arg (tail, head);
+	      if (m == MATCH_YES)
+		seen_keyword = 1;
+	      if (m == MATCH_ERROR)
+		goto cleanup;
+	    }
+
+	  if (m == MATCH_NO)
+	    {
+	      /* Try for a non-keyword argument.  */
+	      m = match_actual_arg (&tail->expr);
+	      if (m == MATCH_ERROR)
+		goto cleanup;
+	      if (m == MATCH_NO)
+		goto syntax;
+	    }
+	}
+
+
+    next:
+      if (gfc_match_char (')') == MATCH_YES)
+	break;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+    }
+
+  *argp = head;
+  matching_actual_arglist--;
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in argument list at %C");
+
+cleanup:
+  gfc_free_actual_arglist (head);
+  gfc_current_locus = old_loc;
+  matching_actual_arglist--;
+  return MATCH_ERROR;
+}
+
+
+/* Used by gfc_match_varspec() to extend the reference list by one
+   element.  */
+
+static gfc_ref *
+extend_ref (gfc_expr *primary, gfc_ref *tail)
+{
+  if (primary->ref == NULL)
+    primary->ref = tail = gfc_get_ref ();
+  else
+    {
+      if (tail == NULL)
+	gfc_internal_error ("extend_ref(): Bad tail");
+      tail->next = gfc_get_ref ();
+      tail = tail->next;
+    }
+
+  return tail;
+}
+
+
+/* Match any additional specifications associated with the current
+   variable like member references or substrings.  If equiv_flag is
+   set we only match stuff that is allowed inside an EQUIVALENCE
+   statement.  sub_flag tells whether we expect a type-bound procedure found
+   to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
+   components, 'ppc_arg' determines whether the PPC may be called (with an
+   argument list), or whether it may just be referred to as a pointer.  */
+
+match
+gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
+		   bool ppc_arg)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_ref *substring, *tail;
+  gfc_component *component;
+  gfc_symbol *sym = primary->symtree->n.sym;
+  match m;
+  bool unknown;
+
+  tail = NULL;
+
+  gfc_gobble_whitespace ();
+
+  if (gfc_peek_ascii_char () == '[')
+    {
+      if ((sym->ts.type != BT_CLASS && sym->attr.dimension)
+	  || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+	      && CLASS_DATA (sym)->attr.dimension))
+	{
+	  gfc_error ("Array section designator, e.g. '(:)', is required "
+		     "besides the coarray designator '[...]' at %C");
+	  return MATCH_ERROR;
+	}
+      if ((sym->ts.type != BT_CLASS && !sym->attr.codimension)
+	  || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+	      && !CLASS_DATA (sym)->attr.codimension))
+	{
+	  gfc_error ("Coarray designator at %C but '%s' is not a coarray",
+		     sym->name);
+	  return MATCH_ERROR;
+	}
+    }
+
+  /* For associate names, we may not yet know whether they are arrays or not.
+     Thus if we have one and parentheses follow, we have to assume that it
+     actually is one for now.  The final decision will be made at
+     resolution time, of course.  */
+  if (sym->assoc && gfc_peek_ascii_char () == '(')
+    sym->attr.dimension = 1;
+
+  if ((equiv_flag && gfc_peek_ascii_char () == '(')
+      || gfc_peek_ascii_char () == '[' || sym->attr.codimension
+      || (sym->attr.dimension && sym->ts.type != BT_CLASS
+	  && !sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (primary)
+	  && !(gfc_matching_procptr_assignment
+	       && sym->attr.flavor == FL_PROCEDURE))
+      || (sym->ts.type == BT_CLASS && sym->attr.class_ok
+	  && (CLASS_DATA (sym)->attr.dimension
+	      || CLASS_DATA (sym)->attr.codimension)))
+    {
+      gfc_array_spec *as;
+
+      tail = extend_ref (primary, tail);
+      tail->type = REF_ARRAY;
+
+      /* In EQUIVALENCE, we don't know yet whether we are seeing
+	 an array, character variable or array of character
+	 variables.  We'll leave the decision till resolve time.  */
+
+      if (equiv_flag)
+	as = NULL;
+      else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
+	as = CLASS_DATA (sym)->as;
+      else
+	as = sym->as;
+
+      m = gfc_match_array_ref (&tail->u.ar, as, equiv_flag,
+			       as ? as->corank : 0);
+      if (m != MATCH_YES)
+	return m;
+
+      gfc_gobble_whitespace ();
+      if (equiv_flag && gfc_peek_ascii_char () == '(')
+	{
+	  tail = extend_ref (primary, tail);
+	  tail->type = REF_ARRAY;
+
+	  m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag, 0);
+	  if (m != MATCH_YES)
+	    return m;
+	}
+    }
+
+  primary->ts = sym->ts;
+
+  if (equiv_flag)
+    return MATCH_YES;
+
+  if (sym->ts.type == BT_UNKNOWN && gfc_peek_ascii_char () == '%'
+      && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
+    gfc_set_default_type (sym, 0, sym->ns);
+
+  if (sym->ts.type == BT_UNKNOWN && gfc_match_char ('%') == MATCH_YES)
+    {
+      gfc_error ("Symbol '%s' at %C has no IMPLICIT type", sym->name);
+      return MATCH_ERROR;
+    }
+  else if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
+	   && gfc_match_char ('%') == MATCH_YES)
+    {
+      gfc_error ("Unexpected '%%' for nonderived-type variable '%s' at %C",
+		 sym->name);
+      return MATCH_ERROR;
+    }
+
+  if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
+      || gfc_match_char ('%') != MATCH_YES)
+    goto check_substring;
+
+  sym = sym->ts.u.derived;
+
+  for (;;)
+    {
+      bool t;
+      gfc_symtree *tbp;
+
+      m = gfc_match_name (name);
+      if (m == MATCH_NO)
+	gfc_error ("Expected structure component name at %C");
+      if (m != MATCH_YES)
+	return MATCH_ERROR;
+
+      if (sym->f2k_derived)
+	tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus);
+      else
+	tbp = NULL;
+
+      if (tbp)
+	{
+	  gfc_symbol* tbp_sym;
+
+	  if (!t)
+	    return MATCH_ERROR;
+
+	  gcc_assert (!tail || !tail->next);
+
+	  if (!(primary->expr_type == EXPR_VARIABLE
+		|| (primary->expr_type == EXPR_STRUCTURE
+		    && primary->symtree && primary->symtree->n.sym
+		    && primary->symtree->n.sym->attr.flavor)))
+	    return MATCH_ERROR;
+
+	  if (tbp->n.tb->is_generic)
+	    tbp_sym = NULL;
+	  else
+	    tbp_sym = tbp->n.tb->u.specific->n.sym;
+
+	  primary->expr_type = EXPR_COMPCALL;
+	  primary->value.compcall.tbp = tbp->n.tb;
+	  primary->value.compcall.name = tbp->name;
+	  primary->value.compcall.ignore_pass = 0;
+	  primary->value.compcall.assign = 0;
+	  primary->value.compcall.base_object = NULL;
+	  gcc_assert (primary->symtree->n.sym->attr.referenced);
+	  if (tbp_sym)
+	    primary->ts = tbp_sym->ts;
+	  else
+	    gfc_clear_ts (&primary->ts);
+
+	  m = gfc_match_actual_arglist (tbp->n.tb->subroutine,
+					&primary->value.compcall.actual);
+	  if (m == MATCH_ERROR)
+	    return MATCH_ERROR;
+	  if (m == MATCH_NO)
+	    {
+	      if (sub_flag)
+		primary->value.compcall.actual = NULL;
+	      else
+		{
+		  gfc_error ("Expected argument list at %C");
+		  return MATCH_ERROR;
+		}
+	    }
+
+	  break;
+	}
+
+      component = gfc_find_component (sym, name, false, false);
+      if (component == NULL)
+	return MATCH_ERROR;
+
+      tail = extend_ref (primary, tail);
+      tail->type = REF_COMPONENT;
+
+      tail->u.c.component = component;
+      tail->u.c.sym = sym;
+
+      primary->ts = component->ts;
+
+      if (component->attr.proc_pointer && ppc_arg)
+	{
+	  /* Procedure pointer component call: Look for argument list.  */
+	  m = gfc_match_actual_arglist (sub_flag,
+					&primary->value.compcall.actual);
+	  if (m == MATCH_ERROR)
+	    return MATCH_ERROR;
+
+	  if (m == MATCH_NO && !gfc_matching_ptr_assignment
+	      && !gfc_matching_procptr_assignment && !matching_actual_arglist)
+	    {
+	      gfc_error ("Procedure pointer component '%s' requires an "
+			 "argument list at %C", component->name);
+	      return MATCH_ERROR;
+	    }
+
+	  if (m == MATCH_YES)
+	    primary->expr_type = EXPR_PPC;
+
+          break;
+	}
+
+      if (component->as != NULL && !component->attr.proc_pointer)
+	{
+	  tail = extend_ref (primary, tail);
+	  tail->type = REF_ARRAY;
+
+	  m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag,
+			  component->as->corank);
+	  if (m != MATCH_YES)
+	    return m;
+	}
+      else if (component->ts.type == BT_CLASS && component->attr.class_ok
+	       && CLASS_DATA (component)->as && !component->attr.proc_pointer)
+	{
+	  tail = extend_ref (primary, tail);
+	  tail->type = REF_ARRAY;
+
+	  m = gfc_match_array_ref (&tail->u.ar, CLASS_DATA (component)->as,
+				   equiv_flag,
+				   CLASS_DATA (component)->as->corank);
+	  if (m != MATCH_YES)
+	    return m;
+	}
+
+      if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS)
+	  || gfc_match_char ('%') != MATCH_YES)
+	break;
+
+      sym = component->ts.u.derived;
+    }
+
+check_substring:
+  unknown = false;
+  if (primary->ts.type == BT_UNKNOWN && sym->attr.flavor != FL_DERIVED)
+    {
+      if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
+       {
+	 gfc_set_default_type (sym, 0, sym->ns);
+	 primary->ts = sym->ts;
+	 unknown = true;
+       }
+    }
+
+  if (primary->ts.type == BT_CHARACTER)
+    {
+      switch (match_substring (primary->ts.u.cl, equiv_flag, &substring))
+	{
+	case MATCH_YES:
+	  if (tail == NULL)
+	    primary->ref = substring;
+	  else
+	    tail->next = substring;
+
+	  if (primary->expr_type == EXPR_CONSTANT)
+	    primary->expr_type = EXPR_SUBSTRING;
+
+	  if (substring)
+	    primary->ts.u.cl = NULL;
+
+	  break;
+
+	case MATCH_NO:
+	  if (unknown)
+	    {
+	      gfc_clear_ts (&primary->ts);
+	      gfc_clear_ts (&sym->ts);
+	    }
+	  break;
+
+	case MATCH_ERROR:
+	  return MATCH_ERROR;
+	}
+    }
+
+  /* F2008, C727.  */
+  if (primary->expr_type == EXPR_PPC && gfc_is_coindexed (primary))
+    {
+      gfc_error ("Coindexed procedure-pointer component at %C");
+      return MATCH_ERROR;
+    }
+
+  return MATCH_YES;
+}
+
+
+/* Given an expression that is a variable, figure out what the
+   ultimate variable's type and attribute is, traversing the reference
+   structures if necessary.
+
+   This subroutine is trickier than it looks.  We start at the base
+   symbol and store the attribute.  Component references load a
+   completely new attribute.
+
+   A couple of rules come into play.  Subobjects of targets are always
+   targets themselves.  If we see a component that goes through a
+   pointer, then the expression must also be a target, since the
+   pointer is associated with something (if it isn't core will soon be
+   dumped).  If we see a full part or section of an array, the
+   expression is also an array.
+
+   We can have at most one full array reference.  */
+
+symbol_attribute
+gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
+{
+  int dimension, codimension, pointer, allocatable, target;
+  symbol_attribute attr;
+  gfc_ref *ref;
+  gfc_symbol *sym;
+  gfc_component *comp;
+
+  if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
+    gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
+
+  sym = expr->symtree->n.sym;
+  attr = sym->attr;
+
+  if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
+    {
+      dimension = CLASS_DATA (sym)->attr.dimension;
+      codimension = CLASS_DATA (sym)->attr.codimension;
+      pointer = CLASS_DATA (sym)->attr.class_pointer;
+      allocatable = CLASS_DATA (sym)->attr.allocatable;
+    }
+  else
+    {
+      dimension = attr.dimension;
+      codimension = attr.codimension;
+      pointer = attr.pointer;
+      allocatable = attr.allocatable;
+    }
+
+  target = attr.target;
+  if (pointer || attr.proc_pointer)
+    target = 1;
+
+  if (ts != NULL && expr->ts.type == BT_UNKNOWN)
+    *ts = sym->ts;
+
+  for (ref = expr->ref; ref; ref = ref->next)
+    switch (ref->type)
+      {
+      case REF_ARRAY:
+
+	switch (ref->u.ar.type)
+	  {
+	  case AR_FULL:
+	    dimension = 1;
+	    break;
+
+	  case AR_SECTION:
+	    allocatable = pointer = 0;
+	    dimension = 1;
+	    break;
+
+	  case AR_ELEMENT:
+	    /* Handle coarrays.  */
+	    if (ref->u.ar.dimen > 0)
+	      allocatable = pointer = 0;
+	    break;
+
+	  case AR_UNKNOWN:
+	    gfc_internal_error ("gfc_variable_attr(): Bad array reference");
+	  }
+
+	break;
+
+      case REF_COMPONENT:
+	comp = ref->u.c.component;
+	attr = comp->attr;
+	if (ts != NULL)
+	  {
+	    *ts = comp->ts;
+	    /* Don't set the string length if a substring reference
+	       follows.  */
+	    if (ts->type == BT_CHARACTER
+		&& ref->next && ref->next->type == REF_SUBSTRING)
+		ts->u.cl = NULL;
+	  }
+
+	if (comp->ts.type == BT_CLASS)
+	  {
+	    codimension = CLASS_DATA (comp)->attr.codimension;
+	    pointer = CLASS_DATA (comp)->attr.class_pointer;
+	    allocatable = CLASS_DATA (comp)->attr.allocatable;
+	  }
+	else
+	  {
+	    codimension = comp->attr.codimension;
+	    pointer = comp->attr.pointer;
+	    allocatable = comp->attr.allocatable;
+	  }
+	if (pointer || attr.proc_pointer)
+	  target = 1;
+
+	break;
+
+      case REF_SUBSTRING:
+	allocatable = pointer = 0;
+	break;
+      }
+
+  attr.dimension = dimension;
+  attr.codimension = codimension;
+  attr.pointer = pointer;
+  attr.allocatable = allocatable;
+  attr.target = target;
+  attr.save = sym->attr.save;
+
+  return attr;
+}
+
+
+/* Return the attribute from a general expression.  */
+
+symbol_attribute
+gfc_expr_attr (gfc_expr *e)
+{
+  symbol_attribute attr;
+
+  switch (e->expr_type)
+    {
+    case EXPR_VARIABLE:
+      attr = gfc_variable_attr (e, NULL);
+      break;
+
+    case EXPR_FUNCTION:
+      gfc_clear_attr (&attr);
+
+      if (e->value.function.esym && e->value.function.esym->result)
+	{
+	  gfc_symbol *sym = e->value.function.esym->result;
+	  attr = sym->attr;
+	  if (sym->ts.type == BT_CLASS)
+	    {
+	      attr.dimension = CLASS_DATA (sym)->attr.dimension;
+	      attr.pointer = CLASS_DATA (sym)->attr.class_pointer;
+	      attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
+	    }
+	}
+      else
+	attr = gfc_variable_attr (e, NULL);
+
+      /* TODO: NULL() returns pointers.  May have to take care of this
+	 here.  */
+
+      break;
+
+    default:
+      gfc_clear_attr (&attr);
+      break;
+    }
+
+  return attr;
+}
+
+
+/* Match a structure constructor.  The initial symbol has already been
+   seen.  */
+
+typedef struct gfc_structure_ctor_component
+{
+  char* name;
+  gfc_expr* val;
+  locus where;
+  struct gfc_structure_ctor_component* next;
+}
+gfc_structure_ctor_component;
+
+#define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
+
+static void
+gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
+{
+  free (comp->name);
+  gfc_free_expr (comp->val);
+  free (comp);
+}
+
+
+/* Translate the component list into the actual constructor by sorting it in
+   the order required; this also checks along the way that each and every
+   component actually has an initializer and handles default initializers
+   for components without explicit value given.  */
+static bool
+build_actual_constructor (gfc_structure_ctor_component **comp_head,
+			  gfc_constructor_base *ctor_head, gfc_symbol *sym)
+{
+  gfc_structure_ctor_component *comp_iter;
+  gfc_component *comp;
+
+  for (comp = sym->components; comp; comp = comp->next)
+    {
+      gfc_structure_ctor_component **next_ptr;
+      gfc_expr *value = NULL;
+
+      /* Try to find the initializer for the current component by name.  */
+      next_ptr = comp_head;
+      for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next)
+	{
+	  if (!strcmp (comp_iter->name, comp->name))
+	    break;
+	  next_ptr = &comp_iter->next;
+	}
+
+      /* If an extension, try building the parent derived type by building
+	 a value expression for the parent derived type and calling self.  */
+      if (!comp_iter && comp == sym->components && sym->attr.extension)
+	{
+	  value = gfc_get_structure_constructor_expr (comp->ts.type,
+						      comp->ts.kind,
+						      &gfc_current_locus);
+	  value->ts = comp->ts;
+
+	  if (!build_actual_constructor (comp_head, 
+					 &value->value.constructor, 
+					 comp->ts.u.derived))
+	    {
+	      gfc_free_expr (value);
+	      return false;
+	    }
+
+	  gfc_constructor_append_expr (ctor_head, value, NULL);
+	  continue;
+	}
+
+      /* If it was not found, try the default initializer if there's any;
+	 otherwise, it's an error unless this is a deferred parameter.  */
+      if (!comp_iter)
+	{
+	  if (comp->initializer)
+	    {
+	      if (!gfc_notify_std (GFC_STD_F2003, "Structure constructor "
+				   "with missing optional arguments at %C"))
+		return false;
+	      value = gfc_copy_expr (comp->initializer);
+	    }
+	  else if (!comp->attr.deferred_parameter)
+	    {
+	      gfc_error ("No initializer for component '%s' given in the"
+			 " structure constructor at %C!", comp->name);
+	      return false;
+	    }
+	}
+      else
+	value = comp_iter->val;
+
+      /* Add the value to the constructor chain built.  */
+      gfc_constructor_append_expr (ctor_head, value, NULL);
+
+      /* Remove the entry from the component list.  We don't want the expression
+	 value to be free'd, so set it to NULL.  */
+      if (comp_iter)
+	{
+	  *next_ptr = comp_iter->next;
+	  comp_iter->val = NULL;
+	  gfc_free_structure_ctor_component (comp_iter);
+	}
+    }
+  return true;
+}
+
+
+bool
+gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **cexpr,
+				      gfc_actual_arglist **arglist,
+				      bool parent)
+{
+  gfc_actual_arglist *actual;
+  gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
+  gfc_constructor_base ctor_head = NULL;
+  gfc_component *comp; /* Is set NULL when named component is first seen */
+  const char* last_name = NULL;
+  locus old_locus;
+  gfc_expr *expr;
+
+  expr = parent ? *cexpr : e;
+  old_locus = gfc_current_locus;
+  if (parent)
+    ; /* gfc_current_locus = *arglist->expr ? ->where;*/
+  else
+    gfc_current_locus = expr->where;
+
+  comp_tail = comp_head = NULL;
+
+  if (!parent && sym->attr.abstract)
+    {
+      gfc_error ("Can't construct ABSTRACT type '%s' at %L",
+		 sym->name, &expr->where);
+      goto cleanup;
+    }
+
+  comp = sym->components;
+  actual = parent ? *arglist : expr->value.function.actual;
+  for ( ; actual; )
+    {
+      gfc_component *this_comp = NULL;
+
+      if (!comp_head)
+	comp_tail = comp_head = gfc_get_structure_ctor_component ();
+      else
+	{
+	  comp_tail->next = gfc_get_structure_ctor_component ();
+	  comp_tail = comp_tail->next;
+       	}
+      if (actual->name)
+	{
+	  if (!gfc_notify_std (GFC_STD_F2003, "Structure"
+			       " constructor with named arguments at %C"))
+	    goto cleanup;
+
+	  comp_tail->name = xstrdup (actual->name);
+	  last_name = comp_tail->name;
+	  comp = NULL;
+	}
+      else
+	{
+	  /* Components without name are not allowed after the first named
+	     component initializer!  */
+	  if (!comp || comp->attr.deferred_parameter)
+	    {
+	      if (last_name)
+		gfc_error ("Component initializer without name after component"
+			   " named %s at %L!", last_name,
+			   actual->expr ? &actual->expr->where
+					: &gfc_current_locus);
+	      else
+		gfc_error ("Too many components in structure constructor at "
+			   "%L!", actual->expr ? &actual->expr->where
+					       : &gfc_current_locus);
+	      goto cleanup;
+	    }
+
+	  comp_tail->name = xstrdup (comp->name);
+	}
+
+      /* Find the current component in the structure definition and check
+	     its access is not private.  */
+      if (comp)
+	this_comp = gfc_find_component (sym, comp->name, false, false);
+      else
+	{
+	  this_comp = gfc_find_component (sym, (const char *)comp_tail->name,
+					  false, false);
+	  comp = NULL; /* Reset needed!  */
+	}
+
+      /* Here we can check if a component name is given which does not
+	 correspond to any component of the defined structure.  */
+      if (!this_comp)
+	goto cleanup;
+
+      comp_tail->val = actual->expr;
+      if (actual->expr != NULL)
+	comp_tail->where = actual->expr->where;
+      actual->expr = NULL;
+
+      /* Check if this component is already given a value.  */
+      for (comp_iter = comp_head; comp_iter != comp_tail; 
+	   comp_iter = comp_iter->next)
+	{
+	  gcc_assert (comp_iter);
+	  if (!strcmp (comp_iter->name, comp_tail->name))
+	    {
+	      gfc_error ("Component '%s' is initialized twice in the structure"
+			 " constructor at %L!", comp_tail->name,
+			 comp_tail->val ? &comp_tail->where
+					: &gfc_current_locus);
+	      goto cleanup;
+	    }
+	}
+
+      /* F2008, R457/C725, for PURE C1283.  */
+      if (this_comp->attr.pointer && comp_tail->val
+	  && gfc_is_coindexed (comp_tail->val))
+     	{
+       	  gfc_error ("Coindexed expression to pointer component '%s' in "
+		     "structure constructor at %L!", comp_tail->name,
+		     &comp_tail->where);
+	  goto cleanup;
+	}
+
+          /* If not explicitly a parent constructor, gather up the components
+             and build one.  */
+          if (comp && comp == sym->components
+                && sym->attr.extension
+		&& comp_tail->val
+                && (comp_tail->val->ts.type != BT_DERIVED
+                      ||
+                    comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
+            {
+              bool m;
+	      gfc_actual_arglist *arg_null = NULL;
+
+	      actual->expr = comp_tail->val;
+	      comp_tail->val = NULL;
+
+              m = gfc_convert_to_structure_constructor (NULL,
+					comp->ts.u.derived, &comp_tail->val,
+					comp->ts.u.derived->attr.zero_comp
+					  ? &arg_null : &actual, true);
+              if (!m)
+                goto cleanup;
+
+	      if (comp->ts.u.derived->attr.zero_comp)
+		{
+		  comp = comp->next;
+		  continue;
+		}
+            }
+
+      if (comp)
+	comp = comp->next;
+      if (parent && !comp)
+	break;
+
+      if (actual)
+	actual = actual->next;
+    }
+
+  if (!build_actual_constructor (&comp_head, &ctor_head, sym))
+    goto cleanup;
+
+  /* No component should be left, as this should have caused an error in the
+     loop constructing the component-list (name that does not correspond to any
+     component in the structure definition).  */
+  if (comp_head && sym->attr.extension)
+    {
+      for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
+	{
+	  gfc_error ("component '%s' at %L has already been set by a "
+		     "parent derived type constructor", comp_iter->name,
+		     &comp_iter->where);
+	}
+      goto cleanup;
+    }
+  else
+    gcc_assert (!comp_head);
+
+  if (parent)
+    {
+      expr = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &gfc_current_locus);
+      expr->ts.u.derived = sym;
+      expr->value.constructor = ctor_head;
+      *cexpr = expr;
+    }
+  else
+    {
+      expr->ts.u.derived = sym;
+      expr->ts.kind = 0;
+      expr->ts.type = BT_DERIVED;
+      expr->value.constructor = ctor_head;
+      expr->expr_type = EXPR_STRUCTURE;
+    }
+
+  gfc_current_locus = old_locus; 
+  if (parent)
+    *arglist = actual;
+  return true;
+
+  cleanup:
+  gfc_current_locus = old_locus; 
+
+  for (comp_iter = comp_head; comp_iter; )
+    {
+      gfc_structure_ctor_component *next = comp_iter->next;
+      gfc_free_structure_ctor_component (comp_iter);
+      comp_iter = next;
+    }
+  gfc_constructor_free (ctor_head);
+
+  return false;
+}
+
+
+match
+gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
+{
+  match m;
+  gfc_expr *e;
+  gfc_symtree *symtree;
+
+  gfc_get_sym_tree (sym->name, NULL, &symtree, false);   /* Can't fail */
+
+  e = gfc_get_expr ();
+  e->symtree = symtree;
+  e->expr_type = EXPR_FUNCTION;
+
+  gcc_assert (sym->attr.flavor == FL_DERIVED
+	      && symtree->n.sym->attr.flavor == FL_PROCEDURE);
+  e->value.function.esym = sym;
+  e->symtree->n.sym->attr.generic = 1;
+
+   m = gfc_match_actual_arglist (0, &e->value.function.actual);
+   if (m != MATCH_YES)
+     {
+       gfc_free_expr (e);
+       return m;
+     }
+
+   if (!gfc_convert_to_structure_constructor (e, sym, NULL, NULL, false))
+     {
+       gfc_free_expr (e);
+       return MATCH_ERROR;
+     }
+
+   *result = e;
+   return MATCH_YES;
+}
+
+
+/* If the symbol is an implicit do loop index and implicitly typed,
+   it should not be host associated.  Provide a symtree from the
+   current namespace.  */
+static match
+check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
+{
+  if ((*sym)->attr.flavor == FL_VARIABLE
+      && (*sym)->ns != gfc_current_ns
+      && (*sym)->attr.implied_index
+      && (*sym)->attr.implicit_type
+      && !(*sym)->attr.use_assoc)
+    {
+      int i;
+      i = gfc_get_sym_tree ((*sym)->name, NULL, st, false);
+      if (i)
+	return MATCH_ERROR;
+      *sym = (*st)->n.sym;
+    }
+  return MATCH_YES;
+}
+
+
+/* Procedure pointer as function result: Replace the function symbol by the
+   auto-generated hidden result variable named "ppr@".  */
+
+static bool
+replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st)
+{
+  /* Check for procedure pointer result variable.  */
+  if ((*sym)->attr.function && !(*sym)->attr.external
+      && (*sym)->result && (*sym)->result != *sym
+      && (*sym)->result->attr.proc_pointer
+      && (*sym) == gfc_current_ns->proc_name
+      && (*sym) == (*sym)->result->ns->proc_name
+      && strcmp ("ppr@", (*sym)->result->name) == 0)
+    {
+      /* Automatic replacement with "hidden" result variable.  */
+      (*sym)->result->attr.referenced = (*sym)->attr.referenced;
+      *sym = (*sym)->result;
+      *st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name);
+      return true;
+    }
+  return false;
+}
+
+
+/* Matches a variable name followed by anything that might follow it--
+   array reference, argument list of a function, etc.  */
+
+match
+gfc_match_rvalue (gfc_expr **result)
+{
+  gfc_actual_arglist *actual_arglist;
+  char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_state_data *st;
+  gfc_symbol *sym;
+  gfc_symtree *symtree;
+  locus where, old_loc;
+  gfc_expr *e;
+  match m, m2;
+  int i;
+  gfc_typespec *ts;
+  bool implicit_char;
+  gfc_ref *ref;
+
+  m = gfc_match_name (name);
+  if (m != MATCH_YES)
+    return m;
+
+  if (gfc_find_state (COMP_INTERFACE)
+      && !gfc_current_ns->has_import_set)
+    i = gfc_get_sym_tree (name, NULL, &symtree, false);
+  else
+    i = gfc_get_ha_sym_tree (name, &symtree);
+
+  if (i)
+    return MATCH_ERROR;
+
+  sym = symtree->n.sym;
+  e = NULL;
+  where = gfc_current_locus;
+
+  replace_hidden_procptr_result (&sym, &symtree);
+
+  /* If this is an implicit do loop index and implicitly typed,
+     it should not be host associated.  */
+  m = check_for_implicit_index (&symtree, &sym);
+  if (m != MATCH_YES)
+    return m;
+
+  gfc_set_sym_referenced (sym);
+  sym->attr.implied_index = 0;
+
+  if (sym->attr.function && sym->result == sym)
+    {
+      /* See if this is a directly recursive function call.  */
+      gfc_gobble_whitespace ();
+      if (sym->attr.recursive
+	  && gfc_peek_ascii_char () == '('
+	  && gfc_current_ns->proc_name == sym
+	  && !sym->attr.dimension)
+	{
+	  gfc_error ("'%s' at %C is the name of a recursive function "
+		     "and so refers to the result variable. Use an "
+		     "explicit RESULT variable for direct recursion "
+		     "(12.5.2.1)", sym->name);
+	  return MATCH_ERROR;
+	}
+
+      if (gfc_is_function_return_value (sym, gfc_current_ns))
+	goto variable;
+
+      if (sym->attr.entry
+	  && (sym->ns == gfc_current_ns
+	      || sym->ns == gfc_current_ns->parent))
+	{
+	  gfc_entry_list *el = NULL;
+	  
+	  for (el = sym->ns->entries; el; el = el->next)
+	    if (sym == el->sym)
+	      goto variable;
+	}
+    }
+
+  if (gfc_matching_procptr_assignment)
+    goto procptr0;
+
+  if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
+    goto function0;
+
+  if (sym->attr.generic)
+    goto generic_function;
+
+  switch (sym->attr.flavor)
+    {
+    case FL_VARIABLE:
+    variable:
+      e = gfc_get_expr ();
+
+      e->expr_type = EXPR_VARIABLE;
+      e->symtree = symtree;
+
+      m = gfc_match_varspec (e, 0, false, true);
+      break;
+
+    case FL_PARAMETER:
+      /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
+	 end up here.  Unfortunately, sym->value->expr_type is set to 
+	 EXPR_CONSTANT, and so the if () branch would be followed without
+	 the !sym->as check.  */
+      if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
+	e = gfc_copy_expr (sym->value);
+      else
+	{
+	  e = gfc_get_expr ();
+	  e->expr_type = EXPR_VARIABLE;
+	}
+
+      e->symtree = symtree;
+      m = gfc_match_varspec (e, 0, false, true);
+
+      if (sym->ts.is_c_interop || sym->ts.is_iso_c)
+	break;
+
+      /* Variable array references to derived type parameters cause
+	 all sorts of headaches in simplification. Treating such
+	 expressions as variable works just fine for all array
+	 references.  */
+      if (sym->value && sym->ts.type == BT_DERIVED && e->ref)
+	{
+	  for (ref = e->ref; ref; ref = ref->next)
+	    if (ref->type == REF_ARRAY)
+	      break;
+
+	  if (ref == NULL || ref->u.ar.type == AR_FULL)
+	    break;
+
+	  ref = e->ref;
+	  e->ref = NULL;
+	  gfc_free_expr (e);
+	  e = gfc_get_expr ();
+	  e->expr_type = EXPR_VARIABLE;
+	  e->symtree = symtree;
+	  e->ref = ref;
+	}
+
+      break;
+
+    case FL_DERIVED:
+      sym = gfc_use_derived (sym);
+      if (sym == NULL)
+	m = MATCH_ERROR;
+      else
+	goto generic_function;
+      break;
+
+    /* If we're here, then the name is known to be the name of a
+       procedure, yet it is not sure to be the name of a function.  */
+    case FL_PROCEDURE:
+
+    /* Procedure Pointer Assignments. */
+    procptr0:
+      if (gfc_matching_procptr_assignment)
+	{
+	  gfc_gobble_whitespace ();
+	  if (!sym->attr.dimension && gfc_peek_ascii_char () == '(')
+	    /* Parse functions returning a procptr.  */
+	    goto function0;
+
+	  e = gfc_get_expr ();
+	  e->expr_type = EXPR_VARIABLE;
+	  e->symtree = symtree;
+	  m = gfc_match_varspec (e, 0, false, true);
+	  if (!e->ref && sym->attr.flavor == FL_UNKNOWN
+	      && sym->ts.type == BT_UNKNOWN
+	      && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
+	    {
+	      m = MATCH_ERROR;
+	      break;
+	    }
+	  break;
+	}
+
+      if (sym->attr.subroutine)
+	{
+	  gfc_error ("Unexpected use of subroutine name '%s' at %C",
+		     sym->name);
+	  m = MATCH_ERROR;
+	  break;
+	}
+
+      /* At this point, the name has to be a non-statement function.
+	 If the name is the same as the current function being
+	 compiled, then we have a variable reference (to the function
+	 result) if the name is non-recursive.  */
+
+      st = gfc_enclosing_unit (NULL);
+
+      if (st != NULL && st->state == COMP_FUNCTION
+	  && st->sym == sym
+	  && !sym->attr.recursive)
+	{
+	  e = gfc_get_expr ();
+	  e->symtree = symtree;
+	  e->expr_type = EXPR_VARIABLE;
+
+	  m = gfc_match_varspec (e, 0, false, true);
+	  break;
+	}
+
+    /* Match a function reference.  */
+    function0:
+      m = gfc_match_actual_arglist (0, &actual_arglist);
+      if (m == MATCH_NO)
+	{
+	  if (sym->attr.proc == PROC_ST_FUNCTION)
+	    gfc_error ("Statement function '%s' requires argument list at %C",
+		       sym->name);
+	  else
+	    gfc_error ("Function '%s' requires an argument list at %C",
+		       sym->name);
+
+	  m = MATCH_ERROR;
+	  break;
+	}
+
+      if (m != MATCH_YES)
+	{
+	  m = MATCH_ERROR;
+	  break;
+	}
+
+      gfc_get_ha_sym_tree (name, &symtree);	/* Can't fail */
+      sym = symtree->n.sym;
+
+      replace_hidden_procptr_result (&sym, &symtree);
+
+      e = gfc_get_expr ();
+      e->symtree = symtree;
+      e->expr_type = EXPR_FUNCTION;
+      e->value.function.actual = actual_arglist;
+      e->where = gfc_current_locus;
+
+      if (sym->ts.type == BT_CLASS && sym->attr.class_ok
+	  && CLASS_DATA (sym)->as)
+	e->rank = CLASS_DATA (sym)->as->rank;
+      else if (sym->as != NULL)
+	e->rank = sym->as->rank;
+
+      if (!sym->attr.function
+	  && !gfc_add_function (&sym->attr, sym->name, NULL))
+	{
+	  m = MATCH_ERROR;
+	  break;
+	}
+
+      /* Check here for the existence of at least one argument for the
+         iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED.  The
+         argument(s) given will be checked in gfc_iso_c_func_interface,
+         during resolution of the function call.  */
+      if (sym->attr.is_iso_c == 1
+	  && (sym->from_intmod == INTMOD_ISO_C_BINDING
+	      && (sym->intmod_sym_id == ISOCBINDING_LOC
+		  || sym->intmod_sym_id == ISOCBINDING_FUNLOC
+		  || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
+        {
+          /* make sure we were given a param */
+          if (actual_arglist == NULL)
+            {
+              gfc_error ("Missing argument to '%s' at %C", sym->name);
+              m = MATCH_ERROR;
+              break;
+            }
+        }
+
+      if (sym->result == NULL)
+	sym->result = sym;
+
+      m = MATCH_YES;
+      break;
+
+    case FL_UNKNOWN:
+
+      /* Special case for derived type variables that get their types
+	 via an IMPLICIT statement.  This can't wait for the
+	 resolution phase.  */
+
+      if (gfc_peek_ascii_char () == '%'
+	  && sym->ts.type == BT_UNKNOWN
+	  && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
+	gfc_set_default_type (sym, 0, sym->ns);
+
+      /* If the symbol has a (co)dimension attribute, the expression is a
+	 variable.  */
+
+      if (sym->attr.dimension || sym->attr.codimension)
+	{
+	  if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
+	    {
+	      m = MATCH_ERROR;
+	      break;
+	    }
+
+	  e = gfc_get_expr ();
+	  e->symtree = symtree;
+	  e->expr_type = EXPR_VARIABLE;
+	  m = gfc_match_varspec (e, 0, false, true);
+	  break;
+	}
+
+      if (sym->ts.type == BT_CLASS && sym->attr.class_ok
+	  && (CLASS_DATA (sym)->attr.dimension
+	      || CLASS_DATA (sym)->attr.codimension))
+	{
+	  if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
+	    {
+	      m = MATCH_ERROR;
+	      break;
+	    }
+
+	  e = gfc_get_expr ();
+	  e->symtree = symtree;
+	  e->expr_type = EXPR_VARIABLE;
+	  m = gfc_match_varspec (e, 0, false, true);
+	  break;
+	}
+
+      /* Name is not an array, so we peek to see if a '(' implies a
+	 function call or a substring reference.  Otherwise the
+	 variable is just a scalar.  */
+
+      gfc_gobble_whitespace ();
+      if (gfc_peek_ascii_char () != '(')
+	{
+	  /* Assume a scalar variable */
+	  e = gfc_get_expr ();
+	  e->symtree = symtree;
+	  e->expr_type = EXPR_VARIABLE;
+
+	  if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
+	    {
+	      m = MATCH_ERROR;
+	      break;
+	    }
+
+	  /*FIXME:??? gfc_match_varspec does set this for us: */
+	  e->ts = sym->ts;
+	  m = gfc_match_varspec (e, 0, false, true);
+	  break;
+	}
+
+      /* See if this is a function reference with a keyword argument
+	 as first argument. We do this because otherwise a spurious
+	 symbol would end up in the symbol table.  */
+
+      old_loc = gfc_current_locus;
+      m2 = gfc_match (" ( %n =", argname);
+      gfc_current_locus = old_loc;
+
+      e = gfc_get_expr ();
+      e->symtree = symtree;
+
+      if (m2 != MATCH_YES)
+	{
+	  /* Try to figure out whether we're dealing with a character type.
+	     We're peeking ahead here, because we don't want to call 
+	     match_substring if we're dealing with an implicitly typed
+	     non-character variable.  */
+	  implicit_char = false;
+	  if (sym->ts.type == BT_UNKNOWN)
+	    {
+	      ts = gfc_get_default_type (sym->name, NULL);
+	      if (ts->type == BT_CHARACTER)
+		implicit_char = true;
+	    }
+
+	  /* See if this could possibly be a substring reference of a name
+	     that we're not sure is a variable yet.  */
+
+	  if ((implicit_char || sym->ts.type == BT_CHARACTER)
+	      && match_substring (sym->ts.u.cl, 0, &e->ref) == MATCH_YES)
+	    {
+
+	      e->expr_type = EXPR_VARIABLE;
+
+	      if (sym->attr.flavor != FL_VARIABLE
+		  && !gfc_add_flavor (&sym->attr, FL_VARIABLE, 
+				      sym->name, NULL))
+		{
+		  m = MATCH_ERROR;
+		  break;
+		}
+
+	      if (sym->ts.type == BT_UNKNOWN
+		  && !gfc_set_default_type (sym, 1, NULL))
+		{
+		  m = MATCH_ERROR;
+		  break;
+		}
+
+	      e->ts = sym->ts;
+	      if (e->ref)
+		e->ts.u.cl = NULL;
+	      m = MATCH_YES;
+	      break;
+	    }
+	}
+
+      /* Give up, assume we have a function.  */
+
+      gfc_get_sym_tree (name, NULL, &symtree, false);	/* Can't fail */
+      sym = symtree->n.sym;
+      e->expr_type = EXPR_FUNCTION;
+
+      if (!sym->attr.function
+	  && !gfc_add_function (&sym->attr, sym->name, NULL))
+	{
+	  m = MATCH_ERROR;
+	  break;
+	}
+
+      sym->result = sym;
+
+      m = gfc_match_actual_arglist (0, &e->value.function.actual);
+      if (m == MATCH_NO)
+	gfc_error ("Missing argument list in function '%s' at %C", sym->name);
+
+      if (m != MATCH_YES)
+	{
+	  m = MATCH_ERROR;
+	  break;
+	}
+
+      /* If our new function returns a character, array or structure
+	 type, it might have subsequent references.  */
+
+      m = gfc_match_varspec (e, 0, false, true);
+      if (m == MATCH_NO)
+	m = MATCH_YES;
+
+      break;
+
+    generic_function:
+      gfc_get_sym_tree (name, NULL, &symtree, false);	/* Can't fail */
+
+      e = gfc_get_expr ();
+      e->symtree = symtree;
+      e->expr_type = EXPR_FUNCTION;
+
+      if (sym->attr.flavor == FL_DERIVED)
+	{
+	  e->value.function.esym = sym;
+	  e->symtree->n.sym->attr.generic = 1;
+	}
+
+      m = gfc_match_actual_arglist (0, &e->value.function.actual);
+      break;
+
+    default:
+      gfc_error ("Symbol at %C is not appropriate for an expression");
+      return MATCH_ERROR;
+    }
+
+  if (m == MATCH_YES)
+    {
+      e->where = where;
+      *result = e;
+    }
+  else
+    gfc_free_expr (e);
+
+  return m;
+}
+
+
+/* Match a variable, i.e. something that can be assigned to.  This
+   starts as a symbol, can be a structure component or an array
+   reference.  It can be a function if the function doesn't have a
+   separate RESULT variable.  If the symbol has not been previously
+   seen, we assume it is a variable.
+
+   This function is called by two interface functions:
+   gfc_match_variable, which has host_flag = 1, and
+   gfc_match_equiv_variable, with host_flag = 0, to restrict the
+   match of the symbol to the local scope.  */
+
+static match
+match_variable (gfc_expr **result, int equiv_flag, int host_flag)
+{
+  gfc_symbol *sym;
+  gfc_symtree *st;
+  gfc_expr *expr;
+  locus where;
+  match m;
+
+  /* Since nothing has any business being an lvalue in a module
+     specification block, an interface block or a contains section,
+     we force the changed_symbols mechanism to work by setting
+     host_flag to 0. This prevents valid symbols that have the name
+     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_INTERFACE
+      || gfc_current_state () == COMP_CONTAINS)
+    host_flag = 0;
+
+  where = gfc_current_locus;
+  m = gfc_match_sym_tree (&st, host_flag);
+  if (m != MATCH_YES)
+    return m;
+
+  sym = st->n.sym;
+
+  /* If this is an implicit do loop index and implicitly typed,
+     it should not be host associated.  */
+  m = check_for_implicit_index (&st, &sym);
+  if (m != MATCH_YES)
+    return m;
+
+  sym->attr.implied_index = 0;
+
+  gfc_set_sym_referenced (sym);
+  switch (sym->attr.flavor)
+    {
+    case FL_VARIABLE:
+      /* Everything is alright.  */
+      break;
+
+    case FL_UNKNOWN:
+      {
+	sym_flavor flavor = FL_UNKNOWN;
+
+	gfc_gobble_whitespace ();
+
+	if (sym->attr.external || sym->attr.procedure
+	    || sym->attr.function || sym->attr.subroutine)
+	  flavor = FL_PROCEDURE;
+
+	/* If it is not a procedure, is not typed and is host associated,
+	   we cannot give it a flavor yet.  */
+	else if (sym->ns == gfc_current_ns->parent
+		   && sym->ts.type == BT_UNKNOWN)
+	  break;
+
+	/* These are definitive indicators that this is a variable.  */
+	else if (gfc_peek_ascii_char () != '(' || sym->ts.type != BT_UNKNOWN
+		 || sym->attr.pointer || sym->as != NULL)
+	  flavor = FL_VARIABLE;
+
+	if (flavor != FL_UNKNOWN
+	    && !gfc_add_flavor (&sym->attr, flavor, sym->name, NULL))
+	  return MATCH_ERROR;
+      }
+      break;
+
+    case FL_PARAMETER:
+      if (equiv_flag)
+	{
+	  gfc_error ("Named constant at %C in an EQUIVALENCE");
+	  return MATCH_ERROR;
+	}
+      /* Otherwise this is checked for and an error given in the
+	 variable definition context checks.  */
+      break;
+
+    case FL_PROCEDURE:
+      /* Check for a nonrecursive function result variable.  */
+      if (sym->attr.function
+	  && !sym->attr.external
+	  && sym->result == sym
+	  && (gfc_is_function_return_value (sym, gfc_current_ns)
+	      || (sym->attr.entry
+		  && sym->ns == gfc_current_ns)
+	      || (sym->attr.entry
+		  && sym->ns == gfc_current_ns->parent)))
+	{
+	  /* If a function result is a derived type, then the derived
+	     type may still have to be resolved.  */
+
+	  if (sym->ts.type == BT_DERIVED
+	      && gfc_use_derived (sym->ts.u.derived) == NULL)
+	    return MATCH_ERROR;
+	  break;
+	}
+
+      if (sym->attr.proc_pointer
+	  || replace_hidden_procptr_result (&sym, &st))
+	break;
+
+      /* Fall through to error */
+
+    default:
+      gfc_error ("'%s' at %C is not a variable", sym->name);
+      return MATCH_ERROR;
+    }
+
+  /* Special case for derived type variables that get their types
+     via an IMPLICIT statement.  This can't wait for the
+     resolution phase.  */
+
+    {
+      gfc_namespace * implicit_ns;
+
+      if (gfc_current_ns->proc_name == sym)
+	implicit_ns = gfc_current_ns;
+      else
+	implicit_ns = sym->ns;
+	
+      if (gfc_peek_ascii_char () == '%'
+	  && sym->ts.type == BT_UNKNOWN
+	  && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
+	gfc_set_default_type (sym, 0, implicit_ns);
+    }
+
+  expr = gfc_get_expr ();
+
+  expr->expr_type = EXPR_VARIABLE;
+  expr->symtree = st;
+  expr->ts = sym->ts;
+  expr->where = where;
+
+  /* Now see if we have to do more.  */
+  m = gfc_match_varspec (expr, equiv_flag, false, false);
+  if (m != MATCH_YES)
+    {
+      gfc_free_expr (expr);
+      return m;
+    }
+
+  *result = expr;
+  return MATCH_YES;
+}
+
+
+match
+gfc_match_variable (gfc_expr **result, int equiv_flag)
+{
+  return match_variable (result, equiv_flag, 1);
+}
+
+
+match
+gfc_match_equiv_variable (gfc_expr **result)
+{
+  return match_variable (result, 1, 0);
+}
+
diff --git a/gcc-4.9/gcc/fortran/resolve.c b/gcc-4.9/gcc/fortran/resolve.c
new file mode 100644
index 000000000..6e23e570b
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/resolve.c
@@ -0,0 +1,14645 @@
+/* Perform type resolution on the various structures.
+   Copyright (C) 2001-2014 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "flags.h"
+#include "gfortran.h"
+#include "obstack.h"
+#include "bitmap.h"
+#include "arith.h"  /* For gfc_compare_expr().  */
+#include "dependency.h"
+#include "data.h"
+#include "target-memory.h" /* for gfc_simplify_transfer */
+#include "constructor.h"
+
+/* Types used in equivalence statements.  */
+
+typedef enum seq_type
+{
+  SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
+}
+seq_type;
+
+/* Stack to keep track of the nesting of blocks as we move through the
+   code.  See resolve_branch() and resolve_code().  */
+
+typedef struct code_stack
+{
+  struct gfc_code *head, *current;
+  struct code_stack *prev;
+
+  /* This bitmap keeps track of the targets valid for a branch from
+     inside this block except for END {IF|SELECT}s of enclosing
+     blocks.  */
+  bitmap reachable_labels;
+}
+code_stack;
+
+static code_stack *cs_base = NULL;
+
+
+/* Nonzero if we're inside a FORALL or DO CONCURRENT block.  */
+
+static int forall_flag;
+int gfc_do_concurrent_flag;
+
+/* True when we are resolving an expression that is an actual argument to
+   a procedure.  */
+static bool actual_arg = false;
+/* True when we are resolving an expression that is the first actual argument
+   to a procedure.  */
+static bool first_actual_arg = false;
+
+
+/* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block.  */
+
+static int omp_workshare_flag;
+
+/* Nonzero if we are processing a formal arglist. The corresponding function
+   resets the flag each time that it is read.  */
+static int formal_arg_flag = 0;
+
+/* True if we are resolving a specification expression.  */
+static bool specification_expr = false;
+
+/* The id of the last entry seen.  */
+static int current_entry_id;
+
+/* We use bitmaps to determine if a branch target is valid.  */
+static bitmap_obstack labels_obstack;
+
+/* True when simplifying a EXPR_VARIABLE argument to an inquiry function.  */
+static bool inquiry_argument = false;
+
+
+int
+gfc_is_formal_arg (void)
+{
+  return formal_arg_flag;
+}
+
+/* Is the symbol host associated?  */
+static bool
+is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
+{
+  for (ns = ns->parent; ns; ns = ns->parent)
+    {
+      if (sym->ns == ns)
+	return true;
+    }
+
+  return false;
+}
+
+/* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
+   an ABSTRACT derived-type.  If where is not NULL, an error message with that
+   locus is printed, optionally using name.  */
+
+static bool
+resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
+{
+  if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
+    {
+      if (where)
+	{
+	  if (name)
+	    gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
+		       name, where, ts->u.derived->name);
+	  else
+	    gfc_error ("ABSTRACT type '%s' used at %L",
+		       ts->u.derived->name, where);
+	}
+
+      return false;
+    }
+
+  return true;
+}
+
+
+static bool
+check_proc_interface (gfc_symbol *ifc, locus *where)
+{
+  /* Several checks for F08:C1216.  */
+  if (ifc->attr.procedure)
+    {
+      gfc_error ("Interface '%s' at %L is declared "
+		 "in a later PROCEDURE statement", ifc->name, where);
+      return false;
+    }
+  if (ifc->generic)
+    {
+      /* For generic interfaces, check if there is
+	 a specific procedure with the same name.  */
+      gfc_interface *gen = ifc->generic;
+      while (gen && strcmp (gen->sym->name, ifc->name) != 0)
+	gen = gen->next;
+      if (!gen)
+	{
+	  gfc_error ("Interface '%s' at %L may not be generic",
+		     ifc->name, where);
+	  return false;
+	}
+    }
+  if (ifc->attr.proc == PROC_ST_FUNCTION)
+    {
+      gfc_error ("Interface '%s' at %L may not be a statement function",
+		 ifc->name, where);
+      return false;
+    }
+  if (gfc_is_intrinsic (ifc, 0, ifc->declared_at)
+      || gfc_is_intrinsic (ifc, 1, ifc->declared_at))
+    ifc->attr.intrinsic = 1;
+  if (ifc->attr.intrinsic && !gfc_intrinsic_actual_ok (ifc->name, 0))
+    {
+      gfc_error ("Intrinsic procedure '%s' not allowed in "
+		 "PROCEDURE statement at %L", ifc->name, where);
+      return false;
+    }
+  if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0')
+    {
+      gfc_error ("Interface '%s' at %L must be explicit", ifc->name, where);
+      return false;
+    }
+  return true;
+}
+
+
+static void resolve_symbol (gfc_symbol *sym);
+
+
+/* Resolve the interface for a PROCEDURE declaration or procedure pointer.  */
+
+static bool
+resolve_procedure_interface (gfc_symbol *sym)
+{
+  gfc_symbol *ifc = sym->ts.interface;
+
+  if (!ifc)
+    return true;
+
+  if (ifc == sym)
+    {
+      gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface",
+		 sym->name, &sym->declared_at);
+      return false;
+    }
+  if (!check_proc_interface (ifc, &sym->declared_at))
+    return false;
+
+  if (ifc->attr.if_source || ifc->attr.intrinsic)
+    {
+      /* Resolve interface and copy attributes.  */
+      resolve_symbol (ifc);
+      if (ifc->attr.intrinsic)
+	gfc_resolve_intrinsic (ifc, &ifc->declared_at);
+
+      if (ifc->result)
+	{
+	  sym->ts = ifc->result->ts;
+	  sym->result = sym;
+	}
+      else
+	sym->ts = ifc->ts;
+      sym->ts.interface = ifc;
+      sym->attr.function = ifc->attr.function;
+      sym->attr.subroutine = ifc->attr.subroutine;
+
+      sym->attr.allocatable = ifc->attr.allocatable;
+      sym->attr.pointer = ifc->attr.pointer;
+      sym->attr.pure = ifc->attr.pure;
+      sym->attr.elemental = ifc->attr.elemental;
+      sym->attr.dimension = ifc->attr.dimension;
+      sym->attr.contiguous = ifc->attr.contiguous;
+      sym->attr.recursive = ifc->attr.recursive;
+      sym->attr.always_explicit = ifc->attr.always_explicit;
+      sym->attr.ext_attr |= ifc->attr.ext_attr;
+      sym->attr.is_bind_c = ifc->attr.is_bind_c;
+      sym->attr.class_ok = ifc->attr.class_ok;
+      /* Copy array spec.  */
+      sym->as = gfc_copy_array_spec (ifc->as);
+      /* Copy char length.  */
+      if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
+	{
+	  sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
+	  if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
+	      && !gfc_resolve_expr (sym->ts.u.cl->length))
+	    return false;
+	}
+    }
+
+  return true;
+}
+
+
+/* Resolve types of formal argument lists.  These have to be done early so that
+   the formal argument lists of module procedures can be copied to the
+   containing module before the individual procedures are resolved
+   individually.  We also resolve argument lists of procedures in interface
+   blocks because they are self-contained scoping units.
+
+   Since a dummy argument cannot be a non-dummy procedure, the only
+   resort left for untyped names are the IMPLICIT types.  */
+
+static void
+resolve_formal_arglist (gfc_symbol *proc)
+{
+  gfc_formal_arglist *f;
+  gfc_symbol *sym;
+  bool saved_specification_expr;
+  int i;
+
+  if (proc->result != NULL)
+    sym = proc->result;
+  else
+    sym = proc;
+
+  if (gfc_elemental (proc)
+      || sym->attr.pointer || sym->attr.allocatable
+      || (sym->as && sym->as->rank != 0))
+    {
+      proc->attr.always_explicit = 1;
+      sym->attr.always_explicit = 1;
+    }
+
+  formal_arg_flag = 1;
+
+  for (f = proc->formal; f; f = f->next)
+    {
+      gfc_array_spec *as;
+
+      sym = f->sym;
+
+      if (sym == NULL)
+	{
+	  /* Alternate return placeholder.  */
+	  if (gfc_elemental (proc))
+	    gfc_error ("Alternate return specifier in elemental subroutine "
+		       "'%s' at %L is not allowed", proc->name,
+		       &proc->declared_at);
+	  if (proc->attr.function)
+	    gfc_error ("Alternate return specifier in function "
+		       "'%s' at %L is not allowed", proc->name,
+		       &proc->declared_at);
+	  continue;
+	}
+      else if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
+	       && !resolve_procedure_interface (sym))
+	return;
+
+      if (strcmp (proc->name, sym->name) == 0)
+        {
+          gfc_error ("Self-referential argument "
+                     "'%s' at %L is not allowed", sym->name,
+                     &proc->declared_at);
+          return;
+        }
+
+      if (sym->attr.if_source != IFSRC_UNKNOWN)
+	resolve_formal_arglist (sym);
+
+      if (sym->attr.subroutine || sym->attr.external)
+	{
+	  if (sym->attr.flavor == FL_UNKNOWN)
+	    gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, &sym->declared_at);
+	}
+      else
+	{
+	  if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
+	      && (!sym->attr.function || sym->result == sym))
+	    gfc_set_default_type (sym, 1, sym->ns);
+	}
+
+      as = sym->ts.type == BT_CLASS && sym->attr.class_ok
+	   ? CLASS_DATA (sym)->as : sym->as;
+
+      saved_specification_expr = specification_expr;
+      specification_expr = true;
+      gfc_resolve_array_spec (as, 0);
+      specification_expr = saved_specification_expr;
+
+      /* We can't tell if an array with dimension (:) is assumed or deferred
+	 shape until we know if it has the pointer or allocatable attributes.
+      */
+      if (as && as->rank > 0 && as->type == AS_DEFERRED
+	  && ((sym->ts.type != BT_CLASS
+	       && !(sym->attr.pointer || sym->attr.allocatable))
+              || (sym->ts.type == BT_CLASS
+		  && !(CLASS_DATA (sym)->attr.class_pointer
+		       || CLASS_DATA (sym)->attr.allocatable)))
+	  && sym->attr.flavor != FL_PROCEDURE)
+	{
+	  as->type = AS_ASSUMED_SHAPE;
+	  for (i = 0; i < as->rank; i++)
+	    as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+	}
+
+      if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE)
+	  || (as && as->type == AS_ASSUMED_RANK)
+	  || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
+	  || (sym->ts.type == BT_CLASS && sym->attr.class_ok
+	      && (CLASS_DATA (sym)->attr.class_pointer
+		  || CLASS_DATA (sym)->attr.allocatable
+		  || CLASS_DATA (sym)->attr.target))
+	  || sym->attr.optional)
+	{
+	  proc->attr.always_explicit = 1;
+	  if (proc->result)
+	    proc->result->attr.always_explicit = 1;
+	}
+
+      /* If the flavor is unknown at this point, it has to be a variable.
+	 A procedure specification would have already set the type.  */
+
+      if (sym->attr.flavor == FL_UNKNOWN)
+	gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
+
+      if (gfc_pure (proc))
+	{
+	  if (sym->attr.flavor == FL_PROCEDURE)
+	    {
+	      /* F08:C1279.  */
+	      if (!gfc_pure (sym))
+		{
+		  gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
+			    "also be PURE", sym->name, &sym->declared_at);
+		  continue;
+		}
+	    }
+	  else if (!sym->attr.pointer)
+	    {
+	      if (proc->attr.function && sym->attr.intent != INTENT_IN)
+		{
+		  if (sym->attr.value)
+		    gfc_notify_std (GFC_STD_F2008, "Argument '%s'"
+				    " of pure function '%s' at %L with VALUE "
+				    "attribute but without INTENT(IN)",
+				    sym->name, proc->name, &sym->declared_at);
+		  else
+		    gfc_error ("Argument '%s' of pure function '%s' at %L must "
+			       "be INTENT(IN) or VALUE", sym->name, proc->name,
+			       &sym->declared_at);
+		}
+
+	      if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
+		{
+		  if (sym->attr.value)
+		    gfc_notify_std (GFC_STD_F2008, "Argument '%s'"
+				    " of pure subroutine '%s' at %L with VALUE "
+				    "attribute but without INTENT", sym->name,
+				    proc->name, &sym->declared_at);
+		  else
+		    gfc_error ("Argument '%s' of pure subroutine '%s' at %L "
+			       "must have its INTENT specified or have the "
+			       "VALUE attribute", sym->name, proc->name,
+			       &sym->declared_at);
+		}
+	    }
+	}
+
+      if (proc->attr.implicit_pure)
+	{
+	  if (sym->attr.flavor == FL_PROCEDURE)
+	    {
+	      if (!gfc_pure (sym))
+		proc->attr.implicit_pure = 0;
+	    }
+	  else if (!sym->attr.pointer)
+	    {
+	      if (proc->attr.function && sym->attr.intent != INTENT_IN
+		  && !sym->value)
+		proc->attr.implicit_pure = 0;
+
+	      if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN
+		  && !sym->value)
+		proc->attr.implicit_pure = 0;
+	    }
+	}
+
+      if (gfc_elemental (proc))
+	{
+	  /* F08:C1289.  */
+	  if (sym->attr.codimension
+	      || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+		  && CLASS_DATA (sym)->attr.codimension))
+	    {
+	      gfc_error ("Coarray dummy argument '%s' at %L to elemental "
+			 "procedure", sym->name, &sym->declared_at);
+	      continue;
+	    }
+
+	  if (sym->as || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+			  && CLASS_DATA (sym)->as))
+	    {
+	      gfc_error ("Argument '%s' of elemental procedure at %L must "
+			 "be scalar", sym->name, &sym->declared_at);
+	      continue;
+	    }
+
+	  if (sym->attr.allocatable
+	      || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+		  && CLASS_DATA (sym)->attr.allocatable))
+	    {
+	      gfc_error ("Argument '%s' of elemental procedure at %L cannot "
+			 "have the ALLOCATABLE attribute", sym->name,
+			 &sym->declared_at);
+	      continue;
+	    }
+
+	  if (sym->attr.pointer
+	      || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+		  && CLASS_DATA (sym)->attr.class_pointer))
+	    {
+	      gfc_error ("Argument '%s' of elemental procedure at %L cannot "
+			 "have the POINTER attribute", sym->name,
+			 &sym->declared_at);
+	      continue;
+	    }
+
+	  if (sym->attr.flavor == FL_PROCEDURE)
+	    {
+	      gfc_error ("Dummy procedure '%s' not allowed in elemental "
+			 "procedure '%s' at %L", sym->name, proc->name,
+			 &sym->declared_at);
+	      continue;
+	    }
+
+	  /* Fortran 2008 Corrigendum 1, C1290a.  */
+	  if (sym->attr.intent == INTENT_UNKNOWN && !sym->attr.value)
+	    {
+	      gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
+			 "have its INTENT specified or have the VALUE "
+			 "attribute", sym->name, proc->name,
+			 &sym->declared_at);
+	      continue;
+	    }
+	}
+
+      /* Each dummy shall be specified to be scalar.  */
+      if (proc->attr.proc == PROC_ST_FUNCTION)
+	{
+	  if (sym->as != NULL)
+	    {
+	      gfc_error ("Argument '%s' of statement function at %L must "
+			 "be scalar", sym->name, &sym->declared_at);
+	      continue;
+	    }
+
+	  if (sym->ts.type == BT_CHARACTER)
+	    {
+	      gfc_charlen *cl = sym->ts.u.cl;
+	      if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
+		{
+		  gfc_error ("Character-valued argument '%s' of statement "
+			     "function at %L must have constant length",
+			     sym->name, &sym->declared_at);
+		  continue;
+		}
+	    }
+	}
+    }
+  formal_arg_flag = 0;
+}
+
+
+/* Work function called when searching for symbols that have argument lists
+   associated with them.  */
+
+static void
+find_arglists (gfc_symbol *sym)
+{
+  if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns
+      || sym->attr.flavor == FL_DERIVED || sym->attr.intrinsic)
+    return;
+
+  resolve_formal_arglist (sym);
+}
+
+
+/* Given a namespace, resolve all formal argument lists within the namespace.
+ */
+
+static void
+resolve_formal_arglists (gfc_namespace *ns)
+{
+  if (ns == NULL)
+    return;
+
+  gfc_traverse_ns (ns, find_arglists);
+}
+
+
+static void
+resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
+{
+  bool t;
+
+  /* If this namespace is not a function or an entry master function,
+     ignore it.  */
+  if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
+      || sym->attr.entry_master)
+    return;
+
+  /* Try to find out of what the return type is.  */
+  if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
+    {
+      t = gfc_set_default_type (sym->result, 0, ns);
+
+      if (!t && !sym->result->attr.untyped)
+	{
+	  if (sym->result == sym)
+	    gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
+		       sym->name, &sym->declared_at);
+	  else if (!sym->result->attr.proc_pointer)
+	    gfc_error ("Result '%s' of contained function '%s' at %L has "
+		       "no IMPLICIT type", sym->result->name, sym->name,
+		       &sym->result->declared_at);
+	  sym->result->attr.untyped = 1;
+	}
+    }
+
+  /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
+     type, lists the only ways a character length value of * can be used:
+     dummy arguments of procedures, named constants, and function results
+     in external functions.  Internal function results and results of module
+     procedures are not on this list, ergo, not permitted.  */
+
+  if (sym->result->ts.type == BT_CHARACTER)
+    {
+      gfc_charlen *cl = sym->result->ts.u.cl;
+      if ((!cl || !cl->length) && !sym->result->ts.deferred)
+	{
+	  /* See if this is a module-procedure and adapt error message
+	     accordingly.  */
+	  bool module_proc;
+	  gcc_assert (ns->parent && ns->parent->proc_name);
+	  module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
+
+	  gfc_error ("Character-valued %s '%s' at %L must not be"
+		     " assumed length",
+		     module_proc ? _("module procedure")
+				 : _("internal function"),
+		     sym->name, &sym->declared_at);
+	}
+    }
+}
+
+
+/* Add NEW_ARGS to the formal argument list of PROC, taking care not to
+   introduce duplicates.  */
+
+static void
+merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
+{
+  gfc_formal_arglist *f, *new_arglist;
+  gfc_symbol *new_sym;
+
+  for (; new_args != NULL; new_args = new_args->next)
+    {
+      new_sym = new_args->sym;
+      /* See if this arg is already in the formal argument list.  */
+      for (f = proc->formal; f; f = f->next)
+	{
+	  if (new_sym == f->sym)
+	    break;
+	}
+
+      if (f)
+	continue;
+
+      /* Add a new argument.  Argument order is not important.  */
+      new_arglist = gfc_get_formal_arglist ();
+      new_arglist->sym = new_sym;
+      new_arglist->next = proc->formal;
+      proc->formal  = new_arglist;
+    }
+}
+
+
+/* Flag the arguments that are not present in all entries.  */
+
+static void
+check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
+{
+  gfc_formal_arglist *f, *head;
+  head = new_args;
+
+  for (f = proc->formal; f; f = f->next)
+    {
+      if (f->sym == NULL)
+	continue;
+
+      for (new_args = head; new_args; new_args = new_args->next)
+	{
+	  if (new_args->sym == f->sym)
+	    break;
+	}
+
+      if (new_args)
+	continue;
+
+      f->sym->attr.not_always_present = 1;
+    }
+}
+
+
+/* Resolve alternate entry points.  If a symbol has multiple entry points we
+   create a new master symbol for the main routine, and turn the existing
+   symbol into an entry point.  */
+
+static void
+resolve_entries (gfc_namespace *ns)
+{
+  gfc_namespace *old_ns;
+  gfc_code *c;
+  gfc_symbol *proc;
+  gfc_entry_list *el;
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  static int master_count = 0;
+
+  if (ns->proc_name == NULL)
+    return;
+
+  /* No need to do anything if this procedure doesn't have alternate entry
+     points.  */
+  if (!ns->entries)
+    return;
+
+  /* We may already have resolved alternate entry points.  */
+  if (ns->proc_name->attr.entry_master)
+    return;
+
+  /* If this isn't a procedure something has gone horribly wrong.  */
+  gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
+
+  /* Remember the current namespace.  */
+  old_ns = gfc_current_ns;
+
+  gfc_current_ns = ns;
+
+  /* Add the main entry point to the list of entry points.  */
+  el = gfc_get_entry_list ();
+  el->sym = ns->proc_name;
+  el->id = 0;
+  el->next = ns->entries;
+  ns->entries = el;
+  ns->proc_name->attr.entry = 1;
+
+  /* If it is a module function, it needs to be in the right namespace
+     so that gfc_get_fake_result_decl can gather up the results. The
+     need for this arose in get_proc_name, where these beasts were
+     left in their own namespace, to keep prior references linked to
+     the entry declaration.*/
+  if (ns->proc_name->attr.function
+      && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
+    el->sym->ns = ns;
+
+  /* Do the same for entries where the master is not a module
+     procedure.  These are retained in the module namespace because
+     of the module procedure declaration.  */
+  for (el = el->next; el; el = el->next)
+    if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
+	  && el->sym->attr.mod_proc)
+      el->sym->ns = ns;
+  el = ns->entries;
+
+  /* Add an entry statement for it.  */
+  c = gfc_get_code (EXEC_ENTRY);
+  c->ext.entry = el;
+  c->next = ns->code;
+  ns->code = c;
+
+  /* Create a new symbol for the master function.  */
+  /* Give the internal function a unique name (within this file).
+     Also include the function name so the user has some hope of figuring
+     out what is going on.  */
+  snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
+	    master_count++, ns->proc_name->name);
+  gfc_get_ha_symbol (name, &proc);
+  gcc_assert (proc != NULL);
+
+  gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
+  if (ns->proc_name->attr.subroutine)
+    gfc_add_subroutine (&proc->attr, proc->name, NULL);
+  else
+    {
+      gfc_symbol *sym;
+      gfc_typespec *ts, *fts;
+      gfc_array_spec *as, *fas;
+      gfc_add_function (&proc->attr, proc->name, NULL);
+      proc->result = proc;
+      fas = ns->entries->sym->as;
+      fas = fas ? fas : ns->entries->sym->result->as;
+      fts = &ns->entries->sym->result->ts;
+      if (fts->type == BT_UNKNOWN)
+	fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
+      for (el = ns->entries->next; el; el = el->next)
+	{
+	  ts = &el->sym->result->ts;
+	  as = el->sym->as;
+	  as = as ? as : el->sym->result->as;
+	  if (ts->type == BT_UNKNOWN)
+	    ts = gfc_get_default_type (el->sym->result->name, NULL);
+
+	  if (! gfc_compare_types (ts, fts)
+	      || (el->sym->result->attr.dimension
+		  != ns->entries->sym->result->attr.dimension)
+	      || (el->sym->result->attr.pointer
+		  != ns->entries->sym->result->attr.pointer))
+	    break;
+	  else if (as && fas && ns->entries->sym->result != el->sym->result
+		      && gfc_compare_array_spec (as, fas) == 0)
+	    gfc_error ("Function %s at %L has entries with mismatched "
+		       "array specifications", ns->entries->sym->name,
+		       &ns->entries->sym->declared_at);
+	  /* The characteristics need to match and thus both need to have
+	     the same string length, i.e. both len=*, or both len=4.
+	     Having both len=<variable> is also possible, but difficult to
+	     check at compile time.  */
+	  else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
+		   && (((ts->u.cl->length && !fts->u.cl->length)
+			||(!ts->u.cl->length && fts->u.cl->length))
+		       || (ts->u.cl->length
+			   && ts->u.cl->length->expr_type
+			      != fts->u.cl->length->expr_type)
+		       || (ts->u.cl->length
+			   && ts->u.cl->length->expr_type == EXPR_CONSTANT
+		           && mpz_cmp (ts->u.cl->length->value.integer,
+				       fts->u.cl->length->value.integer) != 0)))
+	    gfc_notify_std (GFC_STD_GNU, "Function %s at %L with "
+			    "entries returning variables of different "
+			    "string lengths", ns->entries->sym->name,
+			    &ns->entries->sym->declared_at);
+	}
+
+      if (el == NULL)
+	{
+	  sym = ns->entries->sym->result;
+	  /* All result types the same.  */
+	  proc->ts = *fts;
+	  if (sym->attr.dimension)
+	    gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
+	  if (sym->attr.pointer)
+	    gfc_add_pointer (&proc->attr, NULL);
+	}
+      else
+	{
+	  /* Otherwise the result will be passed through a union by
+	     reference.  */
+	  proc->attr.mixed_entry_master = 1;
+	  for (el = ns->entries; el; el = el->next)
+	    {
+	      sym = el->sym->result;
+	      if (sym->attr.dimension)
+		{
+		  if (el == ns->entries)
+		    gfc_error ("FUNCTION result %s can't be an array in "
+			       "FUNCTION %s at %L", sym->name,
+			       ns->entries->sym->name, &sym->declared_at);
+		  else
+		    gfc_error ("ENTRY result %s can't be an array in "
+			       "FUNCTION %s at %L", sym->name,
+			       ns->entries->sym->name, &sym->declared_at);
+		}
+	      else if (sym->attr.pointer)
+		{
+		  if (el == ns->entries)
+		    gfc_error ("FUNCTION result %s can't be a POINTER in "
+			       "FUNCTION %s at %L", sym->name,
+			       ns->entries->sym->name, &sym->declared_at);
+		  else
+		    gfc_error ("ENTRY result %s can't be a POINTER in "
+			       "FUNCTION %s at %L", sym->name,
+			       ns->entries->sym->name, &sym->declared_at);
+		}
+	      else
+		{
+		  ts = &sym->ts;
+		  if (ts->type == BT_UNKNOWN)
+		    ts = gfc_get_default_type (sym->name, NULL);
+		  switch (ts->type)
+		    {
+		    case BT_INTEGER:
+		      if (ts->kind == gfc_default_integer_kind)
+			sym = NULL;
+		      break;
+		    case BT_REAL:
+		      if (ts->kind == gfc_default_real_kind
+			  || ts->kind == gfc_default_double_kind)
+			sym = NULL;
+		      break;
+		    case BT_COMPLEX:
+		      if (ts->kind == gfc_default_complex_kind)
+			sym = NULL;
+		      break;
+		    case BT_LOGICAL:
+		      if (ts->kind == gfc_default_logical_kind)
+			sym = NULL;
+		      break;
+		    case BT_UNKNOWN:
+		      /* We will issue error elsewhere.  */
+		      sym = NULL;
+		      break;
+		    default:
+		      break;
+		    }
+		  if (sym)
+		    {
+		      if (el == ns->entries)
+			gfc_error ("FUNCTION result %s can't be of type %s "
+				   "in FUNCTION %s at %L", sym->name,
+				   gfc_typename (ts), ns->entries->sym->name,
+				   &sym->declared_at);
+		      else
+			gfc_error ("ENTRY result %s can't be of type %s "
+				   "in FUNCTION %s at %L", sym->name,
+				   gfc_typename (ts), ns->entries->sym->name,
+				   &sym->declared_at);
+		    }
+		}
+	    }
+	}
+    }
+  proc->attr.access = ACCESS_PRIVATE;
+  proc->attr.entry_master = 1;
+
+  /* Merge all the entry point arguments.  */
+  for (el = ns->entries; el; el = el->next)
+    merge_argument_lists (proc, el->sym->formal);
+
+  /* Check the master formal arguments for any that are not
+     present in all entry points.  */
+  for (el = ns->entries; el; el = el->next)
+    check_argument_lists (proc, el->sym->formal);
+
+  /* Use the master function for the function body.  */
+  ns->proc_name = proc;
+
+  /* Finalize the new symbols.  */
+  gfc_commit_symbols ();
+
+  /* Restore the original namespace.  */
+  gfc_current_ns = old_ns;
+}
+
+
+/* Resolve common variables.  */
+static void
+resolve_common_vars (gfc_symbol *sym, bool named_common)
+{
+  gfc_symbol *csym = sym;
+
+  for (; csym; csym = csym->common_next)
+    {
+      if (csym->value || csym->attr.data)
+	{
+	  if (!csym->ns->is_block_data)
+	    gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
+			    "but only in BLOCK DATA initialization is "
+			    "allowed", csym->name, &csym->declared_at);
+	  else if (!named_common)
+	    gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
+			    "in a blank COMMON but initialization is only "
+			    "allowed in named common blocks", csym->name,
+			    &csym->declared_at);
+	}
+
+      if (UNLIMITED_POLY (csym))
+	gfc_error_now ("'%s' in cannot appear in COMMON at %L "
+		       "[F2008:C5100]", csym->name, &csym->declared_at);
+
+      if (csym->ts.type != BT_DERIVED)
+	continue;
+
+      if (!(csym->ts.u.derived->attr.sequence
+	    || csym->ts.u.derived->attr.is_bind_c))
+	gfc_error_now ("Derived type variable '%s' in COMMON at %L "
+		       "has neither the SEQUENCE nor the BIND(C) "
+		       "attribute", csym->name, &csym->declared_at);
+      if (csym->ts.u.derived->attr.alloc_comp)
+	gfc_error_now ("Derived type variable '%s' in COMMON at %L "
+		       "has an ultimate component that is "
+		       "allocatable", csym->name, &csym->declared_at);
+      if (gfc_has_default_initializer (csym->ts.u.derived))
+	gfc_error_now ("Derived type variable '%s' in COMMON at %L "
+		       "may not have default initializer", csym->name,
+		       &csym->declared_at);
+
+      if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
+	gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
+    }
+}
+
+/* Resolve common blocks.  */
+static void
+resolve_common_blocks (gfc_symtree *common_root)
+{
+  gfc_symbol *sym;
+  gfc_gsymbol * gsym;
+
+  if (common_root == NULL)
+    return;
+
+  if (common_root->left)
+    resolve_common_blocks (common_root->left);
+  if (common_root->right)
+    resolve_common_blocks (common_root->right);
+
+  resolve_common_vars (common_root->n.common->head, true);
+
+  /* The common name is a global name - in Fortran 2003 also if it has a
+     C binding name, since Fortran 2008 only the C binding name is a global
+     identifier.  */
+  if (!common_root->n.common->binding_label
+      || gfc_notification_std (GFC_STD_F2008))
+    {
+      gsym = gfc_find_gsymbol (gfc_gsym_root,
+			       common_root->n.common->name);
+
+      if (gsym && gfc_notification_std (GFC_STD_F2008)
+	  && gsym->type == GSYM_COMMON
+	  && ((common_root->n.common->binding_label
+	       && (!gsym->binding_label
+		   || strcmp (common_root->n.common->binding_label,
+			      gsym->binding_label) != 0))
+	      || (!common_root->n.common->binding_label
+		  && gsym->binding_label)))
+	{
+	  gfc_error ("In Fortran 2003 COMMON '%s' 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,
+		     &gsym->where,
+		     common_root->n.common->binding_label
+		     ? common_root->n.common->binding_label : "(blank)",
+		     gsym->binding_label ? gsym->binding_label : "(blank)");
+	  return;
+	}
+
+      if (gsym && gsym->type != GSYM_COMMON
+	  && !common_root->n.common->binding_label)
+	{
+	  gfc_error ("COMMON block '%s' at %L uses the same global identifier "
+		     "as entity at %L",
+		     common_root->n.common->name, &common_root->n.common->where,
+		     &gsym->where);
+	  return;
+	}
+      if (gsym && gsym->type != GSYM_COMMON)
+	{
+	  gfc_error ("Fortran 2008: COMMON block '%s' 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);
+	  return;
+	}
+      if (!gsym)
+	{
+	  gsym = gfc_get_gsymbol (common_root->n.common->name);
+	  gsym->type = GSYM_COMMON;
+	  gsym->where = common_root->n.common->where;
+	  gsym->defined = 1;
+	}
+      gsym->used = 1;
+    }
+
+  if (common_root->n.common->binding_label)
+    {
+      gsym = gfc_find_gsymbol (gfc_gsym_root,
+			       common_root->n.common->binding_label);
+      if (gsym && gsym->type != GSYM_COMMON)
+	{
+	  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);
+	  return;
+	}
+      if (!gsym)
+	{
+	  gsym = gfc_get_gsymbol (common_root->n.common->binding_label);
+	  gsym->type = GSYM_COMMON;
+	  gsym->where = common_root->n.common->where;
+	  gsym->defined = 1;
+	}
+      gsym->used = 1;
+    }
+
+  gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
+  if (sym == NULL)
+    return;
+
+  if (sym->attr.flavor == FL_PARAMETER)
+    gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
+	       sym->name, &common_root->n.common->where, &sym->declared_at);
+
+  if (sym->attr.external)
+    gfc_error ("COMMON block '%s' at %L can not have the EXTERNAL attribute",
+	       sym->name, &common_root->n.common->where);
+
+  if (sym->attr.intrinsic)
+    gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
+	       sym->name, &common_root->n.common->where);
+  else if (sym->attr.result
+	   || gfc_is_function_return_value (sym, gfc_current_ns))
+    gfc_notify_std (GFC_STD_F2003, "COMMON block '%s' at %L "
+		    "that is also a function result", sym->name,
+		    &common_root->n.common->where);
+  else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
+	   && sym->attr.proc != PROC_ST_FUNCTION)
+    gfc_notify_std (GFC_STD_F2003, "COMMON block '%s' at %L "
+		    "that is also a global procedure", sym->name,
+		    &common_root->n.common->where);
+}
+
+
+/* Resolve contained function types.  Because contained functions can call one
+   another, they have to be worked out before any of the contained procedures
+   can be resolved.
+
+   The good news is that if a function doesn't already have a type, the only
+   way it can get one is through an IMPLICIT type or a RESULT variable, because
+   by definition contained functions are contained namespace they're contained
+   in, not in a sibling or parent namespace.  */
+
+static void
+resolve_contained_functions (gfc_namespace *ns)
+{
+  gfc_namespace *child;
+  gfc_entry_list *el;
+
+  resolve_formal_arglists (ns);
+
+  for (child = ns->contained; child; child = child->sibling)
+    {
+      /* Resolve alternate entry points first.  */
+      resolve_entries (child);
+
+      /* Then check function return types.  */
+      resolve_contained_fntype (child->proc_name, child);
+      for (el = child->entries; el; el = el->next)
+	resolve_contained_fntype (el->sym, child);
+    }
+}
+
+
+static bool resolve_fl_derived0 (gfc_symbol *sym);
+
+
+/* Resolve all of the elements of a structure constructor and make sure that
+   the types are correct. The 'init' flag indicates that the given
+   constructor is an initializer.  */
+
+static bool
+resolve_structure_cons (gfc_expr *expr, int init)
+{
+  gfc_constructor *cons;
+  gfc_component *comp;
+  bool t;
+  symbol_attribute a;
+
+  t = true;
+
+  if (expr->ts.type == BT_DERIVED)
+    resolve_fl_derived0 (expr->ts.u.derived);
+
+  cons = gfc_constructor_first (expr->value.constructor);
+
+  /* A constructor may have references if it is the result of substituting a
+     parameter variable.  In this case we just pull out the component we
+     want.  */
+  if (expr->ref)
+    comp = expr->ref->u.c.sym->components;
+  else
+    comp = expr->ts.u.derived->components;
+
+  for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
+    {
+      int rank;
+
+      if (!cons->expr)
+	continue;
+
+      if (!gfc_resolve_expr (cons->expr))
+	{
+	  t = false;
+	  continue;
+	}
+
+      rank = comp->as ? comp->as->rank : 0;
+      if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
+	  && (comp->attr.allocatable || cons->expr->rank))
+	{
+	  gfc_error ("The rank of the element in the structure "
+		     "constructor at %L does not match that of the "
+		     "component (%d/%d)", &cons->expr->where,
+		     cons->expr->rank, rank);
+	  t = false;
+	}
+
+      /* If we don't have the right type, try to convert it.  */
+
+      if (!comp->attr.proc_pointer &&
+	  !gfc_compare_types (&cons->expr->ts, &comp->ts))
+	{
+	  if (strcmp (comp->name, "_extends") == 0)
+	    {
+	      /* Can afford to be brutal with the _extends initializer.
+		 The derived type can get lost because it is PRIVATE
+		 but it is not usage constrained by the standard.  */
+	      cons->expr->ts = comp->ts;
+	    }
+	  else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
+	    {
+	      gfc_error ("The element in the structure constructor at %L, "
+			 "for pointer component '%s', is %s but should be %s",
+			 &cons->expr->where, comp->name,
+			 gfc_basic_typename (cons->expr->ts.type),
+			 gfc_basic_typename (comp->ts.type));
+	      t = false;
+	    }
+	  else
+	    {
+	      bool t2 = gfc_convert_type (cons->expr, &comp->ts, 1);
+	      if (t)
+		t = t2;
+	    }
+	}
+
+      /* For strings, the length of the constructor should be the same as
+	 the one of the structure, ensure this if the lengths are known at
+ 	 compile time and when we are dealing with PARAMETER or structure
+	 constructors.  */
+      if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl
+	  && comp->ts.u.cl->length
+	  && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
+	  && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
+	  && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
+	  && cons->expr->rank != 0
+	  && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
+		      comp->ts.u.cl->length->value.integer) != 0)
+	{
+	  if (cons->expr->expr_type == EXPR_VARIABLE
+	      && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
+	    {
+	      /* Wrap the parameter in an array constructor (EXPR_ARRAY)
+		 to make use of the gfc_resolve_character_array_constructor
+		 machinery.  The expression is later simplified away to
+		 an array of string literals.  */
+	      gfc_expr *para = cons->expr;
+	      cons->expr = gfc_get_expr ();
+	      cons->expr->ts = para->ts;
+	      cons->expr->where = para->where;
+	      cons->expr->expr_type = EXPR_ARRAY;
+	      cons->expr->rank = para->rank;
+	      cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
+	      gfc_constructor_append_expr (&cons->expr->value.constructor,
+					   para, &cons->expr->where);
+	    }
+	  if (cons->expr->expr_type == EXPR_ARRAY)
+	    {
+	      gfc_constructor *p;
+	      p = gfc_constructor_first (cons->expr->value.constructor);
+	      if (cons->expr->ts.u.cl != p->expr->ts.u.cl)
+		{
+		  gfc_charlen *cl, *cl2;
+
+		  cl2 = NULL;
+		  for (cl = gfc_current_ns->cl_list; cl; cl = cl->next)
+		    {
+		      if (cl == cons->expr->ts.u.cl)
+			break;
+		      cl2 = cl;
+		    }
+
+		  gcc_assert (cl);
+
+		  if (cl2)
+		    cl2->next = cl->next;
+
+		  gfc_free_expr (cl->length);
+		  free (cl);
+		}
+
+	      cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+	      cons->expr->ts.u.cl->length_from_typespec = true;
+	      cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
+	      gfc_resolve_character_array_constructor (cons->expr);
+	    }
+	}
+
+      if (cons->expr->expr_type == EXPR_NULL
+	  && !(comp->attr.pointer || comp->attr.allocatable
+	       || comp->attr.proc_pointer || comp->ts.f90_type == BT_VOID
+	       || (comp->ts.type == BT_CLASS
+		   && (CLASS_DATA (comp)->attr.class_pointer
+		       || CLASS_DATA (comp)->attr.allocatable))))
+	{
+	  t = false;
+	  gfc_error ("The NULL in the structure constructor at %L is "
+		     "being applied to component '%s', which is neither "
+		     "a POINTER nor ALLOCATABLE", &cons->expr->where,
+		     comp->name);
+	}
+
+      if (comp->attr.proc_pointer && comp->ts.interface)
+	{
+	  /* Check procedure pointer interface.  */
+	  gfc_symbol *s2 = NULL;
+	  gfc_component *c2;
+	  const char *name;
+	  char err[200];
+
+	  c2 = gfc_get_proc_ptr_comp (cons->expr);
+	  if (c2)
+	    {
+	      s2 = c2->ts.interface;
+	      name = c2->name;
+	    }
+	  else if (cons->expr->expr_type == EXPR_FUNCTION)
+	    {
+	      s2 = cons->expr->symtree->n.sym->result;
+	      name = cons->expr->symtree->n.sym->result->name;
+	    }
+	  else if (cons->expr->expr_type != EXPR_NULL)
+	    {
+	      s2 = cons->expr->symtree->n.sym;
+	      name = cons->expr->symtree->n.sym->name;
+	    }
+
+	  if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
+					     err, sizeof (err), NULL, NULL))
+	    {
+	      gfc_error ("Interface mismatch for procedure-pointer component "
+			 "'%s' in structure constructor at %L: %s",
+			 comp->name, &cons->expr->where, err);
+	      return false;
+	    }
+	}
+
+      if (!comp->attr.pointer || comp->attr.proc_pointer
+	  || cons->expr->expr_type == EXPR_NULL)
+	continue;
+
+      a = gfc_expr_attr (cons->expr);
+
+      if (!a.pointer && !a.target)
+	{
+	  t = false;
+	  gfc_error ("The element in the structure constructor at %L, "
+		     "for pointer component '%s' should be a POINTER or "
+		     "a TARGET", &cons->expr->where, comp->name);
+	}
+
+      if (init)
+	{
+	  /* F08:C461. Additional checks for pointer initialization.  */
+	  if (a.allocatable)
+	    {
+	      t = false;
+	      gfc_error ("Pointer initialization target at %L "
+			 "must not be ALLOCATABLE ", &cons->expr->where);
+	    }
+	  if (!a.save)
+	    {
+	      t = false;
+	      gfc_error ("Pointer initialization target at %L "
+			 "must have the SAVE attribute", &cons->expr->where);
+	    }
+	}
+
+      /* F2003, C1272 (3).  */
+      bool impure = cons->expr->expr_type == EXPR_VARIABLE
+		    && (gfc_impure_variable (cons->expr->symtree->n.sym)
+			|| gfc_is_coindexed (cons->expr));
+      if (impure && gfc_pure (NULL))
+	{
+	  t = false;
+	  gfc_error ("Invalid expression in the structure constructor for "
+		     "pointer component '%s' at %L in PURE procedure",
+		     comp->name, &cons->expr->where);
+	}
+
+      if (impure)
+	gfc_unset_implicit_pure (NULL);
+    }
+
+  return t;
+}
+
+
+/****************** Expression name resolution ******************/
+
+/* Returns 0 if a symbol was not declared with a type or
+   attribute declaration statement, nonzero otherwise.  */
+
+static int
+was_declared (gfc_symbol *sym)
+{
+  symbol_attribute a;
+
+  a = sym->attr;
+
+  if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
+    return 1;
+
+  if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
+      || a.optional || a.pointer || a.save || a.target || a.volatile_
+      || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
+      || a.asynchronous || a.codimension)
+    return 1;
+
+  return 0;
+}
+
+
+/* Determine if a symbol is generic or not.  */
+
+static int
+generic_sym (gfc_symbol *sym)
+{
+  gfc_symbol *s;
+
+  if (sym->attr.generic ||
+      (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
+    return 1;
+
+  if (was_declared (sym) || sym->ns->parent == NULL)
+    return 0;
+
+  gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
+
+  if (s != NULL)
+    {
+      if (s == sym)
+	return 0;
+      else
+	return generic_sym (s);
+    }
+
+  return 0;
+}
+
+
+/* Determine if a symbol is specific or not.  */
+
+static int
+specific_sym (gfc_symbol *sym)
+{
+  gfc_symbol *s;
+
+  if (sym->attr.if_source == IFSRC_IFBODY
+      || sym->attr.proc == PROC_MODULE
+      || sym->attr.proc == PROC_INTERNAL
+      || sym->attr.proc == PROC_ST_FUNCTION
+      || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
+      || sym->attr.external)
+    return 1;
+
+  if (was_declared (sym) || sym->ns->parent == NULL)
+    return 0;
+
+  gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
+
+  return (s == NULL) ? 0 : specific_sym (s);
+}
+
+
+/* Figure out if the procedure is specific, generic or unknown.  */
+
+typedef enum
+{ PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
+proc_type;
+
+static proc_type
+procedure_kind (gfc_symbol *sym)
+{
+  if (generic_sym (sym))
+    return PTYPE_GENERIC;
+
+  if (specific_sym (sym))
+    return PTYPE_SPECIFIC;
+
+  return PTYPE_UNKNOWN;
+}
+
+/* Check references to assumed size arrays.  The flag need_full_assumed_size
+   is nonzero when matching actual arguments.  */
+
+static int need_full_assumed_size = 0;
+
+static bool
+check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
+{
+  if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
+      return false;
+
+  /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
+     What should it be?  */
+  if (e->ref && (e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
+	  && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
+	       && (e->ref->u.ar.type == AR_FULL))
+    {
+      gfc_error ("The upper bound in the last dimension must "
+		 "appear in the reference to the assumed size "
+		 "array '%s' at %L", sym->name, &e->where);
+      return true;
+    }
+  return false;
+}
+
+
+/* Look for bad assumed size array references in argument expressions
+  of elemental and array valued intrinsic procedures.  Since this is
+  called from procedure resolution functions, it only recurses at
+  operators.  */
+
+static bool
+resolve_assumed_size_actual (gfc_expr *e)
+{
+  if (e == NULL)
+   return false;
+
+  switch (e->expr_type)
+    {
+    case EXPR_VARIABLE:
+      if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
+	return true;
+      break;
+
+    case EXPR_OP:
+      if (resolve_assumed_size_actual (e->value.op.op1)
+	  || resolve_assumed_size_actual (e->value.op.op2))
+	return true;
+      break;
+
+    default:
+      break;
+    }
+  return false;
+}
+
+
+/* Check a generic procedure, passed as an actual argument, to see if
+   there is a matching specific name.  If none, it is an error, and if
+   more than one, the reference is ambiguous.  */
+static int
+count_specific_procs (gfc_expr *e)
+{
+  int n;
+  gfc_interface *p;
+  gfc_symbol *sym;
+
+  n = 0;
+  sym = e->symtree->n.sym;
+
+  for (p = sym->generic; p; p = p->next)
+    if (strcmp (sym->name, p->sym->name) == 0)
+      {
+	e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
+				       sym->name);
+	n++;
+      }
+
+  if (n > 1)
+    gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
+	       &e->where);
+
+  if (n == 0)
+    gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
+	       "argument at %L", sym->name, &e->where);
+
+  return n;
+}
+
+
+/* See if a call to sym could possibly be a not allowed RECURSION because of
+   a missing RECURSIVE declaration.  This means that either sym is the current
+   context itself, or sym is the parent of a contained procedure calling its
+   non-RECURSIVE containing procedure.
+   This also works if sym is an ENTRY.  */
+
+static bool
+is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
+{
+  gfc_symbol* proc_sym;
+  gfc_symbol* context_proc;
+  gfc_namespace* real_context;
+
+  if (sym->attr.flavor == FL_PROGRAM
+      || sym->attr.flavor == FL_DERIVED)
+    return false;
+
+  gcc_assert (sym->attr.flavor == FL_PROCEDURE);
+
+  /* If we've got an ENTRY, find real procedure.  */
+  if (sym->attr.entry && sym->ns->entries)
+    proc_sym = sym->ns->entries->sym;
+  else
+    proc_sym = sym;
+
+  /* If sym is RECURSIVE, all is well of course.  */
+  if (proc_sym->attr.recursive || gfc_option.flag_recursive)
+    return false;
+
+  /* Find the context procedure's "real" symbol if it has entries.
+     We look for a procedure symbol, so recurse on the parents if we don't
+     find one (like in case of a BLOCK construct).  */
+  for (real_context = context; ; real_context = real_context->parent)
+    {
+      /* We should find something, eventually!  */
+      gcc_assert (real_context);
+
+      context_proc = (real_context->entries ? real_context->entries->sym
+					    : real_context->proc_name);
+
+      /* In some special cases, there may not be a proc_name, like for this
+	 invalid code:
+	 real(bad_kind()) function foo () ...
+	 when checking the call to bad_kind ().
+	 In these cases, we simply return here and assume that the
+	 call is ok.  */
+      if (!context_proc)
+	return false;
+
+      if (context_proc->attr.flavor != FL_LABEL)
+	break;
+    }
+
+  /* A call from sym's body to itself is recursion, of course.  */
+  if (context_proc == proc_sym)
+    return true;
+
+  /* The same is true if context is a contained procedure and sym the
+     containing one.  */
+  if (context_proc->attr.contained)
+    {
+      gfc_symbol* parent_proc;
+
+      gcc_assert (context->parent);
+      parent_proc = (context->parent->entries ? context->parent->entries->sym
+					      : context->parent->proc_name);
+
+      if (parent_proc == proc_sym)
+	return true;
+    }
+
+  return false;
+}
+
+
+/* Resolve an intrinsic procedure: Set its function/subroutine attribute,
+   its typespec and formal argument list.  */
+
+bool
+gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
+{
+  gfc_intrinsic_sym* isym = NULL;
+  const char* symstd;
+
+  if (sym->formal)
+    return true;
+
+  /* Already resolved.  */
+  if (sym->from_intmod && sym->ts.type != BT_UNKNOWN)
+    return true;
+
+  /* We already know this one is an intrinsic, so we don't call
+     gfc_is_intrinsic for full checking but rather use gfc_find_function and
+     gfc_find_subroutine directly to check whether it is a function or
+     subroutine.  */
+
+  if (sym->intmod_sym_id && sym->attr.subroutine)
+    {
+      gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
+      isym = gfc_intrinsic_subroutine_by_id (id);
+    }
+  else if (sym->intmod_sym_id)
+    {
+      gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
+      isym = gfc_intrinsic_function_by_id (id);
+    }
+  else if (!sym->attr.subroutine)
+    isym = gfc_find_function (sym->name);
+
+  if (isym && !sym->attr.subroutine)
+    {
+      if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
+	  && !sym->attr.implicit_type)
+	gfc_warning ("Type specified for intrinsic function '%s' at %L is"
+		      " ignored", sym->name, &sym->declared_at);
+
+      if (!sym->attr.function &&
+	  !gfc_add_function(&sym->attr, sym->name, loc))
+	return false;
+
+      sym->ts = isym->ts;
+    }
+  else if (isym || (isym = gfc_find_subroutine (sym->name)))
+    {
+      if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
+	{
+	  gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
+		      " specifier", sym->name, &sym->declared_at);
+	  return false;
+	}
+
+      if (!sym->attr.subroutine &&
+	  !gfc_add_subroutine(&sym->attr, sym->name, loc))
+	return false;
+    }
+  else
+    {
+      gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name,
+		 &sym->declared_at);
+      return false;
+    }
+
+  gfc_copy_formal_args_intr (sym, isym);
+
+  sym->attr.pure = isym->pure;
+  sym->attr.elemental = isym->elemental;
+
+  /* Check it is actually available in the standard settings.  */
+  if (!gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at))
+    {
+      gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
+		 " available in the current standard settings but %s.  Use"
+		 " an appropriate -std=* option or enable -fall-intrinsics"
+		 " in order to use it.",
+		 sym->name, &sym->declared_at, symstd);
+      return false;
+    }
+
+  return true;
+}
+
+
+/* Resolve a procedure expression, like passing it to a called procedure or as
+   RHS for a procedure pointer assignment.  */
+
+static bool
+resolve_procedure_expression (gfc_expr* expr)
+{
+  gfc_symbol* sym;
+
+  if (expr->expr_type != EXPR_VARIABLE)
+    return true;
+  gcc_assert (expr->symtree);
+
+  sym = expr->symtree->n.sym;
+
+  if (sym->attr.intrinsic)
+    gfc_resolve_intrinsic (sym, &expr->where);
+
+  if (sym->attr.flavor != FL_PROCEDURE
+      || (sym->attr.function && sym->result == sym))
+    return true;
+
+  /* A non-RECURSIVE procedure that is used as procedure expression within its
+     own body is in danger of being called recursively.  */
+  if (is_illegal_recursion (sym, gfc_current_ns))
+    gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
+		 " itself recursively.  Declare it RECURSIVE or use"
+		 " -frecursive", sym->name, &expr->where);
+
+  return true;
+}
+
+
+/* Resolve an actual argument list.  Most of the time, this is just
+   resolving the expressions in the list.
+   The exception is that we sometimes have to decide whether arguments
+   that look like procedure arguments are really simple variable
+   references.  */
+
+static bool
+resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
+			bool no_formal_args)
+{
+  gfc_symbol *sym;
+  gfc_symtree *parent_st;
+  gfc_expr *e;
+  int save_need_full_assumed_size;
+  bool return_value = false;
+  bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg;
+
+  actual_arg = true;
+  first_actual_arg = true;
+
+  for (; arg; arg = arg->next)
+    {
+      e = arg->expr;
+      if (e == NULL)
+	{
+	  /* Check the label is a valid branching target.  */
+	  if (arg->label)
+	    {
+	      if (arg->label->defined == ST_LABEL_UNKNOWN)
+		{
+		  gfc_error ("Label %d referenced at %L is never defined",
+			     arg->label->value, &arg->label->where);
+		  goto cleanup;
+		}
+	    }
+	  first_actual_arg = false;
+	  continue;
+	}
+
+      if (e->expr_type == EXPR_VARIABLE
+	    && e->symtree->n.sym->attr.generic
+	    && no_formal_args
+	    && count_specific_procs (e) != 1)
+	goto cleanup;
+
+      if (e->ts.type != BT_PROCEDURE)
+	{
+	  save_need_full_assumed_size = need_full_assumed_size;
+	  if (e->expr_type != EXPR_VARIABLE)
+	    need_full_assumed_size = 0;
+	  if (!gfc_resolve_expr (e))
+	    goto cleanup;
+	  need_full_assumed_size = save_need_full_assumed_size;
+	  goto argument_list;
+	}
+
+      /* See if the expression node should really be a variable reference.  */
+
+      sym = e->symtree->n.sym;
+
+      if (sym->attr.flavor == FL_PROCEDURE
+	  || sym->attr.intrinsic
+	  || sym->attr.external)
+	{
+	  int actual_ok;
+
+	  /* If a procedure is not already determined to be something else
+	     check if it is intrinsic.  */
+	  if (gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
+	    sym->attr.intrinsic = 1;
+
+	  if (sym->attr.proc == PROC_ST_FUNCTION)
+	    {
+	      gfc_error ("Statement function '%s' at %L is not allowed as an "
+			 "actual argument", sym->name, &e->where);
+	    }
+
+	  actual_ok = gfc_intrinsic_actual_ok (sym->name,
+					       sym->attr.subroutine);
+	  if (sym->attr.intrinsic && actual_ok == 0)
+	    {
+	      gfc_error ("Intrinsic '%s' at %L is not allowed as an "
+			 "actual argument", sym->name, &e->where);
+	    }
+
+	  if (sym->attr.contained && !sym->attr.use_assoc
+	      && sym->ns->proc_name->attr.flavor != FL_MODULE)
+	    {
+	      if (!gfc_notify_std (GFC_STD_F2008, "Internal procedure '%s' is"
+				   " used as actual argument at %L", 
+				   sym->name, &e->where))
+		goto cleanup;
+	    }
+
+	  if (sym->attr.elemental && !sym->attr.intrinsic)
+	    {
+	      gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
+			 "allowed as an actual argument at %L", sym->name,
+			 &e->where);
+	    }
+
+	  /* Check if a generic interface has a specific procedure
+	    with the same name before emitting an error.  */
+	  if (sym->attr.generic && count_specific_procs (e) != 1)
+	    goto cleanup;
+
+	  /* Just in case a specific was found for the expression.  */
+	  sym = e->symtree->n.sym;
+
+	  /* If the symbol is the function that names the current (or
+	     parent) scope, then we really have a variable reference.  */
+
+	  if (gfc_is_function_return_value (sym, sym->ns))
+	    goto got_variable;
+
+	  /* If all else fails, see if we have a specific intrinsic.  */
+	  if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
+	    {
+	      gfc_intrinsic_sym *isym;
+
+	      isym = gfc_find_function (sym->name);
+	      if (isym == NULL || !isym->specific)
+		{
+		  gfc_error ("Unable to find a specific INTRINSIC procedure "
+			     "for the reference '%s' at %L", sym->name,
+			     &e->where);
+		  goto cleanup;
+		}
+	      sym->ts = isym->ts;
+	      sym->attr.intrinsic = 1;
+	      sym->attr.function = 1;
+	    }
+
+	  if (!gfc_resolve_expr (e))
+	    goto cleanup;
+	  goto argument_list;
+	}
+
+      /* See if the name is a module procedure in a parent unit.  */
+
+      if (was_declared (sym) || sym->ns->parent == NULL)
+	goto got_variable;
+
+      if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
+	{
+	  gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
+	  goto cleanup;
+	}
+
+      if (parent_st == NULL)
+	goto got_variable;
+
+      sym = parent_st->n.sym;
+      e->symtree = parent_st;		/* Point to the right thing.  */
+
+      if (sym->attr.flavor == FL_PROCEDURE
+	  || sym->attr.intrinsic
+	  || sym->attr.external)
+	{
+	  if (!gfc_resolve_expr (e))
+	    goto cleanup;
+	  goto argument_list;
+	}
+
+    got_variable:
+      e->expr_type = EXPR_VARIABLE;
+      e->ts = sym->ts;
+      if ((sym->as != NULL && sym->ts.type != BT_CLASS)
+	  || (sym->ts.type == BT_CLASS && sym->attr.class_ok
+	      && CLASS_DATA (sym)->as))
+	{
+	  e->rank = sym->ts.type == BT_CLASS
+		    ? CLASS_DATA (sym)->as->rank : sym->as->rank;
+	  e->ref = gfc_get_ref ();
+	  e->ref->type = REF_ARRAY;
+	  e->ref->u.ar.type = AR_FULL;
+	  e->ref->u.ar.as = sym->ts.type == BT_CLASS
+			    ? CLASS_DATA (sym)->as : sym->as;
+	}
+
+      /* Expressions are assigned a default ts.type of BT_PROCEDURE in
+	 primary.c (match_actual_arg). If above code determines that it
+	 is a  variable instead, it needs to be resolved as it was not
+	 done at the beginning of this function.  */
+      save_need_full_assumed_size = need_full_assumed_size;
+      if (e->expr_type != EXPR_VARIABLE)
+	need_full_assumed_size = 0;
+      if (!gfc_resolve_expr (e))
+	goto cleanup;
+      need_full_assumed_size = save_need_full_assumed_size;
+
+    argument_list:
+      /* Check argument list functions %VAL, %LOC and %REF.  There is
+	 nothing to do for %REF.  */
+      if (arg->name && arg->name[0] == '%')
+	{
+	  if (strncmp ("%VAL", arg->name, 4) == 0)
+	    {
+	      if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
+		{
+		  gfc_error ("By-value argument at %L is not of numeric "
+			     "type", &e->where);
+		  goto cleanup;
+		}
+
+	      if (e->rank)
+		{
+		  gfc_error ("By-value argument at %L cannot be an array or "
+			     "an array section", &e->where);
+		  goto cleanup;
+		}
+
+	      /* Intrinsics are still PROC_UNKNOWN here.  However,
+		 since same file external procedures are not resolvable
+		 in gfortran, it is a good deal easier to leave them to
+		 intrinsic.c.  */
+	      if (ptype != PROC_UNKNOWN
+		  && ptype != PROC_DUMMY
+		  && ptype != PROC_EXTERNAL
+		  && ptype != PROC_MODULE)
+		{
+		  gfc_error ("By-value argument at %L is not allowed "
+			     "in this context", &e->where);
+		  goto cleanup;
+		}
+	    }
+
+	  /* Statement functions have already been excluded above.  */
+	  else if (strncmp ("%LOC", arg->name, 4) == 0
+		   && e->ts.type == BT_PROCEDURE)
+	    {
+	      if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
+		{
+		  gfc_error ("Passing internal procedure at %L by location "
+			     "not allowed", &e->where);
+		  goto cleanup;
+		}
+	    }
+	}
+
+      /* Fortran 2008, C1237.  */
+      if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
+	  && gfc_has_ultimate_pointer (e))
+	{
+	  gfc_error ("Coindexed actual argument at %L with ultimate pointer "
+		     "component", &e->where);
+	  goto cleanup;
+	}
+
+      first_actual_arg = false;
+    }
+
+  return_value = true;
+
+cleanup:
+  actual_arg = actual_arg_sav;
+  first_actual_arg = first_actual_arg_sav;
+
+  return return_value;
+}
+
+
+/* Do the checks of the actual argument list that are specific to elemental
+   procedures.  If called with c == NULL, we have a function, otherwise if
+   expr == NULL, we have a subroutine.  */
+
+static bool
+resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
+{
+  gfc_actual_arglist *arg0;
+  gfc_actual_arglist *arg;
+  gfc_symbol *esym = NULL;
+  gfc_intrinsic_sym *isym = NULL;
+  gfc_expr *e = NULL;
+  gfc_intrinsic_arg *iformal = NULL;
+  gfc_formal_arglist *eformal = NULL;
+  bool formal_optional = false;
+  bool set_by_optional = false;
+  int i;
+  int rank = 0;
+
+  /* Is this an elemental procedure?  */
+  if (expr && expr->value.function.actual != NULL)
+    {
+      if (expr->value.function.esym != NULL
+	  && expr->value.function.esym->attr.elemental)
+	{
+	  arg0 = expr->value.function.actual;
+	  esym = expr->value.function.esym;
+	}
+      else if (expr->value.function.isym != NULL
+	       && expr->value.function.isym->elemental)
+	{
+	  arg0 = expr->value.function.actual;
+	  isym = expr->value.function.isym;
+	}
+      else
+	return true;
+    }
+  else if (c && c->ext.actual != NULL)
+    {
+      arg0 = c->ext.actual;
+
+      if (c->resolved_sym)
+	esym = c->resolved_sym;
+      else
+	esym = c->symtree->n.sym;
+      gcc_assert (esym);
+
+      if (!esym->attr.elemental)
+	return true;
+    }
+  else
+    return true;
+
+  /* The rank of an elemental is the rank of its array argument(s).  */
+  for (arg = arg0; arg; arg = arg->next)
+    {
+      if (arg->expr != NULL && arg->expr->rank != 0)
+	{
+	  rank = arg->expr->rank;
+	  if (arg->expr->expr_type == EXPR_VARIABLE
+	      && arg->expr->symtree->n.sym->attr.optional)
+	    set_by_optional = true;
+
+	  /* Function specific; set the result rank and shape.  */
+	  if (expr)
+	    {
+	      expr->rank = rank;
+	      if (!expr->shape && arg->expr->shape)
+		{
+		  expr->shape = gfc_get_shape (rank);
+		  for (i = 0; i < rank; i++)
+		    mpz_init_set (expr->shape[i], arg->expr->shape[i]);
+		}
+	    }
+	  break;
+	}
+    }
+
+  /* If it is an array, it shall not be supplied as an actual argument
+     to an elemental procedure unless an array of the same rank is supplied
+     as an actual argument corresponding to a nonoptional dummy argument of
+     that elemental procedure(12.4.1.5).  */
+  formal_optional = false;
+  if (isym)
+    iformal = isym->formal;
+  else
+    eformal = esym->formal;
+
+  for (arg = arg0; arg; arg = arg->next)
+    {
+      if (eformal)
+	{
+	  if (eformal->sym && eformal->sym->attr.optional)
+	    formal_optional = true;
+	  eformal = eformal->next;
+	}
+      else if (isym && iformal)
+	{
+	  if (iformal->optional)
+	    formal_optional = true;
+	  iformal = iformal->next;
+	}
+      else if (isym)
+	formal_optional = true;
+
+      if (pedantic && arg->expr != NULL
+	  && arg->expr->expr_type == EXPR_VARIABLE
+	  && arg->expr->symtree->n.sym->attr.optional
+	  && formal_optional
+	  && arg->expr->rank
+	  && (set_by_optional || arg->expr->rank != rank)
+	  && !(isym && isym->id == GFC_ISYM_CONVERSION))
+	{
+	  gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
+		       "MISSING, it cannot be the actual argument of an "
+		       "ELEMENTAL procedure unless there is a non-optional "
+		       "argument with the same rank (12.4.1.5)",
+		       arg->expr->symtree->n.sym->name, &arg->expr->where);
+	}
+    }
+
+  for (arg = arg0; arg; arg = arg->next)
+    {
+      if (arg->expr == NULL || arg->expr->rank == 0)
+	continue;
+
+      /* Being elemental, the last upper bound of an assumed size array
+	 argument must be present.  */
+      if (resolve_assumed_size_actual (arg->expr))
+	return false;
+
+      /* Elemental procedure's array actual arguments must conform.  */
+      if (e != NULL)
+	{
+	  if (!gfc_check_conformance (arg->expr, e, "elemental procedure"))
+	    return false;
+	}
+      else
+	e = arg->expr;
+    }
+
+  /* INTENT(OUT) is only allowed for subroutines; if any actual argument
+     is an array, the intent inout/out variable needs to be also an array.  */
+  if (rank > 0 && esym && expr == NULL)
+    for (eformal = esym->formal, arg = arg0; arg && eformal;
+	 arg = arg->next, eformal = eformal->next)
+      if ((eformal->sym->attr.intent == INTENT_OUT
+	   || eformal->sym->attr.intent == INTENT_INOUT)
+	  && arg->expr && arg->expr->rank == 0)
+	{
+	  gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
+		     "ELEMENTAL subroutine '%s' is a scalar, but another "
+		     "actual argument is an array", &arg->expr->where,
+		     (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
+		     : "INOUT", eformal->sym->name, esym->name);
+	  return false;
+	}
+  return true;
+}
+
+
+/* This function does the checking of references to global procedures
+   as defined in sections 18.1 and 14.1, respectively, of the Fortran
+   77 and 95 standards.  It checks for a gsymbol for the name, making
+   one if it does not already exist.  If it already exists, then the
+   reference being resolved must correspond to the type of gsymbol.
+   Otherwise, the new symbol is equipped with the attributes of the
+   reference.  The corresponding code that is called in creating
+   global entities is parse.c.
+
+   In addition, for all but -std=legacy, the gsymbols are used to
+   check the interfaces of external procedures from the same file.
+   The namespace of the gsymbol is resolved and then, once this is
+   done the interface is checked.  */
+
+
+static bool
+not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
+{
+  if (!gsym_ns->proc_name->attr.recursive)
+    return true;
+
+  if (sym->ns == gsym_ns)
+    return false;
+
+  if (sym->ns->parent && sym->ns->parent == gsym_ns)
+    return false;
+
+  return true;
+}
+
+static bool
+not_entry_self_reference  (gfc_symbol *sym, gfc_namespace *gsym_ns)
+{
+  if (gsym_ns->entries)
+    {
+      gfc_entry_list *entry = gsym_ns->entries;
+
+      for (; entry; entry = entry->next)
+	{
+	  if (strcmp (sym->name, entry->sym->name) == 0)
+	    {
+	      if (strcmp (gsym_ns->proc_name->name,
+			  sym->ns->proc_name->name) == 0)
+		return false;
+
+	      if (sym->ns->parent
+		  && strcmp (gsym_ns->proc_name->name,
+			     sym->ns->parent->proc_name->name) == 0)
+		return false;
+	    }
+	}
+    }
+  return true;
+}
+
+
+/* Check for the requirement of an explicit interface. F08:12.4.2.2.  */
+
+bool
+gfc_explicit_interface_required (gfc_symbol *sym, char *errmsg, int err_len)
+{
+  gfc_formal_arglist *arg = gfc_sym_get_dummy_args (sym);
+
+  for ( ; arg; arg = arg->next)
+    {
+      if (!arg->sym)
+	continue;
+
+      if (arg->sym->attr.allocatable)  /* (2a)  */
+	{
+	  strncpy (errmsg, _("allocatable argument"), err_len);
+	  return true;
+	}
+      else if (arg->sym->attr.asynchronous)
+	{
+	  strncpy (errmsg, _("asynchronous argument"), err_len);
+	  return true;
+	}
+      else if (arg->sym->attr.optional)
+	{
+	  strncpy (errmsg, _("optional argument"), err_len);
+	  return true;
+	}
+      else if (arg->sym->attr.pointer)
+	{
+	  strncpy (errmsg, _("pointer argument"), err_len);
+	  return true;
+	}
+      else if (arg->sym->attr.target)
+	{
+	  strncpy (errmsg, _("target argument"), err_len);
+	  return true;
+	}
+      else if (arg->sym->attr.value)
+	{
+	  strncpy (errmsg, _("value argument"), err_len);
+	  return true;
+	}
+      else if (arg->sym->attr.volatile_)
+	{
+	  strncpy (errmsg, _("volatile argument"), err_len);
+	  return true;
+	}
+      else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_SHAPE)  /* (2b)  */
+	{
+	  strncpy (errmsg, _("assumed-shape argument"), err_len);
+	  return true;
+	}
+      else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_RANK)  /* TS 29113, 6.2.  */
+	{
+	  strncpy (errmsg, _("assumed-rank argument"), err_len);
+	  return true;
+	}
+      else if (arg->sym->attr.codimension)  /* (2c)  */
+	{
+	  strncpy (errmsg, _("coarray argument"), err_len);
+	  return true;
+	}
+      else if (false)  /* (2d) TODO: parametrized derived type  */
+	{
+	  strncpy (errmsg, _("parametrized derived type argument"), err_len);
+	  return true;
+	}
+      else if (arg->sym->ts.type == BT_CLASS)  /* (2e)  */
+	{
+	  strncpy (errmsg, _("polymorphic argument"), err_len);
+	  return true;
+	}
+      else if (arg->sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
+	{
+	  strncpy (errmsg, _("NO_ARG_CHECK attribute"), err_len);
+	  return true;
+	}
+      else if (arg->sym->ts.type == BT_ASSUMED)
+	{
+	  /* As assumed-type is unlimited polymorphic (cf. above).
+	     See also TS 29113, Note 6.1.  */
+	  strncpy (errmsg, _("assumed-type argument"), err_len);
+	  return true;
+	}
+    }
+
+  if (sym->attr.function)
+    {
+      gfc_symbol *res = sym->result ? sym->result : sym;
+
+      if (res->attr.dimension)  /* (3a)  */
+	{
+	  strncpy (errmsg, _("array result"), err_len);
+	  return true;
+	}
+      else if (res->attr.pointer || res->attr.allocatable)  /* (3b)  */
+	{
+	  strncpy (errmsg, _("pointer or allocatable result"), err_len);
+	  return true;
+	}
+      else if (res->ts.type == BT_CHARACTER && res->ts.u.cl
+	       && res->ts.u.cl->length
+	       && res->ts.u.cl->length->expr_type != EXPR_CONSTANT)  /* (3c)  */
+	{
+	  strncpy (errmsg, _("result with non-constant character length"), err_len);
+	  return true;
+	}
+    }
+
+  if (sym->attr.elemental && !sym->attr.intrinsic)  /* (4)  */
+    {
+      strncpy (errmsg, _("elemental procedure"), err_len);
+      return true;
+    }
+  else if (sym->attr.is_bind_c)  /* (5)  */
+    {
+      strncpy (errmsg, _("bind(c) procedure"), err_len);
+      return true;
+    }
+
+  return false;
+}
+
+
+static void
+resolve_global_procedure (gfc_symbol *sym, locus *where,
+			  gfc_actual_arglist **actual, int sub)
+{
+  gfc_gsymbol * gsym;
+  gfc_namespace *ns;
+  enum gfc_symbol_type type;
+  char reason[200];
+
+  type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
+
+  gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name);
+
+  if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
+    gfc_global_used (gsym, where);
+
+  if ((sym->attr.if_source == IFSRC_UNKNOWN
+       || sym->attr.if_source == IFSRC_IFBODY)
+      && gsym->type != GSYM_UNKNOWN
+      && !gsym->binding_label
+      && gsym->ns
+      && gsym->ns->resolved != -1
+      && gsym->ns->proc_name
+      && not_in_recursive (sym, gsym->ns)
+      && not_entry_self_reference (sym, gsym->ns))
+    {
+      gfc_symbol *def_sym;
+
+      /* Resolve the gsymbol namespace if needed.  */
+      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);
+
+	  /* Store the new derived types with the global namespace.  */
+	  if (gfc_derived_types)
+	    gsym->ns->derived_types = gfc_derived_types;
+
+	  /* 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
+	 the procedure currently being resolved.  */
+      ns = gfc_global_ns_list;
+      for (; ns && ns != gsym->ns; ns = ns->sibling)
+	{
+	  if (ns->sibling == gsym->ns)
+	    {
+	      ns->sibling = gsym->ns->sibling;
+	      gsym->ns->sibling = gfc_global_ns_list;
+	      gfc_global_ns_list = gsym->ns;
+	      break;
+	    }
+	}
+
+      def_sym = gsym->ns->proc_name;
+
+      /* This can happen if a binding name has been specified.  */
+      if (gsym->binding_label && gsym->sym_name != def_sym->name)
+	gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &def_sym);
+
+      if (def_sym->attr.entry_master)
+	{
+	  gfc_entry_list *entry;
+	  for (entry = gsym->ns->entries; entry; entry = entry->next)
+	    if (strcmp (entry->sym->name, sym->name) == 0)
+	      {
+		def_sym = entry->sym;
+		break;
+	      }
+	}
+
+      if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts))
+	{
+	  gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
+		     sym->name, &sym->declared_at, gfc_typename (&sym->ts),
+		     gfc_typename (&def_sym->ts));
+	  goto done;
+	}
+
+      if (sym->attr.if_source == IFSRC_UNKNOWN
+	  && gfc_explicit_interface_required (def_sym, reason, sizeof(reason)))
+	{
+	  gfc_error ("Explicit interface required for '%s' at %L: %s",
+		     sym->name, &sym->declared_at, reason);
+	  goto done;
+	}
+
+      if (!pedantic && (gfc_option.allow_std & GFC_STD_GNU))
+	/* Turn erros into warnings with -std=gnu and -std=legacy.  */
+	gfc_errors_to_warnings (1);
+
+      if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1,
+				   reason, sizeof(reason), NULL, NULL))
+	{	
+	  gfc_error ("Interface mismatch in global procedure '%s' at %L: %s ",
+		    sym->name, &sym->declared_at, reason);
+	  goto done;
+	}
+
+      if (!pedantic
+	  || ((gfc_option.warn_std & GFC_STD_LEGACY)
+	      && !(gfc_option.warn_std & GFC_STD_GNU)))
+	gfc_errors_to_warnings (1);
+
+      if (sym->attr.if_source != IFSRC_IFBODY)
+	gfc_procedure_use (def_sym, actual, where);
+    }
+    
+done:
+  gfc_errors_to_warnings (0);
+
+  if (gsym->type == GSYM_UNKNOWN)
+    {
+      gsym->type = type;
+      gsym->where = *where;
+    }
+
+  gsym->used = 1;
+}
+
+
+/************* Function resolution *************/
+
+/* Resolve a function call known to be generic.
+   Section 14.1.2.4.1.  */
+
+static match
+resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
+{
+  gfc_symbol *s;
+
+  if (sym->attr.generic)
+    {
+      s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
+      if (s != NULL)
+	{
+	  expr->value.function.name = s->name;
+	  expr->value.function.esym = s;
+
+	  if (s->ts.type != BT_UNKNOWN)
+	    expr->ts = s->ts;
+	  else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
+	    expr->ts = s->result->ts;
+
+	  if (s->as != NULL)
+	    expr->rank = s->as->rank;
+	  else if (s->result != NULL && s->result->as != NULL)
+	    expr->rank = s->result->as->rank;
+
+	  gfc_set_sym_referenced (expr->value.function.esym);
+
+	  return MATCH_YES;
+	}
+
+      /* TODO: Need to search for elemental references in generic
+	 interface.  */
+    }
+
+  if (sym->attr.intrinsic)
+    return gfc_intrinsic_func_interface (expr, 0);
+
+  return MATCH_NO;
+}
+
+
+static bool
+resolve_generic_f (gfc_expr *expr)
+{
+  gfc_symbol *sym;
+  match m;
+  gfc_interface *intr = NULL;
+
+  sym = expr->symtree->n.sym;
+
+  for (;;)
+    {
+      m = resolve_generic_f0 (expr, sym);
+      if (m == MATCH_YES)
+	return true;
+      else if (m == MATCH_ERROR)
+	return false;
+
+generic:
+      if (!intr)
+	for (intr = sym->generic; intr; intr = intr->next)
+	  if (intr->sym->attr.flavor == FL_DERIVED)
+	    break;
+
+      if (sym->ns->parent == NULL)
+	break;
+      gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
+
+      if (sym == NULL)
+	break;
+      if (!generic_sym (sym))
+	goto generic;
+    }
+
+  /* Last ditch attempt.  See if the reference is to an intrinsic
+     that possesses a matching interface.  14.1.2.4  */
+  if (sym  && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
+    {
+      gfc_error ("There is no specific function for the generic '%s' "
+		 "at %L", expr->symtree->n.sym->name, &expr->where);
+      return false;
+    }
+
+  if (intr)
+    {
+      if (!gfc_convert_to_structure_constructor (expr, intr->sym, NULL, 
+						 NULL, false))
+	return false;
+      return resolve_structure_cons (expr, 0);
+    }
+
+  m = gfc_intrinsic_func_interface (expr, 0);
+  if (m == MATCH_YES)
+    return true;
+
+  if (m == MATCH_NO)
+    gfc_error ("Generic function '%s' at %L is not consistent with a "
+	       "specific intrinsic interface", expr->symtree->n.sym->name,
+	       &expr->where);
+
+  return false;
+}
+
+
+/* Resolve a function call known to be specific.  */
+
+static match
+resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
+{
+  match m;
+
+  if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
+    {
+      if (sym->attr.dummy)
+	{
+	  sym->attr.proc = PROC_DUMMY;
+	  goto found;
+	}
+
+      sym->attr.proc = PROC_EXTERNAL;
+      goto found;
+    }
+
+  if (sym->attr.proc == PROC_MODULE
+      || sym->attr.proc == PROC_ST_FUNCTION
+      || sym->attr.proc == PROC_INTERNAL)
+    goto found;
+
+  if (sym->attr.intrinsic)
+    {
+      m = gfc_intrinsic_func_interface (expr, 1);
+      if (m == MATCH_YES)
+	return MATCH_YES;
+      if (m == MATCH_NO)
+	gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
+		   "with an intrinsic", sym->name, &expr->where);
+
+      return MATCH_ERROR;
+    }
+
+  return MATCH_NO;
+
+found:
+  gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
+
+  if (sym->result)
+    expr->ts = sym->result->ts;
+  else
+    expr->ts = sym->ts;
+  expr->value.function.name = sym->name;
+  expr->value.function.esym = sym;
+  if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)
+    expr->rank = CLASS_DATA (sym)->as->rank;
+  else if (sym->as != NULL)
+    expr->rank = sym->as->rank;
+
+  return MATCH_YES;
+}
+
+
+static bool
+resolve_specific_f (gfc_expr *expr)
+{
+  gfc_symbol *sym;
+  match m;
+
+  sym = expr->symtree->n.sym;
+
+  for (;;)
+    {
+      m = resolve_specific_f0 (sym, expr);
+      if (m == MATCH_YES)
+	return true;
+      if (m == MATCH_ERROR)
+	return false;
+
+      if (sym->ns->parent == NULL)
+	break;
+
+      gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
+
+      if (sym == NULL)
+	break;
+    }
+
+  gfc_error ("Unable to resolve the specific function '%s' at %L",
+	     expr->symtree->n.sym->name, &expr->where);
+
+  return true;
+}
+
+
+/* Resolve a procedure call not known to be generic nor specific.  */
+
+static bool
+resolve_unknown_f (gfc_expr *expr)
+{
+  gfc_symbol *sym;
+  gfc_typespec *ts;
+
+  sym = expr->symtree->n.sym;
+
+  if (sym->attr.dummy)
+    {
+      sym->attr.proc = PROC_DUMMY;
+      expr->value.function.name = sym->name;
+      goto set_type;
+    }
+
+  /* See if we have an intrinsic function reference.  */
+
+  if (gfc_is_intrinsic (sym, 0, expr->where))
+    {
+      if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
+	return true;
+      return false;
+    }
+
+  /* The reference is to an external name.  */
+
+  sym->attr.proc = PROC_EXTERNAL;
+  expr->value.function.name = sym->name;
+  expr->value.function.esym = expr->symtree->n.sym;
+
+  if (sym->as != NULL)
+    expr->rank = sym->as->rank;
+
+  /* Type of the expression is either the type of the symbol or the
+     default type of the symbol.  */
+
+set_type:
+  gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
+
+  if (sym->ts.type != BT_UNKNOWN)
+    expr->ts = sym->ts;
+  else
+    {
+      ts = gfc_get_default_type (sym->name, sym->ns);
+
+      if (ts->type == BT_UNKNOWN)
+	{
+	  gfc_error ("Function '%s' at %L has no IMPLICIT type",
+		     sym->name, &expr->where);
+	  return false;
+	}
+      else
+	expr->ts = *ts;
+    }
+
+  return true;
+}
+
+
+/* Return true, if the symbol is an external procedure.  */
+static bool
+is_external_proc (gfc_symbol *sym)
+{
+  if (!sym->attr.dummy && !sym->attr.contained
+	&& !gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at)
+	&& sym->attr.proc != PROC_ST_FUNCTION
+	&& !sym->attr.proc_pointer
+	&& !sym->attr.use_assoc
+	&& sym->name)
+    return true;
+
+  return false;
+}
+
+
+/* Figure out if a function reference is pure or not.  Also set the name
+   of the function for a potential error message.  Return nonzero if the
+   function is PURE, zero if not.  */
+static int
+pure_stmt_function (gfc_expr *, gfc_symbol *);
+
+static int
+pure_function (gfc_expr *e, const char **name)
+{
+  int pure;
+
+  *name = NULL;
+
+  if (e->symtree != NULL
+        && e->symtree->n.sym != NULL
+        && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
+    return pure_stmt_function (e, e->symtree->n.sym);
+
+  if (e->value.function.esym)
+    {
+      pure = gfc_pure (e->value.function.esym);
+      *name = e->value.function.esym->name;
+    }
+  else if (e->value.function.isym)
+    {
+      pure = e->value.function.isym->pure
+	     || e->value.function.isym->elemental;
+      *name = e->value.function.isym->name;
+    }
+  else
+    {
+      /* Implicit functions are not pure.  */
+      pure = 0;
+      *name = e->value.function.name;
+    }
+
+  return pure;
+}
+
+
+static bool
+impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
+		 int *f ATTRIBUTE_UNUSED)
+{
+  const char *name;
+
+  /* Don't bother recursing into other statement functions
+     since they will be checked individually for purity.  */
+  if (e->expr_type != EXPR_FUNCTION
+	|| !e->symtree
+	|| e->symtree->n.sym == sym
+	|| e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
+    return false;
+
+  return pure_function (e, &name) ? false : true;
+}
+
+
+static int
+pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
+{
+  return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
+}
+
+
+/* Resolve a function call, which means resolving the arguments, then figuring
+   out which entity the name refers to.  */
+
+static bool
+resolve_function (gfc_expr *expr)
+{
+  gfc_actual_arglist *arg;
+  gfc_symbol *sym;
+  const char *name;
+  bool t;
+  int temp;
+  procedure_type p = PROC_INTRINSIC;
+  bool no_formal_args;
+
+  sym = NULL;
+  if (expr->symtree)
+    sym = expr->symtree->n.sym;
+
+  /* If this is a procedure pointer component, it has already been resolved.  */
+  if (gfc_is_proc_ptr_comp (expr))
+    return true;
+
+  if (sym && sym->attr.intrinsic
+      && !gfc_resolve_intrinsic (sym, &expr->where))
+    return false;
+
+  if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
+    {
+      gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
+      return false;
+    }
+
+  /* If this ia a deferred TBP with an abstract interface (which may
+     of course be referenced), expr->value.function.esym will be set.  */
+  if (sym && sym->attr.abstract && !expr->value.function.esym)
+    {
+      gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
+		 sym->name, &expr->where);
+      return false;
+    }
+
+  /* Switch off assumed size checking and do this again for certain kinds
+     of procedure, once the procedure itself is resolved.  */
+  need_full_assumed_size++;
+
+  if (expr->symtree && expr->symtree->n.sym)
+    p = expr->symtree->n.sym->attr.proc;
+
+  if (expr->value.function.isym && expr->value.function.isym->inquiry)
+    inquiry_argument = true;
+  no_formal_args = sym && is_external_proc (sym)
+  		       && gfc_sym_get_dummy_args (sym) == NULL;
+
+  if (!resolve_actual_arglist (expr->value.function.actual, 
+			       p, no_formal_args))
+    {
+      inquiry_argument = false;
+      return false;
+    }
+
+  inquiry_argument = false;
+
+  /* Resume assumed_size checking.  */
+  need_full_assumed_size--;
+
+  /* If the procedure is external, check for usage.  */
+  if (sym && is_external_proc (sym))
+    resolve_global_procedure (sym, &expr->where,
+			      &expr->value.function.actual, 0);
+
+  if (sym && sym->ts.type == BT_CHARACTER
+      && sym->ts.u.cl
+      && sym->ts.u.cl->length == NULL
+      && !sym->attr.dummy
+      && !sym->ts.deferred
+      && expr->value.function.esym == NULL
+      && !sym->attr.contained)
+    {
+      /* Internal procedures are taken care of in resolve_contained_fntype.  */
+      gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
+		 "be used at %L since it is not a dummy argument",
+		 sym->name, &expr->where);
+      return false;
+    }
+
+  /* See if function is already resolved.  */
+
+  if (expr->value.function.name != NULL)
+    {
+      if (expr->ts.type == BT_UNKNOWN)
+	expr->ts = sym->ts;
+      t = true;
+    }
+  else
+    {
+      /* Apply the rules of section 14.1.2.  */
+
+      switch (procedure_kind (sym))
+	{
+	case PTYPE_GENERIC:
+	  t = resolve_generic_f (expr);
+	  break;
+
+	case PTYPE_SPECIFIC:
+	  t = resolve_specific_f (expr);
+	  break;
+
+	case PTYPE_UNKNOWN:
+	  t = resolve_unknown_f (expr);
+	  break;
+
+	default:
+	  gfc_internal_error ("resolve_function(): bad function type");
+	}
+    }
+
+  /* If the expression is still a function (it might have simplified),
+     then we check to see if we are calling an elemental function.  */
+
+  if (expr->expr_type != EXPR_FUNCTION)
+    return t;
+
+  temp = need_full_assumed_size;
+  need_full_assumed_size = 0;
+
+  if (!resolve_elemental_actual (expr, NULL))
+    return false;
+
+  if (omp_workshare_flag
+      && expr->value.function.esym
+      && ! gfc_elemental (expr->value.function.esym))
+    {
+      gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
+		 "in WORKSHARE construct", expr->value.function.esym->name,
+		 &expr->where);
+      t = false;
+    }
+
+#define GENERIC_ID expr->value.function.isym->id
+  else if (expr->value.function.actual != NULL
+	   && expr->value.function.isym != NULL
+	   && GENERIC_ID != GFC_ISYM_LBOUND
+	   && GENERIC_ID != GFC_ISYM_LEN
+	   && GENERIC_ID != GFC_ISYM_LOC
+	   && GENERIC_ID != GFC_ISYM_C_LOC
+	   && GENERIC_ID != GFC_ISYM_PRESENT)
+    {
+      /* Array intrinsics must also have the last upper bound of an
+	 assumed size array argument.  UBOUND and SIZE have to be
+	 excluded from the check if the second argument is anything
+	 than a constant.  */
+
+      for (arg = expr->value.function.actual; arg; arg = arg->next)
+	{
+	  if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
+	      && arg == expr->value.function.actual
+	      && arg->next != NULL && arg->next->expr)
+	    {
+	      if (arg->next->expr->expr_type != EXPR_CONSTANT)
+		break;
+
+	      if (arg->next->name && strncmp (arg->next->name, "kind", 4) == 0)
+		break;
+
+	      if ((int)mpz_get_si (arg->next->expr->value.integer)
+			< arg->expr->rank)
+		break;
+	    }
+
+	  if (arg->expr != NULL
+	      && arg->expr->rank > 0
+	      && resolve_assumed_size_actual (arg->expr))
+	    return false;
+	}
+    }
+#undef GENERIC_ID
+
+  need_full_assumed_size = temp;
+  name = NULL;
+
+  if (!pure_function (expr, &name) && name)
+    {
+      if (forall_flag)
+	{
+	  gfc_error ("Reference to non-PURE function '%s' at %L inside a "
+		     "FORALL %s", name, &expr->where,
+		     forall_flag == 2 ? "mask" : "block");
+	  t = false;
+	}
+      else if (gfc_do_concurrent_flag)
+	{
+	  gfc_error ("Reference to non-PURE function '%s' at %L inside a "
+		     "DO CONCURRENT %s", name, &expr->where,
+		     gfc_do_concurrent_flag == 2 ? "mask" : "block");
+	  t = false;
+	}
+      else if (gfc_pure (NULL))
+	{
+	  gfc_error ("Function reference to '%s' at %L is to a non-PURE "
+		     "procedure within a PURE procedure", name, &expr->where);
+	  t = false;
+	}
+
+      gfc_unset_implicit_pure (NULL);
+    }
+
+  /* Functions without the RECURSIVE attribution are not allowed to
+   * call themselves.  */
+  if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
+    {
+      gfc_symbol *esym;
+      esym = expr->value.function.esym;
+
+      if (is_illegal_recursion (esym, gfc_current_ns))
+      {
+	if (esym->attr.entry && esym->ns->entries)
+	  gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
+		     " function '%s' is not RECURSIVE",
+		     esym->name, &expr->where, esym->ns->entries->sym->name);
+	else
+	  gfc_error ("Function '%s' at %L cannot be called recursively, as it"
+		     " is not RECURSIVE", esym->name, &expr->where);
+
+	t = false;
+      }
+    }
+
+  /* Character lengths of use associated functions may contains references to
+     symbols not referenced from the current program unit otherwise.  Make sure
+     those symbols are marked as referenced.  */
+
+  if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
+      && expr->value.function.esym->attr.use_assoc)
+    {
+      gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
+    }
+
+  /* Make sure that the expression has a typespec that works.  */
+  if (expr->ts.type == BT_UNKNOWN)
+    {
+      if (expr->symtree->n.sym->result
+	    && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
+	    && !expr->symtree->n.sym->result->attr.proc_pointer)
+	expr->ts = expr->symtree->n.sym->result->ts;
+    }
+
+  return t;
+}
+
+
+/************* Subroutine resolution *************/
+
+static void
+pure_subroutine (gfc_code *c, gfc_symbol *sym)
+{
+  if (gfc_pure (sym))
+    return;
+
+  if (forall_flag)
+    gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
+	       sym->name, &c->loc);
+  else if (gfc_do_concurrent_flag)
+    gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
+	       "PURE", sym->name, &c->loc);
+  else if (gfc_pure (NULL))
+    gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
+	       &c->loc);
+
+  gfc_unset_implicit_pure (NULL);
+}
+
+
+static match
+resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
+{
+  gfc_symbol *s;
+
+  if (sym->attr.generic)
+    {
+      s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
+      if (s != NULL)
+	{
+	  c->resolved_sym = s;
+	  pure_subroutine (c, s);
+	  return MATCH_YES;
+	}
+
+      /* TODO: Need to search for elemental references in generic interface.  */
+    }
+
+  if (sym->attr.intrinsic)
+    return gfc_intrinsic_sub_interface (c, 0);
+
+  return MATCH_NO;
+}
+
+
+static bool
+resolve_generic_s (gfc_code *c)
+{
+  gfc_symbol *sym;
+  match m;
+
+  sym = c->symtree->n.sym;
+
+  for (;;)
+    {
+      m = resolve_generic_s0 (c, sym);
+      if (m == MATCH_YES)
+	return true;
+      else if (m == MATCH_ERROR)
+	return false;
+
+generic:
+      if (sym->ns->parent == NULL)
+	break;
+      gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
+
+      if (sym == NULL)
+	break;
+      if (!generic_sym (sym))
+	goto generic;
+    }
+
+  /* Last ditch attempt.  See if the reference is to an intrinsic
+     that possesses a matching interface.  14.1.2.4  */
+  sym = c->symtree->n.sym;
+
+  if (!gfc_is_intrinsic (sym, 1, c->loc))
+    {
+      gfc_error ("There is no specific subroutine for the generic '%s' at %L",
+		 sym->name, &c->loc);
+      return false;
+    }
+
+  m = gfc_intrinsic_sub_interface (c, 0);
+  if (m == MATCH_YES)
+    return true;
+  if (m == MATCH_NO)
+    gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
+	       "intrinsic subroutine interface", sym->name, &c->loc);
+
+  return false;
+}
+
+
+/* Resolve a subroutine call known to be specific.  */
+
+static match
+resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
+{
+  match m;
+
+  if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
+    {
+      if (sym->attr.dummy)
+	{
+	  sym->attr.proc = PROC_DUMMY;
+	  goto found;
+	}
+
+      sym->attr.proc = PROC_EXTERNAL;
+      goto found;
+    }
+
+  if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
+    goto found;
+
+  if (sym->attr.intrinsic)
+    {
+      m = gfc_intrinsic_sub_interface (c, 1);
+      if (m == MATCH_YES)
+	return MATCH_YES;
+      if (m == MATCH_NO)
+	gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
+		   "with an intrinsic", sym->name, &c->loc);
+
+      return MATCH_ERROR;
+    }
+
+  return MATCH_NO;
+
+found:
+  gfc_procedure_use (sym, &c->ext.actual, &c->loc);
+
+  c->resolved_sym = sym;
+  pure_subroutine (c, sym);
+
+  return MATCH_YES;
+}
+
+
+static bool
+resolve_specific_s (gfc_code *c)
+{
+  gfc_symbol *sym;
+  match m;
+
+  sym = c->symtree->n.sym;
+
+  for (;;)
+    {
+      m = resolve_specific_s0 (c, sym);
+      if (m == MATCH_YES)
+	return true;
+      if (m == MATCH_ERROR)
+	return false;
+
+      if (sym->ns->parent == NULL)
+	break;
+
+      gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
+
+      if (sym == NULL)
+	break;
+    }
+
+  sym = c->symtree->n.sym;
+  gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
+	     sym->name, &c->loc);
+
+  return false;
+}
+
+
+/* Resolve a subroutine call not known to be generic nor specific.  */
+
+static bool
+resolve_unknown_s (gfc_code *c)
+{
+  gfc_symbol *sym;
+
+  sym = c->symtree->n.sym;
+
+  if (sym->attr.dummy)
+    {
+      sym->attr.proc = PROC_DUMMY;
+      goto found;
+    }
+
+  /* See if we have an intrinsic function reference.  */
+
+  if (gfc_is_intrinsic (sym, 1, c->loc))
+    {
+      if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
+	return true;
+      return false;
+    }
+
+  /* The reference is to an external name.  */
+
+found:
+  gfc_procedure_use (sym, &c->ext.actual, &c->loc);
+
+  c->resolved_sym = sym;
+
+  pure_subroutine (c, sym);
+
+  return true;
+}
+
+
+/* Resolve a subroutine call.  Although it was tempting to use the same code
+   for functions, subroutines and functions are stored differently and this
+   makes things awkward.  */
+
+static bool
+resolve_call (gfc_code *c)
+{
+  bool t;
+  procedure_type ptype = PROC_INTRINSIC;
+  gfc_symbol *csym, *sym;
+  bool no_formal_args;
+
+  csym = c->symtree ? c->symtree->n.sym : NULL;
+
+  if (csym && csym->ts.type != BT_UNKNOWN)
+    {
+      gfc_error ("'%s' at %L has a type, which is not consistent with "
+		 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
+      return false;
+    }
+
+  if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
+    {
+      gfc_symtree *st;
+      gfc_find_sym_tree (c->symtree->name, gfc_current_ns, 1, &st);
+      sym = st ? st->n.sym : NULL;
+      if (sym && csym != sym
+	      && sym->ns == gfc_current_ns
+	      && sym->attr.flavor == FL_PROCEDURE
+	      && sym->attr.contained)
+	{
+	  sym->refs++;
+	  if (csym->attr.generic)
+	    c->symtree->n.sym = sym;
+	  else
+	    c->symtree = st;
+	  csym = c->symtree->n.sym;
+	}
+    }
+
+  /* If this ia a deferred TBP, c->expr1 will be set.  */
+  if (!c->expr1 && csym)
+    {
+      if (csym->attr.abstract)
+	{
+	  gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
+		    csym->name, &c->loc);
+	  return false;
+	}
+
+      /* Subroutines without the RECURSIVE attribution are not allowed to
+	 call themselves.  */
+      if (is_illegal_recursion (csym, gfc_current_ns))
+	{
+	  if (csym->attr.entry && csym->ns->entries)
+	    gfc_error ("ENTRY '%s' at %L cannot be called recursively, "
+		       "as subroutine '%s' is not RECURSIVE",
+		       csym->name, &c->loc, csym->ns->entries->sym->name);
+	  else
+	    gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, "
+		       "as it is not RECURSIVE", csym->name, &c->loc);
+
+	  t = false;
+	}
+    }
+
+  /* Switch off assumed size checking and do this again for certain kinds
+     of procedure, once the procedure itself is resolved.  */
+  need_full_assumed_size++;
+
+  if (csym)
+    ptype = csym->attr.proc;
+
+  no_formal_args = csym && is_external_proc (csym)
+			&& gfc_sym_get_dummy_args (csym) == NULL;
+  if (!resolve_actual_arglist (c->ext.actual, ptype, no_formal_args))
+    return false;
+
+  /* Resume assumed_size checking.  */
+  need_full_assumed_size--;
+
+  /* If external, check for usage.  */
+  if (csym && is_external_proc (csym))
+    resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
+
+  t = true;
+  if (c->resolved_sym == NULL)
+    {
+      c->resolved_isym = NULL;
+      switch (procedure_kind (csym))
+	{
+	case PTYPE_GENERIC:
+	  t = resolve_generic_s (c);
+	  break;
+
+	case PTYPE_SPECIFIC:
+	  t = resolve_specific_s (c);
+	  break;
+
+	case PTYPE_UNKNOWN:
+	  t = resolve_unknown_s (c);
+	  break;
+
+	default:
+	  gfc_internal_error ("resolve_subroutine(): bad function type");
+	}
+    }
+
+  /* Some checks of elemental subroutine actual arguments.  */
+  if (!resolve_elemental_actual (NULL, c))
+    return false;
+
+  return t;
+}
+
+
+/* Compare the shapes of two arrays that have non-NULL shapes.  If both
+   op1->shape and op2->shape are non-NULL return true if their shapes
+   match.  If both op1->shape and op2->shape are non-NULL return false
+   if their shapes do not match.  If either op1->shape or op2->shape is
+   NULL, return true.  */
+
+static bool
+compare_shapes (gfc_expr *op1, gfc_expr *op2)
+{
+  bool t;
+  int i;
+
+  t = true;
+
+  if (op1->shape != NULL && op2->shape != NULL)
+    {
+      for (i = 0; i < op1->rank; i++)
+	{
+	  if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
+	   {
+	     gfc_error ("Shapes for operands at %L and %L are not conformable",
+			 &op1->where, &op2->where);
+	     t = false;
+	     break;
+	   }
+	}
+    }
+
+  return t;
+}
+
+
+/* Resolve an operator expression node.  This can involve replacing the
+   operation with a user defined function call.  */
+
+static bool
+resolve_operator (gfc_expr *e)
+{
+  gfc_expr *op1, *op2;
+  char msg[200];
+  bool dual_locus_error;
+  bool t;
+
+  /* Resolve all subnodes-- give them types.  */
+
+  switch (e->value.op.op)
+    {
+    default:
+      if (!gfc_resolve_expr (e->value.op.op2))
+	return false;
+
+    /* Fall through...  */
+
+    case INTRINSIC_NOT:
+    case INTRINSIC_UPLUS:
+    case INTRINSIC_UMINUS:
+    case INTRINSIC_PARENTHESES:
+      if (!gfc_resolve_expr (e->value.op.op1))
+	return false;
+      break;
+    }
+
+  /* Typecheck the new node.  */
+
+  op1 = e->value.op.op1;
+  op2 = e->value.op.op2;
+  dual_locus_error = false;
+
+  if ((op1 && op1->expr_type == EXPR_NULL)
+      || (op2 && op2->expr_type == EXPR_NULL))
+    {
+      sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
+      goto bad_op;
+    }
+
+  switch (e->value.op.op)
+    {
+    case INTRINSIC_UPLUS:
+    case INTRINSIC_UMINUS:
+      if (op1->ts.type == BT_INTEGER
+	  || op1->ts.type == BT_REAL
+	  || op1->ts.type == BT_COMPLEX)
+	{
+	  e->ts = op1->ts;
+	  break;
+	}
+
+      sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
+	       gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
+      goto bad_op;
+
+    case INTRINSIC_PLUS:
+    case INTRINSIC_MINUS:
+    case INTRINSIC_TIMES:
+    case INTRINSIC_DIVIDE:
+    case INTRINSIC_POWER:
+      if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
+	{
+	  gfc_type_convert_binary (e, 1);
+	  break;
+	}
+
+      sprintf (msg,
+	       _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
+	       gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
+	       gfc_typename (&op2->ts));
+      goto bad_op;
+
+    case INTRINSIC_CONCAT:
+      if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
+	  && op1->ts.kind == op2->ts.kind)
+	{
+	  e->ts.type = BT_CHARACTER;
+	  e->ts.kind = op1->ts.kind;
+	  break;
+	}
+
+      sprintf (msg,
+	       _("Operands of string concatenation operator at %%L are %s/%s"),
+	       gfc_typename (&op1->ts), gfc_typename (&op2->ts));
+      goto bad_op;
+
+    case INTRINSIC_AND:
+    case INTRINSIC_OR:
+    case INTRINSIC_EQV:
+    case INTRINSIC_NEQV:
+      if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
+	{
+	  e->ts.type = BT_LOGICAL;
+	  e->ts.kind = gfc_kind_max (op1, op2);
+	  if (op1->ts.kind < e->ts.kind)
+	    gfc_convert_type (op1, &e->ts, 2);
+	  else if (op2->ts.kind < e->ts.kind)
+	    gfc_convert_type (op2, &e->ts, 2);
+	  break;
+	}
+
+      sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
+	       gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
+	       gfc_typename (&op2->ts));
+
+      goto bad_op;
+
+    case INTRINSIC_NOT:
+      if (op1->ts.type == BT_LOGICAL)
+	{
+	  e->ts.type = BT_LOGICAL;
+	  e->ts.kind = op1->ts.kind;
+	  break;
+	}
+
+      sprintf (msg, _("Operand of .not. operator at %%L is %s"),
+	       gfc_typename (&op1->ts));
+      goto bad_op;
+
+    case INTRINSIC_GT:
+    case INTRINSIC_GT_OS:
+    case INTRINSIC_GE:
+    case INTRINSIC_GE_OS:
+    case INTRINSIC_LT:
+    case INTRINSIC_LT_OS:
+    case INTRINSIC_LE:
+    case INTRINSIC_LE_OS:
+      if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
+	{
+	  strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
+	  goto bad_op;
+	}
+
+      /* Fall through...  */
+
+    case INTRINSIC_EQ:
+    case INTRINSIC_EQ_OS:
+    case INTRINSIC_NE:
+    case INTRINSIC_NE_OS:
+      if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
+	  && op1->ts.kind == op2->ts.kind)
+	{
+	  e->ts.type = BT_LOGICAL;
+	  e->ts.kind = gfc_default_logical_kind;
+	  break;
+	}
+
+      if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
+	{
+	  gfc_type_convert_binary (e, 1);
+
+	  e->ts.type = BT_LOGICAL;
+	  e->ts.kind = gfc_default_logical_kind;
+
+	  if (gfc_option.warn_compare_reals)
+	    {
+	      gfc_intrinsic_op op = e->value.op.op;
+
+	      /* Type conversion has made sure that the types of op1 and op2
+		 agree, so it is only necessary to check the first one.   */
+	      if ((op1->ts.type == BT_REAL || op1->ts.type == BT_COMPLEX)
+		  && (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS
+		      || op == INTRINSIC_NE || op == INTRINSIC_NE_OS))
+		{
+		  const char *msg;
+
+		  if (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS)
+		    msg = "Equality comparison for %s at %L";
+		  else
+		    msg = "Inequality comparison for %s at %L";
+
+		  gfc_warning (msg, gfc_typename (&op1->ts), &op1->where);
+		}
+	    }
+
+	  break;
+	}
+
+      if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
+	sprintf (msg,
+		 _("Logicals at %%L must be compared with %s instead of %s"),
+		 (e->value.op.op == INTRINSIC_EQ
+		  || e->value.op.op == INTRINSIC_EQ_OS)
+		 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
+      else
+	sprintf (msg,
+		 _("Operands of comparison operator '%s' at %%L are %s/%s"),
+		 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
+		 gfc_typename (&op2->ts));
+
+      goto bad_op;
+
+    case INTRINSIC_USER:
+      if (e->value.op.uop->op == NULL)
+	sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
+      else if (op2 == NULL)
+	sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
+		 e->value.op.uop->name, gfc_typename (&op1->ts));
+      else
+	{
+	  sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
+		   e->value.op.uop->name, gfc_typename (&op1->ts),
+		   gfc_typename (&op2->ts));
+	  e->value.op.uop->op->sym->attr.referenced = 1;
+	}
+
+      goto bad_op;
+
+    case INTRINSIC_PARENTHESES:
+      e->ts = op1->ts;
+      if (e->ts.type == BT_CHARACTER)
+	e->ts.u.cl = op1->ts.u.cl;
+      break;
+
+    default:
+      gfc_internal_error ("resolve_operator(): Bad intrinsic");
+    }
+
+  /* Deal with arrayness of an operand through an operator.  */
+
+  t = true;
+
+  switch (e->value.op.op)
+    {
+    case INTRINSIC_PLUS:
+    case INTRINSIC_MINUS:
+    case INTRINSIC_TIMES:
+    case INTRINSIC_DIVIDE:
+    case INTRINSIC_POWER:
+    case INTRINSIC_CONCAT:
+    case INTRINSIC_AND:
+    case INTRINSIC_OR:
+    case INTRINSIC_EQV:
+    case INTRINSIC_NEQV:
+    case INTRINSIC_EQ:
+    case INTRINSIC_EQ_OS:
+    case INTRINSIC_NE:
+    case INTRINSIC_NE_OS:
+    case INTRINSIC_GT:
+    case INTRINSIC_GT_OS:
+    case INTRINSIC_GE:
+    case INTRINSIC_GE_OS:
+    case INTRINSIC_LT:
+    case INTRINSIC_LT_OS:
+    case INTRINSIC_LE:
+    case INTRINSIC_LE_OS:
+
+      if (op1->rank == 0 && op2->rank == 0)
+	e->rank = 0;
+
+      if (op1->rank == 0 && op2->rank != 0)
+	{
+	  e->rank = op2->rank;
+
+	  if (e->shape == NULL)
+	    e->shape = gfc_copy_shape (op2->shape, op2->rank);
+	}
+
+      if (op1->rank != 0 && op2->rank == 0)
+	{
+	  e->rank = op1->rank;
+
+	  if (e->shape == NULL)
+	    e->shape = gfc_copy_shape (op1->shape, op1->rank);
+	}
+
+      if (op1->rank != 0 && op2->rank != 0)
+	{
+	  if (op1->rank == op2->rank)
+	    {
+	      e->rank = op1->rank;
+	      if (e->shape == NULL)
+		{
+		  t = compare_shapes (op1, op2);
+		  if (!t)
+		    e->shape = NULL;
+		  else
+		    e->shape = gfc_copy_shape (op1->shape, op1->rank);
+		}
+	    }
+	  else
+	    {
+	      /* Allow higher level expressions to work.  */
+	      e->rank = 0;
+
+	      /* Try user-defined operators, and otherwise throw an error.  */
+	      dual_locus_error = true;
+	      sprintf (msg,
+		       _("Inconsistent ranks for operator at %%L and %%L"));
+	      goto bad_op;
+	    }
+	}
+
+      break;
+
+    case INTRINSIC_PARENTHESES:
+    case INTRINSIC_NOT:
+    case INTRINSIC_UPLUS:
+    case INTRINSIC_UMINUS:
+      /* Simply copy arrayness attribute */
+      e->rank = op1->rank;
+
+      if (e->shape == NULL)
+	e->shape = gfc_copy_shape (op1->shape, op1->rank);
+
+      break;
+
+    default:
+      break;
+    }
+
+  /* Attempt to simplify the expression.  */
+  if (t)
+    {
+      t = gfc_simplify_expr (e, 0);
+      /* Some calls do not succeed in simplification and return false
+	 even though there is no error; e.g. variable references to
+	 PARAMETER arrays.  */
+      if (!gfc_is_constant_expr (e))
+	t = true;
+    }
+  return t;
+
+bad_op:
+
+  {
+    match m = gfc_extend_expr (e);
+    if (m == MATCH_YES)
+      return true;
+    if (m == MATCH_ERROR)
+      return false;
+  }
+
+  if (dual_locus_error)
+    gfc_error (msg, &op1->where, &op2->where);
+  else
+    gfc_error (msg, &e->where);
+
+  return false;
+}
+
+
+/************** Array resolution subroutines **************/
+
+typedef enum
+{ CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
+comparison;
+
+/* Compare two integer expressions.  */
+
+static comparison
+compare_bound (gfc_expr *a, gfc_expr *b)
+{
+  int i;
+
+  if (a == NULL || a->expr_type != EXPR_CONSTANT
+      || b == NULL || b->expr_type != EXPR_CONSTANT)
+    return CMP_UNKNOWN;
+
+  /* If either of the types isn't INTEGER, we must have
+     raised an error earlier.  */
+
+  if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
+    return CMP_UNKNOWN;
+
+  i = mpz_cmp (a->value.integer, b->value.integer);
+
+  if (i < 0)
+    return CMP_LT;
+  if (i > 0)
+    return CMP_GT;
+  return CMP_EQ;
+}
+
+
+/* Compare an integer expression with an integer.  */
+
+static comparison
+compare_bound_int (gfc_expr *a, int b)
+{
+  int i;
+
+  if (a == NULL || a->expr_type != EXPR_CONSTANT)
+    return CMP_UNKNOWN;
+
+  if (a->ts.type != BT_INTEGER)
+    gfc_internal_error ("compare_bound_int(): Bad expression");
+
+  i = mpz_cmp_si (a->value.integer, b);
+
+  if (i < 0)
+    return CMP_LT;
+  if (i > 0)
+    return CMP_GT;
+  return CMP_EQ;
+}
+
+
+/* Compare an integer expression with a mpz_t.  */
+
+static comparison
+compare_bound_mpz_t (gfc_expr *a, mpz_t b)
+{
+  int i;
+
+  if (a == NULL || a->expr_type != EXPR_CONSTANT)
+    return CMP_UNKNOWN;
+
+  if (a->ts.type != BT_INTEGER)
+    gfc_internal_error ("compare_bound_int(): Bad expression");
+
+  i = mpz_cmp (a->value.integer, b);
+
+  if (i < 0)
+    return CMP_LT;
+  if (i > 0)
+    return CMP_GT;
+  return CMP_EQ;
+}
+
+
+/* Compute the last value of a sequence given by a triplet.
+   Return 0 if it wasn't able to compute the last value, or if the
+   sequence if empty, and 1 otherwise.  */
+
+static int
+compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
+				gfc_expr *stride, mpz_t last)
+{
+  mpz_t rem;
+
+  if (start == NULL || start->expr_type != EXPR_CONSTANT
+      || end == NULL || end->expr_type != EXPR_CONSTANT
+      || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
+    return 0;
+
+  if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
+      || (stride != NULL && stride->ts.type != BT_INTEGER))
+    return 0;
+
+  if (stride == NULL || compare_bound_int (stride, 1) == CMP_EQ)
+    {
+      if (compare_bound (start, end) == CMP_GT)
+	return 0;
+      mpz_set (last, end->value.integer);
+      return 1;
+    }
+
+  if (compare_bound_int (stride, 0) == CMP_GT)
+    {
+      /* Stride is positive */
+      if (mpz_cmp (start->value.integer, end->value.integer) > 0)
+	return 0;
+    }
+  else
+    {
+      /* Stride is negative */
+      if (mpz_cmp (start->value.integer, end->value.integer) < 0)
+	return 0;
+    }
+
+  mpz_init (rem);
+  mpz_sub (rem, end->value.integer, start->value.integer);
+  mpz_tdiv_r (rem, rem, stride->value.integer);
+  mpz_sub (last, end->value.integer, rem);
+  mpz_clear (rem);
+
+  return 1;
+}
+
+
+/* Compare a single dimension of an array reference to the array
+   specification.  */
+
+static bool
+check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
+{
+  mpz_t last_value;
+
+  if (ar->dimen_type[i] == DIMEN_STAR)
+    {
+      gcc_assert (ar->stride[i] == NULL);
+      /* This implies [*] as [*:] and [*:3] are not possible.  */
+      if (ar->start[i] == NULL)
+	{
+	  gcc_assert (ar->end[i] == NULL);
+	  return true;
+	}
+    }
+
+/* Given start, end and stride values, calculate the minimum and
+   maximum referenced indexes.  */
+
+  switch (ar->dimen_type[i])
+    {
+    case DIMEN_VECTOR:
+    case DIMEN_THIS_IMAGE:
+      break;
+
+    case DIMEN_STAR:
+    case DIMEN_ELEMENT:
+      if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
+	{
+	  if (i < as->rank)
+	    gfc_warning ("Array reference at %L is out of bounds "
+			 "(%ld < %ld) in dimension %d", &ar->c_where[i],
+			 mpz_get_si (ar->start[i]->value.integer),
+			 mpz_get_si (as->lower[i]->value.integer), i+1);
+	  else
+	    gfc_warning ("Array reference at %L is out of bounds "
+			 "(%ld < %ld) in codimension %d", &ar->c_where[i],
+			 mpz_get_si (ar->start[i]->value.integer),
+			 mpz_get_si (as->lower[i]->value.integer),
+			 i + 1 - as->rank);
+	  return true;
+	}
+      if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
+	{
+	  if (i < as->rank)
+	    gfc_warning ("Array reference at %L is out of bounds "
+			 "(%ld > %ld) in dimension %d", &ar->c_where[i],
+			 mpz_get_si (ar->start[i]->value.integer),
+			 mpz_get_si (as->upper[i]->value.integer), i+1);
+	  else
+	    gfc_warning ("Array reference at %L is out of bounds "
+			 "(%ld > %ld) in codimension %d", &ar->c_where[i],
+			 mpz_get_si (ar->start[i]->value.integer),
+			 mpz_get_si (as->upper[i]->value.integer),
+			 i + 1 - as->rank);
+	  return true;
+	}
+
+      break;
+
+    case DIMEN_RANGE:
+      {
+#define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
+#define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
+
+	comparison comp_start_end = compare_bound (AR_START, AR_END);
+
+	/* Check for zero stride, which is not allowed.  */
+	if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
+	  {
+	    gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
+	    return false;
+	  }
+
+	/* if start == len || (stride > 0 && start < len)
+			   || (stride < 0 && start > len),
+	   then the array section contains at least one element.  In this
+	   case, there is an out-of-bounds access if
+	   (start < lower || start > upper).  */
+	if (compare_bound (AR_START, AR_END) == CMP_EQ
+	    || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
+		 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
+	    || (compare_bound_int (ar->stride[i], 0) == CMP_LT
+	        && comp_start_end == CMP_GT))
+	  {
+	    if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
+	      {
+		gfc_warning ("Lower array reference at %L is out of bounds "
+		       "(%ld < %ld) in dimension %d", &ar->c_where[i],
+		       mpz_get_si (AR_START->value.integer),
+		       mpz_get_si (as->lower[i]->value.integer), i+1);
+		return true;
+	      }
+	    if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
+	      {
+		gfc_warning ("Lower array reference at %L is out of bounds "
+		       "(%ld > %ld) in dimension %d", &ar->c_where[i],
+		       mpz_get_si (AR_START->value.integer),
+		       mpz_get_si (as->upper[i]->value.integer), i+1);
+		return true;
+	      }
+	  }
+
+	/* If we can compute the highest index of the array section,
+	   then it also has to be between lower and upper.  */
+	mpz_init (last_value);
+	if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
+					    last_value))
+	  {
+	    if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
+	      {
+		gfc_warning ("Upper array reference at %L is out of bounds "
+		       "(%ld < %ld) in dimension %d", &ar->c_where[i],
+		       mpz_get_si (last_value),
+		       mpz_get_si (as->lower[i]->value.integer), i+1);
+	        mpz_clear (last_value);
+		return true;
+	      }
+	    if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
+	      {
+		gfc_warning ("Upper array reference at %L is out of bounds "
+		       "(%ld > %ld) in dimension %d", &ar->c_where[i],
+		       mpz_get_si (last_value),
+		       mpz_get_si (as->upper[i]->value.integer), i+1);
+	        mpz_clear (last_value);
+		return true;
+	      }
+	  }
+	mpz_clear (last_value);
+
+#undef AR_START
+#undef AR_END
+      }
+      break;
+
+    default:
+      gfc_internal_error ("check_dimension(): Bad array reference");
+    }
+
+  return true;
+}
+
+
+/* Compare an array reference with an array specification.  */
+
+static bool
+compare_spec_to_ref (gfc_array_ref *ar)
+{
+  gfc_array_spec *as;
+  int i;
+
+  as = ar->as;
+  i = as->rank - 1;
+  /* TODO: Full array sections are only allowed as actual parameters.  */
+  if (as->type == AS_ASSUMED_SIZE
+      && (/*ar->type == AR_FULL
+	  ||*/ (ar->type == AR_SECTION
+	      && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
+    {
+      gfc_error ("Rightmost upper bound of assumed size array section "
+		 "not specified at %L", &ar->where);
+      return false;
+    }
+
+  if (ar->type == AR_FULL)
+    return true;
+
+  if (as->rank != ar->dimen)
+    {
+      gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
+		 &ar->where, ar->dimen, as->rank);
+      return false;
+    }
+
+  /* ar->codimen == 0 is a local array.  */
+  if (as->corank != ar->codimen && ar->codimen != 0)
+    {
+      gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
+		 &ar->where, ar->codimen, as->corank);
+      return false;
+    }
+
+  for (i = 0; i < as->rank; i++)
+    if (!check_dimension (i, ar, as))
+      return false;
+
+  /* Local access has no coarray spec.  */
+  if (ar->codimen != 0)
+    for (i = as->rank; i < as->rank + as->corank; i++)
+      {
+	if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate
+	    && ar->dimen_type[i] != DIMEN_THIS_IMAGE)
+	  {
+	    gfc_error ("Coindex of codimension %d must be a scalar at %L",
+		       i + 1 - as->rank, &ar->where);
+	    return false;
+	  }
+	if (!check_dimension (i, ar, as))
+	  return false;
+      }
+
+  return true;
+}
+
+
+/* Resolve one part of an array index.  */
+
+static bool
+gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
+		     int force_index_integer_kind)
+{
+  gfc_typespec ts;
+
+  if (index == NULL)
+    return true;
+
+  if (!gfc_resolve_expr (index))
+    return false;
+
+  if (check_scalar && index->rank != 0)
+    {
+      gfc_error ("Array index at %L must be scalar", &index->where);
+      return false;
+    }
+
+  if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
+    {
+      gfc_error ("Array index at %L must be of INTEGER type, found %s",
+		 &index->where, gfc_basic_typename (index->ts.type));
+      return false;
+    }
+
+  if (index->ts.type == BT_REAL)
+    if (!gfc_notify_std (GFC_STD_LEGACY, "REAL array index at %L", 
+			 &index->where))
+      return false;
+
+  if ((index->ts.kind != gfc_index_integer_kind
+       && force_index_integer_kind)
+      || index->ts.type != BT_INTEGER)
+    {
+      gfc_clear_ts (&ts);
+      ts.type = BT_INTEGER;
+      ts.kind = gfc_index_integer_kind;
+
+      gfc_convert_type_warn (index, &ts, 2, 0);
+    }
+
+  return true;
+}
+
+/* Resolve one part of an array index.  */
+
+bool
+gfc_resolve_index (gfc_expr *index, int check_scalar)
+{
+  return gfc_resolve_index_1 (index, check_scalar, 1);
+}
+
+/* Resolve a dim argument to an intrinsic function.  */
+
+bool
+gfc_resolve_dim_arg (gfc_expr *dim)
+{
+  if (dim == NULL)
+    return true;
+
+  if (!gfc_resolve_expr (dim))
+    return false;
+
+  if (dim->rank != 0)
+    {
+      gfc_error ("Argument dim at %L must be scalar", &dim->where);
+      return false;
+
+    }
+
+  if (dim->ts.type != BT_INTEGER)
+    {
+      gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
+      return false;
+    }
+
+  if (dim->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 (dim, &ts, 2, 0);
+    }
+
+  return true;
+}
+
+/* Given an expression that contains array references, update those array
+   references to point to the right array specifications.  While this is
+   filled in during matching, this information is difficult to save and load
+   in a module, so we take care of it here.
+
+   The idea here is that the original array reference comes from the
+   base symbol.  We traverse the list of reference structures, setting
+   the stored reference to references.  Component references can
+   provide an additional array specification.  */
+
+static void
+find_array_spec (gfc_expr *e)
+{
+  gfc_array_spec *as;
+  gfc_component *c;
+  gfc_ref *ref;
+
+  if (e->symtree->n.sym->ts.type == BT_CLASS)
+    as = CLASS_DATA (e->symtree->n.sym)->as;
+  else
+    as = e->symtree->n.sym->as;
+
+  for (ref = e->ref; ref; ref = ref->next)
+    switch (ref->type)
+      {
+      case REF_ARRAY:
+	if (as == NULL)
+	  gfc_internal_error ("find_array_spec(): Missing spec");
+
+	ref->u.ar.as = as;
+	as = NULL;
+	break;
+
+      case REF_COMPONENT:
+	c = ref->u.c.component;
+	if (c->attr.dimension)
+	  {
+	    if (as != NULL)
+	      gfc_internal_error ("find_array_spec(): unused as(1)");
+	    as = c->as;
+	  }
+
+	break;
+
+      case REF_SUBSTRING:
+	break;
+      }
+
+  if (as != NULL)
+    gfc_internal_error ("find_array_spec(): unused as(2)");
+}
+
+
+/* Resolve an array reference.  */
+
+static bool
+resolve_array_ref (gfc_array_ref *ar)
+{
+  int i, check_scalar;
+  gfc_expr *e;
+
+  for (i = 0; i < ar->dimen + ar->codimen; i++)
+    {
+      check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
+
+      /* Do not force gfc_index_integer_kind for the start.  We can
+         do fine with any integer kind.  This avoids temporary arrays
+	 created for indexing with a vector.  */
+      if (!gfc_resolve_index_1 (ar->start[i], check_scalar, 0))
+	return false;
+      if (!gfc_resolve_index (ar->end[i], check_scalar))
+	return false;
+      if (!gfc_resolve_index (ar->stride[i], check_scalar))
+	return false;
+
+      e = ar->start[i];
+
+      if (ar->dimen_type[i] == DIMEN_UNKNOWN)
+	switch (e->rank)
+	  {
+	  case 0:
+	    ar->dimen_type[i] = DIMEN_ELEMENT;
+	    break;
+
+	  case 1:
+	    ar->dimen_type[i] = DIMEN_VECTOR;
+	    if (e->expr_type == EXPR_VARIABLE
+		&& e->symtree->n.sym->ts.type == BT_DERIVED)
+	      ar->start[i] = gfc_get_parentheses (e);
+	    break;
+
+	  default:
+	    gfc_error ("Array index at %L is an array of rank %d",
+		       &ar->c_where[i], e->rank);
+	    return false;
+	  }
+
+      /* Fill in the upper bound, which may be lower than the
+	 specified one for something like a(2:10:5), which is
+	 identical to a(2:7:5).  Only relevant for strides not equal
+	 to one.  Don't try a division by zero.  */
+      if (ar->dimen_type[i] == DIMEN_RANGE
+	  && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
+	  && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0
+	  && mpz_cmp_si (ar->stride[i]->value.integer, 0L) != 0)
+	{
+	  mpz_t size, end;
+
+	  if (gfc_ref_dimen_size (ar, i, &size, &end))
+	    {
+	      if (ar->end[i] == NULL)
+		{
+		  ar->end[i] =
+		    gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
+					   &ar->where);
+		  mpz_set (ar->end[i]->value.integer, end);
+		}
+	      else if (ar->end[i]->ts.type == BT_INTEGER
+		       && ar->end[i]->expr_type == EXPR_CONSTANT)
+		{
+		  mpz_set (ar->end[i]->value.integer, end);
+		}
+	      else
+		gcc_unreachable ();
+
+	      mpz_clear (size);
+	      mpz_clear (end);
+	    }
+	}
+    }
+
+  if (ar->type == AR_FULL)
+    {
+      if (ar->as->rank == 0)
+	ar->type = AR_ELEMENT;
+
+      /* Make sure array is the same as array(:,:), this way
+	 we don't need to special case all the time.  */
+      ar->dimen = ar->as->rank;
+      for (i = 0; i < ar->dimen; i++)
+	{
+	  ar->dimen_type[i] = DIMEN_RANGE;
+
+	  gcc_assert (ar->start[i] == NULL);
+	  gcc_assert (ar->end[i] == NULL);
+	  gcc_assert (ar->stride[i] == NULL);
+	}
+    }
+
+  /* If the reference type is unknown, figure out what kind it is.  */
+
+  if (ar->type == AR_UNKNOWN)
+    {
+      ar->type = AR_ELEMENT;
+      for (i = 0; i < ar->dimen; i++)
+	if (ar->dimen_type[i] == DIMEN_RANGE
+	    || ar->dimen_type[i] == DIMEN_VECTOR)
+	  {
+	    ar->type = AR_SECTION;
+	    break;
+	  }
+    }
+
+  if (!ar->as->cray_pointee && !compare_spec_to_ref (ar))
+    return false;
+
+  if (ar->as->corank && ar->codimen == 0)
+    {
+      int n;
+      ar->codimen = ar->as->corank;
+      for (n = ar->dimen; n < ar->dimen + ar->codimen; n++)
+	ar->dimen_type[n] = DIMEN_THIS_IMAGE;
+    }
+
+  return true;
+}
+
+
+static bool
+resolve_substring (gfc_ref *ref)
+{
+  int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
+
+  if (ref->u.ss.start != NULL)
+    {
+      if (!gfc_resolve_expr (ref->u.ss.start))
+	return false;
+
+      if (ref->u.ss.start->ts.type != BT_INTEGER)
+	{
+	  gfc_error ("Substring start index at %L must be of type INTEGER",
+		     &ref->u.ss.start->where);
+	  return false;
+	}
+
+      if (ref->u.ss.start->rank != 0)
+	{
+	  gfc_error ("Substring start index at %L must be scalar",
+		     &ref->u.ss.start->where);
+	  return false;
+	}
+
+      if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
+	  && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
+	      || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
+	{
+	  gfc_error ("Substring start index at %L is less than one",
+		     &ref->u.ss.start->where);
+	  return false;
+	}
+    }
+
+  if (ref->u.ss.end != NULL)
+    {
+      if (!gfc_resolve_expr (ref->u.ss.end))
+	return false;
+
+      if (ref->u.ss.end->ts.type != BT_INTEGER)
+	{
+	  gfc_error ("Substring end index at %L must be of type INTEGER",
+		     &ref->u.ss.end->where);
+	  return false;
+	}
+
+      if (ref->u.ss.end->rank != 0)
+	{
+	  gfc_error ("Substring end index at %L must be scalar",
+		     &ref->u.ss.end->where);
+	  return false;
+	}
+
+      if (ref->u.ss.length != NULL
+	  && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
+	  && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
+	      || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
+	{
+	  gfc_error ("Substring end index at %L exceeds the string length",
+		     &ref->u.ss.start->where);
+	  return false;
+	}
+
+      if (compare_bound_mpz_t (ref->u.ss.end,
+			       gfc_integer_kinds[k].huge) == CMP_GT
+	  && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
+	      || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
+	{
+	  gfc_error ("Substring end index at %L is too large",
+		     &ref->u.ss.end->where);
+	  return false;
+	}
+    }
+
+  return true;
+}
+
+
+/* This function supplies missing substring charlens.  */
+
+void
+gfc_resolve_substring_charlen (gfc_expr *e)
+{
+  gfc_ref *char_ref;
+  gfc_expr *start, *end;
+
+  for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
+    if (char_ref->type == REF_SUBSTRING)
+      break;
+
+  if (!char_ref)
+    return;
+
+  gcc_assert (char_ref->next == NULL);
+
+  if (e->ts.u.cl)
+    {
+      if (e->ts.u.cl->length)
+	gfc_free_expr (e->ts.u.cl->length);
+      else if (e->expr_type == EXPR_VARIABLE
+		 && e->symtree->n.sym->attr.dummy)
+	return;
+    }
+
+  e->ts.type = BT_CHARACTER;
+  e->ts.kind = gfc_default_character_kind;
+
+  if (!e->ts.u.cl)
+    e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+
+  if (char_ref->u.ss.start)
+    start = gfc_copy_expr (char_ref->u.ss.start);
+  else
+    start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+
+  if (char_ref->u.ss.end)
+    end = gfc_copy_expr (char_ref->u.ss.end);
+  else if (e->expr_type == EXPR_VARIABLE)
+    end = gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
+  else
+    end = NULL;
+
+  if (!start || !end)
+    {
+      gfc_free_expr (start);
+      gfc_free_expr (end);
+      return;
+    }
+
+  /* Length = (end - start +1).  */
+  e->ts.u.cl->length = gfc_subtract (end, start);
+  e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
+				gfc_get_int_expr (gfc_default_integer_kind,
+						  NULL, 1));
+
+  e->ts.u.cl->length->ts.type = BT_INTEGER;
+  e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
+
+  /* Make sure that the length is simplified.  */
+  gfc_simplify_expr (e->ts.u.cl->length, 1);
+  gfc_resolve_expr (e->ts.u.cl->length);
+}
+
+
+/* Resolve subtype references.  */
+
+static bool
+resolve_ref (gfc_expr *expr)
+{
+  int current_part_dimension, n_components, seen_part_dimension;
+  gfc_ref *ref;
+
+  for (ref = expr->ref; ref; ref = ref->next)
+    if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
+      {
+	find_array_spec (expr);
+	break;
+      }
+
+  for (ref = expr->ref; ref; ref = ref->next)
+    switch (ref->type)
+      {
+      case REF_ARRAY:
+	if (!resolve_array_ref (&ref->u.ar))
+	  return false;
+	break;
+
+      case REF_COMPONENT:
+	break;
+
+      case REF_SUBSTRING:
+	if (!resolve_substring (ref))
+	  return false;
+	break;
+      }
+
+  /* Check constraints on part references.  */
+
+  current_part_dimension = 0;
+  seen_part_dimension = 0;
+  n_components = 0;
+
+  for (ref = expr->ref; ref; ref = ref->next)
+    {
+      switch (ref->type)
+	{
+	case REF_ARRAY:
+	  switch (ref->u.ar.type)
+	    {
+	    case AR_FULL:
+	      /* Coarray scalar.  */
+	      if (ref->u.ar.as->rank == 0)
+		{
+		  current_part_dimension = 0;
+		  break;
+		}
+	      /* Fall through.  */
+	    case AR_SECTION:
+	      current_part_dimension = 1;
+	      break;
+
+	    case AR_ELEMENT:
+	      current_part_dimension = 0;
+	      break;
+
+	    case AR_UNKNOWN:
+	      gfc_internal_error ("resolve_ref(): Bad array reference");
+	    }
+
+	  break;
+
+	case REF_COMPONENT:
+	  if (current_part_dimension || seen_part_dimension)
+	    {
+	      /* F03:C614.  */
+	      if (ref->u.c.component->attr.pointer
+		  || ref->u.c.component->attr.proc_pointer
+		  || (ref->u.c.component->ts.type == BT_CLASS
+			&& CLASS_DATA (ref->u.c.component)->attr.pointer))
+		{
+		  gfc_error ("Component to the right of a part reference "
+			     "with nonzero rank must not have the POINTER "
+			     "attribute at %L", &expr->where);
+		  return false;
+		}
+	      else if (ref->u.c.component->attr.allocatable
+			|| (ref->u.c.component->ts.type == BT_CLASS
+			    && CLASS_DATA (ref->u.c.component)->attr.allocatable))
+
+		{
+		  gfc_error ("Component to the right of a part reference "
+			     "with nonzero rank must not have the ALLOCATABLE "
+			     "attribute at %L", &expr->where);
+		  return false;
+		}
+	    }
+
+	  n_components++;
+	  break;
+
+	case REF_SUBSTRING:
+	  break;
+	}
+
+      if (((ref->type == REF_COMPONENT && n_components > 1)
+	   || ref->next == NULL)
+	  && current_part_dimension
+	  && seen_part_dimension)
+	{
+	  gfc_error ("Two or more part references with nonzero rank must "
+		     "not be specified at %L", &expr->where);
+	  return false;
+	}
+
+      if (ref->type == REF_COMPONENT)
+	{
+	  if (current_part_dimension)
+	    seen_part_dimension = 1;
+
+	  /* reset to make sure */
+	  current_part_dimension = 0;
+	}
+    }
+
+  return true;
+}
+
+
+/* Given an expression, determine its shape.  This is easier than it sounds.
+   Leaves the shape array NULL if it is not possible to determine the shape.  */
+
+static void
+expression_shape (gfc_expr *e)
+{
+  mpz_t array[GFC_MAX_DIMENSIONS];
+  int i;
+
+  if (e->rank <= 0 || e->shape != NULL)
+    return;
+
+  for (i = 0; i < e->rank; i++)
+    if (!gfc_array_dimen_size (e, i, &array[i]))
+      goto fail;
+
+  e->shape = gfc_get_shape (e->rank);
+
+  memcpy (e->shape, array, e->rank * sizeof (mpz_t));
+
+  return;
+
+fail:
+  for (i--; i >= 0; i--)
+    mpz_clear (array[i]);
+}
+
+
+/* Given a variable expression node, compute the rank of the expression by
+   examining the base symbol and any reference structures it may have.  */
+
+static void
+expression_rank (gfc_expr *e)
+{
+  gfc_ref *ref;
+  int i, rank;
+
+  /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
+     could lead to serious confusion...  */
+  gcc_assert (e->expr_type != EXPR_COMPCALL);
+
+  if (e->ref == NULL)
+    {
+      if (e->expr_type == EXPR_ARRAY)
+	goto done;
+      /* Constructors can have a rank different from one via RESHAPE().  */
+
+      if (e->symtree == NULL)
+	{
+	  e->rank = 0;
+	  goto done;
+	}
+
+      e->rank = (e->symtree->n.sym->as == NULL)
+		? 0 : e->symtree->n.sym->as->rank;
+      goto done;
+    }
+
+  rank = 0;
+
+  for (ref = e->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer
+	  && ref->u.c.component->attr.function && !ref->next)
+	rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0;
+
+      if (ref->type != REF_ARRAY)
+	continue;
+
+      if (ref->u.ar.type == AR_FULL)
+	{
+	  rank = ref->u.ar.as->rank;
+	  break;
+	}
+
+      if (ref->u.ar.type == AR_SECTION)
+	{
+	  /* Figure out the rank of the section.  */
+	  if (rank != 0)
+	    gfc_internal_error ("expression_rank(): Two array specs");
+
+	  for (i = 0; i < ref->u.ar.dimen; i++)
+	    if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
+		|| ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
+	      rank++;
+
+	  break;
+	}
+    }
+
+  e->rank = rank;
+
+done:
+  expression_shape (e);
+}
+
+
+/* Resolve a variable expression.  */
+
+static bool
+resolve_variable (gfc_expr *e)
+{
+  gfc_symbol *sym;
+  bool t;
+
+  t = true;
+
+  if (e->symtree == NULL)
+    return false;
+  sym = e->symtree->n.sym;
+
+  /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
+     as ts.type is set to BT_ASSUMED in resolve_symbol.  */
+  if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
+    {
+      if (!actual_arg || inquiry_argument)
+	{
+	  gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
+		     "be used as actual argument", sym->name, &e->where);
+	  return false;
+	}
+    }
+  /* TS 29113, 407b.  */
+  else if (e->ts.type == BT_ASSUMED)
+    {
+      if (!actual_arg)
+	{
+	  gfc_error ("Assumed-type variable %s at %L may only be used "
+		     "as actual argument", sym->name, &e->where);
+	  return false;
+	}
+      else if (inquiry_argument && !first_actual_arg)
+	{
+	  /* FIXME: It doesn't work reliably as inquiry_argument is not set
+	     for all inquiry functions in resolve_function; the reason is
+	     that the function-name resolution happens too late in that
+	     function.  */
+	  gfc_error ("Assumed-type variable %s at %L as actual argument to "
+		     "an inquiry function shall be the first argument",
+		     sym->name, &e->where);
+	  return false;
+	}
+    }
+  /* TS 29113, C535b.  */
+  else if ((sym->ts.type == BT_CLASS && sym->attr.class_ok
+	    && CLASS_DATA (sym)->as
+	    && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
+	   || (sym->ts.type != BT_CLASS && sym->as
+	       && sym->as->type == AS_ASSUMED_RANK))
+    {
+      if (!actual_arg)
+	{
+	  gfc_error ("Assumed-rank variable %s at %L may only be used as "
+		     "actual argument", sym->name, &e->where);
+	  return false;
+	}
+      else if (inquiry_argument && !first_actual_arg)
+	{
+	  /* FIXME: It doesn't work reliably as inquiry_argument is not set
+	     for all inquiry functions in resolve_function; the reason is
+	     that the function-name resolution happens too late in that
+	     function.  */
+	  gfc_error ("Assumed-rank variable %s at %L as actual argument "
+		     "to an inquiry function shall be the first argument",
+		     sym->name, &e->where);
+	  return false;
+	}
+    }
+
+  if ((sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) && e->ref
+      && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
+	   && e->ref->next == NULL))
+    {
+      gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
+		 "a subobject reference", sym->name, &e->ref->u.ar.where);
+      return false;
+    }
+  /* TS 29113, 407b.  */
+  else if (e->ts.type == BT_ASSUMED && e->ref
+	   && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
+		&& e->ref->next == NULL))
+    {
+      gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
+		 "reference", sym->name, &e->ref->u.ar.where);
+      return false;
+    }
+
+  /* TS 29113, C535b.  */
+  if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
+	&& CLASS_DATA (sym)->as
+	&& CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
+       || (sym->ts.type != BT_CLASS && sym->as
+	   && sym->as->type == AS_ASSUMED_RANK))
+      && e->ref
+      && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
+	   && e->ref->next == NULL))
+    {
+      gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
+		 "reference", sym->name, &e->ref->u.ar.where);
+      return false;
+    }
+
+
+  /* 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.
+     TODO Understand why class scalar expressions must be excluded.  */
+  if (sym->assoc && !(sym->ts.type == BT_CLASS && e->rank == 0))
+    {
+      if (sym->ts.type == BT_CLASS)
+	gfc_fix_class_refs (e);
+      if (!sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
+	return false;
+    }
+
+  if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
+    sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
+
+  /* On the other hand, the parser may not have known this is an array;
+     in this case, we have to add a FULL reference.  */
+  if (sym->assoc && sym->attr.dimension && !e->ref)
+    {
+      e->ref = gfc_get_ref ();
+      e->ref->type = REF_ARRAY;
+      e->ref->u.ar.type = AR_FULL;
+      e->ref->u.ar.dimen = 0;
+    }
+
+  if (e->ref && !resolve_ref (e))
+    return false;
+
+  if (sym->attr.flavor == FL_PROCEDURE
+      && (!sym->attr.function
+	  || (sym->attr.function && sym->result
+	      && sym->result->attr.proc_pointer
+	      && !sym->result->attr.function)))
+    {
+      e->ts.type = BT_PROCEDURE;
+      goto resolve_procedure;
+    }
+
+  if (sym->ts.type != BT_UNKNOWN)
+    gfc_variable_attr (e, &e->ts);
+  else
+    {
+      /* Must be a simple variable reference.  */
+      if (!gfc_set_default_type (sym, 1, sym->ns))
+	return false;
+      e->ts = sym->ts;
+    }
+
+  if (check_assumed_size_reference (sym, e))
+    return false;
+
+  /* Deal with forward references to entries during resolve_code, to
+     satisfy, at least partially, 12.5.2.5.  */
+  if (gfc_current_ns->entries
+      && current_entry_id == sym->entry_id
+      && cs_base
+      && cs_base->current
+      && cs_base->current->op != EXEC_ENTRY)
+    {
+      gfc_entry_list *entry;
+      gfc_formal_arglist *formal;
+      int n;
+      bool seen, saved_specification_expr;
+
+      /* If the symbol is a dummy...  */
+      if (sym->attr.dummy && sym->ns == gfc_current_ns)
+	{
+	  entry = gfc_current_ns->entries;
+	  seen = false;
+
+	  /* ...test if the symbol is a parameter of previous entries.  */
+	  for (; entry && entry->id <= current_entry_id; entry = entry->next)
+	    for (formal = entry->sym->formal; formal; formal = formal->next)
+	      {
+		if (formal->sym && sym->name == formal->sym->name)
+		  {
+		    seen = true;
+		    break;
+		  }
+	      }
+
+	  /*  If it has not been seen as a dummy, this is an error.  */
+	  if (!seen)
+	    {
+	      if (specification_expr)
+		gfc_error ("Variable '%s', used in a specification expression"
+			   ", is referenced at %L before the ENTRY statement "
+			   "in which it is a parameter",
+			   sym->name, &cs_base->current->loc);
+	      else
+		gfc_error ("Variable '%s' is used at %L before the ENTRY "
+			   "statement in which it is a parameter",
+			   sym->name, &cs_base->current->loc);
+	      t = false;
+	    }
+	}
+
+      /* Now do the same check on the specification expressions.  */
+      saved_specification_expr = specification_expr;
+      specification_expr = true;
+      if (sym->ts.type == BT_CHARACTER
+	  && !gfc_resolve_expr (sym->ts.u.cl->length))
+	t = false;
+
+      if (sym->as)
+	for (n = 0; n < sym->as->rank; n++)
+	  {
+	     if (!gfc_resolve_expr (sym->as->lower[n]))
+	       t = false;
+	     if (!gfc_resolve_expr (sym->as->upper[n]))
+	       t = false;
+	  }
+      specification_expr = saved_specification_expr;
+
+      if (t)
+	/* Update the symbol's entry level.  */
+	sym->entry_id = current_entry_id + 1;
+    }
+
+  /* If a symbol has been host_associated mark it.  This is used latter,
+     to identify if aliasing is possible via host association.  */
+  if (sym->attr.flavor == FL_VARIABLE
+	&& gfc_current_ns->parent
+	&& (gfc_current_ns->parent == sym->ns
+	      || (gfc_current_ns->parent->parent
+		    && gfc_current_ns->parent->parent == sym->ns)))
+    sym->attr.host_assoc = 1;
+
+resolve_procedure:
+  if (t && !resolve_procedure_expression (e))
+    t = false;
+
+  /* F2008, C617 and C1229.  */
+  if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
+      && gfc_is_coindexed (e))
+    {
+      gfc_ref *ref, *ref2 = NULL;
+
+      for (ref = e->ref; ref; ref = ref->next)
+	{
+	  if (ref->type == REF_COMPONENT)
+	    ref2 = ref;
+	  if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
+	    break;
+	}
+
+      for ( ; ref; ref = ref->next)
+	if (ref->type == REF_COMPONENT)
+	  break;
+
+      /* Expression itself is not coindexed object.  */
+      if (ref && e->ts.type == BT_CLASS)
+	{
+	  gfc_error ("Polymorphic subobject of coindexed object at %L",
+		     &e->where);
+	  t = false;
+	}
+
+      /* Expression itself is coindexed object.  */
+      if (ref == NULL)
+	{
+	  gfc_component *c;
+	  c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
+	  for ( ; c; c = c->next)
+	    if (c->attr.allocatable && c->ts.type == BT_CLASS)
+	      {
+		gfc_error ("Coindexed object with polymorphic allocatable "
+			 "subcomponent at %L", &e->where);
+		t = false;
+		break;
+	      }
+	}
+    }
+
+  return t;
+}
+
+
+/* Checks to see that the correct symbol has been host associated.
+   The only situation where this arises is that in which a twice
+   contained function is parsed after the host association is made.
+   Therefore, on detecting this, change the symbol in the expression
+   and convert the array reference into an actual arglist if the old
+   symbol is a variable.  */
+static bool
+check_host_association (gfc_expr *e)
+{
+  gfc_symbol *sym, *old_sym;
+  gfc_symtree *st;
+  int n;
+  gfc_ref *ref;
+  gfc_actual_arglist *arg, *tail = NULL;
+  bool retval = e->expr_type == EXPR_FUNCTION;
+
+  /*  If the expression is the result of substitution in
+      interface.c(gfc_extend_expr) because there is no way in
+      which the host association can be wrong.  */
+  if (e->symtree == NULL
+	|| e->symtree->n.sym == NULL
+	|| e->user_operator)
+    return retval;
+
+  old_sym = e->symtree->n.sym;
+
+  if (gfc_current_ns->parent
+	&& old_sym->ns != gfc_current_ns)
+    {
+      /* Use the 'USE' name so that renamed module symbols are
+	 correctly handled.  */
+      gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
+
+      if (sym && old_sym != sym
+	      && sym->ts.type == old_sym->ts.type
+	      && sym->attr.flavor == FL_PROCEDURE
+	      && sym->attr.contained)
+	{
+	  /* Clear the shape, since it might not be valid.  */
+	  gfc_free_shape (&e->shape, e->rank);
+
+	  /* Give the expression the right symtree!  */
+	  gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
+	  gcc_assert (st != NULL);
+
+	  if (old_sym->attr.flavor == FL_PROCEDURE
+		|| e->expr_type == EXPR_FUNCTION)
+  	    {
+	      /* Original was function so point to the new symbol, since
+		 the actual argument list is already attached to the
+		 expression. */
+	      e->value.function.esym = NULL;
+	      e->symtree = st;
+	    }
+	  else
+	    {
+	      /* Original was variable so convert array references into
+		 an actual arglist. This does not need any checking now
+		 since resolve_function will take care of it.  */
+	      e->value.function.actual = NULL;
+	      e->expr_type = EXPR_FUNCTION;
+	      e->symtree = st;
+
+	      /* Ambiguity will not arise if the array reference is not
+		 the last reference.  */
+	      for (ref = e->ref; ref; ref = ref->next)
+		if (ref->type == REF_ARRAY && ref->next == NULL)
+		  break;
+
+	      gcc_assert (ref->type == REF_ARRAY);
+
+	      /* Grab the start expressions from the array ref and
+		 copy them into actual arguments.  */
+	      for (n = 0; n < ref->u.ar.dimen; n++)
+		{
+		  arg = gfc_get_actual_arglist ();
+		  arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
+		  if (e->value.function.actual == NULL)
+		    tail = e->value.function.actual = arg;
+	          else
+		    {
+		      tail->next = arg;
+		      tail = arg;
+		    }
+		}
+
+	      /* Dump the reference list and set the rank.  */
+	      gfc_free_ref_list (e->ref);
+	      e->ref = NULL;
+	      e->rank = sym->as ? sym->as->rank : 0;
+	    }
+
+	  gfc_resolve_expr (e);
+	  sym->refs++;
+	}
+    }
+  /* This might have changed!  */
+  return e->expr_type == EXPR_FUNCTION;
+}
+
+
+static void
+gfc_resolve_character_operator (gfc_expr *e)
+{
+  gfc_expr *op1 = e->value.op.op1;
+  gfc_expr *op2 = e->value.op.op2;
+  gfc_expr *e1 = NULL;
+  gfc_expr *e2 = NULL;
+
+  gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
+
+  if (op1->ts.u.cl && op1->ts.u.cl->length)
+    e1 = gfc_copy_expr (op1->ts.u.cl->length);
+  else if (op1->expr_type == EXPR_CONSTANT)
+    e1 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+			   op1->value.character.length);
+
+  if (op2->ts.u.cl && op2->ts.u.cl->length)
+    e2 = gfc_copy_expr (op2->ts.u.cl->length);
+  else if (op2->expr_type == EXPR_CONSTANT)
+    e2 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+			   op2->value.character.length);
+
+  e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+
+  if (!e1 || !e2)
+    {
+      gfc_free_expr (e1);
+      gfc_free_expr (e2);
+
+      return;
+    }
+
+  e->ts.u.cl->length = gfc_add (e1, e2);
+  e->ts.u.cl->length->ts.type = BT_INTEGER;
+  e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
+  gfc_simplify_expr (e->ts.u.cl->length, 0);
+  gfc_resolve_expr (e->ts.u.cl->length);
+
+  return;
+}
+
+
+/*  Ensure that an character expression has a charlen and, if possible, a
+    length expression.  */
+
+static void
+fixup_charlen (gfc_expr *e)
+{
+  /* The cases fall through so that changes in expression type and the need
+     for multiple fixes are picked up.  In all circumstances, a charlen should
+     be available for the middle end to hang a backend_decl on.  */
+  switch (e->expr_type)
+    {
+    case EXPR_OP:
+      gfc_resolve_character_operator (e);
+
+    case EXPR_ARRAY:
+      if (e->expr_type == EXPR_ARRAY)
+	gfc_resolve_character_array_constructor (e);
+
+    case EXPR_SUBSTRING:
+      if (!e->ts.u.cl && e->ref)
+	gfc_resolve_substring_charlen (e);
+
+    default:
+      if (!e->ts.u.cl)
+	e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+
+      break;
+    }
+}
+
+
+/* Update an actual argument to include the passed-object for type-bound
+   procedures at the right position.  */
+
+static gfc_actual_arglist*
+update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
+		     const char *name)
+{
+  gcc_assert (argpos > 0);
+
+  if (argpos == 1)
+    {
+      gfc_actual_arglist* result;
+
+      result = gfc_get_actual_arglist ();
+      result->expr = po;
+      result->next = lst;
+      if (name)
+        result->name = name;
+
+      return result;
+    }
+
+  if (lst)
+    lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
+  else
+    lst = update_arglist_pass (NULL, po, argpos - 1, name);
+  return lst;
+}
+
+
+/* Extract the passed-object from an EXPR_COMPCALL (a copy of it).  */
+
+static gfc_expr*
+extract_compcall_passed_object (gfc_expr* e)
+{
+  gfc_expr* po;
+
+  gcc_assert (e->expr_type == EXPR_COMPCALL);
+
+  if (e->value.compcall.base_object)
+    po = gfc_copy_expr (e->value.compcall.base_object);
+  else
+    {
+      po = gfc_get_expr ();
+      po->expr_type = EXPR_VARIABLE;
+      po->symtree = e->symtree;
+      po->ref = gfc_copy_ref (e->ref);
+      po->where = e->where;
+    }
+
+  if (!gfc_resolve_expr (po))
+    return NULL;
+
+  return po;
+}
+
+
+/* Update the arglist of an EXPR_COMPCALL expression to include the
+   passed-object.  */
+
+static bool
+update_compcall_arglist (gfc_expr* e)
+{
+  gfc_expr* po;
+  gfc_typebound_proc* tbp;
+
+  tbp = e->value.compcall.tbp;
+
+  if (tbp->error)
+    return false;
+
+  po = extract_compcall_passed_object (e);
+  if (!po)
+    return false;
+
+  if (tbp->nopass || e->value.compcall.ignore_pass)
+    {
+      gfc_free_expr (po);
+      return true;
+    }
+
+  gcc_assert (tbp->pass_arg_num > 0);
+  e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
+						  tbp->pass_arg_num,
+						  tbp->pass_arg);
+
+  return true;
+}
+
+
+/* Extract the passed object from a PPC call (a copy of it).  */
+
+static gfc_expr*
+extract_ppc_passed_object (gfc_expr *e)
+{
+  gfc_expr *po;
+  gfc_ref **ref;
+
+  po = gfc_get_expr ();
+  po->expr_type = EXPR_VARIABLE;
+  po->symtree = e->symtree;
+  po->ref = gfc_copy_ref (e->ref);
+  po->where = e->where;
+
+  /* Remove PPC reference.  */
+  ref = &po->ref;
+  while ((*ref)->next)
+    ref = &(*ref)->next;
+  gfc_free_ref_list (*ref);
+  *ref = NULL;
+
+  if (!gfc_resolve_expr (po))
+    return NULL;
+
+  return po;
+}
+
+
+/* Update the actual arglist of a procedure pointer component to include the
+   passed-object.  */
+
+static bool
+update_ppc_arglist (gfc_expr* e)
+{
+  gfc_expr* po;
+  gfc_component *ppc;
+  gfc_typebound_proc* tb;
+
+  ppc = gfc_get_proc_ptr_comp (e);
+  if (!ppc)
+    return false;
+
+  tb = ppc->tb;
+
+  if (tb->error)
+    return false;
+  else if (tb->nopass)
+    return true;
+
+  po = extract_ppc_passed_object (e);
+  if (!po)
+    return false;
+
+  /* F08:R739.  */
+  if (po->rank != 0)
+    {
+      gfc_error ("Passed-object at %L must be scalar", &e->where);
+      return false;
+    }
+
+  /* F08:C611.  */
+  if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
+    {
+      gfc_error ("Base object for procedure-pointer component call at %L is of"
+		 " ABSTRACT type '%s'", &e->where, po->ts.u.derived->name);
+      return false;
+    }
+
+  gcc_assert (tb->pass_arg_num > 0);
+  e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
+						  tb->pass_arg_num,
+						  tb->pass_arg);
+
+  return true;
+}
+
+
+/* Check that the object a TBP is called on is valid, i.e. it must not be
+   of ABSTRACT type (as in subobject%abstract_parent%tbp()).  */
+
+static bool
+check_typebound_baseobject (gfc_expr* e)
+{
+  gfc_expr* base;
+  bool return_value = false;
+
+  base = extract_compcall_passed_object (e);
+  if (!base)
+    return false;
+
+  gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
+
+  if (base->ts.type == BT_CLASS && !gfc_expr_attr (base).class_ok)
+    return false;
+
+  /* F08:C611.  */
+  if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
+    {
+      gfc_error ("Base object for type-bound procedure call at %L is of"
+		 " ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
+      goto cleanup;
+    }
+
+  /* F08:C1230. If the procedure called is NOPASS,
+     the base object must be scalar.  */
+  if (e->value.compcall.tbp->nopass && base->rank != 0)
+    {
+      gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
+		 " be scalar", &e->where);
+      goto cleanup;
+    }
+
+  return_value = true;
+
+cleanup:
+  gfc_free_expr (base);
+  return return_value;
+}
+
+
+/* Resolve a call to a type-bound procedure, either function or subroutine,
+   statically from the data in an EXPR_COMPCALL expression.  The adapted
+   arglist and the target-procedure symtree are returned.  */
+
+static bool
+resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
+			  gfc_actual_arglist** actual)
+{
+  gcc_assert (e->expr_type == EXPR_COMPCALL);
+  gcc_assert (!e->value.compcall.tbp->is_generic);
+
+  /* Update the actual arglist for PASS.  */
+  if (!update_compcall_arglist (e))
+    return false;
+
+  *actual = e->value.compcall.actual;
+  *target = e->value.compcall.tbp->u.specific;
+
+  gfc_free_ref_list (e->ref);
+  e->ref = NULL;
+  e->value.compcall.actual = NULL;
+
+  /* If we find a deferred typebound procedure, check for derived types
+     that an overriding typebound procedure has not been missed.  */
+  if (e->value.compcall.name
+      && !e->value.compcall.tbp->non_overridable
+      && e->value.compcall.base_object
+      && e->value.compcall.base_object->ts.type == BT_DERIVED)
+    {
+      gfc_symtree *st;
+      gfc_symbol *derived;
+
+      /* Use the derived type of the base_object.  */
+      derived = e->value.compcall.base_object->ts.u.derived;
+      st = NULL;
+
+      /* If necessary, go through the inheritance chain.  */
+      while (!st && derived)
+	{
+	  /* Look for the typebound procedure 'name'.  */
+	  if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
+	    st = gfc_find_symtree (derived->f2k_derived->tb_sym_root,
+				   e->value.compcall.name);
+	  if (!st)
+	    derived = gfc_get_derived_super_type (derived);
+	}
+
+      /* Now find the specific name in the derived type namespace.  */
+      if (st && st->n.tb && st->n.tb->u.specific)
+	gfc_find_sym_tree (st->n.tb->u.specific->name,
+			   derived->ns, 1, &st);
+      if (st)
+	*target = st;
+    }
+  return true;
+}
+
+
+/* Get the ultimate declared type from an expression.  In addition,
+   return the last class/derived type reference and the copy of the
+   reference list.  If check_types is set true, derived types are
+   identified as well as class references.  */
+static gfc_symbol*
+get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
+			gfc_expr *e, bool check_types)
+{
+  gfc_symbol *declared;
+  gfc_ref *ref;
+
+  declared = NULL;
+  if (class_ref)
+    *class_ref = NULL;
+  if (new_ref)
+    *new_ref = gfc_copy_ref (e->ref);
+
+  for (ref = e->ref; ref; ref = ref->next)
+    {
+      if (ref->type != REF_COMPONENT)
+	continue;
+
+      if ((ref->u.c.component->ts.type == BT_CLASS
+	     || (check_types && ref->u.c.component->ts.type == BT_DERIVED))
+	  && ref->u.c.component->attr.flavor != FL_PROCEDURE)
+	{
+	  declared = ref->u.c.component->ts.u.derived;
+	  if (class_ref)
+	    *class_ref = ref;
+	}
+    }
+
+  if (declared == NULL)
+    declared = e->symtree->n.sym->ts.u.derived;
+
+  return declared;
+}
+
+
+/* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
+   which of the specific bindings (if any) matches the arglist and transform
+   the expression into a call of that binding.  */
+
+static bool
+resolve_typebound_generic_call (gfc_expr* e, const char **name)
+{
+  gfc_typebound_proc* genproc;
+  const char* genname;
+  gfc_symtree *st;
+  gfc_symbol *derived;
+
+  gcc_assert (e->expr_type == EXPR_COMPCALL);
+  genname = e->value.compcall.name;
+  genproc = e->value.compcall.tbp;
+
+  if (!genproc->is_generic)
+    return true;
+
+  /* Try the bindings on this type and in the inheritance hierarchy.  */
+  for (; genproc; genproc = genproc->overridden)
+    {
+      gfc_tbp_generic* g;
+
+      gcc_assert (genproc->is_generic);
+      for (g = genproc->u.generic; g; g = g->next)
+	{
+	  gfc_symbol* target;
+	  gfc_actual_arglist* args;
+	  bool matches;
+
+	  gcc_assert (g->specific);
+
+	  if (g->specific->error)
+	    continue;
+
+	  target = g->specific->u.specific->n.sym;
+
+	  /* Get the right arglist by handling PASS/NOPASS.  */
+	  args = gfc_copy_actual_arglist (e->value.compcall.actual);
+	  if (!g->specific->nopass)
+	    {
+	      gfc_expr* po;
+	      po = extract_compcall_passed_object (e);
+	      if (!po)
+		{
+		  gfc_free_actual_arglist (args);
+		  return false;
+		}
+
+	      gcc_assert (g->specific->pass_arg_num > 0);
+	      gcc_assert (!g->specific->error);
+	      args = update_arglist_pass (args, po, g->specific->pass_arg_num,
+					  g->specific->pass_arg);
+	    }
+	  resolve_actual_arglist (args, target->attr.proc,
+				  is_external_proc (target)
+				  && gfc_sym_get_dummy_args (target) == NULL);
+
+	  /* Check if this arglist matches the formal.  */
+	  matches = gfc_arglist_matches_symbol (&args, target);
+
+	  /* Clean up and break out of the loop if we've found it.  */
+	  gfc_free_actual_arglist (args);
+	  if (matches)
+	    {
+	      e->value.compcall.tbp = g->specific;
+	      genname = g->specific_st->name;
+	      /* Pass along the name for CLASS methods, where the vtab
+		 procedure pointer component has to be referenced.  */
+	      if (name)
+		*name = genname;
+	      goto success;
+	    }
+	}
+    }
+
+  /* Nothing matching found!  */
+  gfc_error ("Found no matching specific binding for the call to the GENERIC"
+	     " '%s' at %L", genname, &e->where);
+  return false;
+
+success:
+  /* Make sure that we have the right specific instance for the name.  */
+  derived = get_declared_from_expr (NULL, NULL, e, true);
+
+  st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
+  if (st)
+    e->value.compcall.tbp = st->n.tb;
+
+  return true;
+}
+
+
+/* Resolve a call to a type-bound subroutine.  */
+
+static bool
+resolve_typebound_call (gfc_code* c, const char **name)
+{
+  gfc_actual_arglist* newactual;
+  gfc_symtree* target;
+
+  /* Check that's really a SUBROUTINE.  */
+  if (!c->expr1->value.compcall.tbp->subroutine)
+    {
+      gfc_error ("'%s' at %L should be a SUBROUTINE",
+		 c->expr1->value.compcall.name, &c->loc);
+      return false;
+    }
+
+  if (!check_typebound_baseobject (c->expr1))
+    return false;
+
+  /* Pass along the name for CLASS methods, where the vtab
+     procedure pointer component has to be referenced.  */
+  if (name)
+    *name = c->expr1->value.compcall.name;
+
+  if (!resolve_typebound_generic_call (c->expr1, name))
+    return false;
+
+  /* Transform into an ordinary EXEC_CALL for now.  */
+
+  if (!resolve_typebound_static (c->expr1, &target, &newactual))
+    return false;
+
+  c->ext.actual = newactual;
+  c->symtree = target;
+  c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
+
+  gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
+
+  gfc_free_expr (c->expr1);
+  c->expr1 = gfc_get_expr ();
+  c->expr1->expr_type = EXPR_FUNCTION;
+  c->expr1->symtree = target;
+  c->expr1->where = c->loc;
+
+  return resolve_call (c);
+}
+
+
+/* Resolve a component-call expression.  */
+static bool
+resolve_compcall (gfc_expr* e, const char **name)
+{
+  gfc_actual_arglist* newactual;
+  gfc_symtree* target;
+
+  /* Check that's really a FUNCTION.  */
+  if (!e->value.compcall.tbp->function)
+    {
+      gfc_error ("'%s' at %L should be a FUNCTION",
+		 e->value.compcall.name, &e->where);
+      return false;
+    }
+
+  /* These must not be assign-calls!  */
+  gcc_assert (!e->value.compcall.assign);
+
+  if (!check_typebound_baseobject (e))
+    return false;
+
+  /* Pass along the name for CLASS methods, where the vtab
+     procedure pointer component has to be referenced.  */
+  if (name)
+    *name = e->value.compcall.name;
+
+  if (!resolve_typebound_generic_call (e, name))
+    return false;
+  gcc_assert (!e->value.compcall.tbp->is_generic);
+
+  /* Take the rank from the function's symbol.  */
+  if (e->value.compcall.tbp->u.specific->n.sym->as)
+    e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
+
+  /* For now, we simply transform it into an EXPR_FUNCTION call with the same
+     arglist to the TBP's binding target.  */
+
+  if (!resolve_typebound_static (e, &target, &newactual))
+    return false;
+
+  e->value.function.actual = newactual;
+  e->value.function.name = NULL;
+  e->value.function.esym = target->n.sym;
+  e->value.function.isym = NULL;
+  e->symtree = target;
+  e->ts = target->n.sym->ts;
+  e->expr_type = EXPR_FUNCTION;
+
+  /* Resolution is not necessary if this is a class subroutine; this
+     function only has to identify the specific proc. Resolution of
+     the call will be done next in resolve_typebound_call.  */
+  return gfc_resolve_expr (e);
+}
+
+
+static bool resolve_fl_derived (gfc_symbol *sym);
+
+
+/* Resolve a typebound function, or 'method'. First separate all
+   the non-CLASS references by calling resolve_compcall directly.  */
+
+static bool
+resolve_typebound_function (gfc_expr* e)
+{
+  gfc_symbol *declared;
+  gfc_component *c;
+  gfc_ref *new_ref;
+  gfc_ref *class_ref;
+  gfc_symtree *st;
+  const char *name;
+  gfc_typespec ts;
+  gfc_expr *expr;
+  bool overridable;
+
+  st = e->symtree;
+
+  /* Deal with typebound operators for CLASS objects.  */
+  expr = e->value.compcall.base_object;
+  overridable = !e->value.compcall.tbp->non_overridable;
+  if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
+    {
+      /* If the base_object is not a variable, the corresponding actual
+	 argument expression must be stored in e->base_expression so
+	 that the corresponding tree temporary can be used as the base
+	 object in gfc_conv_procedure_call.  */
+      if (expr->expr_type != EXPR_VARIABLE)
+	{
+	  gfc_actual_arglist *args;
+
+	  for (args= e->value.function.actual; args; args = args->next)
+	    {
+	      if (expr == args->expr)
+		expr = args->expr;
+	    }
+	}
+
+      /* Since the typebound operators are generic, we have to ensure
+	 that any delays in resolution are corrected and that the vtab
+	 is present.  */
+      ts = expr->ts;
+      declared = ts.u.derived;
+      c = gfc_find_component (declared, "_vptr", true, true);
+      if (c->ts.u.derived == NULL)
+	c->ts.u.derived = gfc_find_derived_vtab (declared);
+
+      if (!resolve_compcall (e, &name))
+	return false;
+
+      /* Use the generic name if it is there.  */
+      name = name ? name : e->value.function.esym->name;
+      e->symtree = expr->symtree;
+      e->ref = gfc_copy_ref (expr->ref);
+      get_declared_from_expr (&class_ref, NULL, e, false);
+
+      /* Trim away the extraneous references that emerge from nested
+	 use of interface.c (extend_expr).  */
+      if (class_ref && class_ref->next)
+	{
+	  gfc_free_ref_list (class_ref->next);
+	  class_ref->next = NULL;
+	}
+      else if (e->ref && !class_ref)
+	{
+	  gfc_free_ref_list (e->ref);
+	  e->ref = NULL;
+	}
+
+      gfc_add_vptr_component (e);
+      gfc_add_component_ref (e, name);
+      e->value.function.esym = NULL;
+      if (expr->expr_type != EXPR_VARIABLE)
+	e->base_expr = expr;
+      return true;
+    }
+
+  if (st == NULL)
+    return resolve_compcall (e, NULL);
+
+  if (!resolve_ref (e))
+    return false;
+
+  /* Get the CLASS declared type.  */
+  declared = get_declared_from_expr (&class_ref, &new_ref, e, true);
+  
+  if (!resolve_fl_derived (declared))
+    return false;
+
+  /* Weed out cases of the ultimate component being a derived type.  */
+  if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
+	 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
+    {
+      gfc_free_ref_list (new_ref);
+      return resolve_compcall (e, NULL);
+    }
+
+  c = gfc_find_component (declared, "_data", true, true);
+  declared = c->ts.u.derived;
+
+  /* Treat the call as if it is a typebound procedure, in order to roll
+     out the correct name for the specific function.  */
+  if (!resolve_compcall (e, &name))
+    {
+      gfc_free_ref_list (new_ref);
+      return false;
+    }
+  ts = e->ts;
+
+  if (overridable)
+    {
+      /* Convert the expression to a procedure pointer component call.  */
+      e->value.function.esym = NULL;
+      e->symtree = st;
+
+      if (new_ref)
+	e->ref = new_ref;
+
+      /* '_vptr' points to the vtab, which contains the procedure pointers.  */
+      gfc_add_vptr_component (e);
+      gfc_add_component_ref (e, name);
+
+      /* Recover the typespec for the expression.  This is really only
+	necessary for generic procedures, where the additional call
+	to gfc_add_component_ref seems to throw the collection of the
+	correct typespec.  */
+      e->ts = ts;
+    }
+  else if (new_ref)
+    gfc_free_ref_list (new_ref);
+
+  return true;
+}
+
+/* Resolve a typebound subroutine, or 'method'. First separate all
+   the non-CLASS references by calling resolve_typebound_call
+   directly.  */
+
+static bool
+resolve_typebound_subroutine (gfc_code *code)
+{
+  gfc_symbol *declared;
+  gfc_component *c;
+  gfc_ref *new_ref;
+  gfc_ref *class_ref;
+  gfc_symtree *st;
+  const char *name;
+  gfc_typespec ts;
+  gfc_expr *expr;
+  bool overridable;
+
+  st = code->expr1->symtree;
+
+  /* Deal with typebound operators for CLASS objects.  */
+  expr = code->expr1->value.compcall.base_object;
+  overridable = !code->expr1->value.compcall.tbp->non_overridable;
+  if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name)
+    {
+      /* If the base_object is not a variable, the corresponding actual
+	 argument expression must be stored in e->base_expression so
+	 that the corresponding tree temporary can be used as the base
+	 object in gfc_conv_procedure_call.  */
+      if (expr->expr_type != EXPR_VARIABLE)
+	{
+	  gfc_actual_arglist *args;
+
+	  args= code->expr1->value.function.actual;
+	  for (; args; args = args->next)
+	    if (expr == args->expr)
+	      expr = args->expr;
+	}
+
+      /* Since the typebound operators are generic, we have to ensure
+	 that any delays in resolution are corrected and that the vtab
+	 is present.  */
+      declared = expr->ts.u.derived;
+      c = gfc_find_component (declared, "_vptr", true, true);
+      if (c->ts.u.derived == NULL)
+	c->ts.u.derived = gfc_find_derived_vtab (declared);
+
+      if (!resolve_typebound_call (code, &name))
+	return false;
+
+      /* Use the generic name if it is there.  */
+      name = name ? name : code->expr1->value.function.esym->name;
+      code->expr1->symtree = expr->symtree;
+      code->expr1->ref = gfc_copy_ref (expr->ref);
+
+      /* Trim away the extraneous references that emerge from nested
+	 use of interface.c (extend_expr).  */
+      get_declared_from_expr (&class_ref, NULL, code->expr1, false);
+      if (class_ref && class_ref->next)
+	{
+	  gfc_free_ref_list (class_ref->next);
+	  class_ref->next = NULL;
+	}
+      else if (code->expr1->ref && !class_ref)
+	{
+	  gfc_free_ref_list (code->expr1->ref);
+	  code->expr1->ref = NULL;
+	}
+
+      /* Now use the procedure in the vtable.  */
+      gfc_add_vptr_component (code->expr1);
+      gfc_add_component_ref (code->expr1, name);
+      code->expr1->value.function.esym = NULL;
+      if (expr->expr_type != EXPR_VARIABLE)
+	code->expr1->base_expr = expr;
+      return true;
+    }
+
+  if (st == NULL)
+    return resolve_typebound_call (code, NULL);
+
+  if (!resolve_ref (code->expr1))
+    return false;
+
+  /* Get the CLASS declared type.  */
+  get_declared_from_expr (&class_ref, &new_ref, code->expr1, true);
+
+  /* Weed out cases of the ultimate component being a derived type.  */
+  if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
+	 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
+    {
+      gfc_free_ref_list (new_ref);
+      return resolve_typebound_call (code, NULL);
+    }
+
+  if (!resolve_typebound_call (code, &name))
+    {
+      gfc_free_ref_list (new_ref);
+      return false;
+    }
+  ts = code->expr1->ts;
+
+  if (overridable)
+    {
+      /* Convert the expression to a procedure pointer component call.  */
+      code->expr1->value.function.esym = NULL;
+      code->expr1->symtree = st;
+
+      if (new_ref)
+	code->expr1->ref = new_ref;
+
+      /* '_vptr' points to the vtab, which contains the procedure pointers.  */
+      gfc_add_vptr_component (code->expr1);
+      gfc_add_component_ref (code->expr1, name);
+
+      /* Recover the typespec for the expression.  This is really only
+	necessary for generic procedures, where the additional call
+	to gfc_add_component_ref seems to throw the collection of the
+	correct typespec.  */
+      code->expr1->ts = ts;
+    }
+  else if (new_ref)
+    gfc_free_ref_list (new_ref);
+
+  return true;
+}
+
+
+/* Resolve a CALL to a Procedure Pointer Component (Subroutine).  */
+
+static bool
+resolve_ppc_call (gfc_code* c)
+{
+  gfc_component *comp;
+
+  comp = gfc_get_proc_ptr_comp (c->expr1);
+  gcc_assert (comp != NULL);
+
+  c->resolved_sym = c->expr1->symtree->n.sym;
+  c->expr1->expr_type = EXPR_VARIABLE;
+
+  if (!comp->attr.subroutine)
+    gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
+
+  if (!resolve_ref (c->expr1))
+    return false;
+
+  if (!update_ppc_arglist (c->expr1))
+    return false;
+
+  c->ext.actual = c->expr1->value.compcall.actual;
+
+  if (!resolve_actual_arglist (c->ext.actual, comp->attr.proc, 
+			       !(comp->ts.interface 
+				 && comp->ts.interface->formal)))
+    return false;
+
+  gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
+
+  return true;
+}
+
+
+/* Resolve a Function Call to a Procedure Pointer Component (Function).  */
+
+static bool
+resolve_expr_ppc (gfc_expr* e)
+{
+  gfc_component *comp;
+
+  comp = gfc_get_proc_ptr_comp (e);
+  gcc_assert (comp != NULL);
+
+  /* Convert to EXPR_FUNCTION.  */
+  e->expr_type = EXPR_FUNCTION;
+  e->value.function.isym = NULL;
+  e->value.function.actual = e->value.compcall.actual;
+  e->ts = comp->ts;
+  if (comp->as != NULL)
+    e->rank = comp->as->rank;
+
+  if (!comp->attr.function)
+    gfc_add_function (&comp->attr, comp->name, &e->where);
+
+  if (!resolve_ref (e))
+    return false;
+
+  if (!resolve_actual_arglist (e->value.function.actual, comp->attr.proc, 
+			       !(comp->ts.interface 
+				 && comp->ts.interface->formal)))
+    return false;
+
+  if (!update_ppc_arglist (e))
+    return false;
+
+  gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
+
+  return true;
+}
+
+
+static bool
+gfc_is_expandable_expr (gfc_expr *e)
+{
+  gfc_constructor *con;
+
+  if (e->expr_type == EXPR_ARRAY)
+    {
+      /* Traverse the constructor looking for variables that are flavor
+	 parameter.  Parameters must be expanded since they are fully used at
+	 compile time.  */
+      con = gfc_constructor_first (e->value.constructor);
+      for (; con; con = gfc_constructor_next (con))
+	{
+	  if (con->expr->expr_type == EXPR_VARIABLE
+	      && con->expr->symtree
+	      && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
+	      || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
+	    return true;
+	  if (con->expr->expr_type == EXPR_ARRAY
+	      && gfc_is_expandable_expr (con->expr))
+	    return true;
+	}
+    }
+
+  return false;
+}
+
+/* Resolve an expression.  That is, make sure that types of operands agree
+   with their operators, intrinsic operators are converted to function calls
+   for overloaded types and unresolved function references are resolved.  */
+
+bool
+gfc_resolve_expr (gfc_expr *e)
+{
+  bool t;
+  bool inquiry_save, actual_arg_save, first_actual_arg_save;
+
+  if (e == NULL)
+    return true;
+
+  /* inquiry_argument only applies to variables.  */
+  inquiry_save = inquiry_argument;
+  actual_arg_save = actual_arg;
+  first_actual_arg_save = first_actual_arg;
+
+  if (e->expr_type != EXPR_VARIABLE)
+    {
+      inquiry_argument = false;
+      actual_arg = false;
+      first_actual_arg = false;
+    }
+
+  switch (e->expr_type)
+    {
+    case EXPR_OP:
+      t = resolve_operator (e);
+      break;
+
+    case EXPR_FUNCTION:
+    case EXPR_VARIABLE:
+
+      if (check_host_association (e))
+	t = resolve_function (e);
+      else
+	{
+	  t = resolve_variable (e);
+	  if (t)
+	    expression_rank (e);
+	}
+
+      if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
+	  && e->ref->type != REF_SUBSTRING)
+	gfc_resolve_substring_charlen (e);
+
+      break;
+
+    case EXPR_COMPCALL:
+      t = resolve_typebound_function (e);
+      break;
+
+    case EXPR_SUBSTRING:
+      t = resolve_ref (e);
+      break;
+
+    case EXPR_CONSTANT:
+    case EXPR_NULL:
+      t = true;
+      break;
+
+    case EXPR_PPC:
+      t = resolve_expr_ppc (e);
+      break;
+
+    case EXPR_ARRAY:
+      t = false;
+      if (!resolve_ref (e))
+	break;
+
+      t = gfc_resolve_array_constructor (e);
+      /* Also try to expand a constructor.  */
+      if (t)
+	{
+	  expression_rank (e);
+	  if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
+	    gfc_expand_constructor (e, false);
+	}
+
+      /* This provides the opportunity for the length of constructors with
+	 character valued function elements to propagate the string length
+	 to the expression.  */
+      if (t && e->ts.type == BT_CHARACTER)
+        {
+	  /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
+	     here rather then add a duplicate test for it above.  */
+	  gfc_expand_constructor (e, false);
+	  t = gfc_resolve_character_array_constructor (e);
+	}
+
+      break;
+
+    case EXPR_STRUCTURE:
+      t = resolve_ref (e);
+      if (!t)
+	break;
+
+      t = resolve_structure_cons (e, 0);
+      if (!t)
+	break;
+
+      t = gfc_simplify_expr (e, 0);
+      break;
+
+    default:
+      gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
+    }
+
+  if (e->ts.type == BT_CHARACTER && t && !e->ts.u.cl)
+    fixup_charlen (e);
+
+  inquiry_argument = inquiry_save;
+  actual_arg = actual_arg_save;
+  first_actual_arg = first_actual_arg_save;
+
+  return t;
+}
+
+
+/* Resolve an expression from an iterator.  They must be scalar and have
+   INTEGER or (optionally) REAL type.  */
+
+static bool
+gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
+			   const char *name_msgid)
+{
+  if (!gfc_resolve_expr (expr))
+    return false;
+
+  if (expr->rank != 0)
+    {
+      gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
+      return false;
+    }
+
+  if (expr->ts.type != BT_INTEGER)
+    {
+      if (expr->ts.type == BT_REAL)
+	{
+	  if (real_ok)
+	    return gfc_notify_std (GFC_STD_F95_DEL,
+				   "%s at %L must be integer",
+				   _(name_msgid), &expr->where);
+	  else
+	    {
+	      gfc_error ("%s at %L must be INTEGER", _(name_msgid),
+			 &expr->where);
+	      return false;
+	    }
+	}
+      else
+	{
+	  gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
+	  return false;
+	}
+    }
+  return true;
+}
+
+
+/* Resolve the expressions in an iterator structure.  If REAL_OK is
+   false allow only INTEGER type iterators, otherwise allow REAL types.
+   Set own_scope to true for ac-implied-do and data-implied-do as those
+   have a separate scope such that, e.g., a INTENT(IN) doesn't apply.  */
+
+bool
+gfc_resolve_iterator (gfc_iterator *iter, bool real_ok, bool own_scope)
+{
+  if (!gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable"))
+    return false;
+
+  if (!gfc_check_vardef_context (iter->var, false, false, own_scope, 
+				 _("iterator variable")))
+    return false;
+
+  if (!gfc_resolve_iterator_expr (iter->start, real_ok, 
+				  "Start expression in DO loop"))
+    return false;
+
+  if (!gfc_resolve_iterator_expr (iter->end, real_ok, 
+				  "End expression in DO loop"))
+    return false;
+
+  if (!gfc_resolve_iterator_expr (iter->step, real_ok, 
+				  "Step expression in DO loop"))
+    return false;
+
+  if (iter->step->expr_type == EXPR_CONSTANT)
+    {
+      if ((iter->step->ts.type == BT_INTEGER
+	   && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
+	  || (iter->step->ts.type == BT_REAL
+	      && mpfr_sgn (iter->step->value.real) == 0))
+	{
+	  gfc_error ("Step expression in DO loop at %L cannot be zero",
+		     &iter->step->where);
+	  return false;
+	}
+    }
+
+  /* Convert start, end, and step to the same type as var.  */
+  if (iter->start->ts.kind != iter->var->ts.kind
+      || iter->start->ts.type != iter->var->ts.type)
+    gfc_convert_type (iter->start, &iter->var->ts, 2);
+
+  if (iter->end->ts.kind != iter->var->ts.kind
+      || iter->end->ts.type != iter->var->ts.type)
+    gfc_convert_type (iter->end, &iter->var->ts, 2);
+
+  if (iter->step->ts.kind != iter->var->ts.kind
+      || iter->step->ts.type != iter->var->ts.type)
+    gfc_convert_type (iter->step, &iter->var->ts, 2);
+
+  if (iter->start->expr_type == EXPR_CONSTANT
+      && iter->end->expr_type == EXPR_CONSTANT
+      && iter->step->expr_type == EXPR_CONSTANT)
+    {
+      int sgn, cmp;
+      if (iter->start->ts.type == BT_INTEGER)
+	{
+	  sgn = mpz_cmp_ui (iter->step->value.integer, 0);
+	  cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
+	}
+      else
+	{
+	  sgn = mpfr_sgn (iter->step->value.real);
+	  cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
+	}
+      if (gfc_option.warn_zerotrip &&
+	  ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0)))
+	gfc_warning ("DO loop at %L will be executed zero times"
+		     " (use -Wno-zerotrip to suppress)",
+		     &iter->step->where);
+    }
+
+  return true;
+}
+
+
+/* Traversal function for find_forall_index.  f == 2 signals that
+   that variable itself is not to be checked - only the references.  */
+
+static bool
+forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
+{
+  if (expr->expr_type != EXPR_VARIABLE)
+    return false;
+
+  /* A scalar assignment  */
+  if (!expr->ref || *f == 1)
+    {
+      if (expr->symtree->n.sym == sym)
+	return true;
+      else
+	return false;
+    }
+
+  if (*f == 2)
+    *f = 1;
+  return false;
+}
+
+
+/* Check whether the FORALL index appears in the expression or not.
+   Returns true if SYM is found in EXPR.  */
+
+bool
+find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
+{
+  if (gfc_traverse_expr (expr, sym, forall_index, f))
+    return true;
+  else
+    return false;
+}
+
+
+/* Resolve a list of FORALL iterators.  The FORALL index-name is constrained
+   to be a scalar INTEGER variable.  The subscripts and stride are scalar
+   INTEGERs, and if stride is a constant it must be nonzero.
+   Furthermore "A subscript or stride in a forall-triplet-spec shall
+   not contain a reference to any index-name in the
+   forall-triplet-spec-list in which it appears." (7.5.4.1)  */
+
+static void
+resolve_forall_iterators (gfc_forall_iterator *it)
+{
+  gfc_forall_iterator *iter, *iter2;
+
+  for (iter = it; iter; iter = iter->next)
+    {
+      if (gfc_resolve_expr (iter->var)
+	  && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
+	gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
+		   &iter->var->where);
+
+      if (gfc_resolve_expr (iter->start)
+	  && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
+	gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
+		   &iter->start->where);
+      if (iter->var->ts.kind != iter->start->ts.kind)
+	gfc_convert_type (iter->start, &iter->var->ts, 1);
+
+      if (gfc_resolve_expr (iter->end)
+	  && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
+	gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
+		   &iter->end->where);
+      if (iter->var->ts.kind != iter->end->ts.kind)
+	gfc_convert_type (iter->end, &iter->var->ts, 1);
+
+      if (gfc_resolve_expr (iter->stride))
+	{
+	  if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
+	    gfc_error ("FORALL stride expression at %L must be a scalar %s",
+		       &iter->stride->where, "INTEGER");
+
+	  if (iter->stride->expr_type == EXPR_CONSTANT
+	      && mpz_cmp_ui (iter->stride->value.integer, 0) == 0)
+	    gfc_error ("FORALL stride expression at %L cannot be zero",
+		       &iter->stride->where);
+	}
+      if (iter->var->ts.kind != iter->stride->ts.kind)
+	gfc_convert_type (iter->stride, &iter->var->ts, 1);
+    }
+
+  for (iter = it; iter; iter = iter->next)
+    for (iter2 = iter; iter2; iter2 = iter2->next)
+      {
+	if (find_forall_index (iter2->start, iter->var->symtree->n.sym, 0)
+	    || find_forall_index (iter2->end, iter->var->symtree->n.sym, 0)
+	    || find_forall_index (iter2->stride, iter->var->symtree->n.sym, 0))
+	  gfc_error ("FORALL index '%s' may not appear in triplet "
+		     "specification at %L", iter->var->symtree->name,
+		     &iter2->start->where);
+      }
+}
+
+
+/* Given a pointer to a symbol that is a derived type, see if it's
+   inaccessible, i.e. if it's defined in another module and the components are
+   PRIVATE.  The search is recursive if necessary.  Returns zero if no
+   inaccessible components are found, nonzero otherwise.  */
+
+static int
+derived_inaccessible (gfc_symbol *sym)
+{
+  gfc_component *c;
+
+  if (sym->attr.use_assoc && sym->attr.private_comp)
+    return 1;
+
+  for (c = sym->components; c; c = c->next)
+    {
+	if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
+	  return 1;
+    }
+
+  return 0;
+}
+
+
+/* Resolve the argument of a deallocate expression.  The expression must be
+   a pointer or a full array.  */
+
+static bool
+resolve_deallocate_expr (gfc_expr *e)
+{
+  symbol_attribute attr;
+  int allocatable, pointer;
+  gfc_ref *ref;
+  gfc_symbol *sym;
+  gfc_component *c;
+  bool unlimited;
+
+  if (!gfc_resolve_expr (e))
+    return false;
+
+  if (e->expr_type != EXPR_VARIABLE)
+    goto bad;
+
+  sym = e->symtree->n.sym;
+  unlimited = UNLIMITED_POLY(sym);
+
+  if (sym->ts.type == BT_CLASS)
+    {
+      allocatable = CLASS_DATA (sym)->attr.allocatable;
+      pointer = CLASS_DATA (sym)->attr.class_pointer;
+    }
+  else
+    {
+      allocatable = sym->attr.allocatable;
+      pointer = sym->attr.pointer;
+    }
+  for (ref = e->ref; ref; ref = ref->next)
+    {
+      switch (ref->type)
+	{
+	case REF_ARRAY:
+	  if (ref->u.ar.type != AR_FULL
+	      && !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0
+	           && ref->u.ar.codimen && gfc_ref_this_image (ref)))
+	    allocatable = 0;
+	  break;
+
+	case REF_COMPONENT:
+	  c = ref->u.c.component;
+	  if (c->ts.type == BT_CLASS)
+	    {
+	      allocatable = CLASS_DATA (c)->attr.allocatable;
+	      pointer = CLASS_DATA (c)->attr.class_pointer;
+	    }
+	  else
+	    {
+	      allocatable = c->attr.allocatable;
+	      pointer = c->attr.pointer;
+	    }
+	  break;
+
+	case REF_SUBSTRING:
+	  allocatable = 0;
+	  break;
+	}
+    }
+
+  attr = gfc_expr_attr (e);
+
+  if (allocatable == 0 && attr.pointer == 0 && !unlimited)
+    {
+    bad:
+      gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
+		 &e->where);
+      return false;
+    }
+
+  /* F2008, C644.  */
+  if (gfc_is_coindexed (e))
+    {
+      gfc_error ("Coindexed allocatable object at %L", &e->where);
+      return false;
+    }
+
+  if (pointer
+      && !gfc_check_vardef_context (e, true, true, false, 
+				    _("DEALLOCATE object")))
+    return false;
+  if (!gfc_check_vardef_context (e, false, true, false, 
+				 _("DEALLOCATE object")))
+    return false;
+
+  return true;
+}
+
+
+/* Returns true if the expression e contains a reference to the symbol sym.  */
+static bool
+sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
+{
+  if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
+    return true;
+
+  return false;
+}
+
+bool
+gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
+{
+  return gfc_traverse_expr (e, sym, sym_in_expr, 0);
+}
+
+
+/* Given the expression node e for an allocatable/pointer of derived type to be
+   allocated, get the expression node to be initialized afterwards (needed for
+   derived types with default initializers, and derived types with allocatable
+   components that need nullification.)  */
+
+gfc_expr *
+gfc_expr_to_initialize (gfc_expr *e)
+{
+  gfc_expr *result;
+  gfc_ref *ref;
+  int i;
+
+  result = gfc_copy_expr (e);
+
+  /* Change the last array reference from AR_ELEMENT to AR_FULL.  */
+  for (ref = result->ref; ref; ref = ref->next)
+    if (ref->type == REF_ARRAY && ref->next == NULL)
+      {
+	ref->u.ar.type = AR_FULL;
+
+	for (i = 0; i < ref->u.ar.dimen; i++)
+	  ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
+
+	break;
+      }
+
+  gfc_free_shape (&result->shape, result->rank);
+
+  /* Recalculate rank, shape, etc.  */
+  gfc_resolve_expr (result);
+  return result;
+}
+
+
+/* If the last ref of an expression is an array ref, return a copy of the
+   expression with that one removed.  Otherwise, a copy of the original
+   expression.  This is used for allocate-expressions and pointer assignment
+   LHS, where there may be an array specification that needs to be stripped
+   off when using gfc_check_vardef_context.  */
+
+static gfc_expr*
+remove_last_array_ref (gfc_expr* e)
+{
+  gfc_expr* e2;
+  gfc_ref** r;
+
+  e2 = gfc_copy_expr (e);
+  for (r = &e2->ref; *r; r = &(*r)->next)
+    if ((*r)->type == REF_ARRAY && !(*r)->next)
+      {
+	gfc_free_ref_list (*r);
+	*r = NULL;
+	break;
+      }
+
+  return e2;
+}
+
+
+/* Used in resolve_allocate_expr to check that a allocation-object and
+   a source-expr are conformable.  This does not catch all possible
+   cases; in particular a runtime checking is needed.  */
+
+static bool
+conformable_arrays (gfc_expr *e1, gfc_expr *e2)
+{
+  gfc_ref *tail;
+  for (tail = e2->ref; tail && tail->next; tail = tail->next);
+
+  /* First compare rank.  */
+  if ((tail && e1->rank != tail->u.ar.as->rank)
+      || (!tail && e1->rank != e2->rank))
+    {
+      gfc_error ("Source-expr at %L must be scalar or have the "
+		 "same rank as the allocate-object at %L",
+		 &e1->where, &e2->where);
+      return false;
+    }
+
+  if (e1->shape)
+    {
+      int i;
+      mpz_t s;
+
+      mpz_init (s);
+
+      for (i = 0; i < e1->rank; i++)
+	{
+	  if (tail->u.ar.start[i] == NULL)
+	    break;
+
+	  if (tail->u.ar.end[i])
+	    {
+	      mpz_set (s, tail->u.ar.end[i]->value.integer);
+	      mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
+	      mpz_add_ui (s, s, 1);
+	    }
+	  else
+	    {
+	      mpz_set (s, tail->u.ar.start[i]->value.integer);
+	    }
+
+	  if (mpz_cmp (e1->shape[i], s) != 0)
+	    {
+	      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;
+	    }
+	}
+
+      mpz_clear (s);
+    }
+
+  return true;
+}
+
+
+/* Resolve the expression in an ALLOCATE statement, doing the additional
+   checks to see whether the expression is OK or not.  The expression must
+   have a trailing array reference that gives the size of the array.  */
+
+static bool
+resolve_allocate_expr (gfc_expr *e, gfc_code *code)
+{
+  int i, pointer, allocatable, dimension, is_abstract;
+  int codimension;
+  bool coindexed;
+  bool unlimited;
+  symbol_attribute attr;
+  gfc_ref *ref, *ref2;
+  gfc_expr *e2;
+  gfc_array_ref *ar;
+  gfc_symbol *sym = NULL;
+  gfc_alloc *a;
+  gfc_component *c;
+  bool t;
+
+  /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
+     checking of coarrays.  */
+  for (ref = e->ref; ref; ref = ref->next)
+    if (ref->next == NULL)
+      break;
+
+  if (ref && ref->type == REF_ARRAY)
+    ref->u.ar.in_allocate = true;
+
+  if (!gfc_resolve_expr (e))
+    goto failure;
+
+  /* Make sure the expression is allocatable or a pointer.  If it is
+     pointer, the next-to-last reference must be a pointer.  */
+
+  ref2 = NULL;
+  if (e->symtree)
+    sym = e->symtree->n.sym;
+
+  /* Check whether ultimate component is abstract and CLASS.  */
+  is_abstract = 0;
+
+  /* Is the allocate-object unlimited polymorphic?  */
+  unlimited = UNLIMITED_POLY(e);
+
+  if (e->expr_type != EXPR_VARIABLE)
+    {
+      allocatable = 0;
+      attr = gfc_expr_attr (e);
+      pointer = attr.pointer;
+      dimension = attr.dimension;
+      codimension = attr.codimension;
+    }
+  else
+    {
+      if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
+	{
+	  allocatable = CLASS_DATA (sym)->attr.allocatable;
+	  pointer = CLASS_DATA (sym)->attr.class_pointer;
+	  dimension = CLASS_DATA (sym)->attr.dimension;
+	  codimension = CLASS_DATA (sym)->attr.codimension;
+	  is_abstract = CLASS_DATA (sym)->attr.abstract;
+	}
+      else
+	{
+	  allocatable = sym->attr.allocatable;
+	  pointer = sym->attr.pointer;
+	  dimension = sym->attr.dimension;
+	  codimension = sym->attr.codimension;
+	}
+
+      coindexed = false;
+
+      for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
+	{
+	  switch (ref->type)
+	    {
+ 	      case REF_ARRAY:
+                if (ref->u.ar.codimen > 0)
+		  {
+		    int n;
+		    for (n = ref->u.ar.dimen;
+			 n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
+		      if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
+			{
+			  coindexed = true;
+			  break;
+			}
+		   }
+
+		if (ref->next != NULL)
+		  pointer = 0;
+		break;
+
+	      case REF_COMPONENT:
+		/* F2008, C644.  */
+		if (coindexed)
+		  {
+		    gfc_error ("Coindexed allocatable object at %L",
+			       &e->where);
+		    goto failure;
+		  }
+
+		c = ref->u.c.component;
+		if (c->ts.type == BT_CLASS)
+		  {
+		    allocatable = CLASS_DATA (c)->attr.allocatable;
+		    pointer = CLASS_DATA (c)->attr.class_pointer;
+		    dimension = CLASS_DATA (c)->attr.dimension;
+		    codimension = CLASS_DATA (c)->attr.codimension;
+		    is_abstract = CLASS_DATA (c)->attr.abstract;
+		  }
+		else
+		  {
+		    allocatable = c->attr.allocatable;
+		    pointer = c->attr.pointer;
+		    dimension = c->attr.dimension;
+		    codimension = c->attr.codimension;
+		    is_abstract = c->attr.abstract;
+		  }
+		break;
+
+	      case REF_SUBSTRING:
+		allocatable = 0;
+		pointer = 0;
+		break;
+	    }
+	}
+    }
+
+  /* Check for F08:C628.  */
+  if (allocatable == 0 && pointer == 0 && !unlimited)
+    {
+      gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
+		 &e->where);
+      goto failure;
+    }
+
+  /* Some checks for the SOURCE tag.  */
+  if (code->expr3)
+    {
+      /* Check F03:C631.  */
+      if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
+	{
+	  gfc_error ("Type of entity at %L is type incompatible with "
+		      "source-expr at %L", &e->where, &code->expr3->where);
+	  goto failure;
+	}
+
+      /* Check F03:C632 and restriction following Note 6.18.  */
+      if (code->expr3->rank > 0 && !conformable_arrays (code->expr3, e))
+	goto failure;
+
+      /* Check F03:C633.  */
+      if (code->expr3->ts.kind != e->ts.kind && !unlimited)
+	{
+	  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;
+	}
+
+      /* Check F2008, C642.  */
+      if (code->expr3->ts.type == BT_DERIVED
+	  && ((codimension && gfc_expr_attr (code->expr3).lock_comp)
+	      || (code->expr3->ts.u.derived->from_intmod
+		     == INTMOD_ISO_FORTRAN_ENV
+		  && code->expr3->ts.u.derived->intmod_sym_id
+		     == ISOFORTRAN_LOCK_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);
+	  goto failure;
+	}
+    }
+
+  /* Check F08:C629.  */
+  if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
+      && !code->expr3)
+    {
+      gcc_assert (e->ts.type == BT_CLASS);
+      gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
+		 "type-spec or source-expr", sym->name, &e->where);
+      goto failure;
+    }
+
+  if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred)
+    {
+      int cmp = gfc_dep_compare_expr (e->ts.u.cl->length,
+				      code->ext.alloc.ts.u.cl->length);
+      if (cmp == 1 || cmp == -1 || cmp == -3)
+	{
+	  gfc_error ("Allocating %s at %L with type-spec requires the same "
+		     "character-length parameter as in the declaration",
+		     sym->name, &e->where);
+	  goto failure;
+	}
+    }
+
+  /* In the variable definition context checks, gfc_expr_attr is used
+     on the expression.  This is fooled by the array specification
+     present in e, thus we have to eliminate that one temporarily.  */
+  e2 = remove_last_array_ref (e);
+  t = true;
+  if (t && pointer)
+    t = gfc_check_vardef_context (e2, true, true, false, 
+				  _("ALLOCATE object"));
+  if (t)
+    t = gfc_check_vardef_context (e2, false, true, false, 
+				  _("ALLOCATE object"));
+  gfc_free_expr (e2);
+  if (!t)
+    goto failure;
+
+  if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension
+	&& !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED)
+    {
+      /* For class arrays, the initialization with SOURCE is done
+	 using _copy and trans_call. It is convenient to exploit that
+	 when the allocated type is different from the declared type but
+	 no SOURCE exists by setting expr3.  */
+      code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
+    }
+  else if (!code->expr3)
+    {
+      /* Set up default initializer if needed.  */
+      gfc_typespec ts;
+      gfc_expr *init_e;
+
+      if (code->ext.alloc.ts.type == BT_DERIVED)
+	ts = code->ext.alloc.ts;
+      else
+	ts = e->ts;
+
+      if (ts.type == BT_CLASS)
+	ts = ts.u.derived->components->ts;
+
+      if (ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&ts)))
+	{
+	  gfc_code *init_st = gfc_get_code (EXEC_INIT_ASSIGN);
+	  init_st->loc = code->loc;
+	  init_st->expr1 = gfc_expr_to_initialize (e);
+	  init_st->expr2 = init_e;
+	  init_st->next = code->next;
+	  code->next = init_st;
+	}
+    }
+  else if (code->expr3->mold && code->expr3->ts.type == BT_DERIVED)
+    {
+      /* Default initialization via MOLD (non-polymorphic).  */
+      gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
+      gfc_resolve_expr (rhs);
+      gfc_free_expr (code->expr3);
+      code->expr3 = rhs;
+    }
+
+  if (e->ts.type == BT_CLASS && !unlimited && !UNLIMITED_POLY (code->expr3))
+    {
+      /* Make sure the vtab symbol is present when
+	 the module variables are generated.  */
+      gfc_typespec ts = e->ts;
+      if (code->expr3)
+	ts = code->expr3->ts;
+      else if (code->ext.alloc.ts.type == BT_DERIVED)
+	ts = code->ext.alloc.ts;
+
+      gfc_find_derived_vtab (ts.u.derived);
+
+      if (dimension)
+	e = gfc_expr_to_initialize (e);
+    }
+  else if (unlimited && !UNLIMITED_POLY (code->expr3))
+    {
+      /* Again, make sure the vtab symbol is present when
+	 the module variables are generated.  */
+      gfc_typespec *ts = NULL;
+      if (code->expr3)
+	ts = &code->expr3->ts;
+      else
+	ts = &code->ext.alloc.ts;
+
+      gcc_assert (ts);
+
+      gfc_find_vtab (ts);
+
+      if (dimension)
+	e = gfc_expr_to_initialize (e);
+    }
+
+  if (dimension == 0 && codimension == 0)
+    goto success;
+
+  /* Make sure the last reference node is an array specification.  */
+
+  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;
+    }
+
+  /* Make sure that the array section reference makes sense in the
+    context of an ALLOCATE specification.  */
+
+  ar = &ref2->u.ar;
+
+  if (codimension)
+    for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
+      if (ar->dimen_type[i] == DIMEN_THIS_IMAGE)
+	{
+	  gfc_error ("Coarray specification required in ALLOCATE statement "
+		     "at %L", &e->where);
+	  goto failure;
+	}
+
+  for (i = 0; i < ar->dimen; i++)
+    {
+      if (ref2->u.ar.type == AR_ELEMENT)
+	goto check_symbols;
+
+      switch (ar->dimen_type[i])
+	{
+	case DIMEN_ELEMENT:
+	  break;
+
+	case DIMEN_RANGE:
+	  if (ar->start[i] != NULL
+	      && ar->end[i] != NULL
+	      && ar->stride[i] == NULL)
+	    break;
+
+	  /* Fall Through...  */
+
+	case DIMEN_UNKNOWN:
+	case DIMEN_VECTOR:
+	case DIMEN_STAR:
+	case DIMEN_THIS_IMAGE:
+	  gfc_error ("Bad array specification in ALLOCATE statement at %L",
+		     &e->where);
+	  goto failure;
+	}
+
+check_symbols:
+      for (a = code->ext.alloc.list; a; a = a->next)
+	{
+	  sym = a->expr->symtree->n.sym;
+
+	  /* TODO - check derived type components.  */
+	  if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
+	    continue;
+
+	  if ((ar->start[i] != NULL
+	       && gfc_find_sym_in_expr (sym, ar->start[i]))
+	      || (ar->end[i] != NULL
+		  && gfc_find_sym_in_expr (sym, ar->end[i])))
+	    {
+	      gfc_error ("'%s' must not appear in the array specification at "
+			 "%L in the same ALLOCATE statement where it is "
+			 "itself allocated", sym->name, &ar->where);
+	      goto failure;
+	    }
+	}
+    }
+
+  for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
+    {
+      if (ar->dimen_type[i] == DIMEN_ELEMENT
+	  || ar->dimen_type[i] == DIMEN_RANGE)
+	{
+	  if (i == (ar->dimen + ar->codimen - 1))
+	    {
+	      gfc_error ("Expected '*' in coindex specification in ALLOCATE "
+			 "statement at %L", &e->where);
+	      goto failure;
+	    }
+	  continue;
+	}
+
+      if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
+	  && ar->stride[i] == NULL)
+	break;
+
+      gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
+		 &e->where);
+      goto failure;
+    }
+
+success:
+  return true;
+
+failure:
+  return false;
+}
+
+static void
+resolve_allocate_deallocate (gfc_code *code, const char *fcn)
+{
+  gfc_expr *stat, *errmsg, *pe, *qe;
+  gfc_alloc *a, *p, *q;
+
+  stat = code->expr1;
+  errmsg = code->expr2;
+
+  /* Check the stat variable.  */
+  if (stat)
+    {
+      gfc_check_vardef_context (stat, false, false, false, 
+				_("STAT variable"));
+
+      if ((stat->ts.type != BT_INTEGER
+	   && !(stat->ref && (stat->ref->type == REF_ARRAY
+			      || stat->ref->type == REF_COMPONENT)))
+	  || stat->rank > 0)
+	gfc_error ("Stat-variable at %L must be a scalar INTEGER "
+		   "variable", &stat->where);
+
+      for (p = code->ext.alloc.list; p; p = p->next)
+	if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
+	  {
+	    gfc_ref *ref1, *ref2;
+	    bool found = true;
+
+	    for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
+		 ref1 = ref1->next, ref2 = ref2->next)
+	      {
+		if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
+		  continue;
+		if (ref1->u.c.component->name != ref2->u.c.component->name)
+		  {
+		    found = false;
+		    break;
+		  }
+	      }
+
+	    if (found)
+	      {
+		gfc_error ("Stat-variable at %L shall not be %sd within "
+			   "the same %s statement", &stat->where, fcn, fcn);
+		break;
+	      }
+	  }
+    }
+
+  /* Check the errmsg variable.  */
+  if (errmsg)
+    {
+      if (!stat)
+	gfc_warning ("ERRMSG at %L is useless without a STAT tag",
+		     &errmsg->where);
+
+      gfc_check_vardef_context (errmsg, false, false, false,
+				_("ERRMSG variable"));
+
+      if ((errmsg->ts.type != BT_CHARACTER
+	   && !(errmsg->ref
+		&& (errmsg->ref->type == REF_ARRAY
+		    || errmsg->ref->type == REF_COMPONENT)))
+	  || errmsg->rank > 0 )
+	gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
+		   "variable", &errmsg->where);
+
+      for (p = code->ext.alloc.list; p; p = p->next)
+	if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
+	  {
+	    gfc_ref *ref1, *ref2;
+	    bool found = true;
+
+	    for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
+		 ref1 = ref1->next, ref2 = ref2->next)
+	      {
+		if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
+		  continue;
+		if (ref1->u.c.component->name != ref2->u.c.component->name)
+		  {
+		    found = false;
+		    break;
+		  }
+	      }
+
+	    if (found)
+	      {
+		gfc_error ("Errmsg-variable at %L shall not be %sd within "
+			   "the same %s statement", &errmsg->where, fcn, fcn);
+		break;
+	      }
+	  }
+    }
+
+  /* Check that an allocate-object appears only once in the statement.  */
+
+  for (p = code->ext.alloc.list; p; p = p->next)
+    {
+      pe = p->expr;
+      for (q = p->next; q; q = q->next)
+	{
+	  qe = q->expr;
+	  if (pe->symtree->n.sym->name == qe->symtree->n.sym->name)
+	    {
+	      /* This is a potential collision.  */
+	      gfc_ref *pr = pe->ref;
+	      gfc_ref *qr = qe->ref;
+
+	      /* Follow the references  until
+		 a) They start to differ, in which case there is no error;
+		 you can deallocate a%b and a%c in a single statement
+		 b) Both of them stop, which is an error
+		 c) One of them stops, which is also an error.  */
+	      while (1)
+		{
+		  if (pr == NULL && qr == NULL)
+		    {
+		      gfc_error ("Allocate-object at %L also appears at %L",
+				 &pe->where, &qe->where);
+		      break;
+		    }
+		  else if (pr != NULL && qr == NULL)
+		    {
+		      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 ("Allocate-object at %L is subobject of"
+				 " object at %L", &qe->where, &pe->where);
+		      break;
+		    }
+		  /* Here, pr != NULL && qr != NULL  */
+		  gcc_assert(pr->type == qr->type);
+		  if (pr->type == REF_ARRAY)
+		    {
+		      /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
+			 which are legal.  */
+		      gcc_assert (qr->type == REF_ARRAY);
+
+		      if (pr->next && qr->next)
+			{
+			  int i;
+			  gfc_array_ref *par = &(pr->u.ar);
+			  gfc_array_ref *qar = &(qr->u.ar);
+
+			  for (i=0; i<par->dimen; i++)
+			    {
+			      if ((par->start[i] != NULL
+				   || qar->start[i] != NULL)
+				  && gfc_dep_compare_expr (par->start[i],
+							   qar->start[i]) != 0)
+				goto break_label;
+			    }
+			}
+		    }
+		  else
+		    {
+		      if (pr->u.c.component->name != qr->u.c.component->name)
+			break;
+		    }
+
+		  pr = pr->next;
+		  qr = qr->next;
+		}
+	    break_label:
+	      ;
+	    }
+	}
+    }
+
+  if (strcmp (fcn, "ALLOCATE") == 0)
+    {
+      for (a = code->ext.alloc.list; a; a = a->next)
+	resolve_allocate_expr (a->expr, code);
+    }
+  else
+    {
+      for (a = code->ext.alloc.list; a; a = a->next)
+	resolve_deallocate_expr (a->expr);
+    }
+}
+
+
+/************ SELECT CASE resolution subroutines ************/
+
+/* Callback function for our mergesort variant.  Determines interval
+   overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
+   op1 > op2.  Assumes we're not dealing with the default case.
+   We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
+   There are nine situations to check.  */
+
+static int
+compare_cases (const gfc_case *op1, const gfc_case *op2)
+{
+  int retval;
+
+  if (op1->low == NULL) /* op1 = (:L)  */
+    {
+      /* op2 = (:N), so overlap.  */
+      retval = 0;
+      /* op2 = (M:) or (M:N),  L < M  */
+      if (op2->low != NULL
+	  && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
+	retval = -1;
+    }
+  else if (op1->high == NULL) /* op1 = (K:)  */
+    {
+      /* op2 = (M:), so overlap.  */
+      retval = 0;
+      /* op2 = (:N) or (M:N), K > N  */
+      if (op2->high != NULL
+	  && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
+	retval = 1;
+    }
+  else /* op1 = (K:L)  */
+    {
+      if (op2->low == NULL)       /* op2 = (:N), K > N  */
+	retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
+		 ? 1 : 0;
+      else if (op2->high == NULL) /* op2 = (M:), L < M  */
+	retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
+		 ? -1 : 0;
+      else			/* op2 = (M:N)  */
+	{
+	  retval =  0;
+	  /* L < M  */
+	  if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
+	    retval =  -1;
+	  /* K > N  */
+	  else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
+	    retval =  1;
+	}
+    }
+
+  return retval;
+}
+
+
+/* Merge-sort a double linked case list, detecting overlap in the
+   process.  LIST is the head of the double linked case list before it
+   is sorted.  Returns the head of the sorted list if we don't see any
+   overlap, or NULL otherwise.  */
+
+static gfc_case *
+check_case_overlap (gfc_case *list)
+{
+  gfc_case *p, *q, *e, *tail;
+  int insize, nmerges, psize, qsize, cmp, overlap_seen;
+
+  /* If the passed list was empty, return immediately.  */
+  if (!list)
+    return NULL;
+
+  overlap_seen = 0;
+  insize = 1;
+
+  /* Loop unconditionally.  The only exit from this loop is a return
+     statement, when we've finished sorting the case list.  */
+  for (;;)
+    {
+      p = list;
+      list = NULL;
+      tail = NULL;
+
+      /* Count the number of merges we do in this pass.  */
+      nmerges = 0;
+
+      /* Loop while there exists a merge to be done.  */
+      while (p)
+	{
+	  int i;
+
+	  /* Count this merge.  */
+	  nmerges++;
+
+	  /* Cut the list in two pieces by stepping INSIZE places
+	     forward in the list, starting from P.  */
+	  psize = 0;
+	  q = p;
+	  for (i = 0; i < insize; i++)
+	    {
+	      psize++;
+	      q = q->right;
+	      if (!q)
+		break;
+	    }
+	  qsize = insize;
+
+	  /* Now we have two lists.  Merge them!  */
+	  while (psize > 0 || (qsize > 0 && q != NULL))
+	    {
+	      /* See from which the next case to merge comes from.  */
+	      if (psize == 0)
+		{
+		  /* P is empty so the next case must come from Q.  */
+		  e = q;
+		  q = q->right;
+		  qsize--;
+		}
+	      else if (qsize == 0 || q == NULL)
+		{
+		  /* Q is empty.  */
+		  e = p;
+		  p = p->right;
+		  psize--;
+		}
+	      else
+		{
+		  cmp = compare_cases (p, q);
+		  if (cmp < 0)
+		    {
+		      /* The whole case range for P is less than the
+			 one for Q.  */
+		      e = p;
+		      p = p->right;
+		      psize--;
+		    }
+		  else if (cmp > 0)
+		    {
+		      /* The whole case range for Q is greater than
+			 the case range for P.  */
+		      e = q;
+		      q = q->right;
+		      qsize--;
+		    }
+		  else
+		    {
+		      /* The cases overlap, or they are the same
+			 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 ("CASE label at %L overlaps with CASE "
+				 "label at %L", &p->where, &q->where);
+		      overlap_seen = 1;
+		      e = p;
+		      p = p->right;
+		      psize--;
+		    }
+		}
+
+		/* Add the next element to the merged list.  */
+	      if (tail)
+		tail->right = e;
+	      else
+		list = e;
+	      e->left = tail;
+	      tail = e;
+	    }
+
+	  /* P has now stepped INSIZE places along, and so has Q.  So
+	     they're the same.  */
+	  p = q;
+	}
+      tail->right = NULL;
+
+      /* If we have done only one merge or none at all, we've
+	 finished sorting the cases.  */
+      if (nmerges <= 1)
+	{
+	  if (!overlap_seen)
+	    return list;
+	  else
+	    return NULL;
+	}
+
+      /* Otherwise repeat, merging lists twice the size.  */
+      insize *= 2;
+    }
+}
+
+
+/* Check to see if an expression is suitable for use in a CASE statement.
+   Makes sure that all case expressions are scalar constants of the same
+   type.  Return false if anything is wrong.  */
+
+static bool
+validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
+{
+  if (e == NULL) return true;
+
+  if (e->ts.type != case_expr->ts.type)
+    {
+      gfc_error ("Expression in CASE statement at %L must be of type %s",
+		 &e->where, gfc_basic_typename (case_expr->ts.type));
+      return false;
+    }
+
+  /* C805 (R808) For a given case-construct, each case-value shall be of
+     the same type as case-expr.  For character type, length differences
+     are allowed, but the kind type parameters shall be the same.  */
+
+  if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
+    {
+      gfc_error ("Expression in CASE statement at %L must be of kind %d",
+		 &e->where, case_expr->ts.kind);
+      return false;
+    }
+
+  /* Convert the case value kind to that of case expression kind,
+     if needed */
+
+  if (e->ts.kind != case_expr->ts.kind)
+    gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
+
+  if (e->rank != 0)
+    {
+      gfc_error ("Expression in CASE statement at %L must be scalar",
+		 &e->where);
+      return false;
+    }
+
+  return true;
+}
+
+
+/* Given a completely parsed select statement, we:
+
+     - Validate all expressions and code within the SELECT.
+     - Make sure that the selection expression is not of the wrong type.
+     - Make sure that no case ranges overlap.
+     - Eliminate unreachable cases and unreachable code resulting from
+       removing case labels.
+
+   The standard does allow unreachable cases, e.g. CASE (5:3).  But
+   they are a hassle for code generation, and to prevent that, we just
+   cut them out here.  This is not necessary for overlapping cases
+   because they are illegal and we never even try to generate code.
+
+   We have the additional caveat that a SELECT construct could have
+   been a computed GOTO in the source code. Fortunately we can fairly
+   easily work around that here: The case_expr for a "real" SELECT CASE
+   is in code->expr1, but for a computed GOTO it is in code->expr2. All
+   we have to do is make sure that the case_expr is a scalar integer
+   expression.  */
+
+static void
+resolve_select (gfc_code *code, bool select_type)
+{
+  gfc_code *body;
+  gfc_expr *case_expr;
+  gfc_case *cp, *default_case, *tail, *head;
+  int seen_unreachable;
+  int seen_logical;
+  int ncases;
+  bt type;
+  bool t;
+
+  if (code->expr1 == NULL)
+    {
+      /* This was actually a computed GOTO statement.  */
+      case_expr = code->expr2;
+      if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
+	gfc_error ("Selection expression in computed GOTO statement "
+		   "at %L must be a scalar integer expression",
+		   &case_expr->where);
+
+      /* Further checking is not necessary because this SELECT was built
+	 by the compiler, so it should always be OK.  Just move the
+	 case_expr from expr2 to expr so that we can handle computed
+	 GOTOs as normal SELECTs from here on.  */
+      code->expr1 = code->expr2;
+      code->expr2 = NULL;
+      return;
+    }
+
+  case_expr = code->expr1;
+  type = case_expr->ts.type;
+
+  /* F08:C830.  */
+  if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
+    {
+      gfc_error ("Argument of SELECT statement at %L cannot be %s",
+		 &case_expr->where, gfc_typename (&case_expr->ts));
+
+      /* Punt. Going on here just produce more garbage error messages.  */
+      return;
+    }
+
+  /* F08:R842.  */
+  if (!select_type && case_expr->rank != 0)
+    {
+      gfc_error ("Argument of SELECT statement at %L must be a scalar "
+		 "expression", &case_expr->where);
+
+      /* Punt.  */
+      return;
+    }
+
+  /* Raise a warning if an INTEGER case value exceeds the range of
+     the case-expr. Later, all expressions will be promoted to the
+     largest kind of all case-labels.  */
+
+  if (type == BT_INTEGER)
+    for (body = code->block; body; body = body->block)
+      for (cp = body->ext.block.case_list; cp; cp = cp->next)
+	{
+	  if (cp->low
+	      && gfc_check_integer_range (cp->low->value.integer,
+					  case_expr->ts.kind) != ARITH_OK)
+	    gfc_warning ("Expression in CASE statement at %L is "
+			 "not in the range of %s", &cp->low->where,
+			 gfc_typename (&case_expr->ts));
+
+	  if (cp->high
+	      && cp->low != cp->high
+	      && gfc_check_integer_range (cp->high->value.integer,
+					  case_expr->ts.kind) != ARITH_OK)
+	    gfc_warning ("Expression in CASE statement at %L is "
+			 "not in the range of %s", &cp->high->where,
+			 gfc_typename (&case_expr->ts));
+	}
+
+  /* PR 19168 has a long discussion concerning a mismatch of the kinds
+     of the SELECT CASE expression and its CASE values.  Walk the lists
+     of case values, and if we find a mismatch, promote case_expr to
+     the appropriate kind.  */
+
+  if (type == BT_LOGICAL || type == BT_INTEGER)
+    {
+      for (body = code->block; body; body = body->block)
+	{
+	  /* Walk the case label list.  */
+	  for (cp = body->ext.block.case_list; cp; cp = cp->next)
+	    {
+	      /* Intercept the DEFAULT case.  It does not have a kind.  */
+	      if (cp->low == NULL && cp->high == NULL)
+		continue;
+
+	      /* Unreachable case ranges are discarded, so ignore.  */
+	      if (cp->low != NULL && cp->high != NULL
+		  && cp->low != cp->high
+		  && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
+		continue;
+
+	      if (cp->low != NULL
+		  && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
+		gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
+
+	      if (cp->high != NULL
+		  && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
+		gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
+	    }
+	 }
+    }
+
+  /* Assume there is no DEFAULT case.  */
+  default_case = NULL;
+  head = tail = NULL;
+  ncases = 0;
+  seen_logical = 0;
+
+  for (body = code->block; body; body = body->block)
+    {
+      /* Assume the CASE list is OK, and all CASE labels can be matched.  */
+      t = true;
+      seen_unreachable = 0;
+
+      /* Walk the case label list, making sure that all case labels
+	 are legal.  */
+      for (cp = body->ext.block.case_list; cp; cp = cp->next)
+	{
+	  /* Count the number of cases in the whole construct.  */
+	  ncases++;
+
+	  /* Intercept the DEFAULT case.  */
+	  if (cp->low == NULL && cp->high == NULL)
+	    {
+	      if (default_case != NULL)
+		{
+		  gfc_error ("The DEFAULT CASE at %L cannot be followed "
+			     "by a second DEFAULT CASE at %L",
+			     &default_case->where, &cp->where);
+		  t = false;
+		  break;
+		}
+	      else
+		{
+		  default_case = cp;
+		  continue;
+		}
+	    }
+
+	  /* Deal with single value cases and case ranges.  Errors are
+	     issued from the validation function.  */
+	  if (!validate_case_label_expr (cp->low, case_expr)
+	      || !validate_case_label_expr (cp->high, case_expr))
+	    {
+	      t = false;
+	      break;
+	    }
+
+	  if (type == BT_LOGICAL
+	      && ((cp->low == NULL || cp->high == NULL)
+		  || cp->low != cp->high))
+	    {
+	      gfc_error ("Logical range in CASE statement at %L is not "
+			 "allowed", &cp->low->where);
+	      t = false;
+	      break;
+	    }
+
+	  if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
+	    {
+	      int value;
+	      value = cp->low->value.logical == 0 ? 2 : 1;
+	      if (value & seen_logical)
+		{
+		  gfc_error ("Constant logical value in CASE statement "
+			     "is repeated at %L",
+			     &cp->low->where);
+		  t = false;
+		  break;
+		}
+	      seen_logical |= value;
+	    }
+
+	  if (cp->low != NULL && cp->high != NULL
+	      && cp->low != cp->high
+	      && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
+	    {
+	      if (gfc_option.warn_surprising)
+		gfc_warning ("Range specification at %L can never "
+			     "be matched", &cp->where);
+
+	      cp->unreachable = 1;
+	      seen_unreachable = 1;
+	    }
+	  else
+	    {
+	      /* If the case range can be matched, it can also overlap with
+		 other cases.  To make sure it does not, we put it in a
+		 double linked list here.  We sort that with a merge sort
+		 later on to detect any overlapping cases.  */
+	      if (!head)
+		{
+		  head = tail = cp;
+		  head->right = head->left = NULL;
+		}
+	      else
+		{
+		  tail->right = cp;
+		  tail->right->left = tail;
+		  tail = tail->right;
+		  tail->right = NULL;
+		}
+	    }
+	}
+
+      /* It there was a failure in the previous case label, give up
+	 for this case label list.  Continue with the next block.  */
+      if (!t)
+	continue;
+
+      /* See if any case labels that are unreachable have been seen.
+	 If so, we eliminate them.  This is a bit of a kludge because
+	 the case lists for a single case statement (label) is a
+	 single forward linked lists.  */
+      if (seen_unreachable)
+      {
+	/* Advance until the first case in the list is reachable.  */
+	while (body->ext.block.case_list != NULL
+	       && body->ext.block.case_list->unreachable)
+	  {
+	    gfc_case *n = body->ext.block.case_list;
+	    body->ext.block.case_list = body->ext.block.case_list->next;
+	    n->next = NULL;
+	    gfc_free_case_list (n);
+	  }
+
+	/* Strip all other unreachable cases.  */
+	if (body->ext.block.case_list)
+	  {
+	    for (cp = body->ext.block.case_list; cp->next; cp = cp->next)
+	      {
+		if (cp->next->unreachable)
+		  {
+		    gfc_case *n = cp->next;
+		    cp->next = cp->next->next;
+		    n->next = NULL;
+		    gfc_free_case_list (n);
+		  }
+	      }
+	  }
+      }
+    }
+
+  /* See if there were overlapping cases.  If the check returns NULL,
+     there was overlap.  In that case we don't do anything.  If head
+     is non-NULL, we prepend the DEFAULT case.  The sorted list can
+     then used during code generation for SELECT CASE constructs with
+     a case expression of a CHARACTER type.  */
+  if (head)
+    {
+      head = check_case_overlap (head);
+
+      /* Prepend the default_case if it is there.  */
+      if (head != NULL && default_case)
+	{
+	  default_case->left = NULL;
+	  default_case->right = head;
+	  head->left = default_case;
+	}
+    }
+
+  /* Eliminate dead blocks that may be the result if we've seen
+     unreachable case labels for a block.  */
+  for (body = code; body && body->block; body = body->block)
+    {
+      if (body->block->ext.block.case_list == NULL)
+	{
+	  /* Cut the unreachable block from the code chain.  */
+	  gfc_code *c = body->block;
+	  body->block = c->block;
+
+	  /* Kill the dead block, but not the blocks below it.  */
+	  c->block = NULL;
+	  gfc_free_statements (c);
+	}
+    }
+
+  /* More than two cases is legal but insane for logical selects.
+     Issue a warning for it.  */
+  if (gfc_option.warn_surprising && type == BT_LOGICAL
+      && ncases > 2)
+    gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
+		 &code->loc);
+}
+
+
+/* Check if a derived type is extensible.  */
+
+bool
+gfc_type_is_extensible (gfc_symbol *sym)
+{
+  return !(sym->attr.is_bind_c || sym->attr.sequence
+	   || (sym->attr.is_class
+	       && sym->components->ts.u.derived->attr.unlimited_polymorphic));
+}
+
+
+/* Resolve an associate-name:  Resolve target and ensure the type-spec is
+   correct as well as possibly the array-spec.  */
+
+static void
+resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
+{
+  gfc_expr* target;
+
+  gcc_assert (sym->assoc);
+  gcc_assert (sym->attr.flavor == FL_VARIABLE);
+
+  /* If this is for SELECT TYPE, the target may not yet be set.  In that
+     case, return.  Resolution will be called later manually again when
+     this is done.  */
+  target = sym->assoc->target;
+  if (!target)
+    return;
+  gcc_assert (!sym->assoc->dangling);
+
+  if (resolve_target && !gfc_resolve_expr (target))
+    return;
+
+  /* For variable targets, we get some attributes from the target.  */
+  if (target->expr_type == EXPR_VARIABLE)
+    {
+      gfc_symbol* tsym;
+
+      gcc_assert (target->symtree);
+      tsym = target->symtree->n.sym;
+
+      sym->attr.asynchronous = tsym->attr.asynchronous;
+      sym->attr.volatile_ = tsym->attr.volatile_;
+
+      sym->attr.target = tsym->attr.target
+			 || gfc_expr_attr (target).pointer;
+      if (is_subref_array (target))
+	sym->attr.subref_array_pointer = 1;
+    }
+
+  /* Get type if this was not already set.  Note that it can be
+     some other type than the target in case this is a SELECT TYPE
+     selector!  So we must not update when the type is already there.  */
+  if (sym->ts.type == BT_UNKNOWN)
+    sym->ts = target->ts;
+  gcc_assert (sym->ts.type != BT_UNKNOWN);
+
+  /* See if this is a valid association-to-variable.  */
+  sym->assoc->variable = (target->expr_type == EXPR_VARIABLE
+			  && !gfc_has_vector_subscript (target));
+
+  /* Finally resolve if this is an array or not.  */
+  if (sym->attr.dimension && target->rank == 0)
+    {
+      gfc_error ("Associate-name '%s' at %L is used as array",
+		 sym->name, &sym->declared_at);
+      sym->attr.dimension = 0;
+      return;
+    }
+
+  /* We cannot deal with class selectors that need temporaries.  */
+  if (target->ts.type == BT_CLASS
+	&& gfc_ref_needs_temporary_p (target->ref))
+    {
+      gfc_error ("CLASS selector at %L needs a temporary which is not "
+		 "yet implemented", &target->where);
+      return;
+    }
+
+  if (target->ts.type != BT_CLASS && target->rank > 0)
+    sym->attr.dimension = 1;
+  else 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)
+    {
+      sym->as = gfc_get_array_spec ();
+      sym->as->rank = target->rank;
+      sym->as->type = AS_DEFERRED;
+
+      /* Target must not be coindexed, thus the associate-variable
+	 has no corank.  */
+      sym->as->corank = 0;
+    }
+
+  /* Mark this as an associate variable.  */
+  sym->attr.associate_var = 1;
+
+  /* If the target is a good class object, so is the associate variable.  */
+  if (sym->ts.type == BT_CLASS && gfc_expr_attr (target).class_ok)
+    sym->attr.class_ok = 1;
+}
+
+
+/* Resolve a SELECT TYPE statement.  */
+
+static void
+resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
+{
+  gfc_symbol *selector_type;
+  gfc_code *body, *new_st, *if_st, *tail;
+  gfc_code *class_is = NULL, *default_case = NULL;
+  gfc_case *c;
+  gfc_symtree *st;
+  char name[GFC_MAX_SYMBOL_LEN];
+  gfc_namespace *ns;
+  int error = 0;
+  int charlen = 0;
+
+  ns = code->ext.block.ns;
+  gfc_resolve (ns);
+
+  /* Check for F03:C813.  */
+  if (code->expr1->ts.type != BT_CLASS
+      && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
+    {
+      gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
+		 "at %L", &code->loc);
+      return;
+    }
+
+  if (!code->expr1->symtree->n.sym->attr.class_ok)
+    return;
+
+  if (code->expr2)
+    {
+      if (code->expr1->symtree->n.sym->attr.untyped)
+	code->expr1->symtree->n.sym->ts = code->expr2->ts;
+      selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
+
+      /* F2008: C803 The selector expression must not be coindexed.  */
+      if (gfc_is_coindexed (code->expr2))
+	{
+	  gfc_error ("Selector at %L must not be coindexed",
+		     &code->expr2->where);
+	  return;
+	}
+
+    }
+  else
+    {
+      selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
+
+      if (gfc_is_coindexed (code->expr1))
+	{
+	  gfc_error ("Selector at %L must not be coindexed",
+		     &code->expr1->where);
+	  return;
+	}
+    }
+
+  /* Loop over TYPE IS / CLASS IS cases.  */
+  for (body = code->block; body; body = body->block)
+    {
+      c = body->ext.block.case_list;
+
+      /* Check F03:C815.  */
+      if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+	  && !selector_type->attr.unlimited_polymorphic
+	  && !gfc_type_is_extensible (c->ts.u.derived))
+	{
+	  gfc_error ("Derived type '%s' at %L must be extensible",
+		     c->ts.u.derived->name, &c->where);
+	  error++;
+	  continue;
+	}
+
+      /* Check F03:C816.  */
+      if (c->ts.type != BT_UNKNOWN && !selector_type->attr.unlimited_polymorphic
+	  && ((c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
+	      || !gfc_type_is_extension_of (selector_type, c->ts.u.derived)))
+	{
+	  if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+	    gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
+		       c->ts.u.derived->name, &c->where, selector_type->name);
+	  else
+	    gfc_error ("Unexpected intrinsic type '%s' at %L",
+		       gfc_basic_typename (c->ts.type), &c->where);
+	  error++;
+	  continue;
+	}
+
+      /* Check F03:C814.  */
+      if (c->ts.type == BT_CHARACTER && c->ts.u.cl->length != NULL)
+	{
+	  gfc_error ("The type-spec at %L shall specify that each length "
+		     "type parameter is assumed", &c->where);
+	  error++;
+	  continue;
+	}
+
+      /* Intercept the DEFAULT case.  */
+      if (c->ts.type == BT_UNKNOWN)
+	{
+	  /* Check F03:C818.  */
+	  if (default_case)
+	    {
+	      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++;
+	      continue;
+	    }
+
+	  default_case = body;
+	}
+    }
+
+  if (error > 0)
+    return;
+
+  /* Transform SELECT TYPE statement to BLOCK and associate selector to
+     target if present.  If there are any EXIT statements referring to the
+     SELECT TYPE construct, this is no problem because the gfc_code
+     reference stays the same and EXIT is equally possible from the BLOCK
+     it is changed to.  */
+  code->op = EXEC_BLOCK;
+  if (code->expr2)
+    {
+      gfc_association_list* assoc;
+
+      assoc = gfc_get_association_list ();
+      assoc->st = code->expr1->symtree;
+      assoc->target = gfc_copy_expr (code->expr2);
+      assoc->target->where = code->expr2->where;
+      /* assoc->variable will be set by resolve_assoc_var.  */
+
+      code->ext.block.assoc = assoc;
+      code->expr1->symtree->n.sym->assoc = assoc;
+
+      resolve_assoc_var (code->expr1->symtree->n.sym, false);
+    }
+  else
+    code->ext.block.assoc = NULL;
+
+  /* Add EXEC_SELECT to switch on type.  */
+  new_st = gfc_get_code (code->op);
+  new_st->expr1 = code->expr1;
+  new_st->expr2 = code->expr2;
+  new_st->block = code->block;
+  code->expr1 = code->expr2 =  NULL;
+  code->block = NULL;
+  if (!ns->code)
+    ns->code = new_st;
+  else
+    ns->code->next = new_st;
+  code = new_st;
+  code->op = EXEC_SELECT;
+
+  gfc_add_vptr_component (code->expr1);
+  gfc_add_hash_component (code->expr1);
+
+  /* Loop over TYPE IS / CLASS IS cases.  */
+  for (body = code->block; body; body = body->block)
+    {
+      c = body->ext.block.case_list;
+
+      if (c->ts.type == BT_DERIVED)
+	c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+					     c->ts.u.derived->hash_value);
+      else if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN)
+	{
+	  gfc_symbol *ivtab;
+	  gfc_expr *e;
+
+	  ivtab = gfc_find_vtab (&c->ts);
+	  gcc_assert (ivtab && CLASS_DATA (ivtab)->initializer);
+	  e = CLASS_DATA (ivtab)->initializer;
+	  c->low = c->high = gfc_copy_expr (e);
+	}
+
+      else if (c->ts.type == BT_UNKNOWN)
+	continue;
+
+      /* Associate temporary to selector.  This should only be done
+	 when this case is actually true, so build a new ASSOCIATE
+	 that does precisely this here (instead of using the
+	 'global' one).  */
+
+      if (c->ts.type == BT_CLASS)
+	sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
+      else if (c->ts.type == BT_DERIVED)
+	sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
+      else if (c->ts.type == BT_CHARACTER)
+	{
+	  if (c->ts.u.cl && c->ts.u.cl->length
+	      && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+	    charlen = mpz_get_si (c->ts.u.cl->length->value.integer);
+	  sprintf (name, "__tmp_%s_%d_%d", gfc_basic_typename (c->ts.type),
+	           charlen, c->ts.kind);
+	}
+      else
+	sprintf (name, "__tmp_%s_%d", gfc_basic_typename (c->ts.type),
+	         c->ts.kind);
+
+      st = gfc_find_symtree (ns->sym_root, name);
+      gcc_assert (st->n.sym->assoc);
+      st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
+      st->n.sym->assoc->target->where = code->expr1->where;
+      if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN)
+	gfc_add_data_component (st->n.sym->assoc->target);
+
+      new_st = gfc_get_code (EXEC_BLOCK);
+      new_st->ext.block.ns = gfc_build_block_ns (ns);
+      new_st->ext.block.ns->code = body->next;
+      body->next = new_st;
+
+      /* Chain in the new list only if it is marked as dangling.  Otherwise
+	 there is a CASE label overlap and this is already used.  Just ignore,
+	 the error is diagnosed elsewhere.  */
+      if (st->n.sym->assoc->dangling)
+	{
+	  new_st->ext.block.assoc = st->n.sym->assoc;
+	  st->n.sym->assoc->dangling = 0;
+	}
+
+      resolve_assoc_var (st->n.sym, false);
+    }
+
+  /* Take out CLASS IS cases for separate treatment.  */
+  body = code;
+  while (body && body->block)
+    {
+      if (body->block->ext.block.case_list->ts.type == BT_CLASS)
+	{
+	  /* Add to class_is list.  */
+	  if (class_is == NULL)
+	    {
+	      class_is = body->block;
+	      tail = class_is;
+	    }
+	  else
+	    {
+	      for (tail = class_is; tail->block; tail = tail->block) ;
+	      tail->block = body->block;
+	      tail = tail->block;
+	    }
+	  /* Remove from EXEC_SELECT list.  */
+	  body->block = body->block->block;
+	  tail->block = NULL;
+	}
+      else
+	body = body->block;
+    }
+
+  if (class_is)
+    {
+      gfc_symbol *vtab;
+
+      if (!default_case)
+	{
+	  /* Add a default case to hold the CLASS IS cases.  */
+	  for (tail = code; tail->block; tail = tail->block) ;
+	  tail->block = gfc_get_code (EXEC_SELECT_TYPE);
+	  tail = tail->block;
+	  tail->ext.block.case_list = gfc_get_case ();
+	  tail->ext.block.case_list->ts.type = BT_UNKNOWN;
+	  tail->next = NULL;
+	  default_case = tail;
+	}
+
+      /* More than one CLASS IS block?  */
+      if (class_is->block)
+	{
+	  gfc_code **c1,*c2;
+	  bool swapped;
+	  /* Sort CLASS IS blocks by extension level.  */
+	  do
+	    {
+	      swapped = false;
+	      for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
+		{
+		  c2 = (*c1)->block;
+		  /* F03:C817 (check for doubles).  */
+		  if ((*c1)->ext.block.case_list->ts.u.derived->hash_value
+		      == c2->ext.block.case_list->ts.u.derived->hash_value)
+		    {
+		      gfc_error ("Double CLASS IS block in SELECT TYPE "
+				 "statement at %L",
+				 &c2->ext.block.case_list->where);
+		      return;
+		    }
+		  if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension
+		      < c2->ext.block.case_list->ts.u.derived->attr.extension)
+		    {
+		      /* Swap.  */
+		      (*c1)->block = c2->block;
+		      c2->block = *c1;
+		      *c1 = c2;
+		      swapped = true;
+		    }
+		}
+	    }
+	  while (swapped);
+	}
+
+      /* Generate IF chain.  */
+      if_st = gfc_get_code (EXEC_IF);
+      new_st = if_st;
+      for (body = class_is; body; body = body->block)
+	{
+	  new_st->block = gfc_get_code (EXEC_IF);
+	  new_st = new_st->block;
+	  /* Set up IF condition: Call _gfortran_is_extension_of.  */
+	  new_st->expr1 = gfc_get_expr ();
+	  new_st->expr1->expr_type = EXPR_FUNCTION;
+	  new_st->expr1->ts.type = BT_LOGICAL;
+	  new_st->expr1->ts.kind = 4;
+	  new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
+	  new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
+	  new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
+	  /* Set up arguments.  */
+	  new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
+	  new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
+	  new_st->expr1->value.function.actual->expr->where = code->loc;
+	  gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
+	  vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
+	  st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
+	  new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
+	  new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
+	  new_st->next = body->next;
+	}
+	if (default_case->next)
+	  {
+	    new_st->block = gfc_get_code (EXEC_IF);
+	    new_st = new_st->block;
+	    new_st->next = default_case->next;
+	  }
+
+	/* Replace CLASS DEFAULT code by the IF chain.  */
+	default_case->next = if_st;
+    }
+
+  /* Resolve the internal code.  This can not be done earlier because
+     it requires that the sym->assoc of selectors is set already.  */
+  gfc_current_ns = ns;
+  gfc_resolve_blocks (code->block, gfc_current_ns);
+  gfc_current_ns = old_ns;
+
+  resolve_select (code, true);
+}
+
+
+/* Resolve a transfer statement. This is making sure that:
+   -- a derived type being transferred has only non-pointer components
+   -- a derived type being transferred doesn't have private components, unless
+      it's being transferred from the module where the type was defined
+   -- we're not trying to transfer a whole assumed size array.  */
+
+static void
+resolve_transfer (gfc_code *code)
+{
+  gfc_typespec *ts;
+  gfc_symbol *sym;
+  gfc_ref *ref;
+  gfc_expr *exp;
+
+  exp = code->expr1;
+
+  while (exp != NULL && exp->expr_type == EXPR_OP
+	 && exp->value.op.op == INTRINSIC_PARENTHESES)
+    exp = exp->value.op.op1;
+
+  if (exp && exp->expr_type == EXPR_NULL
+      && code->ext.dt)
+    {
+      gfc_error ("Invalid context for NULL () intrinsic at %L",
+		 &exp->where);
+      return;
+    }
+
+  if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
+		      && exp->expr_type != EXPR_FUNCTION))
+    return;
+
+  /* If we are reading, the variable will be changed.  Note that
+     code->ext.dt may be NULL if the TRANSFER is related to
+     an INQUIRE statement -- but in this case, we are not reading, either.  */
+  if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
+      && !gfc_check_vardef_context (exp, false, false, false, 
+				    _("item in READ")))
+    return;
+
+  sym = exp->symtree->n.sym;
+  ts = &sym->ts;
+
+  /* Go to actual component transferred.  */
+  for (ref = exp->ref; ref; ref = ref->next)
+    if (ref->type == REF_COMPONENT)
+      ts = &ref->u.c.component->ts;
+
+  if (ts->type == BT_CLASS)
+    {
+      /* FIXME: Test for defined input/output.  */
+      gfc_error ("Data transfer element at %L cannot be polymorphic unless "
+                "it is processed by a defined input/output procedure",
+                &code->loc);
+      return;
+    }
+
+  if (ts->type == BT_DERIVED)
+    {
+      /* Check that transferred derived type doesn't contain POINTER
+	 components.  */
+      if (ts->u.derived->attr.pointer_comp)
+	{
+	  gfc_error ("Data transfer element at %L cannot have POINTER "
+		     "components unless it is processed by a defined "
+		     "input/output procedure", &code->loc);
+	  return;
+	}
+
+      /* F08:C935.  */
+      if (ts->u.derived->attr.proc_pointer_comp)
+	{
+	  gfc_error ("Data transfer element at %L cannot have "
+		     "procedure pointer components", &code->loc);
+	  return;
+	}
+
+      if (ts->u.derived->attr.alloc_comp)
+	{
+	  gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
+		     "components unless it is processed by a defined "
+		     "input/output procedure", &code->loc);
+	  return;
+	}
+
+      /* C_PTR and C_FUNPTR have private components which means they can not
+         be printed.  However, if -std=gnu and not -pedantic, allow
+         the component to be printed to help debugging.  */
+      if (ts->u.derived->ts.f90_type == BT_VOID)
+	{
+	  if (!gfc_notify_std (GFC_STD_GNU, "Data transfer element at %L "
+			       "cannot have PRIVATE components", &code->loc))
+	    return;
+	}
+      else if (derived_inaccessible (ts->u.derived))
+	{
+	  gfc_error ("Data transfer element at %L cannot have "
+		     "PRIVATE components",&code->loc);
+	  return;
+	}
+    }
+
+  if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE && exp->ref
+      && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
+    {
+      gfc_error ("Data transfer element at %L cannot be a full reference to "
+		 "an assumed-size array", &code->loc);
+      return;
+    }
+}
+
+
+/*********** Toplevel code resolution subroutines ***********/
+
+/* Find the set of labels that are reachable from this block.  We also
+   record the last statement in each block.  */
+
+static void
+find_reachable_labels (gfc_code *block)
+{
+  gfc_code *c;
+
+  if (!block)
+    return;
+
+  cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
+
+  /* Collect labels in this block.  We don't keep those corresponding
+     to END {IF|SELECT}, these are checked in resolve_branch by going
+     up through the code_stack.  */
+  for (c = block; c; c = c->next)
+    {
+      if (c->here && c->op != EXEC_END_NESTED_BLOCK)
+	bitmap_set_bit (cs_base->reachable_labels, c->here->value);
+    }
+
+  /* Merge with labels from parent block.  */
+  if (cs_base->prev)
+    {
+      gcc_assert (cs_base->prev->reachable_labels);
+      bitmap_ior_into (cs_base->reachable_labels,
+		       cs_base->prev->reachable_labels);
+    }
+}
+
+
+static void
+resolve_lock_unlock (gfc_code *code)
+{
+  if (code->expr1->ts.type != BT_DERIVED
+      || code->expr1->expr_type != EXPR_VARIABLE
+      || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
+      || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
+      || code->expr1->rank != 0
+      || (!gfc_is_coarray (code->expr1) && !gfc_is_coindexed (code->expr1)))
+    gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
+	       &code->expr1->where);
+
+  /* Check STAT.  */
+  if (code->expr2
+      && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
+	  || code->expr2->expr_type != EXPR_VARIABLE))
+    gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
+	       &code->expr2->where);
+
+  if (code->expr2
+      && !gfc_check_vardef_context (code->expr2, false, false, false, 
+				    _("STAT variable")))
+    return;
+
+  /* Check ERRMSG.  */
+  if (code->expr3
+      && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
+	  || code->expr3->expr_type != EXPR_VARIABLE))
+    gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
+	       &code->expr3->where);
+
+  if (code->expr3
+      && !gfc_check_vardef_context (code->expr3, false, false, false, 
+				    _("ERRMSG variable")))
+    return;
+
+  /* Check ACQUIRED_LOCK.  */
+  if (code->expr4
+      && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
+	  || code->expr4->expr_type != EXPR_VARIABLE))
+    gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
+	       "variable", &code->expr4->where);
+
+  if (code->expr4
+      && !gfc_check_vardef_context (code->expr4, false, false, false, 
+				    _("ACQUIRED_LOCK variable")))
+    return;
+}
+
+
+static void
+resolve_sync (gfc_code *code)
+{
+  /* Check imageset. The * case matches expr1 == NULL.  */
+  if (code->expr1)
+    {
+      if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
+	gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
+		   "INTEGER expression", &code->expr1->where);
+      if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
+	  && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
+	gfc_error ("Imageset argument at %L must between 1 and num_images()",
+		   &code->expr1->where);
+      else if (code->expr1->expr_type == EXPR_ARRAY
+	       && gfc_simplify_expr (code->expr1, 0))
+	{
+	   gfc_constructor *cons;
+	   cons = gfc_constructor_first (code->expr1->value.constructor);
+	   for (; cons; cons = gfc_constructor_next (cons))
+	     if (cons->expr->expr_type == EXPR_CONSTANT
+		 &&  mpz_cmp_si (cons->expr->value.integer, 1) < 0)
+	       gfc_error ("Imageset argument at %L must between 1 and "
+			  "num_images()", &cons->expr->where);
+	}
+    }
+
+  /* Check STAT.  */
+  if (code->expr2
+      && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
+	  || code->expr2->expr_type != EXPR_VARIABLE))
+    gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
+	       &code->expr2->where);
+
+  /* Check ERRMSG.  */
+  if (code->expr3
+      && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
+	  || code->expr3->expr_type != EXPR_VARIABLE))
+    gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
+	       &code->expr3->where);
+}
+
+
+/* Given a branch to a label, see if the branch is conforming.
+   The code node describes where the branch is located.  */
+
+static void
+resolve_branch (gfc_st_label *label, gfc_code *code)
+{
+  code_stack *stack;
+
+  if (label == NULL)
+    return;
+
+  /* Step one: is this a valid branching target?  */
+
+  if (label->defined == ST_LABEL_UNKNOWN)
+    {
+      gfc_error ("Label %d referenced at %L is never defined", label->value,
+		 &label->where);
+      return;
+    }
+
+  if (label->defined != ST_LABEL_TARGET && label->defined != ST_LABEL_DO_TARGET)
+    {
+      gfc_error ("Statement at %L is not a valid branch target statement "
+		 "for the branch statement at %L", &label->where, &code->loc);
+      return;
+    }
+
+  /* Step two: make sure this branch is not a branch to itself ;-)  */
+
+  if (code->here == label)
+    {
+      gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
+      return;
+    }
+
+  /* Step three:  See if the label is in the same block as the
+     branching statement.  The hard work has been done by setting up
+     the bitmap reachable_labels.  */
+
+  if (bitmap_bit_p (cs_base->reachable_labels, label->value))
+    {
+      /* Check now whether there is a CRITICAL construct; if so, check
+	 whether the label is still visible outside of the CRITICAL block,
+	 which is invalid.  */
+      for (stack = cs_base; stack; stack = stack->prev)
+	{
+	  if (stack->current->op == EXEC_CRITICAL
+	      && bitmap_bit_p (stack->reachable_labels, label->value))
+	    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 ("GOTO statement at %L leaves DO CONCURRENT construct "
+		      "for label at %L", &code->loc, &label->where);
+	}
+
+      return;
+    }
+
+  /* Step four:  If we haven't found the label in the bitmap, it may
+    still be the label of the END of the enclosing block, in which
+    case we find it by going up the code_stack.  */
+
+  for (stack = cs_base; stack; stack = stack->prev)
+    {
+      if (stack->current->next && stack->current->next->here == label)
+	break;
+      if (stack->current->op == EXEC_CRITICAL)
+	{
+	  /* Note: A label at END CRITICAL does not leave the CRITICAL
+	     construct as END CRITICAL is still part of it.  */
+	  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 ("GOTO statement at %L leaves DO CONCURRENT construct for "
+		     "label at %L", &code->loc, &label->where);
+	  return;
+	}
+    }
+
+  if (stack)
+    {
+      gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK);
+      return;
+    }
+
+  /* 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 (GFC_STD_LEGACY, "Label at %L is not in the same block "
+		  "as the GOTO statement at %L", &label->where,
+		  &code->loc);
+  return;
+}
+
+
+/* Check whether EXPR1 has the same shape as EXPR2.  */
+
+static bool
+resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
+{
+  mpz_t shape[GFC_MAX_DIMENSIONS];
+  mpz_t shape2[GFC_MAX_DIMENSIONS];
+  bool result = false;
+  int i;
+
+  /* Compare the rank.  */
+  if (expr1->rank != expr2->rank)
+    return result;
+
+  /* Compare the size of each dimension.  */
+  for (i=0; i<expr1->rank; i++)
+    {
+      if (!gfc_array_dimen_size (expr1, i, &shape[i]))
+	goto ignore;
+
+      if (!gfc_array_dimen_size (expr2, i, &shape2[i]))
+	goto ignore;
+
+      if (mpz_cmp (shape[i], shape2[i]))
+	goto over;
+    }
+
+  /* When either of the two expression is an assumed size array, we
+     ignore the comparison of dimension sizes.  */
+ignore:
+  result = true;
+
+over:
+  gfc_clear_shape (shape, i);
+  gfc_clear_shape (shape2, i);
+  return result;
+}
+
+
+/* Check whether a WHERE assignment target or a WHERE mask expression
+   has the same shape as the outmost WHERE mask expression.  */
+
+static void
+resolve_where (gfc_code *code, gfc_expr *mask)
+{
+  gfc_code *cblock;
+  gfc_code *cnext;
+  gfc_expr *e = NULL;
+
+  cblock = code->block;
+
+  /* Store the first WHERE mask-expr of the WHERE statement or construct.
+     In case of nested WHERE, only the outmost one is stored.  */
+  if (mask == NULL) /* outmost WHERE */
+    e = cblock->expr1;
+  else /* inner WHERE */
+    e = mask;
+
+  while (cblock)
+    {
+      if (cblock->expr1)
+	{
+	  /* Check if the mask-expr has a consistent shape with the
+	     outmost WHERE mask-expr.  */
+	  if (!resolve_where_shape (cblock->expr1, e))
+	    gfc_error ("WHERE mask at %L has inconsistent shape",
+		       &cblock->expr1->where);
+	 }
+
+      /* the assignment statement of a WHERE statement, or the first
+	 statement in where-body-construct of a WHERE construct */
+      cnext = cblock->next;
+      while (cnext)
+	{
+	  switch (cnext->op)
+	    {
+	    /* WHERE assignment statement */
+	    case EXEC_ASSIGN:
+
+	      /* Check shape consistent for WHERE assignment target.  */
+	      if (e && !resolve_where_shape (cnext->expr1, e))
+	       gfc_error ("WHERE assignment target at %L has "
+			  "inconsistent shape", &cnext->expr1->where);
+	      break;
+
+
+	    case EXEC_ASSIGN_CALL:
+	      resolve_call (cnext);
+	      if (!cnext->resolved_sym->attr.elemental)
+		gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
+			  &cnext->ext.actual->expr->where);
+	      break;
+
+	    /* WHERE or WHERE construct is part of a where-body-construct */
+	    case EXEC_WHERE:
+	      resolve_where (cnext, e);
+	      break;
+
+	    default:
+	      gfc_error ("Unsupported statement inside WHERE at %L",
+			 &cnext->loc);
+	    }
+	 /* the next statement within the same where-body-construct */
+	 cnext = cnext->next;
+       }
+    /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
+    cblock = cblock->block;
+  }
+}
+
+
+/* Resolve assignment in FORALL construct.
+   NVAR is the number of FORALL index variables, and VAR_EXPR records the
+   FORALL index variables.  */
+
+static void
+gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
+{
+  int n;
+
+  for (n = 0; n < nvar; n++)
+    {
+      gfc_symbol *forall_index;
+
+      forall_index = var_expr[n]->symtree->n.sym;
+
+      /* Check whether the assignment target is one of the FORALL index
+	 variable.  */
+      if ((code->expr1->expr_type == EXPR_VARIABLE)
+	  && (code->expr1->symtree->n.sym == forall_index))
+	gfc_error ("Assignment to a FORALL index variable at %L",
+		   &code->expr1->where);
+      else
+	{
+	  /* If one of the FORALL index variables doesn't appear in the
+	     assignment variable, then there could be a many-to-one
+	     assignment.  Emit a warning rather than an error because the
+	     mask could be resolving this problem.  */
+	  if (!find_forall_index (code->expr1, forall_index, 0))
+	    gfc_warning ("The FORALL with index '%s' is not used on the "
+			 "left side of the assignment at %L and so might "
+			 "cause multiple assignment to this object",
+			 var_expr[n]->symtree->name, &code->expr1->where);
+	}
+    }
+}
+
+
+/* Resolve WHERE statement in FORALL construct.  */
+
+static void
+gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
+				  gfc_expr **var_expr)
+{
+  gfc_code *cblock;
+  gfc_code *cnext;
+
+  cblock = code->block;
+  while (cblock)
+    {
+      /* the assignment statement of a WHERE statement, or the first
+	 statement in where-body-construct of a WHERE construct */
+      cnext = cblock->next;
+      while (cnext)
+	{
+	  switch (cnext->op)
+	    {
+	    /* WHERE assignment statement */
+	    case EXEC_ASSIGN:
+	      gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
+	      break;
+
+	    /* WHERE operator assignment statement */
+	    case EXEC_ASSIGN_CALL:
+	      resolve_call (cnext);
+	      if (!cnext->resolved_sym->attr.elemental)
+		gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
+			  &cnext->ext.actual->expr->where);
+	      break;
+
+	    /* WHERE or WHERE construct is part of a where-body-construct */
+	    case EXEC_WHERE:
+	      gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
+	      break;
+
+	    default:
+	      gfc_error ("Unsupported statement inside WHERE at %L",
+			 &cnext->loc);
+	    }
+	  /* the next statement within the same where-body-construct */
+	  cnext = cnext->next;
+	}
+      /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
+      cblock = cblock->block;
+    }
+}
+
+
+/* Traverse the FORALL body to check whether the following errors exist:
+   1. For assignment, check if a many-to-one assignment happens.
+   2. For WHERE statement, check the WHERE body to see if there is any
+      many-to-one assignment.  */
+
+static void
+gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
+{
+  gfc_code *c;
+
+  c = code->block->next;
+  while (c)
+    {
+      switch (c->op)
+	{
+	case EXEC_ASSIGN:
+	case EXEC_POINTER_ASSIGN:
+	  gfc_resolve_assign_in_forall (c, nvar, var_expr);
+	  break;
+
+	case EXEC_ASSIGN_CALL:
+	  resolve_call (c);
+	  break;
+
+	/* Because the gfc_resolve_blocks() will handle the nested FORALL,
+	   there is no need to handle it here.  */
+	case EXEC_FORALL:
+	  break;
+	case EXEC_WHERE:
+	  gfc_resolve_where_code_in_forall(c, nvar, var_expr);
+	  break;
+	default:
+	  break;
+	}
+      /* The next statement in the FORALL body.  */
+      c = c->next;
+    }
+}
+
+
+/* Counts the number of iterators needed inside a forall construct, including
+   nested forall constructs. This is used to allocate the needed memory
+   in gfc_resolve_forall.  */
+
+static int
+gfc_count_forall_iterators (gfc_code *code)
+{
+  int max_iters, sub_iters, current_iters;
+  gfc_forall_iterator *fa;
+
+  gcc_assert(code->op == EXEC_FORALL);
+  max_iters = 0;
+  current_iters = 0;
+
+  for (fa = code->ext.forall_iterator; fa; fa = fa->next)
+    current_iters ++;
+
+  code = code->block->next;
+
+  while (code)
+    {
+      if (code->op == EXEC_FORALL)
+        {
+          sub_iters = gfc_count_forall_iterators (code);
+          if (sub_iters > max_iters)
+            max_iters = sub_iters;
+        }
+      code = code->next;
+    }
+
+  return current_iters + max_iters;
+}
+
+
+/* Given a FORALL construct, first resolve the FORALL iterator, then call
+   gfc_resolve_forall_body to resolve the FORALL body.  */
+
+static void
+gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
+{
+  static gfc_expr **var_expr;
+  static int total_var = 0;
+  static int nvar = 0;
+  int old_nvar, tmp;
+  gfc_forall_iterator *fa;
+  int i;
+
+  old_nvar = nvar;
+
+  /* Start to resolve a FORALL construct   */
+  if (forall_save == 0)
+    {
+      /* Count the total number of FORALL index in the nested FORALL
+         construct in order to allocate the VAR_EXPR with proper size.  */
+      total_var = gfc_count_forall_iterators (code);
+
+      /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements.  */
+      var_expr = XCNEWVEC (gfc_expr *, total_var);
+    }
+
+  /* The information about FORALL iterator, including FORALL index start, end
+     and stride. The FORALL index can not appear in start, end or stride.  */
+  for (fa = code->ext.forall_iterator; fa; fa = fa->next)
+    {
+      /* Check if any outer FORALL index name is the same as the current
+	 one.  */
+      for (i = 0; i < nvar; i++)
+	{
+	  if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
+	    {
+	      gfc_error ("An outer FORALL construct already has an index "
+			 "with this name %L", &fa->var->where);
+	    }
+	}
+
+      /* Record the current FORALL index.  */
+      var_expr[nvar] = gfc_copy_expr (fa->var);
+
+      nvar++;
+
+      /* No memory leak.  */
+      gcc_assert (nvar <= total_var);
+    }
+
+  /* Resolve the FORALL body.  */
+  gfc_resolve_forall_body (code, nvar, var_expr);
+
+  /* May call gfc_resolve_forall to resolve the inner FORALL loop.  */
+  gfc_resolve_blocks (code->block, ns);
+
+  tmp = nvar;
+  nvar = old_nvar;
+  /* Free only the VAR_EXPRs allocated in this frame.  */
+  for (i = nvar; i < tmp; i++)
+     gfc_free_expr (var_expr[i]);
+
+  if (nvar == 0)
+    {
+      /* We are in the outermost FORALL construct.  */
+      gcc_assert (forall_save == 0);
+
+      /* VAR_EXPR is not needed any more.  */
+      free (var_expr);
+      total_var = 0;
+    }
+}
+
+
+/* Resolve a BLOCK construct statement.  */
+
+static void
+resolve_block_construct (gfc_code* code)
+{
+  /* Resolve the BLOCK's namespace.  */
+  gfc_resolve (code->ext.block.ns);
+
+  /* For an ASSOCIATE block, the associations (and their targets) are already
+     resolved during resolve_symbol.  */
+}
+
+
+/* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
+   DO code nodes.  */
+
+static void resolve_code (gfc_code *, gfc_namespace *);
+
+void
+gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
+{
+  bool t;
+
+  for (; b; b = b->block)
+    {
+      t = gfc_resolve_expr (b->expr1);
+      if (!gfc_resolve_expr (b->expr2))
+	t = false;
+
+      switch (b->op)
+	{
+	case EXEC_IF:
+	  if (t && b->expr1 != NULL
+	      && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
+	    gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
+		       &b->expr1->where);
+	  break;
+
+	case EXEC_WHERE:
+	  if (t
+	      && b->expr1 != NULL
+	      && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
+	    gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
+		       &b->expr1->where);
+	  break;
+
+	case EXEC_GOTO:
+	  resolve_branch (b->label1, b);
+	  break;
+
+	case EXEC_BLOCK:
+	  resolve_block_construct (b);
+	  break;
+
+	case EXEC_SELECT:
+	case EXEC_SELECT_TYPE:
+	case EXEC_FORALL:
+	case EXEC_DO:
+	case EXEC_DO_WHILE:
+	case EXEC_DO_CONCURRENT:
+	case EXEC_CRITICAL:
+	case EXEC_READ:
+	case EXEC_WRITE:
+	case EXEC_IOLENGTH:
+	case EXEC_WAIT:
+	  break;
+
+	case EXEC_OMP_ATOMIC:
+	case EXEC_OMP_CRITICAL:
+	case EXEC_OMP_DO:
+	case EXEC_OMP_MASTER:
+	case EXEC_OMP_ORDERED:
+	case EXEC_OMP_PARALLEL:
+	case EXEC_OMP_PARALLEL_DO:
+	case EXEC_OMP_PARALLEL_SECTIONS:
+	case EXEC_OMP_PARALLEL_WORKSHARE:
+	case EXEC_OMP_SECTIONS:
+	case EXEC_OMP_SINGLE:
+	case EXEC_OMP_TASK:
+	case EXEC_OMP_TASKWAIT:
+	case EXEC_OMP_TASKYIELD:
+	case EXEC_OMP_WORKSHARE:
+	  break;
+
+	default:
+	  gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
+	}
+
+      resolve_code (b->next, ns);
+    }
+}
+
+
+/* Does everything to resolve an ordinary assignment.  Returns true
+   if this is an interface assignment.  */
+static bool
+resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
+{
+  bool rval = false;
+  gfc_expr *lhs;
+  gfc_expr *rhs;
+  int llen = 0;
+  int rlen = 0;
+  int n;
+  gfc_ref *ref;
+  symbol_attribute attr;
+
+  if (gfc_extend_assign (code, ns))
+    {
+      gfc_expr** rhsptr;
+
+      if (code->op == EXEC_ASSIGN_CALL)
+	{
+	  lhs = code->ext.actual->expr;
+	  rhsptr = &code->ext.actual->next->expr;
+	}
+      else
+	{
+	  gfc_actual_arglist* args;
+	  gfc_typebound_proc* tbp;
+
+	  gcc_assert (code->op == EXEC_COMPCALL);
+
+	  args = code->expr1->value.compcall.actual;
+	  lhs = args->expr;
+	  rhsptr = &args->next->expr;
+
+	  tbp = code->expr1->value.compcall.tbp;
+	  gcc_assert (!tbp->is_generic);
+	}
+
+      /* Make a temporary rhs when there is a default initializer
+	 and rhs is the same symbol as the lhs.  */
+      if ((*rhsptr)->expr_type == EXPR_VARIABLE
+	    && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
+	    && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
+	    && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
+	*rhsptr = gfc_get_parentheses (*rhsptr);
+
+      return true;
+    }
+
+  lhs = code->expr1;
+  rhs = code->expr2;
+
+  if (rhs->is_boz
+      && !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L outside "
+			  "a DATA statement and outside INT/REAL/DBLE/CMPLX", 
+			  &code->loc))
+    return false;
+
+  /* Handle the case of a BOZ literal on the RHS.  */
+  if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
+    {
+      int rc;
+      if (gfc_option.warn_surprising)
+	gfc_warning ("BOZ literal at %L is bitwise transferred "
+		     "non-integer symbol '%s'", &code->loc,
+		     lhs->symtree->n.sym->name);
+
+      if (!gfc_convert_boz (rhs, &lhs->ts))
+	return false;
+      if ((rc = gfc_range_check (rhs)) != ARITH_OK)
+	{
+	  if (rc == ARITH_UNDERFLOW)
+	    gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
+		       ". This check can be disabled with the option "
+		       "-fno-range-check", &rhs->where);
+	  else if (rc == ARITH_OVERFLOW)
+	    gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
+		       ". This check can be disabled with the option "
+		       "-fno-range-check", &rhs->where);
+	  else if (rc == ARITH_NAN)
+	    gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
+		       ". This check can be disabled with the option "
+		       "-fno-range-check", &rhs->where);
+	  return false;
+	}
+    }
+
+  if (lhs->ts.type == BT_CHARACTER
+	&& gfc_option.warn_character_truncation)
+    {
+      if (lhs->ts.u.cl != NULL
+	    && lhs->ts.u.cl->length != NULL
+	    && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+	llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
+
+      if (rhs->expr_type == EXPR_CONSTANT)
+ 	rlen = rhs->value.character.length;
+
+      else if (rhs->ts.u.cl != NULL
+		 && rhs->ts.u.cl->length != NULL
+		 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+	rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
+
+      if (rlen && llen && rlen > llen)
+	gfc_warning_now ("CHARACTER expression will be truncated "
+			 "in assignment (%d/%d) at %L",
+			 llen, rlen, &code->loc);
+    }
+
+  /* Ensure that a vector index expression for the lvalue is evaluated
+     to a temporary if the lvalue symbol is referenced in it.  */
+  if (lhs->rank)
+    {
+      for (ref = lhs->ref; ref; ref= ref->next)
+	if (ref->type == REF_ARRAY)
+	  {
+	    for (n = 0; n < ref->u.ar.dimen; n++)
+	      if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
+		  && gfc_find_sym_in_expr (lhs->symtree->n.sym,
+					   ref->u.ar.start[n]))
+		ref->u.ar.start[n]
+			= gfc_get_parentheses (ref->u.ar.start[n]);
+	  }
+    }
+
+  if (gfc_pure (NULL))
+    {
+      if (lhs->ts.type == BT_DERIVED
+	    && lhs->expr_type == EXPR_VARIABLE
+	    && lhs->ts.u.derived->attr.pointer_comp
+	    && rhs->expr_type == EXPR_VARIABLE
+	    && (gfc_impure_variable (rhs->symtree->n.sym)
+		|| gfc_is_coindexed (rhs)))
+	{
+	  /* F2008, C1283.  */
+	  if (gfc_is_coindexed (rhs))
+	    gfc_error ("Coindexed expression at %L is assigned to "
+			"a derived type variable with a POINTER "
+			"component in a PURE procedure",
+			&rhs->where);
+	  else
+	    gfc_error ("The impure variable at %L is assigned to "
+			"a derived type variable with a POINTER "
+			"component in a PURE procedure (12.6)",
+			&rhs->where);
+	  return rval;
+	}
+
+      /* Fortran 2008, C1283.  */
+      if (gfc_is_coindexed (lhs))
+	{
+	  gfc_error ("Assignment to coindexed variable at %L in a PURE "
+		     "procedure", &rhs->where);
+	  return rval;
+	}
+    }
+
+  if (gfc_implicit_pure (NULL))
+    {
+      if (lhs->expr_type == EXPR_VARIABLE
+	    && lhs->symtree->n.sym != gfc_current_ns->proc_name
+	    && lhs->symtree->n.sym->ns != gfc_current_ns)
+	gfc_unset_implicit_pure (NULL);
+
+      if (lhs->ts.type == BT_DERIVED
+	    && lhs->expr_type == EXPR_VARIABLE
+	    && lhs->ts.u.derived->attr.pointer_comp
+	    && rhs->expr_type == EXPR_VARIABLE
+	    && (gfc_impure_variable (rhs->symtree->n.sym)
+		|| gfc_is_coindexed (rhs)))
+	gfc_unset_implicit_pure (NULL);
+
+      /* Fortran 2008, C1283.  */
+      if (gfc_is_coindexed (lhs))
+	gfc_unset_implicit_pure (NULL);
+    }
+
+  /* F2008, 7.2.1.2.  */
+  attr = gfc_expr_attr (lhs);
+  if (lhs->ts.type == BT_CLASS && attr.allocatable)
+    {
+      if (attr.codimension)
+	{
+	  gfc_error ("Assignment to polymorphic coarray at %L is not "
+		     "permitted", &lhs->where);
+	  return false;
+	}
+      if (!gfc_notify_std (GFC_STD_F2008, "Assignment to an allocatable "
+			   "polymorphic variable at %L", &lhs->where))
+	return false;
+      if (!gfc_option.flag_realloc_lhs)
+	{
+	  gfc_error ("Assignment to an allocatable polymorphic variable at %L "
+		     "requires -frealloc-lhs", &lhs->where);
+	  return false;
+	}
+      /* See PR 43366.  */
+      gfc_error ("Assignment to an allocatable polymorphic variable at %L "
+		 "is not yet supported", &lhs->where);
+      return false;
+    }
+  else if (lhs->ts.type == BT_CLASS)
+    {
+      gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
+		 "assignment at %L - check that there is a matching specific "
+		 "subroutine for '=' operator", &lhs->where);
+      return false;
+    }
+
+  /* F2008, Section 7.2.1.2.  */
+  if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
+    {
+      gfc_error ("Coindexed variable must not have an allocatable ultimate "
+		 "component in assignment at %L", &lhs->where);
+      return false;
+    }
+
+  gfc_check_assign (lhs, rhs, 1);
+  return false;
+}
+
+
+/* Add a component reference onto an expression.  */
+
+static void
+add_comp_ref (gfc_expr *e, gfc_component *c)
+{
+  gfc_ref **ref;
+  ref = &(e->ref);
+  while (*ref)
+    ref = &((*ref)->next);
+  *ref = gfc_get_ref ();
+  (*ref)->type = REF_COMPONENT;
+  (*ref)->u.c.sym = e->ts.u.derived;
+  (*ref)->u.c.component = c;
+  e->ts = c->ts;
+
+  /* Add a full array ref, as necessary.  */
+  if (c->as)
+    {
+      gfc_add_full_array_ref (e, c->as);
+      e->rank = c->as->rank;
+    }
+}
+
+
+/* Build an assignment.  Keep the argument 'op' for future use, so that
+   pointer assignments can be made.  */
+
+static gfc_code *
+build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2,
+		  gfc_component *comp1, gfc_component *comp2, locus loc)
+{
+  gfc_code *this_code;
+
+  this_code = gfc_get_code (op);
+  this_code->next = NULL;
+  this_code->expr1 = gfc_copy_expr (expr1);
+  this_code->expr2 = gfc_copy_expr (expr2);
+  this_code->loc = loc;
+  if (comp1 && comp2)
+    {
+      add_comp_ref (this_code->expr1, comp1);
+      add_comp_ref (this_code->expr2, comp2);
+    }
+
+  return this_code;
+}
+
+
+/* Makes a temporary variable expression based on the characteristics of
+   a given variable expression.  */
+
+static gfc_expr*
+get_temp_from_expr (gfc_expr *e, gfc_namespace *ns)
+{
+  static int serial = 0;
+  char name[GFC_MAX_SYMBOL_LEN];
+  gfc_symtree *tmp;
+  gfc_array_spec *as;
+  gfc_array_ref *aref;
+  gfc_ref *ref;
+
+  sprintf (name, GFC_PREFIX("DA%d"), serial++);
+  gfc_get_sym_tree (name, ns, &tmp, false);
+  gfc_add_type (tmp->n.sym, &e->ts, NULL);
+
+  as = NULL;
+  ref = NULL;
+  aref = NULL;
+
+  /* This function could be expanded to support other expression type
+     but this is not needed here.  */
+  gcc_assert (e->expr_type == EXPR_VARIABLE);
+
+  /* Obtain the arrayspec for the temporary.  */
+  if (e->rank)
+    {
+      aref = gfc_find_array_ref (e);
+      if (e->expr_type == EXPR_VARIABLE
+	  && e->symtree->n.sym->as == aref->as)
+	as = aref->as;
+      else
+	{
+	  for (ref = e->ref; ref; ref = ref->next)
+	    if (ref->type == REF_COMPONENT
+		&& ref->u.c.component->as == aref->as)
+	      {
+		as = aref->as;
+		break;
+	      }
+	}
+    }
+
+  /* Add the attributes and the arrayspec to the temporary.  */
+  tmp->n.sym->attr = gfc_expr_attr (e);
+  tmp->n.sym->attr.function = 0;
+  tmp->n.sym->attr.result = 0;
+  tmp->n.sym->attr.flavor = FL_VARIABLE;
+
+  if (as)
+    {
+      tmp->n.sym->as = gfc_copy_array_spec (as);
+      if (!ref)
+	ref = e->ref;
+      if (as->type == AS_DEFERRED)
+	tmp->n.sym->attr.allocatable = 1;
+    }
+  else
+    tmp->n.sym->attr.dimension = 0;
+
+  gfc_set_sym_referenced (tmp->n.sym);
+  gfc_commit_symbol (tmp->n.sym);
+  e = gfc_lval_expr_from_sym (tmp->n.sym);
+
+  /* Should the lhs be a section, use its array ref for the
+     temporary expression.  */
+  if (aref && aref->type != AR_FULL)
+    {
+      gfc_free_ref_list (e->ref);
+      e->ref = gfc_copy_ref (ref);
+    }
+  return e;
+}
+
+
+/* Add one line of code to the code chain, making sure that 'head' and
+   'tail' are appropriately updated.  */
+
+static void
+add_code_to_chain (gfc_code **this_code, gfc_code **head, gfc_code **tail)
+{
+  gcc_assert (this_code);
+  if (*head == NULL)
+    *head = *tail = *this_code;
+  else
+    *tail = gfc_append_code (*tail, *this_code);
+  *this_code = NULL;
+}
+
+
+/* Counts the potential number of part array references that would
+   result from resolution of typebound defined assignments.  */
+
+static int
+nonscalar_typebound_assign (gfc_symbol *derived, int depth)
+{
+  gfc_component *c;
+  int c_depth = 0, t_depth;
+
+  for (c= derived->components; c; c = c->next)
+    {
+      if ((c->ts.type != BT_DERIVED
+	    || c->attr.pointer
+	    || c->attr.allocatable
+	    || c->attr.proc_pointer_comp
+	    || c->attr.class_pointer
+	    || c->attr.proc_pointer)
+	  && !c->attr.defined_assign_comp)
+	continue;
+
+      if (c->as && c_depth == 0)
+	c_depth = 1;
+
+      if (c->ts.u.derived->attr.defined_assign_comp)
+	t_depth = nonscalar_typebound_assign (c->ts.u.derived,
+					      c->as ? 1 : 0);
+      else
+	t_depth = 0;
+
+      c_depth = t_depth > c_depth ? t_depth : c_depth;
+    }
+  return depth + c_depth;
+}
+
+
+/* Implement 7.2.1.3 of the F08 standard:
+   "An intrinsic assignment where the variable is of derived type is
+   performed as if each component of the variable were assigned from the
+   corresponding component of expr using pointer assignment (7.2.2) for
+   each pointer component, defined assignment for each nonpointer
+   nonallocatable component of a type that has a type-bound defined
+   assignment consistent with the component, intrinsic assignment for
+   each other nonpointer nonallocatable component, ..."
+
+   The pointer assignments are taken care of by the intrinsic
+   assignment of the structure itself.  This function recursively adds
+   defined assignments where required.  The recursion is accomplished
+   by calling resolve_code.
+
+   When the lhs in a defined assignment has intent INOUT, we need a
+   temporary for the lhs.  In pseudo-code:
+
+   ! Only call function lhs once.
+      if (lhs is not a constant or an variable)
+	  temp_x = expr2
+          expr2 => temp_x
+   ! Do the intrinsic assignment
+      expr1 = expr2
+   ! Now do the defined assignments
+      do over components with typebound defined assignment [%cmp]
+	#if one component's assignment procedure is INOUT
+	  t1 = expr1
+	  #if expr2 non-variable
+	    temp_x = expr2
+	    expr2 => temp_x
+	  # endif
+	  expr1 = expr2
+	  # for each cmp
+	    t1%cmp {defined=} expr2%cmp
+	    expr1%cmp = t1%cmp
+	#else
+	  expr1 = expr2
+
+	# for each cmp
+	  expr1%cmp {defined=} expr2%cmp
+	#endif
+   */
+
+/* The temporary assignments have to be put on top of the additional
+   code to avoid the result being changed by the intrinsic assignment.
+   */
+static int component_assignment_level = 0;
+static gfc_code *tmp_head = NULL, *tmp_tail = NULL;
+
+static void
+generate_component_assignments (gfc_code **code, gfc_namespace *ns)
+{
+  gfc_component *comp1, *comp2;
+  gfc_code *this_code = NULL, *head = NULL, *tail = NULL;
+  gfc_expr *t1;
+  int error_count, depth;
+
+  gfc_get_errors (NULL, &error_count);
+
+  /* Filter out continuing processing after an error.  */
+  if (error_count
+      || (*code)->expr1->ts.type != BT_DERIVED
+      || (*code)->expr2->ts.type != BT_DERIVED)
+    return;
+
+  /* TODO: Handle more than one part array reference in assignments.  */
+  depth = nonscalar_typebound_assign ((*code)->expr1->ts.u.derived,
+				      (*code)->expr1->rank ? 1 : 0);
+  if (depth > 1)
+    {
+      gfc_warning ("TODO: type-bound defined assignment(s) at %L not "
+		   "done because multiple part array references would "
+		   "occur in intermediate expressions.", &(*code)->loc);
+      return;
+    }
+
+  component_assignment_level++;
+
+  /* Create a temporary so that functions get called only once.  */
+  if ((*code)->expr2->expr_type != EXPR_VARIABLE
+      && (*code)->expr2->expr_type != EXPR_CONSTANT)
+    {
+      gfc_expr *tmp_expr;
+
+      /* Assign the rhs to the temporary.  */
+      tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
+      this_code = build_assignment (EXEC_ASSIGN,
+				    tmp_expr, (*code)->expr2,
+				    NULL, NULL, (*code)->loc);
+      /* Add the code and substitute the rhs expression.  */
+      add_code_to_chain (&this_code, &tmp_head, &tmp_tail);
+      gfc_free_expr ((*code)->expr2);
+      (*code)->expr2 = tmp_expr;
+    }
+
+  /* Do the intrinsic assignment.  This is not needed if the lhs is one
+     of the temporaries generated here, since the intrinsic assignment
+     to the final result already does this.  */
+  if ((*code)->expr1->symtree->n.sym->name[2] != '@')
+    {
+      this_code = build_assignment (EXEC_ASSIGN,
+				    (*code)->expr1, (*code)->expr2,
+				    NULL, NULL, (*code)->loc);
+      add_code_to_chain (&this_code, &head, &tail);
+    }
+
+  comp1 = (*code)->expr1->ts.u.derived->components;
+  comp2 = (*code)->expr2->ts.u.derived->components;
+
+  t1 = NULL;
+  for (; comp1; comp1 = comp1->next, comp2 = comp2->next)
+    {
+      bool inout = false;
+
+      /* The intrinsic assignment does the right thing for pointers
+	 of all kinds and allocatable components.  */
+      if (comp1->ts.type != BT_DERIVED
+	  || comp1->attr.pointer
+	  || comp1->attr.allocatable
+	  || comp1->attr.proc_pointer_comp
+	  || comp1->attr.class_pointer
+	  || comp1->attr.proc_pointer)
+	continue;
+
+      /* Make an assigment for this component.  */
+      this_code = build_assignment (EXEC_ASSIGN,
+				    (*code)->expr1, (*code)->expr2,
+				    comp1, comp2, (*code)->loc);
+
+      /* Convert the assignment if there is a defined assignment for
+	 this type.  Otherwise, using the call from resolve_code,
+	 recurse into its components.  */
+      resolve_code (this_code, ns);
+
+      if (this_code->op == EXEC_ASSIGN_CALL)
+	{
+	  gfc_formal_arglist *dummy_args;
+	  gfc_symbol *rsym;
+	  /* Check that there is a typebound defined assignment.  If not,
+	     then this must be a module defined assignment.  We cannot
+	     use the defined_assign_comp attribute here because it must
+	     be this derived type that has the defined assignment and not
+	     a parent type.  */
+	  if (!(comp1->ts.u.derived->f2k_derived
+		&& comp1->ts.u.derived->f2k_derived
+					->tb_op[INTRINSIC_ASSIGN]))
+	    {
+	      gfc_free_statements (this_code);
+	      this_code = NULL;
+	      continue;
+	    }
+
+	  /* If the first argument of the subroutine has intent INOUT
+	     a temporary must be generated and used instead.  */
+	  rsym = this_code->resolved_sym;
+	  dummy_args = gfc_sym_get_dummy_args (rsym);
+	  if (dummy_args
+	      && dummy_args->sym->attr.intent == INTENT_INOUT)
+	    {
+	      gfc_code *temp_code;
+	      inout = true;
+
+	      /* Build the temporary required for the assignment and put
+		 it at the head of the generated code.  */
+	      if (!t1)
+		{
+		  t1 = get_temp_from_expr ((*code)->expr1, ns);
+		  temp_code = build_assignment (EXEC_ASSIGN,
+						t1, (*code)->expr1,
+				NULL, NULL, (*code)->loc);
+
+		  /* For allocatable LHS, check whether it is allocated.  Note
+		     that allocatable components with defined assignment are
+		     not yet support.  See PR 57696.  */
+		  if ((*code)->expr1->symtree->n.sym->attr.allocatable)
+		    {
+		      gfc_code *block;
+		      gfc_expr *e =
+			gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym);
+		      block = gfc_get_code (EXEC_IF);
+		      block->block = gfc_get_code (EXEC_IF);
+		      block->block->expr1
+			  = gfc_build_intrinsic_call (ns,
+				    GFC_ISYM_ALLOCATED, "allocated",
+				    (*code)->loc, 1, e);
+		      block->block->next = temp_code;
+		      temp_code = block;
+		    }
+		  add_code_to_chain (&temp_code, &tmp_head, &tmp_tail);
+		}
+
+	      /* Replace the first actual arg with the component of the
+		 temporary.  */
+	      gfc_free_expr (this_code->ext.actual->expr);
+	      this_code->ext.actual->expr = gfc_copy_expr (t1);
+	      add_comp_ref (this_code->ext.actual->expr, comp1);
+
+	      /* If the LHS variable is allocatable and wasn't allocated and
+                 the temporary is allocatable, pointer assign the address of
+                 the freshly allocated LHS to the temporary.  */
+	      if ((*code)->expr1->symtree->n.sym->attr.allocatable
+		  && gfc_expr_attr ((*code)->expr1).allocatable)
+		{
+		  gfc_code *block;
+		  gfc_expr *cond;
+
+		  cond = gfc_get_expr ();
+		  cond->ts.type = BT_LOGICAL;
+		  cond->ts.kind = gfc_default_logical_kind;
+		  cond->expr_type = EXPR_OP;
+		  cond->where = (*code)->loc;
+		  cond->value.op.op = INTRINSIC_NOT;
+		  cond->value.op.op1 = gfc_build_intrinsic_call (ns,
+					  GFC_ISYM_ALLOCATED, "allocated",
+					  (*code)->loc, 1, gfc_copy_expr (t1));
+		  block = gfc_get_code (EXEC_IF);
+		  block->block = gfc_get_code (EXEC_IF);
+		  block->block->expr1 = cond;
+		  block->block->next = build_assignment (EXEC_POINTER_ASSIGN,
+					t1, (*code)->expr1,
+					NULL, NULL, (*code)->loc);
+		  add_code_to_chain (&block, &head, &tail);
+		}
+	    }
+	}
+      else if (this_code->op == EXEC_ASSIGN && !this_code->next)
+	{
+	  /* Don't add intrinsic assignments since they are already
+	     effected by the intrinsic assignment of the structure.  */
+	  gfc_free_statements (this_code);
+	  this_code = NULL;
+	  continue;
+	}
+
+      add_code_to_chain (&this_code, &head, &tail);
+
+      if (t1 && inout)
+	{
+	  /* Transfer the value to the final result.  */
+	  this_code = build_assignment (EXEC_ASSIGN,
+					(*code)->expr1, t1,
+					comp1, comp2, (*code)->loc);
+	  add_code_to_chain (&this_code, &head, &tail);
+	}
+    }
+
+  /* Put the temporary assignments at the top of the generated code.  */
+  if (tmp_head && component_assignment_level == 1)
+    {
+      gfc_append_code (tmp_head, head);
+      head = tmp_head;
+      tmp_head = tmp_tail = NULL;
+    }
+
+  // If we did a pointer assignment - thus, we need to ensure that the LHS is
+  // not accidentally deallocated. Hence, nullify t1.
+  if (t1 && (*code)->expr1->symtree->n.sym->attr.allocatable
+      && gfc_expr_attr ((*code)->expr1).allocatable)
+    {
+      gfc_code *block;
+      gfc_expr *cond;
+      gfc_expr *e;
+
+      e = gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym);
+      cond = gfc_build_intrinsic_call (ns, GFC_ISYM_ASSOCIATED, "associated",
+				       (*code)->loc, 2, gfc_copy_expr (t1), e);
+      block = gfc_get_code (EXEC_IF);
+      block->block = gfc_get_code (EXEC_IF);
+      block->block->expr1 = cond;
+      block->block->next = build_assignment (EXEC_POINTER_ASSIGN,
+					t1, gfc_get_null_expr (&(*code)->loc),
+					NULL, NULL, (*code)->loc);
+      gfc_append_code (tail, block);
+      tail = block;
+    }
+
+  /* Now attach the remaining code chain to the input code.  Step on
+     to the end of the new code since resolution is complete.  */
+  gcc_assert ((*code)->op == EXEC_ASSIGN);
+  tail->next = (*code)->next;
+  /* Overwrite 'code' because this would place the intrinsic assignment
+     before the temporary for the lhs is created.  */
+  gfc_free_expr ((*code)->expr1);
+  gfc_free_expr ((*code)->expr2);
+  **code = *head;
+  if (head != tail)
+    free (head);
+  *code = tail;
+
+  component_assignment_level--;
+}
+
+
+/* Given a block of code, recursively resolve everything pointed to by this
+   code block.  */
+
+static void
+resolve_code (gfc_code *code, gfc_namespace *ns)
+{
+  int omp_workshare_save;
+  int forall_save, do_concurrent_save;
+  code_stack frame;
+  bool t;
+
+  frame.prev = cs_base;
+  frame.head = code;
+  cs_base = &frame;
+
+  find_reachable_labels (code);
+
+  for (; code; code = code->next)
+    {
+      frame.current = code;
+      forall_save = forall_flag;
+      do_concurrent_save = gfc_do_concurrent_flag;
+
+      if (code->op == EXEC_FORALL)
+	{
+	  forall_flag = 1;
+	  gfc_resolve_forall (code, ns, forall_save);
+	  forall_flag = 2;
+	}
+      else if (code->block)
+	{
+	  omp_workshare_save = -1;
+	  switch (code->op)
+	    {
+	    case EXEC_OMP_PARALLEL_WORKSHARE:
+	      omp_workshare_save = omp_workshare_flag;
+	      omp_workshare_flag = 1;
+	      gfc_resolve_omp_parallel_blocks (code, ns);
+	      break;
+	    case EXEC_OMP_PARALLEL:
+	    case EXEC_OMP_PARALLEL_DO:
+	    case EXEC_OMP_PARALLEL_SECTIONS:
+	    case EXEC_OMP_TASK:
+	      omp_workshare_save = omp_workshare_flag;
+	      omp_workshare_flag = 0;
+	      gfc_resolve_omp_parallel_blocks (code, ns);
+	      break;
+	    case EXEC_OMP_DO:
+	      gfc_resolve_omp_do_blocks (code, ns);
+	      break;
+	    case EXEC_SELECT_TYPE:
+	      /* Blocks are handled in resolve_select_type because we have
+		 to transform the SELECT TYPE into ASSOCIATE first.  */
+	      break;
+            case EXEC_DO_CONCURRENT:
+	      gfc_do_concurrent_flag = 1;
+	      gfc_resolve_blocks (code->block, ns);
+	      gfc_do_concurrent_flag = 2;
+	      break;
+	    case EXEC_OMP_WORKSHARE:
+	      omp_workshare_save = omp_workshare_flag;
+	      omp_workshare_flag = 1;
+	      /* FALL THROUGH */
+	    default:
+	      gfc_resolve_blocks (code->block, ns);
+	      break;
+	    }
+
+	  if (omp_workshare_save != -1)
+	    omp_workshare_flag = omp_workshare_save;
+	}
+
+      t = true;
+      if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
+	t = gfc_resolve_expr (code->expr1);
+      forall_flag = forall_save;
+      gfc_do_concurrent_flag = do_concurrent_save;
+
+      if (!gfc_resolve_expr (code->expr2))
+	t = false;
+
+      if (code->op == EXEC_ALLOCATE
+	  && !gfc_resolve_expr (code->expr3))
+	t = false;
+
+      switch (code->op)
+	{
+	case EXEC_NOP:
+	case EXEC_END_BLOCK:
+	case EXEC_END_NESTED_BLOCK:
+	case EXEC_CYCLE:
+	case EXEC_PAUSE:
+	case EXEC_STOP:
+	case EXEC_ERROR_STOP:
+	case EXEC_EXIT:
+	case EXEC_CONTINUE:
+	case EXEC_DT_END:
+	case EXEC_ASSIGN_CALL:
+	case EXEC_CRITICAL:
+	  break;
+
+	case EXEC_SYNC_ALL:
+	case EXEC_SYNC_IMAGES:
+	case EXEC_SYNC_MEMORY:
+	  resolve_sync (code);
+	  break;
+
+	case EXEC_LOCK:
+	case EXEC_UNLOCK:
+	  resolve_lock_unlock (code);
+	  break;
+
+	case EXEC_ENTRY:
+	  /* Keep track of which entry we are up to.  */
+	  current_entry_id = code->ext.entry->id;
+	  break;
+
+	case EXEC_WHERE:
+	  resolve_where (code, NULL);
+	  break;
+
+	case EXEC_GOTO:
+	  if (code->expr1 != NULL)
+	    {
+	      if (code->expr1->ts.type != BT_INTEGER)
+		gfc_error ("ASSIGNED GOTO statement at %L requires an "
+			   "INTEGER variable", &code->expr1->where);
+	      else if (code->expr1->symtree->n.sym->attr.assign != 1)
+		gfc_error ("Variable '%s' has not been assigned a target "
+			   "label at %L", code->expr1->symtree->n.sym->name,
+			   &code->expr1->where);
+	    }
+	  else
+	    resolve_branch (code->label1, code);
+	  break;
+
+	case EXEC_RETURN:
+	  if (code->expr1 != NULL
+		&& (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
+	    gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
+		       "INTEGER return specifier", &code->expr1->where);
+	  break;
+
+	case EXEC_INIT_ASSIGN:
+	case EXEC_END_PROCEDURE:
+	  break;
+
+	case EXEC_ASSIGN:
+	  if (!t)
+	    break;
+
+	  if (!gfc_check_vardef_context (code->expr1, false, false, false, 
+					 _("assignment")))
+	    break;
+
+	  if (resolve_ordinary_assign (code, ns))
+	    {
+	      if (code->op == EXEC_COMPCALL)
+		goto compcall;
+	      else
+		goto call;
+	    }
+
+	  /* F03 7.4.1.3 for non-allocatable, non-pointer components.  */
+	  if (code->expr1->ts.type == BT_DERIVED
+	      && code->expr1->ts.u.derived->attr.defined_assign_comp)
+	    generate_component_assignments (&code, ns);
+
+	  break;
+
+	case EXEC_LABEL_ASSIGN:
+	  if (code->label1->defined == ST_LABEL_UNKNOWN)
+	    gfc_error ("Label %d referenced at %L is never defined",
+		       code->label1->value, &code->label1->where);
+	  if (t
+	      && (code->expr1->expr_type != EXPR_VARIABLE
+		  || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
+		  || code->expr1->symtree->n.sym->ts.kind
+		     != gfc_default_integer_kind
+		  || code->expr1->symtree->n.sym->as != NULL))
+	    gfc_error ("ASSIGN statement at %L requires a scalar "
+		       "default INTEGER variable", &code->expr1->where);
+	  break;
+
+	case EXEC_POINTER_ASSIGN:
+	  {
+	    gfc_expr* e;
+
+	    if (!t)
+	      break;
+
+	    /* This is both a variable definition and pointer assignment
+	       context, so check both of them.  For rank remapping, a final
+	       array ref may be present on the LHS and fool gfc_expr_attr
+	       used in gfc_check_vardef_context.  Remove it.  */
+	    e = remove_last_array_ref (code->expr1);
+	    t = gfc_check_vardef_context (e, true, false, false,
+					  _("pointer assignment"));
+	    if (t)
+	      t = gfc_check_vardef_context (e, false, false, false,
+					    _("pointer assignment"));
+	    gfc_free_expr (e);
+	    if (!t)
+	      break;
+
+	    gfc_check_pointer_assign (code->expr1, code->expr2);
+	    break;
+	  }
+
+	case EXEC_ARITHMETIC_IF:
+	  if (t
+	      && code->expr1->ts.type != BT_INTEGER
+	      && code->expr1->ts.type != BT_REAL)
+	    gfc_error ("Arithmetic IF statement at %L requires a numeric "
+		       "expression", &code->expr1->where);
+
+	  resolve_branch (code->label1, code);
+	  resolve_branch (code->label2, code);
+	  resolve_branch (code->label3, code);
+	  break;
+
+	case EXEC_IF:
+	  if (t && code->expr1 != NULL
+	      && (code->expr1->ts.type != BT_LOGICAL
+		  || code->expr1->rank != 0))
+	    gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
+		       &code->expr1->where);
+	  break;
+
+	case EXEC_CALL:
+	call:
+	  resolve_call (code);
+	  break;
+
+	case EXEC_COMPCALL:
+	compcall:
+	  resolve_typebound_subroutine (code);
+	  break;
+
+	case EXEC_CALL_PPC:
+	  resolve_ppc_call (code);
+	  break;
+
+	case EXEC_SELECT:
+	  /* Select is complicated. Also, a SELECT construct could be
+	     a transformed computed GOTO.  */
+	  resolve_select (code, false);
+	  break;
+
+	case EXEC_SELECT_TYPE:
+	  resolve_select_type (code, ns);
+	  break;
+
+	case EXEC_BLOCK:
+	  resolve_block_construct (code);
+	  break;
+
+	case EXEC_DO:
+	  if (code->ext.iterator != NULL)
+	    {
+	      gfc_iterator *iter = code->ext.iterator;
+	      if (gfc_resolve_iterator (iter, true, false))
+		gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
+	    }
+	  break;
+
+	case EXEC_DO_WHILE:
+	  if (code->expr1 == NULL)
+	    gfc_internal_error ("resolve_code(): No expression on DO WHILE");
+	  if (t
+	      && (code->expr1->rank != 0
+		  || code->expr1->ts.type != BT_LOGICAL))
+	    gfc_error ("Exit condition of DO WHILE loop at %L must be "
+		       "a scalar LOGICAL expression", &code->expr1->where);
+	  break;
+
+	case EXEC_ALLOCATE:
+	  if (t)
+	    resolve_allocate_deallocate (code, "ALLOCATE");
+
+	  break;
+
+	case EXEC_DEALLOCATE:
+	  if (t)
+	    resolve_allocate_deallocate (code, "DEALLOCATE");
+
+	  break;
+
+	case EXEC_OPEN:
+	  if (!gfc_resolve_open (code->ext.open))
+	    break;
+
+	  resolve_branch (code->ext.open->err, code);
+	  break;
+
+	case EXEC_CLOSE:
+	  if (!gfc_resolve_close (code->ext.close))
+	    break;
+
+	  resolve_branch (code->ext.close->err, code);
+	  break;
+
+	case EXEC_BACKSPACE:
+	case EXEC_ENDFILE:
+	case EXEC_REWIND:
+	case EXEC_FLUSH:
+	  if (!gfc_resolve_filepos (code->ext.filepos))
+	    break;
+
+	  resolve_branch (code->ext.filepos->err, code);
+	  break;
+
+	case EXEC_INQUIRE:
+	  if (!gfc_resolve_inquire (code->ext.inquire))
+	      break;
+
+	  resolve_branch (code->ext.inquire->err, code);
+	  break;
+
+	case EXEC_IOLENGTH:
+	  gcc_assert (code->ext.inquire != NULL);
+	  if (!gfc_resolve_inquire (code->ext.inquire))
+	    break;
+
+	  resolve_branch (code->ext.inquire->err, code);
+	  break;
+
+	case EXEC_WAIT:
+	  if (!gfc_resolve_wait (code->ext.wait))
+	    break;
+
+	  resolve_branch (code->ext.wait->err, code);
+	  resolve_branch (code->ext.wait->end, code);
+	  resolve_branch (code->ext.wait->eor, code);
+	  break;
+
+	case EXEC_READ:
+	case EXEC_WRITE:
+	  if (!gfc_resolve_dt (code->ext.dt, &code->loc))
+	    break;
+
+	  resolve_branch (code->ext.dt->err, code);
+	  resolve_branch (code->ext.dt->end, code);
+	  resolve_branch (code->ext.dt->eor, code);
+	  break;
+
+	case EXEC_TRANSFER:
+	  resolve_transfer (code);
+	  break;
+
+	case EXEC_DO_CONCURRENT:
+	case EXEC_FORALL:
+	  resolve_forall_iterators (code->ext.forall_iterator);
+
+	  if (code->expr1 != NULL
+	      && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
+	    gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
+		       "expression", &code->expr1->where);
+	  break;
+
+	case EXEC_OMP_ATOMIC:
+	case EXEC_OMP_BARRIER:
+	case EXEC_OMP_CRITICAL:
+	case EXEC_OMP_FLUSH:
+	case EXEC_OMP_DO:
+	case EXEC_OMP_MASTER:
+	case EXEC_OMP_ORDERED:
+	case EXEC_OMP_SECTIONS:
+	case EXEC_OMP_SINGLE:
+	case EXEC_OMP_TASKWAIT:
+	case EXEC_OMP_TASKYIELD:
+	case EXEC_OMP_WORKSHARE:
+	  gfc_resolve_omp_directive (code, ns);
+	  break;
+
+	case EXEC_OMP_PARALLEL:
+	case EXEC_OMP_PARALLEL_DO:
+	case EXEC_OMP_PARALLEL_SECTIONS:
+	case EXEC_OMP_PARALLEL_WORKSHARE:
+	case EXEC_OMP_TASK:
+	  omp_workshare_save = omp_workshare_flag;
+	  omp_workshare_flag = 0;
+	  gfc_resolve_omp_directive (code, ns);
+	  omp_workshare_flag = omp_workshare_save;
+	  break;
+
+	default:
+	  gfc_internal_error ("resolve_code(): Bad statement code");
+	}
+    }
+
+  cs_base = frame.prev;
+}
+
+
+/* Resolve initial values and make sure they are compatible with
+   the variable.  */
+
+static void
+resolve_values (gfc_symbol *sym)
+{
+  bool t;
+
+  if (sym->value == NULL)
+    return;
+
+  if (sym->value->expr_type == EXPR_STRUCTURE)
+    t= resolve_structure_cons (sym->value, 1);
+  else
+    t = gfc_resolve_expr (sym->value);
+
+  if (!t)
+    return;
+
+  gfc_check_assign_symbol (sym, NULL, sym->value);
+}
+
+
+/* Verify any BIND(C) derived types in the namespace so we can report errors
+   for them once, rather than for each variable declared of that type.  */
+
+static void
+resolve_bind_c_derived_types (gfc_symbol *derived_sym)
+{
+  if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
+      && derived_sym->attr.is_bind_c == 1)
+    verify_bind_c_derived_type (derived_sym);
+
+  return;
+}
+
+
+/* Verify that any binding labels used in a given namespace do not collide
+   with the names or binding labels of any global symbols.  Multiple INTERFACE
+   for the same procedure are permitted.  */
+
+static void
+gfc_verify_binding_labels (gfc_symbol *sym)
+{
+  gfc_gsymbol *gsym;
+  const char *module;
+
+  if (!sym || !sym->attr.is_bind_c || sym->attr.is_iso_c
+      || sym->attr.flavor == FL_DERIVED || !sym->binding_label)
+    return;
+
+  gsym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
+
+  if (sym->module)
+    module = sym->module;
+  else if (sym->ns && sym->ns->proc_name
+	   && sym->ns->proc_name->attr.flavor == FL_MODULE)
+    module = sym->ns->proc_name->name;
+  else if (sym->ns && sym->ns->parent
+	   && sym->ns && sym->ns->parent->proc_name
+	   && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
+    module = sym->ns->parent->proc_name->name;
+  else
+    module = NULL;
+
+  if (!gsym
+      || (!gsym->defined
+	  && (gsym->type == GSYM_FUNCTION || gsym->type == GSYM_SUBROUTINE)))
+    {
+      if (!gsym)
+	gsym = gfc_get_gsymbol (sym->binding_label);
+      gsym->where = sym->declared_at;
+      gsym->sym_name = sym->name;
+      gsym->binding_label = sym->binding_label;
+      gsym->ns = sym->ns;
+      gsym->mod_name = module;
+      if (sym->attr.function)
+        gsym->type = GSYM_FUNCTION;
+      else if (sym->attr.subroutine)
+	gsym->type = GSYM_SUBROUTINE;
+      /* Mark as variable/procedure as defined, unless its an INTERFACE.  */
+      gsym->defined = sym->attr.if_source != IFSRC_IFBODY;
+      return;
+    }
+
+  if (sym->attr.flavor == FL_VARIABLE && gsym->type != GSYM_UNKNOWN)
+    {
+      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.  */
+      sym->binding_label = NULL;
+
+    }
+  else if (sym->attr.flavor == FL_VARIABLE
+	   && (strcmp (module, gsym->mod_name) != 0
+	       || strcmp (sym->name, gsym->sym_name) != 0))
+    {
+      /* This can only happen if the variable is defined in a module - if it
+	 isn't the same module, reject it.  */
+      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);
+      sym->binding_label = NULL;
+    }
+  else if ((sym->attr.function || sym->attr.subroutine)
+	   && ((gsym->type != GSYM_SUBROUTINE && gsym->type != GSYM_FUNCTION)
+	       || (gsym->defined && sym->attr.if_source != IFSRC_IFBODY))
+	   && sym != gsym->ns->proc_name
+	   && (module != gsym->mod_name
+	       || strcmp (gsym->sym_name, sym->name) != 0
+	       || (module && strcmp (module, gsym->mod_name) != 0)))
+    {
+      /* 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 ("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;
+    }
+}
+
+
+/* Resolve an index expression.  */
+
+static bool
+resolve_index_expr (gfc_expr *e)
+{
+  if (!gfc_resolve_expr (e))
+    return false;
+
+  if (!gfc_simplify_expr (e, 0))
+    return false;
+
+  if (!gfc_specification_expr (e))
+    return false;
+
+  return true;
+}
+
+
+/* Resolve a charlen structure.  */
+
+static bool
+resolve_charlen (gfc_charlen *cl)
+{
+  int i, k;
+  bool saved_specification_expr;
+
+  if (cl->resolved)
+    return true;
+
+  cl->resolved = 1;
+  saved_specification_expr = specification_expr;
+  specification_expr = true;
+
+  if (cl->length_from_typespec)
+    {
+      if (!gfc_resolve_expr (cl->length))
+	{
+	  specification_expr = saved_specification_expr;
+	  return false;
+	}
+
+      if (!gfc_simplify_expr (cl->length, 0))
+	{
+	  specification_expr = saved_specification_expr;
+	  return false;
+	}
+    }
+  else
+    {
+
+      if (!resolve_index_expr (cl->length))
+	{
+	  specification_expr = saved_specification_expr;
+	  return false;
+	}
+    }
+
+  /* "If the character length parameter value evaluates to a negative
+     value, the length of character entities declared is zero."  */
+  if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
+    {
+      if (gfc_option.warn_surprising)
+	gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
+			 " the length has been set to zero",
+			 &cl->length->where, i);
+      gfc_replace_expr (cl->length,
+			gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
+    }
+
+  /* Check that the character length is not too large.  */
+  k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
+  if (cl->length && cl->length->expr_type == EXPR_CONSTANT
+      && cl->length->ts.type == BT_INTEGER
+      && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
+    {
+      gfc_error ("String length at %L is too large", &cl->length->where);
+      specification_expr = saved_specification_expr;
+      return false;
+    }
+
+  specification_expr = saved_specification_expr;
+  return true;
+}
+
+
+/* Test for non-constant shape arrays.  */
+
+static bool
+is_non_constant_shape_array (gfc_symbol *sym)
+{
+  gfc_expr *e;
+  int i;
+  bool not_constant;
+
+  not_constant = false;
+  if (sym->as != NULL)
+    {
+      /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
+	 has not been simplified; parameter array references.  Do the
+	 simplification now.  */
+      for (i = 0; i < sym->as->rank + sym->as->corank; i++)
+	{
+	  e = sym->as->lower[i];
+	  if (e && (!resolve_index_expr(e)
+		    || !gfc_is_constant_expr (e)))
+	    not_constant = true;
+	  e = sym->as->upper[i];
+	  if (e && (!resolve_index_expr(e)
+		    || !gfc_is_constant_expr (e)))
+	    not_constant = true;
+	}
+    }
+  return not_constant;
+}
+
+/* Given a symbol and an initialization expression, add code to initialize
+   the symbol to the function entry.  */
+static void
+build_init_assign (gfc_symbol *sym, gfc_expr *init)
+{
+  gfc_expr *lval;
+  gfc_code *init_st;
+  gfc_namespace *ns = sym->ns;
+
+  /* Search for the function namespace if this is a contained
+     function without an explicit result.  */
+  if (sym->attr.function && sym == sym->result
+      && sym->name != sym->ns->proc_name->name)
+    {
+      ns = ns->contained;
+      for (;ns; ns = ns->sibling)
+	if (strcmp (ns->proc_name->name, sym->name) == 0)
+	  break;
+    }
+
+  if (ns == NULL)
+    {
+      gfc_free_expr (init);
+      return;
+    }
+
+  /* Build an l-value expression for the result.  */
+  lval = gfc_lval_expr_from_sym (sym);
+
+  /* Add the code at scope entry.  */
+  init_st = gfc_get_code (EXEC_INIT_ASSIGN);
+  init_st->next = ns->code;
+  ns->code = init_st;
+
+  /* Assign the default initializer to the l-value.  */
+  init_st->loc = sym->declared_at;
+  init_st->expr1 = lval;
+  init_st->expr2 = init;
+}
+
+/* Assign the default initializer to a derived type variable or result.  */
+
+static void
+apply_default_init (gfc_symbol *sym)
+{
+  gfc_expr *init = NULL;
+
+  if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
+    return;
+
+  if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
+    init = gfc_default_initializer (&sym->ts);
+
+  if (init == NULL && sym->ts.type != BT_CLASS)
+    return;
+
+  build_init_assign (sym, init);
+  sym->attr.referenced = 1;
+}
+
+/* Build an initializer for a local integer, real, complex, logical, or
+   character variable, based on the command line flags finit-local-zero,
+   finit-integer=, finit-real=, finit-logical=, and finit-runtime.  Returns
+   null if the symbol should not have a default initialization.  */
+static gfc_expr *
+build_default_init_expr (gfc_symbol *sym)
+{
+  int char_len;
+  gfc_expr *init_expr;
+  int i;
+
+  /* These symbols should never have a default initialization.  */
+  if (sym->attr.allocatable
+      || sym->attr.external
+      || sym->attr.dummy
+      || sym->attr.pointer
+      || sym->attr.in_equivalence
+      || sym->attr.in_common
+      || sym->attr.data
+      || sym->module
+      || sym->attr.cray_pointee
+      || sym->attr.cray_pointer
+      || sym->assoc)
+    return NULL;
+
+  /* Now we'll try to build an initializer expression.  */
+  init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind,
+				     &sym->declared_at);
+
+  /* We will only initialize integers, reals, complex, logicals, and
+     characters, and only if the corresponding command-line flags
+     were set.  Otherwise, we free init_expr and return null.  */
+  switch (sym->ts.type)
+    {
+    case BT_INTEGER:
+      if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
+	mpz_set_si (init_expr->value.integer,
+			 gfc_option.flag_init_integer_value);
+      else
+	{
+	  gfc_free_expr (init_expr);
+	  init_expr = NULL;
+	}
+      break;
+
+    case BT_REAL:
+      switch (gfc_option.flag_init_real)
+	{
+	case GFC_INIT_REAL_SNAN:
+	  init_expr->is_snan = 1;
+	  /* Fall through.  */
+	case GFC_INIT_REAL_NAN:
+	  mpfr_set_nan (init_expr->value.real);
+	  break;
+
+	case GFC_INIT_REAL_INF:
+	  mpfr_set_inf (init_expr->value.real, 1);
+	  break;
+
+	case GFC_INIT_REAL_NEG_INF:
+	  mpfr_set_inf (init_expr->value.real, -1);
+	  break;
+
+	case GFC_INIT_REAL_ZERO:
+	  mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
+	  break;
+
+	default:
+	  gfc_free_expr (init_expr);
+	  init_expr = NULL;
+	  break;
+	}
+      break;
+
+    case BT_COMPLEX:
+      switch (gfc_option.flag_init_real)
+	{
+	case GFC_INIT_REAL_SNAN:
+	  init_expr->is_snan = 1;
+	  /* Fall through.  */
+	case GFC_INIT_REAL_NAN:
+	  mpfr_set_nan (mpc_realref (init_expr->value.complex));
+	  mpfr_set_nan (mpc_imagref (init_expr->value.complex));
+	  break;
+
+	case GFC_INIT_REAL_INF:
+	  mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
+	  mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
+	  break;
+
+	case GFC_INIT_REAL_NEG_INF:
+	  mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
+	  mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
+	  break;
+
+	case GFC_INIT_REAL_ZERO:
+	  mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
+	  break;
+
+	default:
+	  gfc_free_expr (init_expr);
+	  init_expr = NULL;
+	  break;
+	}
+      break;
+
+    case BT_LOGICAL:
+      if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
+	init_expr->value.logical = 0;
+      else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
+	init_expr->value.logical = 1;
+      else
+	{
+	  gfc_free_expr (init_expr);
+	  init_expr = NULL;
+	}
+      break;
+
+    case BT_CHARACTER:
+      /* For characters, the length must be constant in order to
+	 create a default initializer.  */
+      if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
+	  && sym->ts.u.cl->length
+	  && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+	{
+	  char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
+	  init_expr->value.character.length = char_len;
+	  init_expr->value.character.string = gfc_get_wide_string (char_len+1);
+	  for (i = 0; i < char_len; i++)
+	    init_expr->value.character.string[i]
+	      = (unsigned char) gfc_option.flag_init_character_value;
+	}
+      else
+	{
+	  gfc_free_expr (init_expr);
+	  init_expr = NULL;
+	}
+      if (!init_expr && gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
+	  && sym->ts.u.cl->length && gfc_option.flag_max_stack_var_size != 0)
+	{
+	  gfc_actual_arglist *arg;
+	  init_expr = gfc_get_expr ();
+	  init_expr->where = sym->declared_at;
+	  init_expr->ts = sym->ts;
+	  init_expr->expr_type = EXPR_FUNCTION;
+	  init_expr->value.function.isym =
+		gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT);
+	  init_expr->value.function.name = "repeat";
+	  arg = gfc_get_actual_arglist ();
+	  arg->expr = gfc_get_character_expr (sym->ts.kind, &sym->declared_at,
+					      NULL, 1);
+	  arg->expr->value.character.string[0]
+		= gfc_option.flag_init_character_value;
+	  arg->next = gfc_get_actual_arglist ();
+	  arg->next->expr = gfc_copy_expr (sym->ts.u.cl->length);
+	  init_expr->value.function.actual = arg;
+	}
+      break;
+
+    default:
+     gfc_free_expr (init_expr);
+     init_expr = NULL;
+    }
+  return init_expr;
+}
+
+/* Add an initialization expression to a local variable.  */
+static void
+apply_default_init_local (gfc_symbol *sym)
+{
+  gfc_expr *init = NULL;
+
+  /* The symbol should be a variable or a function return value.  */
+  if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
+      || (sym->attr.function && sym->result != sym))
+    return;
+
+  /* Try to build the initializer expression.  If we can't initialize
+     this symbol, then init will be NULL.  */
+  init = build_default_init_expr (sym);
+  if (init == NULL)
+    return;
+
+  /* For saved variables, we don't want to add an initializer at function
+     entry, so we just add a static initializer. Note that automatic variables
+     are stack allocated even with -fno-automatic; we have also to exclude
+     result variable, which are also nonstatic.  */
+  if (sym->attr.save || sym->ns->save_all
+      || (gfc_option.flag_max_stack_var_size == 0 && !sym->attr.result
+	  && (!sym->attr.dimension || !is_non_constant_shape_array (sym))))
+    {
+      /* Don't clobber an existing initializer!  */
+      gcc_assert (sym->value == NULL);
+      sym->value = init;
+      return;
+    }
+
+  build_init_assign (sym, init);
+}
+
+
+/* Resolution of common features of flavors variable and procedure.  */
+
+static bool
+resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
+{
+  gfc_array_spec *as;
+
+  if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
+    as = CLASS_DATA (sym)->as;
+  else
+    as = sym->as;
+
+  /* Constraints on deferred shape variable.  */
+  if (as == NULL || as->type != AS_DEFERRED)
+    {
+      bool pointer, allocatable, dimension;
+
+      if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
+	{
+	  pointer = CLASS_DATA (sym)->attr.class_pointer;
+	  allocatable = CLASS_DATA (sym)->attr.allocatable;
+	  dimension = CLASS_DATA (sym)->attr.dimension;
+	}
+      else
+	{
+	  pointer = sym->attr.pointer && !sym->attr.select_type_temporary;
+	  allocatable = sym->attr.allocatable;
+	  dimension = sym->attr.dimension;
+	}
+
+      if (allocatable)
+	{
+	  if (dimension && as->type != AS_ASSUMED_RANK)
+	    {
+	      gfc_error ("Allocatable array '%s' at %L must have a deferred "
+			 "shape or assumed rank", sym->name, &sym->declared_at);
+	      return false;
+	    }
+	  else if (!gfc_notify_std (GFC_STD_F2003, "Scalar object "
+				    "'%s' at %L may not be ALLOCATABLE", 
+				    sym->name, &sym->declared_at))
+	    return false;
+	}
+
+      if (pointer && dimension && as->type != AS_ASSUMED_RANK)
+	{
+	  gfc_error ("Array pointer '%s' at %L must have a deferred shape or "
+		     "assumed rank", sym->name, &sym->declared_at);
+	  return false;
+	}
+    }
+  else
+    {
+      if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
+	  && sym->ts.type != BT_CLASS && !sym->assoc)
+	{
+	  gfc_error ("Array '%s' at %L cannot have a deferred shape",
+		     sym->name, &sym->declared_at);
+	  return false;
+	 }
+    }
+
+  /* Constraints on polymorphic variables.  */
+  if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
+    {
+      /* F03:C502.  */
+      if (sym->attr.class_ok
+	  && !sym->attr.select_type_temporary
+	  && !UNLIMITED_POLY (sym)
+	  && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
+	{
+	  gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
+		     CLASS_DATA (sym)->ts.u.derived->name, sym->name,
+		     &sym->declared_at);
+	  return false;
+	}
+
+      /* F03:C509.  */
+      /* Assume that use associated symbols were checked in the module ns.
+	 Class-variables that are associate-names are also something special
+	 and excepted from the test.  */
+      if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
+	{
+	  gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
+		     "or pointer", sym->name, &sym->declared_at);
+	  return false;
+	}
+    }
+
+  return true;
+}
+
+
+/* Additional checks for symbols with flavor variable and derived
+   type.  To be called from resolve_fl_variable.  */
+
+static bool
+resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
+{
+  gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
+
+  /* Check to see if a derived type is blocked from being host
+     associated by the presence of another class I symbol in the same
+     namespace.  14.6.1.3 of the standard and the discussion on
+     comp.lang.fortran.  */
+  if (sym->ns != sym->ts.u.derived->ns
+      && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
+    {
+      gfc_symbol *s;
+      gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
+      if (s && s->attr.generic)
+	s = gfc_find_dt_in_generic (s);
+      if (s && s->attr.flavor != FL_DERIVED)
+	{
+	  gfc_error ("The type '%s' 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,
+		     &s->declared_at);
+	  return false;
+	}
+    }
+
+  /* 4th constraint in section 11.3: "If an object of a type for which
+     component-initialization is specified (R429) appears in the
+     specification-part of a module and does not have the ALLOCATABLE
+     or POINTER attribute, the object shall have the SAVE attribute."
+
+     The check for initializers is performed with
+     gfc_has_default_initializer because gfc_default_initializer generates
+     a hidden default for allocatable components.  */
+  if (!(sym->value || no_init_flag) && sym->ns->proc_name
+      && sym->ns->proc_name->attr.flavor == FL_MODULE
+      && !sym->ns->save_all && !sym->attr.save
+      && !sym->attr.pointer && !sym->attr.allocatable
+      && gfc_has_default_initializer (sym->ts.u.derived)
+      && !gfc_notify_std (GFC_STD_F2008, "Implied SAVE for module variable "
+			  "'%s' at %L, needed due to the default "
+			  "initialization", sym->name, &sym->declared_at))
+    return false;
+
+  /* Assign default initializer.  */
+  if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
+      && (!no_init_flag || sym->attr.intent == INTENT_OUT))
+    {
+      sym->value = gfc_default_initializer (&sym->ts);
+    }
+
+  return true;
+}
+
+
+/* Resolve symbols with flavor variable.  */
+
+static bool
+resolve_fl_variable (gfc_symbol *sym, int mp_flag)
+{
+  int no_init_flag, automatic_flag;
+  gfc_expr *e;
+  const char *auto_save_msg;
+  bool saved_specification_expr;
+
+  auto_save_msg = "Automatic object '%s' at %L cannot have the "
+		  "SAVE attribute";
+
+  if (!resolve_fl_var_and_proc (sym, mp_flag))
+    return false;
+
+  /* Set this flag to check that variables are parameters of all entries.
+     This check is effected by the call to gfc_resolve_expr through
+     is_non_constant_shape_array.  */
+  saved_specification_expr = specification_expr;
+  specification_expr = true;
+
+  if (sym->ns->proc_name
+      && (sym->ns->proc_name->attr.flavor == FL_MODULE
+	  || sym->ns->proc_name->attr.is_main_program)
+      && !sym->attr.use_assoc
+      && !sym->attr.allocatable
+      && !sym->attr.pointer
+      && is_non_constant_shape_array (sym))
+    {
+      /* 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 "
+		 "have constant shape", sym->name, &sym->declared_at);
+      specification_expr = saved_specification_expr;
+      return false;
+    }
+
+  /* Constraints on deferred type parameter.  */
+  if (sym->ts.deferred && !(sym->attr.pointer || sym->attr.allocatable))
+    {
+      gfc_error ("Entity '%s' at %L has a deferred type parameter and "
+		 "requires either the pointer or allocatable attribute",
+		     sym->name, &sym->declared_at);
+      specification_expr = saved_specification_expr;
+      return false;
+    }
+
+  if (sym->ts.type == BT_CHARACTER)
+    {
+      /* Make sure that character string variables with assumed length are
+	 dummy arguments.  */
+      e = sym->ts.u.cl->length;
+      if (e == NULL && !sym->attr.dummy && !sym->attr.result
+	  && !sym->ts.deferred && !sym->attr.select_type_temporary)
+	{
+	  gfc_error ("Entity with assumed character length at %L must be a "
+		     "dummy argument or a PARAMETER", &sym->declared_at);
+	  specification_expr = saved_specification_expr;
+	  return false;
+	}
+
+      if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
+	{
+	  gfc_error (auto_save_msg, sym->name, &sym->declared_at);
+	  specification_expr = saved_specification_expr;
+	  return false;
+	}
+
+      if (!gfc_is_constant_expr (e)
+	  && !(e->expr_type == EXPR_VARIABLE
+	       && e->symtree->n.sym->attr.flavor == FL_PARAMETER))
+	{
+	  if (!sym->attr.use_assoc && sym->ns->proc_name
+	      && (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 "
+			"in this context", sym->name, &sym->declared_at);
+	      specification_expr = saved_specification_expr;
+	      return false;
+	    }
+	  if (sym->attr.in_common)
+	    {
+	      gfc_error ("COMMON variable '%s' at %L must have constant "
+			 "character length", sym->name, &sym->declared_at);
+	      specification_expr = saved_specification_expr;
+	      return false;
+	    }
+	}
+    }
+
+  if (sym->value == NULL && sym->attr.referenced)
+    apply_default_init_local (sym); /* Try to apply a default initialization.  */
+
+  /* Determine if the symbol may not have an initializer.  */
+  no_init_flag = automatic_flag = 0;
+  if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
+      || sym->attr.intrinsic || sym->attr.result)
+    no_init_flag = 1;
+  else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
+	   && is_non_constant_shape_array (sym))
+    {
+      no_init_flag = automatic_flag = 1;
+
+      /* Also, they must not have the SAVE attribute.
+	 SAVE_IMPLICIT is checked below.  */
+      if (sym->as && sym->attr.codimension)
+	{
+	  int corank = sym->as->corank;
+	  sym->as->corank = 0;
+	  no_init_flag = automatic_flag = is_non_constant_shape_array (sym);
+	  sym->as->corank = corank;
+	}
+      if (automatic_flag && sym->attr.save == SAVE_EXPLICIT)
+	{
+	  gfc_error (auto_save_msg, sym->name, &sym->declared_at);
+	  specification_expr = saved_specification_expr;
+	  return false;
+	}
+    }
+
+  /* Ensure that any initializer is simplified.  */
+  if (sym->value)
+    gfc_simplify_expr (sym->value, 1);
+
+  /* Reject illegal initializers.  */
+  if (!sym->mark && sym->value)
+    {
+      if (sym->attr.allocatable || (sym->ts.type == BT_CLASS
+				    && CLASS_DATA (sym)->attr.allocatable))
+	gfc_error ("Allocatable '%s' at %L cannot have an initializer",
+		   sym->name, &sym->declared_at);
+      else if (sym->attr.external)
+	gfc_error ("External '%s' at %L cannot have an initializer",
+		   sym->name, &sym->declared_at);
+      else if (sym->attr.dummy
+	&& !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
+	gfc_error ("Dummy '%s' at %L cannot have an initializer",
+		   sym->name, &sym->declared_at);
+      else if (sym->attr.intrinsic)
+	gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
+		   sym->name, &sym->declared_at);
+      else if (sym->attr.result)
+	gfc_error ("Function result '%s' at %L cannot have an initializer",
+		   sym->name, &sym->declared_at);
+      else if (automatic_flag)
+	gfc_error ("Automatic array '%s' at %L cannot have an initializer",
+		   sym->name, &sym->declared_at);
+      else
+	goto no_init_error;
+      specification_expr = saved_specification_expr;
+      return false;
+    }
+
+no_init_error:
+  if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
+    {
+      bool res = resolve_fl_variable_derived (sym, no_init_flag);
+      specification_expr = saved_specification_expr;
+      return res;
+    }
+
+  specification_expr = saved_specification_expr;
+  return true;
+}
+
+
+/* Resolve a procedure.  */
+
+static bool
+resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
+{
+  gfc_formal_arglist *arg;
+
+  if (sym->attr.function
+      && !resolve_fl_var_and_proc (sym, mp_flag))
+    return false;
+
+  if (sym->ts.type == BT_CHARACTER)
+    {
+      gfc_charlen *cl = sym->ts.u.cl;
+
+      if (cl && cl->length && gfc_is_constant_expr (cl->length)
+	     && !resolve_charlen (cl))
+	return false;
+
+      if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
+	  && sym->attr.proc == PROC_ST_FUNCTION)
+	{
+	  gfc_error ("Character-valued statement function '%s' at %L must "
+		     "have constant length", sym->name, &sym->declared_at);
+	  return false;
+	}
+    }
+
+  /* Ensure that derived type for are not of a private type.  Internal
+     module procedures are excluded by 2.2.3.3 - i.e., they are not
+     externally accessible and can access all the objects accessible in
+     the host.  */
+  if (!(sym->ns->parent
+	&& sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
+      && gfc_check_symbol_access (sym))
+    {
+      gfc_interface *iface;
+
+      for (arg = gfc_sym_get_dummy_args (sym); arg; arg = arg->next)
+	{
+	  if (arg->sym
+	      && arg->sym->ts.type == BT_DERIVED
+	      && !arg->sym->ts.u.derived->attr.use_assoc
+	      && !gfc_check_symbol_access (arg->sym->ts.u.derived)
+	      && !gfc_notify_std (GFC_STD_F2003, "'%s' is of a PRIVATE type "
+				  "and cannot be a dummy argument"
+				  " of '%s', which is PUBLIC at %L", 
+				  arg->sym->name, sym->name, 
+				  &sym->declared_at))
+	    {
+	      /* Stop this message from recurring.  */
+	      arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
+	      return false;
+	    }
+	}
+
+      /* PUBLIC interfaces may expose PRIVATE procedures that take types
+	 PRIVATE to the containing module.  */
+      for (iface = sym->generic; iface; iface = iface->next)
+	{
+	  for (arg = gfc_sym_get_dummy_args (iface->sym); arg; arg = arg->next)
+	    {
+	      if (arg->sym
+		  && arg->sym->ts.type == BT_DERIVED
+		  && !arg->sym->ts.u.derived->attr.use_assoc
+		  && !gfc_check_symbol_access (arg->sym->ts.u.derived)
+		  && !gfc_notify_std (GFC_STD_F2003, "Procedure '%s' in "
+				      "PUBLIC interface '%s' at %L "
+				      "takes dummy arguments of '%s' which "
+				      "is PRIVATE", iface->sym->name, 
+				      sym->name, &iface->sym->declared_at, 
+				      gfc_typename(&arg->sym->ts)))
+		{
+		  /* Stop this message from recurring.  */
+		  arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
+		  return false;
+		}
+	     }
+	}
+
+      /* PUBLIC interfaces may expose PRIVATE procedures that take types
+	 PRIVATE to the containing module.  */
+      for (iface = sym->generic; iface; iface = iface->next)
+	{
+	  for (arg = gfc_sym_get_dummy_args (iface->sym); arg; arg = arg->next)
+	    {
+	      if (arg->sym
+		  && arg->sym->ts.type == BT_DERIVED
+		  && !arg->sym->ts.u.derived->attr.use_assoc
+		  && !gfc_check_symbol_access (arg->sym->ts.u.derived)
+		  && !gfc_notify_std (GFC_STD_F2003, "Procedure '%s' in "
+				      "PUBLIC interface '%s' at %L takes "
+				      "dummy arguments of '%s' which is "
+				      "PRIVATE", iface->sym->name, 
+				      sym->name, &iface->sym->declared_at, 
+				      gfc_typename(&arg->sym->ts)))
+		{
+		  /* Stop this message from recurring.  */
+		  arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
+		  return false;
+		}
+	     }
+	}
+    }
+
+  if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
+      && !sym->attr.proc_pointer)
+    {
+      gfc_error ("Function '%s' at %L cannot have an initializer",
+		 sym->name, &sym->declared_at);
+      return false;
+    }
+
+  /* An external symbol may not have an initializer because it is taken to be
+     a procedure. Exception: Procedure Pointers.  */
+  if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
+    {
+      gfc_error ("External object '%s' at %L may not have an initializer",
+		 sym->name, &sym->declared_at);
+      return false;
+    }
+
+  /* An elemental function is required to return a scalar 12.7.1  */
+  if (sym->attr.elemental && sym->attr.function && sym->as)
+    {
+      gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
+		 "result", sym->name, &sym->declared_at);
+      /* Reset so that the error only occurs once.  */
+      sym->attr.elemental = 0;
+      return false;
+    }
+
+  if (sym->attr.proc == PROC_ST_FUNCTION
+      && (sym->attr.allocatable || sym->attr.pointer))
+    {
+      gfc_error ("Statement function '%s' at %L may not have pointer or "
+		 "allocatable attribute", sym->name, &sym->declared_at);
+      return false;
+    }
+
+  /* 5.1.1.5 of the Standard: A function name declared with an asterisk
+     char-len-param shall not be array-valued, pointer-valued, recursive
+     or pure.  ....snip... A character value of * may only be used in the
+     following ways: (i) Dummy arg of procedure - dummy associates with
+     actual length; (ii) To declare a named constant; or (iii) External
+     function - but length must be declared in calling scoping unit.  */
+  if (sym->attr.function
+      && sym->ts.type == BT_CHARACTER && !sym->ts.deferred
+      && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
+    {
+      if ((sym->as && sym->as->rank) || (sym->attr.pointer)
+	  || (sym->attr.recursive) || (sym->attr.pure))
+	{
+	  if (sym->as && sym->as->rank)
+	    gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
+		       "array-valued", sym->name, &sym->declared_at);
+
+	  if (sym->attr.pointer)
+	    gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
+		       "pointer-valued", sym->name, &sym->declared_at);
+
+	  if (sym->attr.pure)
+	    gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
+		       "pure", sym->name, &sym->declared_at);
+
+	  if (sym->attr.recursive)
+	    gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
+		       "recursive", sym->name, &sym->declared_at);
+
+	  return false;
+	}
+
+      /* Appendix B.2 of the standard.  Contained functions give an
+	 error anyway.  Fixed-form is likely to be F77/legacy. Deferred
+	 character length is an F2003 feature.  */
+      if (!sym->attr.contained
+	    && gfc_current_form != FORM_FIXED
+	    && !sym->ts.deferred)
+	gfc_notify_std (GFC_STD_F95_OBS,
+			"CHARACTER(*) function '%s' at %L",
+			sym->name, &sym->declared_at);
+    }
+
+  /* F2008, C1218.  */
+  if (sym->attr.elemental)
+    {
+      if (sym->attr.proc_pointer)
+	{
+	  gfc_error ("Procedure pointer '%s' at %L shall not be elemental",
+		     sym->name, &sym->declared_at);
+	  return false;
+	}
+      if (sym->attr.dummy)
+	{
+	  gfc_error ("Dummy procedure '%s' at %L shall not be elemental",
+		     sym->name, &sym->declared_at);
+	  return false;
+	}
+    }
+
+  if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
+    {
+      gfc_formal_arglist *curr_arg;
+      int has_non_interop_arg = 0;
+
+      if (!verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common, 
+			      sym->common_block))
+        {
+          /* Clear these to prevent looking at them again if there was an
+             error.  */
+          sym->attr.is_bind_c = 0;
+          sym->attr.is_c_interop = 0;
+          sym->ts.is_c_interop = 0;
+        }
+      else
+        {
+          /* So far, no errors have been found.  */
+          sym->attr.is_c_interop = 1;
+          sym->ts.is_c_interop = 1;
+        }
+
+      curr_arg = gfc_sym_get_dummy_args (sym);
+      while (curr_arg != NULL)
+        {
+          /* Skip implicitly typed dummy args here.  */
+	  if (curr_arg->sym->attr.implicit_type == 0)
+	    if (!gfc_verify_c_interop_param (curr_arg->sym))
+	      /* If something is found to fail, record the fact so we
+		 can mark the symbol for the procedure as not being
+		 BIND(C) to try and prevent multiple errors being
+		 reported.  */
+	      has_non_interop_arg = 1;
+
+          curr_arg = curr_arg->next;
+        }
+
+      /* See if any of the arguments were not interoperable and if so, clear
+	 the procedure symbol to prevent duplicate error messages.  */
+      if (has_non_interop_arg != 0)
+	{
+	  sym->attr.is_c_interop = 0;
+	  sym->ts.is_c_interop = 0;
+	  sym->attr.is_bind_c = 0;
+	}
+    }
+
+  if (!sym->attr.proc_pointer)
+    {
+      if (sym->attr.save == SAVE_EXPLICIT)
+	{
+	  gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
+		     "in '%s' at %L", sym->name, &sym->declared_at);
+	  return false;
+	}
+      if (sym->attr.intent)
+	{
+	  gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
+		     "in '%s' at %L", sym->name, &sym->declared_at);
+	  return false;
+	}
+      if (sym->attr.subroutine && sym->attr.result)
+	{
+	  gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
+		     "in '%s' at %L", sym->name, &sym->declared_at);
+	  return false;
+	}
+      if (sym->attr.external && sym->attr.function
+	  && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
+	      || sym->attr.contained))
+	{
+	  gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
+		     "in '%s' at %L", sym->name, &sym->declared_at);
+	  return false;
+	}
+      if (strcmp ("ppr@", sym->name) == 0)
+	{
+	  gfc_error ("Procedure pointer result '%s' at %L "
+		     "is missing the pointer attribute",
+		     sym->ns->proc_name->name, &sym->declared_at);
+	  return false;
+	}
+    }
+
+  return true;
+}
+
+
+/* Resolve a list of finalizer procedures.  That is, after they have hopefully
+   been defined and we now know their defined arguments, check that they fulfill
+   the requirements of the standard for procedures used as finalizers.  */
+
+static bool
+gfc_resolve_finalizers (gfc_symbol* derived)
+{
+  gfc_finalizer* list;
+  gfc_finalizer** prev_link; /* For removing wrong entries from the list.  */
+  bool result = true;
+  bool seen_scalar = false;
+
+  if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
+    return true;
+
+  /* Walk over the list of finalizer-procedures, check them, and if any one
+     does not fit in with the standard's definition, print an error and remove
+     it from the list.  */
+  prev_link = &derived->f2k_derived->finalizers;
+  for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
+    {
+      gfc_formal_arglist *dummy_args;
+      gfc_symbol* arg;
+      gfc_finalizer* i;
+      int my_rank;
+
+      /* Skip this finalizer if we already resolved it.  */
+      if (list->proc_tree)
+	{
+	  prev_link = &(list->next);
+	  continue;
+	}
+
+      /* Check this exists and is a SUBROUTINE.  */
+      if (!list->proc_sym->attr.subroutine)
+	{
+	  gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
+		     list->proc_sym->name, &list->where);
+	  goto error;
+	}
+
+      /* We should have exactly one argument.  */
+      dummy_args = gfc_sym_get_dummy_args (list->proc_sym);
+      if (!dummy_args || dummy_args->next)
+	{
+	  gfc_error ("FINAL procedure at %L must have exactly one argument",
+		     &list->where);
+	  goto error;
+	}
+      arg = dummy_args->sym;
+
+      /* This argument must be of our type.  */
+      if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
+	{
+	  gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
+		     &arg->declared_at, derived->name);
+	  goto error;
+	}
+
+      /* It must neither be a pointer nor allocatable nor optional.  */
+      if (arg->attr.pointer)
+	{
+	  gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
+		     &arg->declared_at);
+	  goto error;
+	}
+      if (arg->attr.allocatable)
+	{
+	  gfc_error ("Argument of FINAL procedure at %L must not be"
+		     " ALLOCATABLE", &arg->declared_at);
+	  goto error;
+	}
+      if (arg->attr.optional)
+	{
+	  gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
+		     &arg->declared_at);
+	  goto error;
+	}
+
+      /* It must not be INTENT(OUT).  */
+      if (arg->attr.intent == INTENT_OUT)
+	{
+	  gfc_error ("Argument of FINAL procedure at %L must not be"
+		     " INTENT(OUT)", &arg->declared_at);
+	  goto error;
+	}
+
+      /* Warn if the procedure is non-scalar and not assumed shape.  */
+      if (gfc_option.warn_surprising && arg->as && arg->as->rank != 0
+	  && arg->as->type != AS_ASSUMED_SHAPE)
+	gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
+		     " shape argument", &arg->declared_at);
+
+      /* Check that it does not match in kind and rank with a FINAL procedure
+	 defined earlier.  To really loop over the *earlier* declarations,
+	 we need to walk the tail of the list as new ones were pushed at the
+	 front.  */
+      /* TODO: Handle kind parameters once they are implemented.  */
+      my_rank = (arg->as ? arg->as->rank : 0);
+      for (i = list->next; i; i = i->next)
+	{
+	  gfc_formal_arglist *dummy_args;
+
+	  /* Argument list might be empty; that is an error signalled earlier,
+	     but we nevertheless continued resolving.  */
+	  dummy_args = gfc_sym_get_dummy_args (i->proc_sym);
+	  if (dummy_args)
+	    {
+	      gfc_symbol* i_arg = dummy_args->sym;
+	      const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
+	      if (i_rank == my_rank)
+		{
+		  gfc_error ("FINAL procedure '%s' declared at %L has the same"
+			     " rank (%d) as '%s'",
+			     list->proc_sym->name, &list->where, my_rank,
+			     i->proc_sym->name);
+		  goto error;
+		}
+	    }
+	}
+
+	/* Is this the/a scalar finalizer procedure?  */
+	if (!arg->as || arg->as->rank == 0)
+	  seen_scalar = true;
+
+	/* Find the symtree for this procedure.  */
+	gcc_assert (!list->proc_tree);
+	list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
+
+	prev_link = &list->next;
+	continue;
+
+	/* Remove wrong nodes immediately from the list so we don't risk any
+	   troubles in the future when they might fail later expectations.  */
+error:
+	result = false;
+	i = list;
+	*prev_link = list->next;
+	gfc_free_finalizer (i);
+    }
+
+  /* Warn if we haven't seen a scalar finalizer procedure (but we know there
+     were nodes in the list, must have been for arrays.  It is surely a good
+     idea to have a scalar version there if there's something to finalize.  */
+  if (gfc_option.warn_surprising && result && !seen_scalar)
+    gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
+		 " defined at %L, suggest also scalar one",
+		 derived->name, &derived->declared_at);
+
+  gfc_find_derived_vtab (derived);
+  return result;
+}
+
+
+/* Check if two GENERIC targets are ambiguous and emit an error is they are.  */
+
+static bool
+check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
+			     const char* generic_name, locus where)
+{
+  gfc_symbol *sym1, *sym2;
+  const char *pass1, *pass2;
+  gfc_formal_arglist *dummy_args;
+
+  gcc_assert (t1->specific && t2->specific);
+  gcc_assert (!t1->specific->is_generic);
+  gcc_assert (!t2->specific->is_generic);
+  gcc_assert (t1->is_operator == t2->is_operator);
+
+  sym1 = t1->specific->u.specific->n.sym;
+  sym2 = t2->specific->u.specific->n.sym;
+
+  if (sym1 == sym2)
+    return true;
+
+  /* Both must be SUBROUTINEs or both must be FUNCTIONs.  */
+  if (sym1->attr.subroutine != sym2->attr.subroutine
+      || sym1->attr.function != sym2->attr.function)
+    {
+      gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
+		 " GENERIC '%s' at %L",
+		 sym1->name, sym2->name, generic_name, &where);
+      return false;
+    }
+
+  /* Determine PASS arguments.  */
+  if (t1->specific->nopass)
+    pass1 = NULL;
+  else if (t1->specific->pass_arg)
+    pass1 = t1->specific->pass_arg;
+  else
+    {
+      dummy_args = gfc_sym_get_dummy_args (t1->specific->u.specific->n.sym);
+      if (dummy_args)
+	pass1 = dummy_args->sym->name;
+      else
+	pass1 = NULL;
+    }
+  if (t2->specific->nopass)
+    pass2 = NULL;
+  else if (t2->specific->pass_arg)
+    pass2 = t2->specific->pass_arg;
+  else
+    {
+      dummy_args = gfc_sym_get_dummy_args (t2->specific->u.specific->n.sym);
+      if (dummy_args)
+	pass2 = dummy_args->sym->name;
+      else
+	pass2 = NULL;
+    }
+
+  /* Compare the interfaces.  */
+  if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0,
+			      NULL, 0, pass1, pass2))
+    {
+      gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
+		 sym1->name, sym2->name, generic_name, &where);
+      return false;
+    }
+
+  return true;
+}
+
+
+/* Worker function for resolving a generic procedure binding; this is used to
+   resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
+
+   The difference between those cases is finding possible inherited bindings
+   that are overridden, as one has to look for them in tb_sym_root,
+   tb_uop_root or tb_op, respectively.  Thus the caller must already find
+   the super-type and set p->overridden correctly.  */
+
+static bool
+resolve_tb_generic_targets (gfc_symbol* super_type,
+			    gfc_typebound_proc* p, const char* name)
+{
+  gfc_tbp_generic* target;
+  gfc_symtree* first_target;
+  gfc_symtree* inherited;
+
+  gcc_assert (p && p->is_generic);
+
+  /* Try to find the specific bindings for the symtrees in our target-list.  */
+  gcc_assert (p->u.generic);
+  for (target = p->u.generic; target; target = target->next)
+    if (!target->specific)
+      {
+	gfc_typebound_proc* overridden_tbp;
+	gfc_tbp_generic* g;
+	const char* target_name;
+
+	target_name = target->specific_st->name;
+
+	/* Defined for this type directly.  */
+	if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
+	  {
+	    target->specific = target->specific_st->n.tb;
+	    goto specific_found;
+	  }
+
+	/* Look for an inherited specific binding.  */
+	if (super_type)
+	  {
+	    inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
+						 true, NULL);
+
+	    if (inherited)
+	      {
+		gcc_assert (inherited->n.tb);
+		target->specific = inherited->n.tb;
+		goto specific_found;
+	      }
+	  }
+
+	gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
+		   " at %L", target_name, name, &p->where);
+	return false;
+
+	/* Once we've found the specific binding, check it is not ambiguous with
+	   other specifics already found or inherited for the same GENERIC.  */
+specific_found:
+	gcc_assert (target->specific);
+
+	/* This must really be a specific binding!  */
+	if (target->specific->is_generic)
+	  {
+	    gfc_error ("GENERIC '%s' at %L must target a specific binding,"
+		       " '%s' is GENERIC, too", name, &p->where, target_name);
+	    return false;
+	  }
+
+	/* Check those already resolved on this type directly.  */
+	for (g = p->u.generic; g; g = g->next)
+	  if (g != target && g->specific
+	      && !check_generic_tbp_ambiguity (target, g, name, p->where))
+	    return false;
+
+	/* Check for ambiguity with inherited specific targets.  */
+	for (overridden_tbp = p->overridden; overridden_tbp;
+	     overridden_tbp = overridden_tbp->overridden)
+	  if (overridden_tbp->is_generic)
+	    {
+	      for (g = overridden_tbp->u.generic; g; g = g->next)
+		{
+		  gcc_assert (g->specific);
+		  if (!check_generic_tbp_ambiguity (target, g, name, p->where))
+		    return false;
+		}
+	    }
+      }
+
+  /* If we attempt to "overwrite" a specific binding, this is an error.  */
+  if (p->overridden && !p->overridden->is_generic)
+    {
+      gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
+		 " the same name", name, &p->where);
+      return false;
+    }
+
+  /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
+     all must have the same attributes here.  */
+  first_target = p->u.generic->specific->u.specific;
+  gcc_assert (first_target);
+  p->subroutine = first_target->n.sym->attr.subroutine;
+  p->function = first_target->n.sym->attr.function;
+
+  return true;
+}
+
+
+/* Resolve a GENERIC procedure binding for a derived type.  */
+
+static bool
+resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
+{
+  gfc_symbol* super_type;
+
+  /* Find the overridden binding if any.  */
+  st->n.tb->overridden = NULL;
+  super_type = gfc_get_derived_super_type (derived);
+  if (super_type)
+    {
+      gfc_symtree* overridden;
+      overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
+					    true, NULL);
+
+      if (overridden && overridden->n.tb)
+	st->n.tb->overridden = overridden->n.tb;
+    }
+
+  /* Resolve using worker function.  */
+  return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
+}
+
+
+/* Retrieve the target-procedure of an operator binding and do some checks in
+   common for intrinsic and user-defined type-bound operators.  */
+
+static gfc_symbol*
+get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
+{
+  gfc_symbol* target_proc;
+
+  gcc_assert (target->specific && !target->specific->is_generic);
+  target_proc = target->specific->u.specific->n.sym;
+  gcc_assert (target_proc);
+
+  /* F08:C468. All operator bindings must have a passed-object dummy argument.  */
+  if (target->specific->nopass)
+    {
+      gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
+      return NULL;
+    }
+
+  return target_proc;
+}
+
+
+/* Resolve a type-bound intrinsic operator.  */
+
+static bool
+resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
+				gfc_typebound_proc* p)
+{
+  gfc_symbol* super_type;
+  gfc_tbp_generic* target;
+
+  /* If there's already an error here, do nothing (but don't fail again).  */
+  if (p->error)
+    return true;
+
+  /* Operators should always be GENERIC bindings.  */
+  gcc_assert (p->is_generic);
+
+  /* Look for an overridden binding.  */
+  super_type = gfc_get_derived_super_type (derived);
+  if (super_type && super_type->f2k_derived)
+    p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
+						     op, true, NULL);
+  else
+    p->overridden = NULL;
+
+  /* Resolve general GENERIC properties using worker function.  */
+  if (!resolve_tb_generic_targets (super_type, p, gfc_op2string(op)))
+    goto error;
+
+  /* Check the targets to be procedures of correct interface.  */
+  for (target = p->u.generic; target; target = target->next)
+    {
+      gfc_symbol* target_proc;
+
+      target_proc = get_checked_tb_operator_target (target, p->where);
+      if (!target_proc)
+	goto error;
+
+      if (!gfc_check_operator_interface (target_proc, op, p->where))
+	goto error;
+
+      /* Add target to non-typebound operator list.  */
+      if (!target->specific->deferred && !derived->attr.use_assoc
+	  && p->access != ACCESS_PRIVATE && derived->ns == gfc_current_ns)
+	{
+	  gfc_interface *head, *intr;
+	  if (!gfc_check_new_interface (derived->ns->op[op], target_proc, p->where))
+	    return false;
+	  head = derived->ns->op[op];
+	  intr = gfc_get_interface ();
+	  intr->sym = target_proc;
+	  intr->where = p->where;
+	  intr->next = head;
+	  derived->ns->op[op] = intr;
+	}
+    }
+
+  return true;
+
+error:
+  p->error = 1;
+  return false;
+}
+
+
+/* Resolve a type-bound user operator (tree-walker callback).  */
+
+static gfc_symbol* resolve_bindings_derived;
+static bool resolve_bindings_result;
+
+static bool check_uop_procedure (gfc_symbol* sym, locus where);
+
+static void
+resolve_typebound_user_op (gfc_symtree* stree)
+{
+  gfc_symbol* super_type;
+  gfc_tbp_generic* target;
+
+  gcc_assert (stree && stree->n.tb);
+
+  if (stree->n.tb->error)
+    return;
+
+  /* Operators should always be GENERIC bindings.  */
+  gcc_assert (stree->n.tb->is_generic);
+
+  /* Find overridden procedure, if any.  */
+  super_type = gfc_get_derived_super_type (resolve_bindings_derived);
+  if (super_type && super_type->f2k_derived)
+    {
+      gfc_symtree* overridden;
+      overridden = gfc_find_typebound_user_op (super_type, NULL,
+					       stree->name, true, NULL);
+
+      if (overridden && overridden->n.tb)
+	stree->n.tb->overridden = overridden->n.tb;
+    }
+  else
+    stree->n.tb->overridden = NULL;
+
+  /* Resolve basically using worker function.  */
+  if (!resolve_tb_generic_targets (super_type, stree->n.tb, stree->name))
+    goto error;
+
+  /* Check the targets to be functions of correct interface.  */
+  for (target = stree->n.tb->u.generic; target; target = target->next)
+    {
+      gfc_symbol* target_proc;
+
+      target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
+      if (!target_proc)
+	goto error;
+
+      if (!check_uop_procedure (target_proc, stree->n.tb->where))
+	goto error;
+    }
+
+  return;
+
+error:
+  resolve_bindings_result = false;
+  stree->n.tb->error = 1;
+}
+
+
+/* Resolve the type-bound procedures for a derived type.  */
+
+static void
+resolve_typebound_procedure (gfc_symtree* stree)
+{
+  gfc_symbol* proc;
+  locus where;
+  gfc_symbol* me_arg;
+  gfc_symbol* super_type;
+  gfc_component* comp;
+
+  gcc_assert (stree);
+
+  /* Undefined specific symbol from GENERIC target definition.  */
+  if (!stree->n.tb)
+    return;
+
+  if (stree->n.tb->error)
+    return;
+
+  /* If this is a GENERIC binding, use that routine.  */
+  if (stree->n.tb->is_generic)
+    {
+      if (!resolve_typebound_generic (resolve_bindings_derived, stree))
+	goto error;
+      return;
+    }
+
+  /* Get the target-procedure to check it.  */
+  gcc_assert (!stree->n.tb->is_generic);
+  gcc_assert (stree->n.tb->u.specific);
+  proc = stree->n.tb->u.specific->n.sym;
+  where = stree->n.tb->where;
+
+  /* Default access should already be resolved from the parser.  */
+  gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
+
+  if (stree->n.tb->deferred)
+    {
+      if (!check_proc_interface (proc, &where))
+	goto error;
+    }
+  else
+    {
+      /* Check for F08:C465.  */
+      if ((!proc->attr.subroutine && !proc->attr.function)
+	  || (proc->attr.proc != PROC_MODULE
+	      && proc->attr.if_source != IFSRC_IFBODY)
+	  || proc->attr.abstract)
+	{
+	  gfc_error ("'%s' must be a module procedure or an external procedure with"
+		    " an explicit interface at %L", proc->name, &where);
+	  goto error;
+	}
+    }
+
+  stree->n.tb->subroutine = proc->attr.subroutine;
+  stree->n.tb->function = proc->attr.function;
+
+  /* Find the super-type of the current derived type.  We could do this once and
+     store in a global if speed is needed, but as long as not I believe this is
+     more readable and clearer.  */
+  super_type = gfc_get_derived_super_type (resolve_bindings_derived);
+
+  /* If PASS, resolve and check arguments if not already resolved / loaded
+     from a .mod file.  */
+  if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
+    {
+      gfc_formal_arglist *dummy_args;
+
+      dummy_args = gfc_sym_get_dummy_args (proc);
+      if (stree->n.tb->pass_arg)
+	{
+	  gfc_formal_arglist *i;
+
+	  /* If an explicit passing argument name is given, walk the arg-list
+	     and look for it.  */
+
+	  me_arg = NULL;
+	  stree->n.tb->pass_arg_num = 1;
+	  for (i = dummy_args; i; i = i->next)
+	    {
+	      if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
+		{
+		  me_arg = i->sym;
+		  break;
+		}
+	      ++stree->n.tb->pass_arg_num;
+	    }
+
+	  if (!me_arg)
+	    {
+	      gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
+			 " argument '%s'",
+			 proc->name, stree->n.tb->pass_arg, &where,
+			 stree->n.tb->pass_arg);
+	      goto error;
+	    }
+	}
+      else
+	{
+	  /* Otherwise, take the first one; there should in fact be at least
+	     one.  */
+	  stree->n.tb->pass_arg_num = 1;
+	  if (!dummy_args)
+	    {
+	      gfc_error ("Procedure '%s' with PASS at %L must have at"
+			 " least one argument", proc->name, &where);
+	      goto error;
+	    }
+	  me_arg = dummy_args->sym;
+	}
+
+      /* Now check that the argument-type matches and the passed-object
+	 dummy argument is generally fine.  */
+
+      gcc_assert (me_arg);
+
+      if (me_arg->ts.type != BT_CLASS)
+	{
+	  gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
+		     " at %L", proc->name, &where);
+	  goto error;
+	}
+
+      if (CLASS_DATA (me_arg)->ts.u.derived
+	  != resolve_bindings_derived)
+	{
+	  gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
+		     " the derived-type '%s'", me_arg->name, proc->name,
+		     me_arg->name, &where, resolve_bindings_derived->name);
+	  goto error;
+	}
+
+      gcc_assert (me_arg->ts.type == BT_CLASS);
+      if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank != 0)
+	{
+	  gfc_error ("Passed-object dummy argument of '%s' at %L must be"
+		     " scalar", proc->name, &where);
+	  goto error;
+	}
+      if (CLASS_DATA (me_arg)->attr.allocatable)
+	{
+	  gfc_error ("Passed-object dummy argument of '%s' at %L must not"
+		     " be ALLOCATABLE", proc->name, &where);
+	  goto error;
+	}
+      if (CLASS_DATA (me_arg)->attr.class_pointer)
+	{
+	  gfc_error ("Passed-object dummy argument of '%s' at %L must not"
+		     " be POINTER", proc->name, &where);
+	  goto error;
+	}
+    }
+
+  /* If we are extending some type, check that we don't override a procedure
+     flagged NON_OVERRIDABLE.  */
+  stree->n.tb->overridden = NULL;
+  if (super_type)
+    {
+      gfc_symtree* overridden;
+      overridden = gfc_find_typebound_proc (super_type, NULL,
+					    stree->name, true, NULL);
+
+      if (overridden)
+	{
+	  if (overridden->n.tb)
+	    stree->n.tb->overridden = overridden->n.tb;
+
+	  if (!gfc_check_typebound_override (stree, overridden))
+	    goto error;
+	}
+    }
+
+  /* See if there's a name collision with a component directly in this type.  */
+  for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
+    if (!strcmp (comp->name, stree->name))
+      {
+	gfc_error ("Procedure '%s' at %L has the same name as a component of"
+		   " '%s'",
+		   stree->name, &where, resolve_bindings_derived->name);
+	goto error;
+      }
+
+  /* Try to find a name collision with an inherited component.  */
+  if (super_type && gfc_find_component (super_type, stree->name, true, true))
+    {
+      gfc_error ("Procedure '%s' at %L has the same name as an inherited"
+		 " component of '%s'",
+		 stree->name, &where, resolve_bindings_derived->name);
+      goto error;
+    }
+
+  stree->n.tb->error = 0;
+  return;
+
+error:
+  resolve_bindings_result = false;
+  stree->n.tb->error = 1;
+}
+
+
+static bool
+resolve_typebound_procedures (gfc_symbol* derived)
+{
+  int op;
+  gfc_symbol* super_type;
+
+  if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
+    return true;
+
+  super_type = gfc_get_derived_super_type (derived);
+  if (super_type)
+    resolve_symbol (super_type);
+
+  resolve_bindings_derived = derived;
+  resolve_bindings_result = true;
+
+  if (derived->f2k_derived->tb_sym_root)
+    gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
+			  &resolve_typebound_procedure);
+
+  if (derived->f2k_derived->tb_uop_root)
+    gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
+			  &resolve_typebound_user_op);
+
+  for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
+    {
+      gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
+      if (p && !resolve_typebound_intrinsic_op (derived, 
+						(gfc_intrinsic_op)op, p))
+	resolve_bindings_result = false;
+    }
+
+  return resolve_bindings_result;
+}
+
+
+/* Add a derived type to the dt_list.  The dt_list is used in trans-types.c
+   to give all identical derived types the same backend_decl.  */
+static void
+add_dt_to_dt_list (gfc_symbol *derived)
+{
+  gfc_dt_list *dt_list;
+
+  for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
+    if (derived == dt_list->derived)
+      return;
+
+  dt_list = gfc_get_dt_list ();
+  dt_list->next = gfc_derived_types;
+  dt_list->derived = derived;
+  gfc_derived_types = dt_list;
+}
+
+
+/* Ensure that a derived-type is really not abstract, meaning that every
+   inherited DEFERRED binding is overridden by a non-DEFERRED one.  */
+
+static bool
+ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
+{
+  if (!st)
+    return true;
+
+  if (!ensure_not_abstract_walker (sub, st->left))
+    return false;
+  if (!ensure_not_abstract_walker (sub, st->right))
+    return false;
+
+  if (st->n.tb && st->n.tb->deferred)
+    {
+      gfc_symtree* overriding;
+      overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
+      if (!overriding)
+	return false;
+      gcc_assert (overriding->n.tb);
+      if (overriding->n.tb->deferred)
+	{
+	  gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
+		     " '%s' is DEFERRED and not overridden",
+		     sub->name, &sub->declared_at, st->name);
+	  return false;
+	}
+    }
+
+  return true;
+}
+
+static bool
+ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
+{
+  /* The algorithm used here is to recursively travel up the ancestry of sub
+     and for each ancestor-type, check all bindings.  If any of them is
+     DEFERRED, look it up starting from sub and see if the found (overriding)
+     binding is not DEFERRED.
+     This is not the most efficient way to do this, but it should be ok and is
+     clearer than something sophisticated.  */
+
+  gcc_assert (ancestor && !sub->attr.abstract);
+
+  if (!ancestor->attr.abstract)
+    return true;
+
+  /* Walk bindings of this ancestor.  */
+  if (ancestor->f2k_derived)
+    {
+      bool t;
+      t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
+      if (!t)
+	return false;
+    }
+
+  /* Find next ancestor type and recurse on it.  */
+  ancestor = gfc_get_derived_super_type (ancestor);
+  if (ancestor)
+    return ensure_not_abstract (sub, ancestor);
+
+  return true;
+}
+
+
+/* This check for typebound defined assignments is done recursively
+   since the order in which derived types are resolved is not always in
+   order of the declarations.  */
+
+static void
+check_defined_assignments (gfc_symbol *derived)
+{
+  gfc_component *c;
+
+  for (c = derived->components; c; c = c->next)
+    {
+      if (c->ts.type != BT_DERIVED
+	  || c->attr.pointer
+	  || c->attr.allocatable
+	  || c->attr.proc_pointer_comp
+	  || c->attr.class_pointer
+	  || c->attr.proc_pointer)
+	continue;
+
+      if (c->ts.u.derived->attr.defined_assign_comp
+	  || (c->ts.u.derived->f2k_derived
+	     && c->ts.u.derived->f2k_derived->tb_op[INTRINSIC_ASSIGN]))
+	{
+	  derived->attr.defined_assign_comp = 1;
+	  return;
+	}
+
+      check_defined_assignments (c->ts.u.derived);
+      if (c->ts.u.derived->attr.defined_assign_comp)
+	{
+	  derived->attr.defined_assign_comp = 1;
+	  return;
+	}
+    }
+}
+
+
+/* Resolve the components of a derived type. This does not have to wait until
+   resolution stage, but can be done as soon as the dt declaration has been
+   parsed.  */
+
+static bool
+resolve_fl_derived0 (gfc_symbol *sym)
+{
+  gfc_symbol* super_type;
+  gfc_component *c;
+
+  if (sym->attr.unlimited_polymorphic)
+    return true;
+
+  super_type = gfc_get_derived_super_type (sym);
+
+  /* F2008, C432. */
+  if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
+    {
+      gfc_error ("As extending type '%s' at %L has a coarray component, "
+		 "parent type '%s' shall also have one", sym->name,
+		 &sym->declared_at, super_type->name);
+      return false;
+    }
+
+  /* Ensure the extended type gets resolved before we do.  */
+  if (super_type && !resolve_fl_derived0 (super_type))
+    return false;
+
+  /* An ABSTRACT type must be extensible.  */
+  if (sym->attr.abstract && !gfc_type_is_extensible (sym))
+    {
+      gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
+		 sym->name, &sym->declared_at);
+      return false;
+    }
+
+  c = (sym->attr.is_class) ? sym->components->ts.u.derived->components
+			   : sym->components;
+
+  for ( ; c != NULL; c = c->next)
+    {
+      if (c->attr.artificial)
+	continue;
+
+      /* F2008, C442.  */
+      if ((!sym->attr.is_class || c != sym->components)
+	  && c->attr.codimension
+	  && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
+	{
+	  gfc_error ("Coarray component '%s' at %L must be allocatable with "
+		     "deferred shape", c->name, &c->loc);
+	  return false;
+	}
+
+      /* F2008, C443.  */
+      if (c->attr.codimension && c->ts.type == BT_DERIVED
+	  && c->ts.u.derived->ts.is_iso_c)
+	{
+	  gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
+		     "shall not be a coarray", c->name, &c->loc);
+	  return false;
+	}
+
+      /* F2008, C444.  */
+      if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
+	  && (c->attr.codimension || c->attr.pointer || c->attr.dimension
+	      || c->attr.allocatable))
+	{
+	  gfc_error ("Component '%s' at %L with coarray component "
+		     "shall be a nonpointer, nonallocatable scalar",
+		     c->name, &c->loc);
+	  return false;
+	}
+
+      /* F2008, C448.  */
+      if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
+	{
+	  gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
+		     "is not an array pointer", c->name, &c->loc);
+	  return false;
+	}
+
+      if (c->attr.proc_pointer && c->ts.interface)
+	{
+	  gfc_symbol *ifc = c->ts.interface;
+
+	  if (!sym->attr.vtype
+	      && !check_proc_interface (ifc, &c->loc))
+	    return false;
+
+	  if (ifc->attr.if_source || ifc->attr.intrinsic)
+	    {
+	      /* Resolve interface and copy attributes.  */
+	      if (ifc->formal && !ifc->formal_ns)
+		resolve_symbol (ifc);
+	      if (ifc->attr.intrinsic)
+		gfc_resolve_intrinsic (ifc, &ifc->declared_at);
+
+	      if (ifc->result)
+		{
+		  c->ts = ifc->result->ts;
+		  c->attr.allocatable = ifc->result->attr.allocatable;
+		  c->attr.pointer = ifc->result->attr.pointer;
+		  c->attr.dimension = ifc->result->attr.dimension;
+		  c->as = gfc_copy_array_spec (ifc->result->as);
+		  c->attr.class_ok = ifc->result->attr.class_ok;
+		}
+	      else
+		{
+		  c->ts = ifc->ts;
+		  c->attr.allocatable = ifc->attr.allocatable;
+		  c->attr.pointer = ifc->attr.pointer;
+		  c->attr.dimension = ifc->attr.dimension;
+		  c->as = gfc_copy_array_spec (ifc->as);
+		  c->attr.class_ok = ifc->attr.class_ok;
+		}
+	      c->ts.interface = ifc;
+	      c->attr.function = ifc->attr.function;
+	      c->attr.subroutine = ifc->attr.subroutine;
+
+	      c->attr.pure = ifc->attr.pure;
+	      c->attr.elemental = ifc->attr.elemental;
+	      c->attr.recursive = ifc->attr.recursive;
+	      c->attr.always_explicit = ifc->attr.always_explicit;
+	      c->attr.ext_attr |= ifc->attr.ext_attr;
+	      /* Copy char length.  */
+	      if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
+		{
+		  gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
+		  if (cl->length && !cl->resolved
+		      && !gfc_resolve_expr (cl->length))
+		    return false;
+		  c->ts.u.cl = cl;
+		}
+	    }
+	}
+      else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
+	{
+	  /* Since PPCs are not implicitly typed, a PPC without an explicit
+	     interface must be a subroutine.  */
+	  gfc_add_subroutine (&c->attr, c->name, &c->loc);
+	}
+
+      /* Procedure pointer components: Check PASS arg.  */
+      if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
+	  && !sym->attr.vtype)
+	{
+	  gfc_symbol* me_arg;
+
+	  if (c->tb->pass_arg)
+	    {
+	      gfc_formal_arglist* i;
+
+	      /* If an explicit passing argument name is given, walk the arg-list
+		and look for it.  */
+
+	      me_arg = NULL;
+	      c->tb->pass_arg_num = 1;
+	      for (i = c->ts.interface->formal; i; i = i->next)
+		{
+		  if (!strcmp (i->sym->name, c->tb->pass_arg))
+		    {
+		      me_arg = i->sym;
+		      break;
+		    }
+		  c->tb->pass_arg_num++;
+		}
+
+	      if (!me_arg)
+		{
+		  gfc_error ("Procedure pointer component '%s' with PASS(%s) "
+			     "at %L has no argument '%s'", c->name,
+			     c->tb->pass_arg, &c->loc, c->tb->pass_arg);
+		  c->tb->error = 1;
+		  return false;
+		}
+	    }
+	  else
+	    {
+	      /* Otherwise, take the first one; there should in fact be at least
+		one.  */
+	      c->tb->pass_arg_num = 1;
+	      if (!c->ts.interface->formal)
+		{
+		  gfc_error ("Procedure pointer component '%s' with PASS at %L "
+			     "must have at least one argument",
+			     c->name, &c->loc);
+		  c->tb->error = 1;
+		  return false;
+		}
+	      me_arg = c->ts.interface->formal->sym;
+	    }
+
+	  /* Now check that the argument-type matches.  */
+	  gcc_assert (me_arg);
+	  if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
+	      || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
+	      || (me_arg->ts.type == BT_CLASS
+		  && CLASS_DATA (me_arg)->ts.u.derived != sym))
+	    {
+	      gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
+			 " the derived type '%s'", me_arg->name, c->name,
+			 me_arg->name, &c->loc, sym->name);
+	      c->tb->error = 1;
+	      return false;
+	    }
+
+	  /* Check for C453.  */
+	  if (me_arg->attr.dimension)
+	    {
+	      gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
+			 "must be scalar", me_arg->name, c->name, me_arg->name,
+			 &c->loc);
+	      c->tb->error = 1;
+	      return false;
+	    }
+
+	  if (me_arg->attr.pointer)
+	    {
+	      gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
+			 "may not have the POINTER attribute", me_arg->name,
+			 c->name, me_arg->name, &c->loc);
+	      c->tb->error = 1;
+	      return false;
+	    }
+
+	  if (me_arg->attr.allocatable)
+	    {
+	      gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
+			 "may not be ALLOCATABLE", me_arg->name, c->name,
+			 me_arg->name, &c->loc);
+	      c->tb->error = 1;
+	      return false;
+	    }
+
+	  if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
+	    gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
+		       " at %L", c->name, &c->loc);
+
+	}
+
+      /* Check type-spec if this is not the parent-type component.  */
+      if (((sym->attr.is_class
+	    && (!sym->components->ts.u.derived->attr.extension
+		|| c != sym->components->ts.u.derived->components))
+	   || (!sym->attr.is_class
+	       && (!sym->attr.extension || c != sym->components)))
+	  && !sym->attr.vtype
+	  && !resolve_typespec_used (&c->ts, &c->loc, c->name))
+	return false;
+
+      /* If this type is an extension, set the accessibility of the parent
+	 component.  */
+      if (super_type
+	  && ((sym->attr.is_class
+	       && c == sym->components->ts.u.derived->components)
+	      || (!sym->attr.is_class && c == sym->components))
+	  && strcmp (super_type->name, c->name) == 0)
+	c->attr.access = super_type->attr.access;
+
+      /* If this type is an extension, see if this component has the same name
+	 as an inherited type-bound procedure.  */
+      if (super_type && !sym->attr.is_class
+	  && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
+	{
+	  gfc_error ("Component '%s' of '%s' at %L has the same name as an"
+		     " inherited type-bound procedure",
+		     c->name, sym->name, &c->loc);
+	  return false;
+	}
+
+      if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
+	    && !c->ts.deferred)
+	{
+	 if (c->ts.u.cl->length == NULL
+	     || (!resolve_charlen(c->ts.u.cl))
+	     || !gfc_is_constant_expr (c->ts.u.cl->length))
+	   {
+	     gfc_error ("Character length of component '%s' needs to "
+			"be a constant specification expression at %L",
+			c->name,
+			c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
+	     return false;
+	   }
+	}
+
+      if (c->ts.type == BT_CHARACTER && c->ts.deferred
+	  && !c->attr.pointer && !c->attr.allocatable)
+	{
+	  gfc_error ("Character component '%s' of '%s' at %L with deferred "
+		     "length must be a POINTER or ALLOCATABLE",
+		     c->name, sym->name, &c->loc);
+	  return false;
+	}
+
+      /* Add the hidden deferred length field.  */
+      if (c->ts.type == BT_CHARACTER && c->ts.deferred && !c->attr.function
+	  && !sym->attr.is_class)
+	{
+	  char name[GFC_MAX_SYMBOL_LEN+9];
+	  gfc_component *strlen;
+	  sprintf (name, "_%s_length", c->name);
+	  strlen = gfc_find_component (sym, name, true, true);
+	  if (strlen == NULL)
+	    {
+	      if (!gfc_add_component (sym, name, &strlen))
+		return false;
+	      strlen->ts.type = BT_INTEGER;
+	      strlen->ts.kind = gfc_charlen_int_kind;
+	      strlen->attr.access = ACCESS_PRIVATE;
+	      strlen->attr.deferred_parameter = 1;
+	    }
+	}
+
+      if (c->ts.type == BT_DERIVED
+	  && sym->component_access != ACCESS_PRIVATE
+	  && gfc_check_symbol_access (sym)
+	  && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
+	  && !c->ts.u.derived->attr.use_assoc
+	  && !gfc_check_symbol_access (c->ts.u.derived)
+	  && !gfc_notify_std (GFC_STD_F2003, "the component '%s' is a "
+			      "PRIVATE type and cannot be a component of "
+			      "'%s', which is PUBLIC at %L", c->name, 
+			      sym->name, &sym->declared_at))
+	return false;
+
+      if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
+	{
+	  gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
+		     "type %s", c->name, &c->loc, sym->name);
+	  return false;
+	}
+
+      if (sym->attr.sequence)
+	{
+	  if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
+	    {
+	      gfc_error ("Component %s of SEQUENCE type declared at %L does "
+			 "not have the SEQUENCE attribute",
+			 c->ts.u.derived->name, &sym->declared_at);
+	      return false;
+	    }
+	}
+
+      if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic)
+	c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived);
+      else if (c->ts.type == BT_CLASS && c->attr.class_ok
+	       && CLASS_DATA (c)->ts.u.derived->attr.generic)
+	CLASS_DATA (c)->ts.u.derived
+			= gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
+
+      if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
+	  && c->attr.pointer && c->ts.u.derived->components == NULL
+	  && !c->ts.u.derived->attr.zero_comp)
+	{
+	  gfc_error ("The pointer component '%s' of '%s' at %L is a type "
+		     "that has not been declared", c->name, sym->name,
+		     &c->loc);
+	  return false;
+	}
+
+      if (c->ts.type == BT_CLASS && c->attr.class_ok
+	  && CLASS_DATA (c)->attr.class_pointer
+	  && CLASS_DATA (c)->ts.u.derived->components == NULL
+	  && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp
+	  && !UNLIMITED_POLY (c))
+	{
+	  gfc_error ("The pointer component '%s' of '%s' at %L is a type "
+		     "that has not been declared", c->name, sym->name,
+		     &c->loc);
+	  return false;
+	}
+
+      /* C437.  */
+      if (c->ts.type == BT_CLASS && c->attr.flavor != FL_PROCEDURE
+	  && (!c->attr.class_ok
+	      || !(CLASS_DATA (c)->attr.class_pointer
+		   || CLASS_DATA (c)->attr.allocatable)))
+	{
+	  gfc_error ("Component '%s' with CLASS at %L must be allocatable "
+		     "or pointer", c->name, &c->loc);
+	  /* Prevent a recurrence of the error.  */
+	  c->ts.type = BT_UNKNOWN;
+	  return false;
+	}
+
+      /* Ensure that all the derived type components are put on the
+	 derived type list; even in formal namespaces, where derived type
+	 pointer components might not have been declared.  */
+      if (c->ts.type == BT_DERIVED
+	    && c->ts.u.derived
+	    && c->ts.u.derived->components
+	    && c->attr.pointer
+	    && sym != c->ts.u.derived)
+	add_dt_to_dt_list (c->ts.u.derived);
+
+      if (!gfc_resolve_array_spec (c->as, 
+				   !(c->attr.pointer || c->attr.proc_pointer 
+				     || c->attr.allocatable)))
+	return false;
+
+      if (c->initializer && !sym->attr.vtype
+	  && !gfc_check_assign_symbol (sym, c, c->initializer))
+	return false;
+    }
+
+  check_defined_assignments (sym);
+
+  if (!sym->attr.defined_assign_comp && super_type)
+    sym->attr.defined_assign_comp
+			= super_type->attr.defined_assign_comp;
+
+  /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
+     all DEFERRED bindings are overridden.  */
+  if (super_type && super_type->attr.abstract && !sym->attr.abstract
+      && !sym->attr.is_class
+      && !ensure_not_abstract (sym, super_type))
+    return false;
+
+  /* Add derived type to the derived type list.  */
+  add_dt_to_dt_list (sym);
+
+  return true;
+}
+
+
+/* The following procedure does the full resolution of a derived type,
+   including resolution of all type-bound procedures (if present). In contrast
+   to 'resolve_fl_derived0' this can only be done after the module has been
+   parsed completely.  */
+
+static bool
+resolve_fl_derived (gfc_symbol *sym)
+{
+  gfc_symbol *gen_dt = NULL;
+
+  if (sym->attr.unlimited_polymorphic)
+    return true;
+
+  if (!sym->attr.is_class)
+    gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
+  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 (GFC_STD_F2003, "Generic name '%s' of function "
+			  "'%s' at %L being the same name as derived "
+			  "type at %L", sym->name, 
+			  gen_dt->generic->sym == sym 
+			  ? gen_dt->generic->next->sym->name 
+			  : gen_dt->generic->sym->name, 
+			  gen_dt->generic->sym == sym 
+			  ? &gen_dt->generic->next->sym->declared_at 
+			  : &gen_dt->generic->sym->declared_at, 
+			  &sym->declared_at))
+    return false;
+
+  /* Resolve the finalizer procedures.  */
+  if (!gfc_resolve_finalizers (sym))
+    return false;
+
+  if (sym->attr.is_class && sym->ts.u.derived == NULL)
+    {
+      /* Fix up incomplete CLASS symbols.  */
+      gfc_component *data = gfc_find_component (sym, "_data", true, true);
+      gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true);
+
+      /* Nothing more to do for unlimited polymorphic entities.  */
+      if (data->ts.u.derived->attr.unlimited_polymorphic)
+	return true;
+      else if (vptr->ts.u.derived == NULL)
+	{
+	  gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
+	  gcc_assert (vtab);
+	  vptr->ts.u.derived = vtab->ts.u.derived;
+	}
+    }
+
+  if (!resolve_fl_derived0 (sym))
+    return false;
+
+  /* Resolve the type-bound procedures.  */
+  if (!resolve_typebound_procedures (sym))
+    return false;
+
+  return true;
+}
+
+
+static bool
+resolve_fl_namelist (gfc_symbol *sym)
+{
+  gfc_namelist *nl;
+  gfc_symbol *nlsym;
+
+  for (nl = sym->namelist; nl; nl = nl->next)
+    {
+      /* Check again, the check in match only works if NAMELIST comes
+	 after the decl.  */
+      if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE)
+     	{
+	  gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
+		     "allowed", nl->sym->name, sym->name, &sym->declared_at);
+	  return false;
+	}
+
+      if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
+	  && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
+			      "with assumed shape in namelist '%s' at %L", 
+			      nl->sym->name, sym->name, &sym->declared_at))
+	return false;
+
+      if (is_non_constant_shape_array (nl->sym)
+	  && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
+			      "with nonconstant shape in namelist '%s' at %L", 
+			      nl->sym->name, sym->name, &sym->declared_at))
+	return false;
+
+      if (nl->sym->ts.type == BT_CHARACTER
+	  && (nl->sym->ts.u.cl->length == NULL
+	      || !gfc_is_constant_expr (nl->sym->ts.u.cl->length))
+	  && !gfc_notify_std (GFC_STD_F2003, "NAMELIST object '%s' with "
+			      "nonconstant character length in "
+			      "namelist '%s' at %L", nl->sym->name, 
+			      sym->name, &sym->declared_at))
+	return false;
+
+      /* FIXME: Once UDDTIO is implemented, the following can be
+	 removed.  */
+      if (nl->sym->ts.type == BT_CLASS)
+	{
+	  gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
+		     "polymorphic and requires a defined input/output "
+		     "procedure", nl->sym->name, sym->name, &sym->declared_at);
+	  return false;
+	}
+
+      if (nl->sym->ts.type == BT_DERIVED
+	  && (nl->sym->ts.u.derived->attr.alloc_comp
+	      || nl->sym->ts.u.derived->attr.pointer_comp))
+	{
+	  if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object '%s' in "
+			       "namelist '%s' at %L with ALLOCATABLE "
+			       "or POINTER components", nl->sym->name, 
+			       sym->name, &sym->declared_at))
+	    return false;
+
+	 /* FIXME: Once UDDTIO is implemented, the following can be
+	    removed.  */
+	  gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
+		     "ALLOCATABLE or POINTER components and thus requires "
+		     "a defined input/output procedure", nl->sym->name,
+		     sym->name, &sym->declared_at);
+	  return false;
+	}
+    }
+
+  /* Reject PRIVATE objects in a PUBLIC namelist.  */
+  if (gfc_check_symbol_access (sym))
+    {
+      for (nl = sym->namelist; nl; nl = nl->next)
+	{
+	  if (!nl->sym->attr.use_assoc
+	      && !is_sym_host_assoc (nl->sym, sym->ns)
+	      && !gfc_check_symbol_access (nl->sym))
+	    {
+	      gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
+			 "cannot be member of PUBLIC namelist '%s' at %L",
+			 nl->sym->name, sym->name, &sym->declared_at);
+	      return false;
+	    }
+
+	  /* Types with private components that came here by USE-association.  */
+	  if (nl->sym->ts.type == BT_DERIVED
+	      && derived_inaccessible (nl->sym->ts.u.derived))
+	    {
+	      gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
+			 "components and cannot be member of namelist '%s' at %L",
+			 nl->sym->name, sym->name, &sym->declared_at);
+	      return false;
+	    }
+
+	  /* Types with private components that are defined in the same module.  */
+	  if (nl->sym->ts.type == BT_DERIVED
+	      && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
+	      && nl->sym->ts.u.derived->attr.private_comp)
+	    {
+	      gfc_error ("NAMELIST object '%s' has PRIVATE components and "
+			 "cannot be a member of PUBLIC namelist '%s' at %L",
+			 nl->sym->name, sym->name, &sym->declared_at);
+	      return false;
+	    }
+	}
+    }
+
+
+  /* 14.1.2 A module or internal procedure represent local entities
+     of the same type as a namelist member and so are not allowed.  */
+  for (nl = sym->namelist; nl; nl = nl->next)
+    {
+      if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
+	continue;
+
+      if (nl->sym->attr.function && nl->sym == nl->sym->result)
+	if ((nl->sym == sym->ns->proc_name)
+	       ||
+	    (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
+	  continue;
+
+      nlsym = NULL;
+      if (nl->sym->name)
+	gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
+      if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
+	{
+	  gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
+		     "attribute in '%s' at %L", nlsym->name,
+		     &sym->declared_at);
+	  return false;
+	}
+    }
+
+  return true;
+}
+
+
+static bool
+resolve_fl_parameter (gfc_symbol *sym)
+{
+  /* A parameter array's shape needs to be constant.  */
+  if (sym->as != NULL
+      && (sym->as->type == AS_DEFERRED
+          || is_non_constant_shape_array (sym)))
+    {
+      gfc_error ("Parameter array '%s' at %L cannot be automatic "
+		 "or of deferred shape", sym->name, &sym->declared_at);
+      return false;
+    }
+
+  /* Make sure a parameter that has been implicitly typed still
+     matches the implicit type, since PARAMETER statements can precede
+     IMPLICIT statements.  */
+  if (sym->attr.implicit_type
+      && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
+							     sym->ns)))
+    {
+      gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
+		 "later IMPLICIT type", sym->name, &sym->declared_at);
+      return false;
+    }
+
+  /* Make sure the types of derived parameters are consistent.  This
+     type checking is deferred until resolution because the type may
+     refer to a derived type from the host.  */
+  if (sym->ts.type == BT_DERIVED
+      && !gfc_compare_types (&sym->ts, &sym->value->ts))
+    {
+      gfc_error ("Incompatible derived type in PARAMETER at %L",
+		 &sym->value->where);
+      return false;
+    }
+  return true;
+}
+
+
+/* Do anything necessary to resolve a symbol.  Right now, we just
+   assume that an otherwise unknown symbol is a variable.  This sort
+   of thing commonly happens for symbols in module.  */
+
+static void
+resolve_symbol (gfc_symbol *sym)
+{
+  int check_constant, mp_flag;
+  gfc_symtree *symtree;
+  gfc_symtree *this_symtree;
+  gfc_namespace *ns;
+  gfc_component *c;
+  symbol_attribute class_attr;
+  gfc_array_spec *as;
+  bool saved_specification_expr;
+
+  if (sym->resolved)
+    return;
+  sym->resolved = 1;
+
+  if (sym->attr.artificial)
+    return;
+
+  if (sym->attr.unlimited_polymorphic)
+    return;
+
+  if (sym->attr.flavor == FL_UNKNOWN
+      || (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic
+	  && !sym->attr.generic && !sym->attr.external
+	  && sym->attr.if_source == IFSRC_UNKNOWN
+	  && sym->ts.type == BT_UNKNOWN))
+    {
+
+    /* If we find that a flavorless symbol is an interface in one of the
+       parent namespaces, find its symtree in this namespace, free the
+       symbol and set the symtree to point to the interface symbol.  */
+      for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
+	{
+	  symtree = gfc_find_symtree (ns->sym_root, sym->name);
+	  if (symtree && (symtree->n.sym->generic ||
+			  (symtree->n.sym->attr.flavor == FL_PROCEDURE
+			   && sym->ns->construct_entities)))
+	    {
+	      this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
+					       sym->name);
+	      gfc_release_symbol (sym);
+	      symtree->n.sym->refs++;
+	      this_symtree->n.sym = symtree->n.sym;
+	      return;
+	    }
+	}
+
+      /* Otherwise give it a flavor according to such attributes as
+	 it has.  */
+      if (sym->attr.flavor == FL_UNKNOWN && sym->attr.external == 0
+	  && sym->attr.intrinsic == 0)
+	sym->attr.flavor = FL_VARIABLE;
+      else if (sym->attr.flavor == FL_UNKNOWN)
+	{
+	  sym->attr.flavor = FL_PROCEDURE;
+	  if (sym->attr.dimension)
+	    sym->attr.function = 1;
+	}
+    }
+
+  if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
+    gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
+
+  if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
+      && !resolve_procedure_interface (sym))
+    return;
+
+  if (sym->attr.is_protected && !sym->attr.proc_pointer
+      && (sym->attr.procedure || sym->attr.external))
+    {
+      if (sym->attr.external)
+	gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
+	           "at %L", &sym->declared_at);
+      else
+	gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
+	           "at %L", &sym->declared_at);
+
+      return;
+    }
+
+  if (sym->attr.flavor == FL_DERIVED && !resolve_fl_derived (sym))
+    return;
+
+  /* Symbols that are module procedures with results (functions) have
+     the types and array specification copied for type checking in
+     procedures that call them, as well as for saving to a module
+     file.  These symbols can't stand the scrutiny that their results
+     can.  */
+  mp_flag = (sym->result != NULL && sym->result != sym);
+
+  /* Make sure that the intrinsic is consistent with its internal
+     representation. This needs to be done before assigning a default
+     type to avoid spurious warnings.  */
+  if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
+      && !gfc_resolve_intrinsic (sym, &sym->declared_at))
+    return;
+
+  /* Resolve associate names.  */
+  if (sym->assoc)
+    resolve_assoc_var (sym, true);
+
+  /* Assign default type to symbols that need one and don't have one.  */
+  if (sym->ts.type == BT_UNKNOWN)
+    {
+      if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
+	{
+	  gfc_set_default_type (sym, 1, NULL);
+	}
+
+      if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
+	  && !sym->attr.function && !sym->attr.subroutine
+	  && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
+	gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
+
+      if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
+	{
+	  /* The specific case of an external procedure should emit an error
+	     in the case that there is no implicit type.  */
+	  if (!mp_flag)
+	    gfc_set_default_type (sym, sym->attr.external, NULL);
+	  else
+	    {
+	      /* Result may be in another namespace.  */
+	      resolve_symbol (sym->result);
+
+	      if (!sym->result->attr.proc_pointer)
+		{
+		  sym->ts = sym->result->ts;
+		  sym->as = gfc_copy_array_spec (sym->result->as);
+		  sym->attr.dimension = sym->result->attr.dimension;
+		  sym->attr.pointer = sym->result->attr.pointer;
+		  sym->attr.allocatable = sym->result->attr.allocatable;
+		  sym->attr.contiguous = sym->result->attr.contiguous;
+		}
+	    }
+	}
+    }
+  else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
+    {
+      bool saved_specification_expr = specification_expr;
+      specification_expr = true;
+      gfc_resolve_array_spec (sym->result->as, false);
+      specification_expr = saved_specification_expr;
+    }
+
+  if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
+    {
+      as = CLASS_DATA (sym)->as;
+      class_attr = CLASS_DATA (sym)->attr;
+      class_attr.pointer = class_attr.class_pointer;
+    }
+  else
+    {
+      class_attr = sym->attr;
+      as = sym->as;
+    }
+
+  /* F2008, C530. */
+  if (sym->attr.contiguous
+      && (!class_attr.dimension
+	  || (as->type != AS_ASSUMED_SHAPE && as->type != AS_ASSUMED_RANK
+	      && !class_attr.pointer)))
+    {
+      gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
+		 "array pointer or an assumed-shape or assumed-rank array",
+		 sym->name, &sym->declared_at);
+      return;
+    }
+
+  /* Assumed size arrays and assumed shape arrays must be dummy
+     arguments.  Array-spec's of implied-shape should have been resolved to
+     AS_EXPLICIT already.  */
+
+  if (as)
+    {
+      gcc_assert (as->type != AS_IMPLIED_SHAPE);
+      if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed)
+	   || as->type == AS_ASSUMED_SHAPE)
+	  && !sym->attr.dummy && !sym->attr.select_type_temporary)
+	{
+	  if (as->type == AS_ASSUMED_SIZE)
+	    gfc_error ("Assumed size array at %L must be a dummy argument",
+		       &sym->declared_at);
+	  else
+	    gfc_error ("Assumed shape array at %L must be a dummy argument",
+		       &sym->declared_at);
+	  return;
+	}
+      /* TS 29113, C535a.  */
+      if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy
+	  && !sym->attr.select_type_temporary)
+	{
+	  gfc_error ("Assumed-rank array at %L must be a dummy argument",
+		     &sym->declared_at);
+	  return;
+	}
+      if (as->type == AS_ASSUMED_RANK
+	  && (sym->attr.codimension || sym->attr.value))
+	{
+	  gfc_error ("Assumed-rank array at %L may not have the VALUE or "
+		     "CODIMENSION attribute", &sym->declared_at);
+	  return;
+	}
+    }
+
+  /* Make sure symbols with known intent or optional are really dummy
+     variable.  Because of ENTRY statement, this has to be deferred
+     until resolution time.  */
+
+  if (!sym->attr.dummy
+      && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
+    {
+      gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
+      return;
+    }
+
+  if (sym->attr.value && !sym->attr.dummy)
+    {
+      gfc_error ("'%s' at %L cannot have the VALUE attribute because "
+		 "it is not a dummy argument", sym->name, &sym->declared_at);
+      return;
+    }
+
+  if (sym->attr.value && sym->ts.type == BT_CHARACTER)
+    {
+      gfc_charlen *cl = sym->ts.u.cl;
+      if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
+	{
+	  gfc_error ("Character dummy variable '%s' at %L with VALUE "
+		     "attribute must have constant length",
+		     sym->name, &sym->declared_at);
+	  return;
+	}
+
+      if (sym->ts.is_c_interop
+	  && mpz_cmp_si (cl->length->value.integer, 1) != 0)
+	{
+	  gfc_error ("C interoperable character dummy variable '%s' at %L "
+		     "with VALUE attribute must have length one",
+		     sym->name, &sym->declared_at);
+	  return;
+	}
+    }
+
+  if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
+      && sym->ts.u.derived->attr.generic)
+    {
+      sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
+      if (!sym->ts.u.derived)
+	{
+	  gfc_error ("The derived type '%s' at %L is of type '%s', "
+		     "which has not been defined", sym->name,
+		     &sym->declared_at, sym->ts.u.derived->name);
+	  sym->ts.type = BT_UNKNOWN;
+	  return;
+	}
+    }
+
+    /* Use the same constraints as TYPE(*), except for the type check
+       and that only scalars and assumed-size arrays are permitted.  */
+    if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
+      {
+	if (!sym->attr.dummy)
+	  {
+	    gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
+		       "a dummy argument", sym->name, &sym->declared_at);
+	    return;
+	  }
+
+	if (sym->ts.type != BT_ASSUMED && sym->ts.type != BT_INTEGER
+	    && sym->ts.type != BT_REAL && sym->ts.type != BT_LOGICAL
+	    && sym->ts.type != BT_COMPLEX)
+	  {
+	    gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
+		       "of type TYPE(*) or of an numeric intrinsic type",
+		       sym->name, &sym->declared_at);
+	    return;
+	  }
+
+      if (sym->attr.allocatable || sym->attr.codimension
+	  || sym->attr.pointer || sym->attr.value)
+	{
+	  gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
+		     "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
+		     "attribute", sym->name, &sym->declared_at);
+	  return;
+	}
+
+      if (sym->attr.intent == INTENT_OUT)
+	{
+	  gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
+		     "have the INTENT(OUT) attribute",
+		     sym->name, &sym->declared_at);
+	  return;
+	}
+      if (sym->attr.dimension && sym->as->type != AS_ASSUMED_SIZE)
+	{
+	  gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
+		     "either be a scalar or an assumed-size array",
+		     sym->name, &sym->declared_at);
+	  return;
+	}
+
+      /* Set the type to TYPE(*) and add a dimension(*) to ensure
+	 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
+	 packing.  */
+      sym->ts.type = BT_ASSUMED;
+      sym->as = gfc_get_array_spec ();
+      sym->as->type = AS_ASSUMED_SIZE;
+      sym->as->rank = 1;
+      sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+    }
+  else if (sym->ts.type == BT_ASSUMED)
+    {
+      /* TS 29113, C407a.  */
+      if (!sym->attr.dummy)
+	{
+	  gfc_error ("Assumed type of variable %s at %L is only permitted "
+		     "for dummy variables", sym->name, &sym->declared_at);
+	  return;
+	}
+      if (sym->attr.allocatable || sym->attr.codimension
+	  || sym->attr.pointer || sym->attr.value)
+    	{
+	  gfc_error ("Assumed-type variable %s at %L may not have the "
+		     "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
+		     sym->name, &sym->declared_at);
+	  return;
+	}
+      if (sym->attr.intent == INTENT_OUT)
+    	{
+	  gfc_error ("Assumed-type variable %s at %L may not have the "
+		     "INTENT(OUT) attribute",
+		     sym->name, &sym->declared_at);
+	  return;
+	}
+      if (sym->attr.dimension && sym->as->type == AS_EXPLICIT)
+	{
+	  gfc_error ("Assumed-type variable %s at %L shall not be an "
+		     "explicit-shape array", sym->name, &sym->declared_at);
+	  return;
+	}
+    }
+
+  /* If the symbol is marked as bind(c), verify it's type and kind.  Do not
+     do this for something that was implicitly typed because that is handled
+     in gfc_set_default_type.  Handle dummy arguments and procedure
+     definitions separately.  Also, anything that is use associated is not
+     handled here but instead is handled in the module it is declared in.
+     Finally, derived type definitions are allowed to be BIND(C) since that
+     only implies that they're interoperable, and they are checked fully for
+     interoperability when a variable is declared of that type.  */
+  if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
+      sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
+      sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
+    {
+      bool t = true;
+
+      /* First, make sure the variable is declared at the
+	 module-level scope (J3/04-007, Section 15.3).	*/
+      if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
+          sym->attr.in_common == 0)
+	{
+	  gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
+		     "is neither a COMMON block nor declared at the "
+		     "module level scope", sym->name, &(sym->declared_at));
+	  t = false;
+	}
+      else if (sym->common_head != NULL)
+        {
+          t = verify_com_block_vars_c_interop (sym->common_head);
+        }
+      else
+	{
+	  /* If type() declaration, we need to verify that the components
+	     of the given type are all C interoperable, etc.  */
+	  if (sym->ts.type == BT_DERIVED &&
+              sym->ts.u.derived->attr.is_c_interop != 1)
+            {
+              /* Make sure the user marked the derived type as BIND(C).  If
+                 not, call the verify routine.  This could print an error
+                 for the derived type more than once if multiple variables
+                 of that type are declared.  */
+              if (sym->ts.u.derived->attr.is_bind_c != 1)
+                verify_bind_c_derived_type (sym->ts.u.derived);
+              t = false;
+            }
+
+	  /* Verify the variable itself as C interoperable if it
+             is BIND(C).  It is not possible for this to succeed if
+             the verify_bind_c_derived_type failed, so don't have to handle
+             any error returned by verify_bind_c_derived_type.  */
+          t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
+                                 sym->common_block);
+	}
+
+      if (!t)
+        {
+          /* clear the is_bind_c flag to prevent reporting errors more than
+             once if something failed.  */
+          sym->attr.is_bind_c = 0;
+          return;
+        }
+    }
+
+  /* If a derived type symbol has reached this point, without its
+     type being declared, we have an error.  Notice that most
+     conditions that produce undefined derived types have already
+     been dealt with.  However, the likes of:
+     implicit type(t) (t) ..... call foo (t) will get us here if
+     the type is not declared in the scope of the implicit
+     statement. Change the type to BT_UNKNOWN, both because it is so
+     and to prevent an ICE.  */
+  if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
+      && sym->ts.u.derived->components == NULL
+      && !sym->ts.u.derived->attr.zero_comp)
+    {
+      gfc_error ("The derived type '%s' at %L is of type '%s', "
+		 "which has not been defined", sym->name,
+		  &sym->declared_at, sym->ts.u.derived->name);
+      sym->ts.type = BT_UNKNOWN;
+      return;
+    }
+
+  /* Make sure that the derived type has been resolved and that the
+     derived type is visible in the symbol's namespace, if it is a
+     module function and is not PRIVATE.  */
+  if (sym->ts.type == BT_DERIVED
+	&& sym->ts.u.derived->attr.use_assoc
+	&& sym->ns->proc_name
+	&& sym->ns->proc_name->attr.flavor == FL_MODULE
+        && !resolve_fl_derived (sym->ts.u.derived))
+    return;
+
+  /* Unless the derived-type declaration is use associated, Fortran 95
+     does not allow public entries of private derived types.
+     See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
+     161 in 95-006r3.  */
+  if (sym->ts.type == BT_DERIVED
+      && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
+      && !sym->ts.u.derived->attr.use_assoc
+      && gfc_check_symbol_access (sym)
+      && !gfc_check_symbol_access (sym->ts.u.derived)
+      && !gfc_notify_std (GFC_STD_F2003, "PUBLIC %s '%s' at %L of PRIVATE "
+			  "derived type '%s'", 
+			  (sym->attr.flavor == FL_PARAMETER) 
+			  ? "parameter" : "variable", 
+			  sym->name, &sym->declared_at, 
+			  sym->ts.u.derived->name))
+    return;
+
+  /* F2008, C1302.  */
+  if (sym->ts.type == BT_DERIVED
+      && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+	   && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
+	  || sym->ts.u.derived->attr.lock_comp)
+      && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
+    {
+      gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
+		 "type LOCK_TYPE must be a coarray", sym->name,
+		 &sym->declared_at);
+      return;
+    }
+
+  /* An assumed-size array with INTENT(OUT) shall not be of a type for which
+     default initialization is defined (5.1.2.4.4).  */
+  if (sym->ts.type == BT_DERIVED
+      && sym->attr.dummy
+      && sym->attr.intent == INTENT_OUT
+      && sym->as
+      && sym->as->type == AS_ASSUMED_SIZE)
+    {
+      for (c = sym->ts.u.derived->components; c; c = c->next)
+	{
+	  if (c->initializer)
+	    {
+	      gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
+			 "ASSUMED SIZE and so cannot have a default initializer",
+			 sym->name, &sym->declared_at);
+	      return;
+	    }
+	}
+    }
+
+  /* F2008, C542.  */
+  if (sym->ts.type == BT_DERIVED && sym->attr.dummy
+      && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp)
+    {
+      gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
+		 "INTENT(OUT)", sym->name, &sym->declared_at);
+      return;
+    }
+
+  /* F2008, C525.  */
+  if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
+	 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
+	     && CLASS_DATA (sym)->attr.coarray_comp))
+       || class_attr.codimension)
+      && (sym->attr.result || sym->result == sym))
+    {
+      gfc_error ("Function result '%s' at %L shall not be a coarray or have "
+	         "a coarray component", sym->name, &sym->declared_at);
+      return;
+    }
+
+  /* F2008, C524.  */
+  if (sym->attr.codimension && sym->ts.type == BT_DERIVED
+      && sym->ts.u.derived->ts.is_iso_c)
+    {
+      gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
+		 "shall not be a coarray", sym->name, &sym->declared_at);
+      return;
+    }
+
+  /* F2008, C525.  */
+  if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
+	|| (sym->ts.type == BT_CLASS && sym->attr.class_ok
+	    && CLASS_DATA (sym)->attr.coarray_comp))
+      && (class_attr.codimension || class_attr.pointer || class_attr.dimension
+	  || class_attr.allocatable))
+    {
+      gfc_error ("Variable '%s' at %L with coarray component shall be a "
+		 "nonpointer, nonallocatable scalar, which is not a coarray",
+		 sym->name, &sym->declared_at);
+      return;
+    }
+
+  /* F2008, C526.  The function-result case was handled above.  */
+  if (class_attr.codimension
+      && !(class_attr.allocatable || sym->attr.dummy || sym->attr.save
+	   || sym->attr.select_type_temporary
+	   || sym->ns->save_all
+	   || sym->ns->proc_name->attr.flavor == FL_MODULE
+	   || sym->ns->proc_name->attr.is_main_program
+	   || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
+    {
+      gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
+		 "nor a dummy argument", sym->name, &sym->declared_at);
+      return;
+    }
+  /* F2008, C528.  */
+  else if (class_attr.codimension && !sym->attr.select_type_temporary
+	   && !class_attr.allocatable && as && as->cotype == AS_DEFERRED)
+    {
+      gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
+		 "deferred shape", sym->name, &sym->declared_at);
+      return;
+    }
+  else if (class_attr.codimension && class_attr.allocatable && as
+	   && (as->cotype != AS_DEFERRED || as->type != AS_DEFERRED))
+    {
+      gfc_error ("Allocatable coarray variable '%s' at %L must have "
+		 "deferred shape", sym->name, &sym->declared_at);
+      return;
+    }
+
+  /* F2008, C541.  */
+  if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
+	|| (sym->ts.type == BT_CLASS && sym->attr.class_ok
+	    && CLASS_DATA (sym)->attr.coarray_comp))
+       || (class_attr.codimension && class_attr.allocatable))
+      && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
+    {
+      gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
+		 "allocatable coarray or have coarray components",
+		 sym->name, &sym->declared_at);
+      return;
+    }
+
+  if (class_attr.codimension && sym->attr.dummy
+      && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
+    {
+      gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
+		 "procedure '%s'", sym->name, &sym->declared_at,
+		 sym->ns->proc_name->name);
+      return;
+    }
+
+  if (sym->ts.type == BT_LOGICAL
+      && ((sym->attr.function && sym->attr.is_bind_c && sym->result == sym)
+	  || ((sym->attr.dummy || sym->attr.result) && sym->ns->proc_name
+	      && sym->ns->proc_name->attr.is_bind_c)))
+    {
+      int i;
+      for (i = 0; gfc_logical_kinds[i].kind; i++)
+        if (gfc_logical_kinds[i].kind == sym->ts.kind)
+          break;
+      if (!gfc_logical_kinds[i].c_bool && sym->attr.dummy
+	  && !gfc_notify_std (GFC_STD_GNU, "LOGICAL dummy argument '%s' at "
+			      "%L with non-C_Bool kind in BIND(C) procedure "
+			      "'%s'", sym->name, &sym->declared_at, 
+			      sym->ns->proc_name->name))
+	return;
+      else if (!gfc_logical_kinds[i].c_bool
+	       && !gfc_notify_std (GFC_STD_GNU, "LOGICAL result variable "
+				   "'%s' at %L with non-C_Bool kind in "
+				   "BIND(C) procedure '%s'", sym->name, 
+				   &sym->declared_at, 
+				   sym->attr.function ? sym->name 
+				   : sym->ns->proc_name->name))
+	return;
+    }
+
+  switch (sym->attr.flavor)
+    {
+    case FL_VARIABLE:
+      if (!resolve_fl_variable (sym, mp_flag))
+	return;
+      break;
+
+    case FL_PROCEDURE:
+      if (!resolve_fl_procedure (sym, mp_flag))
+	return;
+      break;
+
+    case FL_NAMELIST:
+      if (!resolve_fl_namelist (sym))
+	return;
+      break;
+
+    case FL_PARAMETER:
+      if (!resolve_fl_parameter (sym))
+	return;
+      break;
+
+    default:
+      break;
+    }
+
+  /* Resolve array specifier. Check as well some constraints
+     on COMMON blocks.  */
+
+  check_constant = sym->attr.in_common && !sym->attr.pointer;
+
+  /* Set the formal_arg_flag so that check_conflict will not throw
+     an error for host associated variables in the specification
+     expression for an array_valued function.  */
+  if (sym->attr.function && sym->as)
+    formal_arg_flag = 1;
+
+  saved_specification_expr = specification_expr;
+  specification_expr = true;
+  gfc_resolve_array_spec (sym->as, check_constant);
+  specification_expr = saved_specification_expr;
+
+  formal_arg_flag = 0;
+
+  /* Resolve formal namespaces.  */
+  if (sym->formal_ns && sym->formal_ns != gfc_current_ns
+      && !sym->attr.contained && !sym->attr.intrinsic)
+    gfc_resolve (sym->formal_ns);
+
+  /* Make sure the formal namespace is present.  */
+  if (sym->formal && !sym->formal_ns)
+    {
+      gfc_formal_arglist *formal = sym->formal;
+      while (formal && !formal->sym)
+	formal = formal->next;
+
+      if (formal)
+	{
+	  sym->formal_ns = formal->sym->ns;
+          if (sym->ns != formal->sym->ns)
+	    sym->formal_ns->refs++;
+	}
+    }
+
+  /* Check threadprivate restrictions.  */
+  if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
+      && (!sym->attr.in_common
+	  && sym->module == NULL
+	  && (sym->ns->proc_name == NULL
+	      || sym->ns->proc_name->attr.flavor != FL_MODULE)))
+    gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
+
+  /* If we have come this far we can apply default-initializers, as
+     described in 14.7.5, to those variables that have not already
+     been assigned one.  */
+  if (sym->ts.type == BT_DERIVED
+      && !sym->value
+      && !sym->attr.allocatable
+      && !sym->attr.alloc_comp)
+    {
+      symbol_attribute *a = &sym->attr;
+
+      if ((!a->save && !a->dummy && !a->pointer
+	   && !a->in_common && !a->use_assoc
+	   && (a->referenced || a->result)
+	   && !(a->function && sym != sym->result))
+	  || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
+	apply_default_init (sym);
+    }
+
+  if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
+      && sym->attr.dummy && sym->attr.intent == INTENT_OUT
+      && !CLASS_DATA (sym)->attr.class_pointer
+      && !CLASS_DATA (sym)->attr.allocatable)
+    apply_default_init (sym);
+
+  /* If this symbol has a type-spec, check it.  */
+  if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
+      || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
+    if (!resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name))
+      return;
+}
+
+
+/************* Resolve DATA statements *************/
+
+static struct
+{
+  gfc_data_value *vnode;
+  mpz_t left;
+}
+values;
+
+
+/* Advance the values structure to point to the next value in the data list.  */
+
+static bool
+next_data_value (void)
+{
+  while (mpz_cmp_ui (values.left, 0) == 0)
+    {
+
+      if (values.vnode->next == NULL)
+	return false;
+
+      values.vnode = values.vnode->next;
+      mpz_set (values.left, values.vnode->repeat);
+    }
+
+  return true;
+}
+
+
+static bool
+check_data_variable (gfc_data_variable *var, locus *where)
+{
+  gfc_expr *e;
+  mpz_t size;
+  mpz_t offset;
+  bool t;
+  ar_type mark = AR_UNKNOWN;
+  int i;
+  mpz_t section_index[GFC_MAX_DIMENSIONS];
+  gfc_ref *ref;
+  gfc_array_ref *ar;
+  gfc_symbol *sym;
+  int has_pointer;
+
+  if (!gfc_resolve_expr (var->expr))
+    return false;
+
+  ar = NULL;
+  mpz_init_set_si (offset, 0);
+  e = var->expr;
+
+  if (e->expr_type != EXPR_VARIABLE)
+    gfc_internal_error ("check_data_variable(): Bad expression");
+
+  sym = e->symtree->n.sym;
+
+  if (sym->ns->is_block_data && !sym->attr.in_common)
+    {
+      gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
+		 sym->name, &sym->declared_at);
+    }
+
+  if (e->ref == NULL && sym->as)
+    {
+      gfc_error ("DATA array '%s' at %L must be specified in a previous"
+		 " declaration", sym->name, where);
+      return false;
+    }
+
+  has_pointer = sym->attr.pointer;
+
+  if (gfc_is_coindexed (e))
+    {
+      gfc_error ("DATA element '%s' at %L cannot have a coindex", sym->name,
+		 where);
+      return false;
+    }
+
+  for (ref = e->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
+	has_pointer = 1;
+
+      if (has_pointer
+	    && ref->type == REF_ARRAY
+	    && ref->u.ar.type != AR_FULL)
+	  {
+	    gfc_error ("DATA element '%s' at %L is a pointer and so must "
+			"be a full array", sym->name, where);
+	    return false;
+	  }
+    }
+
+  if (e->rank == 0 || has_pointer)
+    {
+      mpz_init_set_ui (size, 1);
+      ref = NULL;
+    }
+  else
+    {
+      ref = e->ref;
+
+      /* Find the array section reference.  */
+      for (ref = e->ref; ref; ref = ref->next)
+	{
+	  if (ref->type != REF_ARRAY)
+	    continue;
+	  if (ref->u.ar.type == AR_ELEMENT)
+	    continue;
+	  break;
+	}
+      gcc_assert (ref);
+
+      /* Set marks according to the reference pattern.  */
+      switch (ref->u.ar.type)
+	{
+	case AR_FULL:
+	  mark = AR_FULL;
+	  break;
+
+	case AR_SECTION:
+	  ar = &ref->u.ar;
+	  /* Get the start position of array section.  */
+	  gfc_get_section_index (ar, section_index, &offset);
+	  mark = AR_SECTION;
+	  break;
+
+	default:
+	  gcc_unreachable ();
+	}
+
+      if (!gfc_array_size (e, &size))
+	{
+	  gfc_error ("Nonconstant array section at %L in DATA statement",
+		     &e->where);
+	  mpz_clear (offset);
+	  return false;
+	}
+    }
+
+  t = true;
+
+  while (mpz_cmp_ui (size, 0) > 0)
+    {
+      if (!next_data_value ())
+	{
+	  gfc_error ("DATA statement at %L has more variables than values",
+		     where);
+	  t = false;
+	  break;
+	}
+
+      t = gfc_check_assign (var->expr, values.vnode->expr, 0);
+      if (!t)
+	break;
+
+      /* If we have more than one element left in the repeat count,
+	 and we have more than one element left in the target variable,
+	 then create a range assignment.  */
+      /* FIXME: Only done for full arrays for now, since array sections
+	 seem tricky.  */
+      if (mark == AR_FULL && ref && ref->next == NULL
+	  && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
+	{
+	  mpz_t range;
+
+	  if (mpz_cmp (size, values.left) >= 0)
+	    {
+	      mpz_init_set (range, values.left);
+	      mpz_sub (size, size, values.left);
+	      mpz_set_ui (values.left, 0);
+	    }
+	  else
+	    {
+	      mpz_init_set (range, size);
+	      mpz_sub (values.left, values.left, size);
+	      mpz_set_ui (size, 0);
+	    }
+
+	  t = gfc_assign_data_value (var->expr, values.vnode->expr,
+				     offset, &range);
+
+	  mpz_add (offset, offset, range);
+	  mpz_clear (range);
+
+	  if (!t)
+	    break;
+	}
+
+      /* Assign initial value to symbol.  */
+      else
+	{
+	  mpz_sub_ui (values.left, values.left, 1);
+	  mpz_sub_ui (size, size, 1);
+
+	  t = gfc_assign_data_value (var->expr, values.vnode->expr,
+				     offset, NULL);
+	  if (!t)
+	    break;
+
+	  if (mark == AR_FULL)
+	    mpz_add_ui (offset, offset, 1);
+
+	  /* Modify the array section indexes and recalculate the offset
+	     for next element.  */
+	  else if (mark == AR_SECTION)
+	    gfc_advance_section (section_index, ar, &offset);
+	}
+    }
+
+  if (mark == AR_SECTION)
+    {
+      for (i = 0; i < ar->dimen; i++)
+	mpz_clear (section_index[i]);
+    }
+
+  mpz_clear (size);
+  mpz_clear (offset);
+
+  return t;
+}
+
+
+static bool traverse_data_var (gfc_data_variable *, locus *);
+
+/* Iterate over a list of elements in a DATA statement.  */
+
+static bool
+traverse_data_list (gfc_data_variable *var, locus *where)
+{
+  mpz_t trip;
+  iterator_stack frame;
+  gfc_expr *e, *start, *end, *step;
+  bool retval = true;
+
+  mpz_init (frame.value);
+  mpz_init (trip);
+
+  start = gfc_copy_expr (var->iter.start);
+  end = gfc_copy_expr (var->iter.end);
+  step = gfc_copy_expr (var->iter.step);
+
+  if (!gfc_simplify_expr (start, 1)
+      || start->expr_type != EXPR_CONSTANT)
+    {
+      gfc_error ("start of implied-do loop at %L could not be "
+		 "simplified to a constant value", &start->where);
+      retval = false;
+      goto cleanup;
+    }
+  if (!gfc_simplify_expr (end, 1)
+      || end->expr_type != EXPR_CONSTANT)
+    {
+      gfc_error ("end of implied-do loop at %L could not be "
+		 "simplified to a constant value", &start->where);
+      retval = false;
+      goto cleanup;
+    }
+  if (!gfc_simplify_expr (step, 1)
+      || step->expr_type != EXPR_CONSTANT)
+    {
+      gfc_error ("step of implied-do loop at %L could not be "
+		 "simplified to a constant value", &start->where);
+      retval = false;
+      goto cleanup;
+    }
+
+  mpz_set (trip, end->value.integer);
+  mpz_sub (trip, trip, start->value.integer);
+  mpz_add (trip, trip, step->value.integer);
+
+  mpz_div (trip, trip, step->value.integer);
+
+  mpz_set (frame.value, start->value.integer);
+
+  frame.prev = iter_stack;
+  frame.variable = var->iter.var->symtree;
+  iter_stack = &frame;
+
+  while (mpz_cmp_ui (trip, 0) > 0)
+    {
+      if (!traverse_data_var (var->list, where))
+	{
+	  retval = false;
+	  goto cleanup;
+	}
+
+      e = gfc_copy_expr (var->expr);
+      if (!gfc_simplify_expr (e, 1))
+	{
+	  gfc_free_expr (e);
+	  retval = false;
+	  goto cleanup;
+	}
+
+      mpz_add (frame.value, frame.value, step->value.integer);
+
+      mpz_sub_ui (trip, trip, 1);
+    }
+
+cleanup:
+  mpz_clear (frame.value);
+  mpz_clear (trip);
+
+  gfc_free_expr (start);
+  gfc_free_expr (end);
+  gfc_free_expr (step);
+
+  iter_stack = frame.prev;
+  return retval;
+}
+
+
+/* Type resolve variables in the variable list of a DATA statement.  */
+
+static bool
+traverse_data_var (gfc_data_variable *var, locus *where)
+{
+  bool t;
+
+  for (; var; var = var->next)
+    {
+      if (var->expr == NULL)
+	t = traverse_data_list (var, where);
+      else
+	t = check_data_variable (var, where);
+
+      if (!t)
+	return false;
+    }
+
+  return true;
+}
+
+
+/* Resolve the expressions and iterators associated with a data statement.
+   This is separate from the assignment checking because data lists should
+   only be resolved once.  */
+
+static bool
+resolve_data_variables (gfc_data_variable *d)
+{
+  for (; d; d = d->next)
+    {
+      if (d->list == NULL)
+	{
+	  if (!gfc_resolve_expr (d->expr))
+	    return false;
+	}
+      else
+	{
+	  if (!gfc_resolve_iterator (&d->iter, false, true))
+	    return false;
+
+	  if (!resolve_data_variables (d->list))
+	    return false;
+	}
+    }
+
+  return true;
+}
+
+
+/* Resolve a single DATA statement.  We implement this by storing a pointer to
+   the value list into static variables, and then recursively traversing the
+   variables list, expanding iterators and such.  */
+
+static void
+resolve_data (gfc_data *d)
+{
+
+  if (!resolve_data_variables (d->var))
+    return;
+
+  values.vnode = d->value;
+  if (d->value == NULL)
+    mpz_set_ui (values.left, 0);
+  else
+    mpz_set (values.left, d->value->repeat);
+
+  if (!traverse_data_var (d->var, &d->where))
+    return;
+
+  /* At this point, we better not have any values left.  */
+
+  if (next_data_value ())
+    gfc_error ("DATA statement at %L has more values than variables",
+	       &d->where);
+}
+
+
+/* 12.6 Constraint: In a pure subprogram any variable which is in common or
+   accessed by host or use association, is a dummy argument to a pure function,
+   is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
+   is storage associated with any such variable, shall not be used in the
+   following contexts: (clients of this function).  */
+
+/* Determines if a variable is not 'pure', i.e., not assignable within a pure
+   procedure.  Returns zero if assignment is OK, nonzero if there is a
+   problem.  */
+int
+gfc_impure_variable (gfc_symbol *sym)
+{
+  gfc_symbol *proc;
+  gfc_namespace *ns;
+
+  if (sym->attr.use_assoc || sym->attr.in_common)
+    return 1;
+
+  /* Check if the symbol's ns is inside the pure procedure.  */
+  for (ns = gfc_current_ns; ns; ns = ns->parent)
+    {
+      if (ns == sym->ns)
+	break;
+      if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
+	return 1;
+    }
+
+  proc = sym->ns->proc_name;
+  if (sym->attr.dummy
+      && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
+	  || proc->attr.function))
+    return 1;
+
+  /* TODO: Sort out what can be storage associated, if anything, and include
+     it here.  In principle equivalences should be scanned but it does not
+     seem to be possible to storage associate an impure variable this way.  */
+  return 0;
+}
+
+
+/* Test whether a symbol is pure or not.  For a NULL pointer, checks if the
+   current namespace is inside a pure procedure.  */
+
+int
+gfc_pure (gfc_symbol *sym)
+{
+  symbol_attribute attr;
+  gfc_namespace *ns;
+
+  if (sym == NULL)
+    {
+      /* Check if the current namespace or one of its parents
+	belongs to a pure procedure.  */
+      for (ns = gfc_current_ns; ns; ns = ns->parent)
+	{
+	  sym = ns->proc_name;
+	  if (sym == NULL)
+	    return 0;
+	  attr = sym->attr;
+	  if (attr.flavor == FL_PROCEDURE && attr.pure)
+	    return 1;
+	}
+      return 0;
+    }
+
+  attr = sym->attr;
+
+  return attr.flavor == FL_PROCEDURE && attr.pure;
+}
+
+
+/* Test whether a symbol is implicitly pure or not.  For a NULL pointer,
+   checks if the current namespace is implicitly pure.  Note that this
+   function returns false for a PURE procedure.  */
+
+int
+gfc_implicit_pure (gfc_symbol *sym)
+{
+  gfc_namespace *ns;
+
+  if (sym == NULL)
+    {
+      /* Check if the current procedure is implicit_pure.  Walk up
+	 the procedure list until we find a procedure.  */
+      for (ns = gfc_current_ns; ns; ns = ns->parent)
+	{
+	  sym = ns->proc_name;
+	  if (sym == NULL)
+	    return 0;
+
+	  if (sym->attr.flavor == FL_PROCEDURE)
+	    break;
+	}
+    }
+
+  return sym->attr.flavor == FL_PROCEDURE && sym->attr.implicit_pure
+    && !sym->attr.pure;
+}
+
+
+void
+gfc_unset_implicit_pure (gfc_symbol *sym)
+{
+  gfc_namespace *ns;
+
+  if (sym == NULL)
+    {
+      /* Check if the current procedure is implicit_pure.  Walk up
+	 the procedure list until we find a procedure.  */
+      for (ns = gfc_current_ns; ns; ns = ns->parent)
+	{
+	  sym = ns->proc_name;
+	  if (sym == NULL)
+	    return;
+
+	  if (sym->attr.flavor == FL_PROCEDURE)
+	    break;
+	}
+    }
+
+  if (sym->attr.flavor == FL_PROCEDURE)
+    sym->attr.implicit_pure = 0;
+  else
+    sym->attr.pure = 0;
+}
+
+
+/* Test whether the current procedure is elemental or not.  */
+
+int
+gfc_elemental (gfc_symbol *sym)
+{
+  symbol_attribute attr;
+
+  if (sym == NULL)
+    sym = gfc_current_ns->proc_name;
+  if (sym == NULL)
+    return 0;
+  attr = sym->attr;
+
+  return attr.flavor == FL_PROCEDURE && attr.elemental;
+}
+
+
+/* Warn about unused labels.  */
+
+static void
+warn_unused_fortran_label (gfc_st_label *label)
+{
+  if (label == NULL)
+    return;
+
+  warn_unused_fortran_label (label->left);
+
+  if (label->defined == ST_LABEL_UNKNOWN)
+    return;
+
+  switch (label->referenced)
+    {
+    case ST_LABEL_UNKNOWN:
+      gfc_warning ("Label %d at %L defined but not used", label->value,
+		   &label->where);
+      break;
+
+    case ST_LABEL_BAD_TARGET:
+      gfc_warning ("Label %d at %L defined but cannot be used",
+		   label->value, &label->where);
+      break;
+
+    default:
+      break;
+    }
+
+  warn_unused_fortran_label (label->right);
+}
+
+
+/* Returns the sequence type of a symbol or sequence.  */
+
+static seq_type
+sequence_type (gfc_typespec ts)
+{
+  seq_type result;
+  gfc_component *c;
+
+  switch (ts.type)
+  {
+    case BT_DERIVED:
+
+      if (ts.u.derived->components == NULL)
+	return SEQ_NONDEFAULT;
+
+      result = sequence_type (ts.u.derived->components->ts);
+      for (c = ts.u.derived->components->next; c; c = c->next)
+	if (sequence_type (c->ts) != result)
+	  return SEQ_MIXED;
+
+      return result;
+
+    case BT_CHARACTER:
+      if (ts.kind != gfc_default_character_kind)
+	  return SEQ_NONDEFAULT;
+
+      return SEQ_CHARACTER;
+
+    case BT_INTEGER:
+      if (ts.kind != gfc_default_integer_kind)
+	  return SEQ_NONDEFAULT;
+
+      return SEQ_NUMERIC;
+
+    case BT_REAL:
+      if (!(ts.kind == gfc_default_real_kind
+	    || ts.kind == gfc_default_double_kind))
+	  return SEQ_NONDEFAULT;
+
+      return SEQ_NUMERIC;
+
+    case BT_COMPLEX:
+      if (ts.kind != gfc_default_complex_kind)
+	  return SEQ_NONDEFAULT;
+
+      return SEQ_NUMERIC;
+
+    case BT_LOGICAL:
+      if (ts.kind != gfc_default_logical_kind)
+	  return SEQ_NONDEFAULT;
+
+      return SEQ_NUMERIC;
+
+    default:
+      return SEQ_NONDEFAULT;
+  }
+}
+
+
+/* Resolve derived type EQUIVALENCE object.  */
+
+static bool
+resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
+{
+  gfc_component *c = derived->components;
+
+  if (!derived)
+    return true;
+
+  /* Shall not be an object of nonsequence derived type.  */
+  if (!derived->attr.sequence)
+    {
+      gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
+		 "attribute to be an EQUIVALENCE object", sym->name,
+		 &e->where);
+      return false;
+    }
+
+  /* Shall not have allocatable components.  */
+  if (derived->attr.alloc_comp)
+    {
+      gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
+		 "components to be an EQUIVALENCE object",sym->name,
+		 &e->where);
+      return false;
+    }
+
+  if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
+    {
+      gfc_error ("Derived type variable '%s' at %L with default "
+		 "initialization cannot be in EQUIVALENCE with a variable "
+		 "in COMMON", sym->name, &e->where);
+      return false;
+    }
+
+  for (; c ; c = c->next)
+    {
+      if (c->ts.type == BT_DERIVED
+	  && (!resolve_equivalence_derived(c->ts.u.derived, sym, e)))
+	return false;
+
+      /* Shall not be an object of sequence derived type containing a pointer
+	 in the structure.  */
+      if (c->attr.pointer)
+	{
+	  gfc_error ("Derived type variable '%s' at %L with pointer "
+		     "component(s) cannot be an EQUIVALENCE object",
+		     sym->name, &e->where);
+	  return false;
+	}
+    }
+  return true;
+}
+
+
+/* Resolve equivalence object.
+   An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
+   an allocatable array, an object of nonsequence derived type, an object of
+   sequence derived type containing a pointer at any level of component
+   selection, an automatic object, a function name, an entry name, a result
+   name, a named constant, a structure component, or a subobject of any of
+   the preceding objects.  A substring shall not have length zero.  A
+   derived type shall not have components with default initialization nor
+   shall two objects of an equivalence group be initialized.
+   Either all or none of the objects shall have an protected attribute.
+   The simple constraints are done in symbol.c(check_conflict) and the rest
+   are implemented here.  */
+
+static void
+resolve_equivalence (gfc_equiv *eq)
+{
+  gfc_symbol *sym;
+  gfc_symbol *first_sym;
+  gfc_expr *e;
+  gfc_ref *r;
+  locus *last_where = NULL;
+  seq_type eq_type, last_eq_type;
+  gfc_typespec *last_ts;
+  int object, cnt_protected;
+  const char *msg;
+
+  last_ts = &eq->expr->symtree->n.sym->ts;
+
+  first_sym = eq->expr->symtree->n.sym;
+
+  cnt_protected = 0;
+
+  for (object = 1; eq; eq = eq->eq, object++)
+    {
+      e = eq->expr;
+
+      e->ts = e->symtree->n.sym->ts;
+      /* match_varspec might not know yet if it is seeing
+	 array reference or substring reference, as it doesn't
+	 know the types.  */
+      if (e->ref && e->ref->type == REF_ARRAY)
+	{
+	  gfc_ref *ref = e->ref;
+	  sym = e->symtree->n.sym;
+
+	  if (sym->attr.dimension)
+	    {
+	      ref->u.ar.as = sym->as;
+	      ref = ref->next;
+	    }
+
+	  /* For substrings, convert REF_ARRAY into REF_SUBSTRING.  */
+	  if (e->ts.type == BT_CHARACTER
+	      && ref
+	      && ref->type == REF_ARRAY
+	      && ref->u.ar.dimen == 1
+	      && ref->u.ar.dimen_type[0] == DIMEN_RANGE
+	      && ref->u.ar.stride[0] == NULL)
+	    {
+	      gfc_expr *start = ref->u.ar.start[0];
+	      gfc_expr *end = ref->u.ar.end[0];
+	      void *mem = NULL;
+
+	      /* Optimize away the (:) reference.  */
+	      if (start == NULL && end == NULL)
+		{
+		  if (e->ref == ref)
+		    e->ref = ref->next;
+		  else
+		    e->ref->next = ref->next;
+		  mem = ref;
+		}
+	      else
+		{
+		  ref->type = REF_SUBSTRING;
+		  if (start == NULL)
+		    start = gfc_get_int_expr (gfc_default_integer_kind,
+					      NULL, 1);
+		  ref->u.ss.start = start;
+		  if (end == NULL && e->ts.u.cl)
+		    end = gfc_copy_expr (e->ts.u.cl->length);
+		  ref->u.ss.end = end;
+		  ref->u.ss.length = e->ts.u.cl;
+		  e->ts.u.cl = NULL;
+		}
+	      ref = ref->next;
+	      free (mem);
+	    }
+
+	  /* Any further ref is an error.  */
+	  if (ref)
+	    {
+	      gcc_assert (ref->type == REF_ARRAY);
+	      gfc_error ("Syntax error in EQUIVALENCE statement at %L",
+			 &ref->u.ar.where);
+	      continue;
+	    }
+	}
+
+      if (!gfc_resolve_expr (e))
+	continue;
+
+      sym = e->symtree->n.sym;
+
+      if (sym->attr.is_protected)
+	cnt_protected++;
+      if (cnt_protected > 0 && cnt_protected != object)
+       	{
+	      gfc_error ("Either all or none of the objects in the "
+			 "EQUIVALENCE set at %L shall have the "
+			 "PROTECTED attribute",
+			 &e->where);
+	      break;
+	}
+
+      /* Shall not equivalence common block variables in a PURE procedure.  */
+      if (sym->ns->proc_name
+	  && sym->ns->proc_name->attr.pure
+	  && sym->attr.in_common)
+	{
+	  gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
+		     "object in the pure procedure '%s'",
+		     sym->name, &e->where, sym->ns->proc_name->name);
+	  break;
+	}
+
+      /* Shall not be a named constant.  */
+      if (e->expr_type == EXPR_CONSTANT)
+	{
+	  gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
+		     "object", sym->name, &e->where);
+	  continue;
+	}
+
+      if (e->ts.type == BT_DERIVED
+	  && !resolve_equivalence_derived (e->ts.u.derived, sym, e))
+	continue;
+
+      /* Check that the types correspond correctly:
+	 Note 5.28:
+	 A numeric sequence structure may be equivalenced to another sequence
+	 structure, an object of default integer type, default real type, double
+	 precision real type, default logical type such that components of the
+	 structure ultimately only become associated to objects of the same
+	 kind. A character sequence structure may be equivalenced to an object
+	 of default character kind or another character sequence structure.
+	 Other objects may be equivalenced only to objects of the same type and
+	 kind parameters.  */
+
+      /* Identical types are unconditionally OK.  */
+      if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
+	goto identical_types;
+
+      last_eq_type = sequence_type (*last_ts);
+      eq_type = sequence_type (sym->ts);
+
+      /* Since the pair of objects is not of the same type, mixed or
+	 non-default sequences can be rejected.  */
+
+      msg = "Sequence %s with mixed components in EQUIVALENCE "
+	    "statement at %L with different type objects";
+      if ((object ==2
+	   && last_eq_type == SEQ_MIXED
+	   && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where))
+	  || (eq_type == SEQ_MIXED
+	      && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)))
+	continue;
+
+      msg = "Non-default type object or sequence %s in EQUIVALENCE "
+	    "statement at %L with objects of different type";
+      if ((object ==2
+	   && last_eq_type == SEQ_NONDEFAULT
+	   && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where))
+	  || (eq_type == SEQ_NONDEFAULT
+	      && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)))
+	continue;
+
+      msg ="Non-CHARACTER object '%s' in default CHARACTER "
+	   "EQUIVALENCE statement at %L";
+      if (last_eq_type == SEQ_CHARACTER
+	  && eq_type != SEQ_CHARACTER
+	  && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))
+		continue;
+
+      msg ="Non-NUMERIC object '%s' in default NUMERIC "
+	   "EQUIVALENCE statement at %L";
+      if (last_eq_type == SEQ_NUMERIC
+	  && eq_type != SEQ_NUMERIC
+	  && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))
+		continue;
+
+  identical_types:
+      last_ts =&sym->ts;
+      last_where = &e->where;
+
+      if (!e->ref)
+	continue;
+
+      /* Shall not be an automatic array.  */
+      if (e->ref->type == REF_ARRAY
+	  && !gfc_resolve_array_spec (e->ref->u.ar.as, 1))
+	{
+	  gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
+		     "an EQUIVALENCE object", sym->name, &e->where);
+	  continue;
+	}
+
+      r = e->ref;
+      while (r)
+	{
+	  /* Shall not be a structure component.  */
+	  if (r->type == REF_COMPONENT)
+	    {
+	      gfc_error ("Structure component '%s' at %L cannot be an "
+			 "EQUIVALENCE object",
+			 r->u.c.component->name, &e->where);
+	      break;
+	    }
+
+	  /* A substring shall not have length zero.  */
+	  if (r->type == REF_SUBSTRING)
+	    {
+	      if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
+		{
+		  gfc_error ("Substring at %L has length zero",
+			     &r->u.ss.start->where);
+		  break;
+		}
+	    }
+	  r = r->next;
+	}
+    }
+}
+
+
+/* Resolve function and ENTRY types, issue diagnostics if needed.  */
+
+static void
+resolve_fntype (gfc_namespace *ns)
+{
+  gfc_entry_list *el;
+  gfc_symbol *sym;
+
+  if (ns->proc_name == NULL || !ns->proc_name->attr.function)
+    return;
+
+  /* If there are any entries, ns->proc_name is the entry master
+     synthetic symbol and ns->entries->sym actual FUNCTION symbol.  */
+  if (ns->entries)
+    sym = ns->entries->sym;
+  else
+    sym = ns->proc_name;
+  if (sym->result == sym
+      && sym->ts.type == BT_UNKNOWN
+      && !gfc_set_default_type (sym, 0, NULL)
+      && !sym->attr.untyped)
+    {
+      gfc_error ("Function '%s' at %L has no IMPLICIT type",
+		 sym->name, &sym->declared_at);
+      sym->attr.untyped = 1;
+    }
+
+  if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
+      && !sym->attr.contained
+      && !gfc_check_symbol_access (sym->ts.u.derived)
+      && gfc_check_symbol_access (sym))
+    {
+      gfc_notify_std (GFC_STD_F2003, "PUBLIC function '%s' at "
+		      "%L of PRIVATE type '%s'", sym->name,
+		      &sym->declared_at, sym->ts.u.derived->name);
+    }
+
+    if (ns->entries)
+    for (el = ns->entries->next; el; el = el->next)
+      {
+	if (el->sym->result == el->sym
+	    && el->sym->ts.type == BT_UNKNOWN
+	    && !gfc_set_default_type (el->sym, 0, NULL)
+	    && !el->sym->attr.untyped)
+	  {
+	    gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
+		       el->sym->name, &el->sym->declared_at);
+	    el->sym->attr.untyped = 1;
+	  }
+      }
+}
+
+
+/* 12.3.2.1.1 Defined operators.  */
+
+static bool
+check_uop_procedure (gfc_symbol *sym, locus where)
+{
+  gfc_formal_arglist *formal;
+
+  if (!sym->attr.function)
+    {
+      gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
+		 sym->name, &where);
+      return false;
+    }
+
+  if (sym->ts.type == BT_CHARACTER
+      && !(sym->ts.u.cl && sym->ts.u.cl->length)
+      && !(sym->result && sym->result->ts.u.cl
+	   && sym->result->ts.u.cl->length))
+    {
+      gfc_error ("User operator procedure '%s' at %L cannot be assumed "
+		 "character length", sym->name, &where);
+      return false;
+    }
+
+  formal = gfc_sym_get_dummy_args (sym);
+  if (!formal || !formal->sym)
+    {
+      gfc_error ("User operator procedure '%s' at %L must have at least "
+		 "one argument", sym->name, &where);
+      return false;
+    }
+
+  if (formal->sym->attr.intent != INTENT_IN)
+    {
+      gfc_error ("First argument of operator interface at %L must be "
+		 "INTENT(IN)", &where);
+      return false;
+    }
+
+  if (formal->sym->attr.optional)
+    {
+      gfc_error ("First argument of operator interface at %L cannot be "
+		 "optional", &where);
+      return false;
+    }
+
+  formal = formal->next;
+  if (!formal || !formal->sym)
+    return true;
+
+  if (formal->sym->attr.intent != INTENT_IN)
+    {
+      gfc_error ("Second argument of operator interface at %L must be "
+		 "INTENT(IN)", &where);
+      return false;
+    }
+
+  if (formal->sym->attr.optional)
+    {
+      gfc_error ("Second argument of operator interface at %L cannot be "
+		 "optional", &where);
+      return false;
+    }
+
+  if (formal->next)
+    {
+      gfc_error ("Operator interface at %L must have, at most, two "
+		 "arguments", &where);
+      return false;
+    }
+
+  return true;
+}
+
+static void
+gfc_resolve_uops (gfc_symtree *symtree)
+{
+  gfc_interface *itr;
+
+  if (symtree == NULL)
+    return;
+
+  gfc_resolve_uops (symtree->left);
+  gfc_resolve_uops (symtree->right);
+
+  for (itr = symtree->n.uop->op; itr; itr = itr->next)
+    check_uop_procedure (itr->sym, itr->sym->declared_at);
+}
+
+
+/* Examine all of the expressions associated with a program unit,
+   assign types to all intermediate expressions, make sure that all
+   assignments are to compatible types and figure out which names
+   refer to which functions or subroutines.  It doesn't check code
+   block, which is handled by resolve_code.  */
+
+static void
+resolve_types (gfc_namespace *ns)
+{
+  gfc_namespace *n;
+  gfc_charlen *cl;
+  gfc_data *d;
+  gfc_equiv *eq;
+  gfc_namespace* old_ns = gfc_current_ns;
+
+  /* Check that all IMPLICIT types are ok.  */
+  if (!ns->seen_implicit_none)
+    {
+      unsigned letter;
+      for (letter = 0; letter != GFC_LETTERS; ++letter)
+	if (ns->set_flag[letter]
+	    && !resolve_typespec_used (&ns->default_type[letter], 
+				       &ns->implicit_loc[letter], NULL))
+	  return;
+    }
+
+  gfc_current_ns = ns;
+
+  resolve_entries (ns);
+
+  resolve_common_vars (ns->blank_common.head, false);
+  resolve_common_blocks (ns->common_root);
+
+  resolve_contained_functions (ns);
+
+  if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE
+      && ns->proc_name->attr.if_source == IFSRC_IFBODY)
+    resolve_formal_arglist (ns->proc_name);
+
+  gfc_traverse_ns (ns, resolve_bind_c_derived_types);
+
+  for (cl = ns->cl_list; cl; cl = cl->next)
+    resolve_charlen (cl);
+
+  gfc_traverse_ns (ns, resolve_symbol);
+
+  resolve_fntype (ns);
+
+  for (n = ns->contained; n; n = n->sibling)
+    {
+      if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
+	gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
+		   "also be PURE", n->proc_name->name,
+		   &n->proc_name->declared_at);
+
+      resolve_types (n);
+    }
+
+  forall_flag = 0;
+  gfc_do_concurrent_flag = 0;
+  gfc_check_interfaces (ns);
+
+  gfc_traverse_ns (ns, resolve_values);
+
+  if (ns->save_all)
+    gfc_save_all (ns);
+
+  iter_stack = NULL;
+  for (d = ns->data; d; d = d->next)
+    resolve_data (d);
+
+  iter_stack = NULL;
+  gfc_traverse_ns (ns, gfc_formalize_init_value);
+
+  gfc_traverse_ns (ns, gfc_verify_binding_labels);
+
+  for (eq = ns->equiv; eq; eq = eq->next)
+    resolve_equivalence (eq);
+
+  /* Warn about unused labels.  */
+  if (warn_unused_label)
+    warn_unused_fortran_label (ns->st_labels);
+
+  gfc_resolve_uops (ns->uop_root);
+
+  gfc_current_ns = old_ns;
+}
+
+
+/* Call resolve_code recursively.  */
+
+static void
+resolve_codes (gfc_namespace *ns)
+{
+  gfc_namespace *n;
+  bitmap_obstack old_obstack;
+
+  if (ns->resolved == 1)
+    return;
+
+  for (n = ns->contained; n; n = n->sibling)
+    resolve_codes (n);
+
+  gfc_current_ns = ns;
+
+  /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct.  */
+  if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
+    cs_base = NULL;
+
+  /* Set to an out of range value.  */
+  current_entry_id = -1;
+
+  old_obstack = labels_obstack;
+  bitmap_obstack_initialize (&labels_obstack);
+
+  resolve_code (ns->code, ns);
+
+  bitmap_obstack_release (&labels_obstack);
+  labels_obstack = old_obstack;
+}
+
+
+/* This function is called after a complete program unit has been compiled.
+   Its purpose is to examine all of the expressions associated with a program
+   unit, assign types to all intermediate expressions, make sure that all
+   assignments are to compatible types and figure out which names refer to
+   which functions or subroutines.  */
+
+void
+gfc_resolve (gfc_namespace *ns)
+{
+  gfc_namespace *old_ns;
+  code_stack *old_cs_base;
+
+  if (ns->resolved)
+    return;
+
+  ns->resolved = -1;
+  old_ns = gfc_current_ns;
+  old_cs_base = cs_base;
+
+  resolve_types (ns);
+  component_assignment_level = 0;
+  resolve_codes (ns);
+
+  gfc_current_ns = old_ns;
+  cs_base = old_cs_base;
+  ns->resolved = 1;
+
+  gfc_run_passes (ns);
+}
diff --git a/gcc-4.9/gcc/fortran/scanner.c b/gcc-4.9/gcc/fortran/scanner.c
new file mode 100644
index 000000000..8f5173421
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/scanner.c
@@ -0,0 +1,2219 @@
+/* Character scanner.
+   Copyright (C) 2000-2014 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+/* Set of subroutines to (ultimately) return the next character to the
+   various matching subroutines.  This file's job is to read files and
+   build up lines that are parsed by the parser.  This means that we
+   handle continuation lines and "include" lines.
+
+   The first thing the scanner does is to load an entire file into
+   memory.  We load the entire file into memory for a couple reasons.
+   The first is that we want to be able to deal with nonseekable input
+   (pipes, stdin) and there is a lot of backing up involved during
+   parsing.
+
+   The second is that we want to be able to print the locus of errors,
+   and an error on line 999999 could conflict with something on line
+   one.  Given nonseekable input, we've got to store the whole thing.
+
+   One thing that helps are the column truncation limits that give us
+   an upper bound on the size of individual lines.  We don't store the
+   truncated stuff.
+
+   From the scanner's viewpoint, the higher level subroutines ask for
+   new characters and do a lot of jumping backwards.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "gfortran.h"
+#include "toplev.h"	/* For set_src_pwd.  */
+#include "debug.h"
+#include "flags.h"
+#include "cpp.h"
+#include "scanner.h"
+
+/* List of include file search directories.  */
+gfc_directorylist *include_dirs, *intrinsic_modules_dirs;
+
+static gfc_file *file_head, *current_file;
+
+static int continue_flag, end_flag, openmp_flag, gcc_attribute_flag;
+static int continue_count, continue_line;
+static locus openmp_locus;
+static locus gcc_attribute_locus;
+
+gfc_source_form gfc_current_form;
+static gfc_linebuf *line_head, *line_tail;
+       
+locus gfc_current_locus;
+const char *gfc_source_file;
+static FILE *gfc_src_file;
+static gfc_char_t *gfc_src_preprocessor_lines[2];
+
+static struct gfc_file_change
+{
+  const char *filename;
+  gfc_linebuf *lb;
+  int line;
+} *file_changes;
+size_t file_changes_cur, file_changes_count;
+size_t file_changes_allocated;
+
+
+/* Functions dealing with our wide characters (gfc_char_t) and
+   sequences of such characters.  */
+
+int
+gfc_wide_fits_in_byte (gfc_char_t c)
+{
+  return (c <= UCHAR_MAX);
+}
+
+static inline int
+wide_is_ascii (gfc_char_t c)
+{
+  return (gfc_wide_fits_in_byte (c) && ((unsigned char) c & ~0x7f) == 0);
+}
+
+int
+gfc_wide_is_printable (gfc_char_t c)
+{
+  return (gfc_wide_fits_in_byte (c) && ISPRINT ((unsigned char) c));
+}
+
+gfc_char_t
+gfc_wide_tolower (gfc_char_t c)
+{
+  return (wide_is_ascii (c) ? (gfc_char_t) TOLOWER((unsigned char) c) : c);
+}
+
+gfc_char_t
+gfc_wide_toupper (gfc_char_t c)
+{
+  return (wide_is_ascii (c) ? (gfc_char_t) TOUPPER((unsigned char) c) : c);
+}
+
+int
+gfc_wide_is_digit (gfc_char_t c)
+{
+  return (c >= '0' && c <= '9');
+}
+
+static inline int
+wide_atoi (gfc_char_t *c)
+{
+#define MAX_DIGITS 20
+  char buf[MAX_DIGITS+1];
+  int i = 0;
+
+  while (gfc_wide_is_digit(*c) && i < MAX_DIGITS)
+    buf[i++] = *c++;
+  buf[i] = '\0';
+  return atoi (buf);
+}
+
+size_t
+gfc_wide_strlen (const gfc_char_t *str)
+{
+  size_t i;
+
+  for (i = 0; str[i]; i++)
+    ;
+
+  return i;
+}
+
+gfc_char_t *
+gfc_wide_memset (gfc_char_t *b, gfc_char_t c, size_t len)
+{
+  size_t i;
+
+  for (i = 0; i < len; i++)
+    b[i] = c;
+
+  return b;
+}
+
+static gfc_char_t *
+wide_strcpy (gfc_char_t *dest, const gfc_char_t *src)
+{
+  gfc_char_t *d;
+
+  for (d = dest; (*d = *src) != '\0'; ++src, ++d)
+    ;
+
+  return dest;
+}
+
+static gfc_char_t *
+wide_strchr (const gfc_char_t *s, gfc_char_t c)
+{
+  do {
+    if (*s == c)
+      {
+        return CONST_CAST(gfc_char_t *, s);
+      }
+  } while (*s++);
+  return 0;
+}
+
+char *
+gfc_widechar_to_char (const gfc_char_t *s, int length)
+{
+  size_t len, i;
+  char *res;
+
+  if (s == NULL)
+    return NULL;
+
+  /* Passing a negative length is used to indicate that length should be
+     calculated using gfc_wide_strlen().  */
+  len = (length >= 0 ? (size_t) length : gfc_wide_strlen (s));
+  res = XNEWVEC (char, len + 1);
+
+  for (i = 0; i < len; i++)
+    {
+      gcc_assert (gfc_wide_fits_in_byte (s[i]));
+      res[i] = (unsigned char) s[i];
+    }
+
+  res[len] = '\0';
+  return res;
+}
+
+gfc_char_t *
+gfc_char_to_widechar (const char *s)
+{
+  size_t len, i;
+  gfc_char_t *res;
+
+  if (s == NULL)
+    return NULL;
+
+  len = strlen (s);
+  res = gfc_get_wide_string (len + 1);
+
+  for (i = 0; i < len; i++)
+    res[i] = (unsigned char) s[i];
+
+  res[len] = '\0';
+  return res;
+}
+
+static int
+wide_strncmp (const gfc_char_t *s1, const char *s2, size_t n)
+{
+  gfc_char_t c1, c2;
+
+  while (n-- > 0)
+    {
+      c1 = *s1++;
+      c2 = *s2++;
+      if (c1 != c2)
+	return (c1 > c2 ? 1 : -1);
+      if (c1 == '\0')
+	return 0;
+    }
+  return 0;
+}
+
+int
+gfc_wide_strncasecmp (const gfc_char_t *s1, const char *s2, size_t n)
+{
+  gfc_char_t c1, c2;
+
+  while (n-- > 0)
+    {
+      c1 = gfc_wide_tolower (*s1++);
+      c2 = TOLOWER (*s2++);
+      if (c1 != c2)
+	return (c1 > c2 ? 1 : -1);
+      if (c1 == '\0')
+	return 0;
+    }
+  return 0;
+}
+
+
+/* Main scanner initialization.  */
+
+void
+gfc_scanner_init_1 (void)
+{
+  file_head = NULL;
+  line_head = NULL;
+  line_tail = NULL;
+
+  continue_count = 0;
+  continue_line = 0;
+
+  end_flag = 0;
+}
+
+
+/* Main scanner destructor.  */
+
+void
+gfc_scanner_done_1 (void)
+{
+  gfc_linebuf *lb;
+  gfc_file *f;
+
+  while(line_head != NULL) 
+    {
+      lb = line_head->next;
+      free (line_head);
+      line_head = lb;
+    }
+     
+  while(file_head != NULL) 
+    {
+      f = file_head->next;
+      free (file_head->filename);
+      free (file_head);
+      file_head = f;    
+    }
+}
+
+
+/* Adds path to the list pointed to by list.  */
+
+static void
+add_path_to_list (gfc_directorylist **list, const char *path,
+		  bool use_for_modules, bool head, bool warn)
+{
+  gfc_directorylist *dir;
+  const char *p;
+  char *q;
+  struct stat st;
+  size_t len;
+  int i;
+  
+  p = path;
+  while (*p == ' ' || *p == '\t')  /* someone might do "-I include" */
+    if (*p++ == '\0')
+      return;
+
+  /* Strip trailing directory separators from the path, as this
+     will confuse Windows systems.  */
+  len = strlen (p);
+  q = (char *) alloca (len + 1);
+  memcpy (q, p, len + 1);
+  i = len - 1;
+  while (i >=0 && IS_DIR_SEPARATOR (q[i]))
+    q[i--] = '\0';
+
+  if (stat (q, &st))
+    {
+      if (errno != ENOENT)
+	gfc_warning_now ("Include directory \"%s\": %s", path,
+			 xstrerror(errno));
+      else
+	{
+	  /* FIXME:  Also support -Wmissing-include-dirs.  */
+	  if (warn)
+	    gfc_warning_now ("Nonexistent include directory \"%s\"", path);
+	}
+      return;
+    }
+  else if (!S_ISDIR (st.st_mode))
+    {
+      gfc_warning_now ("\"%s\" is not a directory", path);
+      return;
+    }
+
+  if (head || *list == NULL)
+    {
+      dir = XCNEW (gfc_directorylist);
+      if (!head)
+        *list = dir;
+    }
+  else
+    {
+      dir = *list;
+      while (dir->next)
+	dir = dir->next;
+
+      dir->next = XCNEW (gfc_directorylist);
+      dir = dir->next;
+    }
+
+  dir->next = head ? *list : NULL;
+  if (head)
+    *list = dir;
+  dir->use_for_modules = use_for_modules;
+  dir->path = XCNEWVEC (char, strlen (p) + 2);
+  strcpy (dir->path, p);
+  strcat (dir->path, "/");	/* make '/' last character */
+}
+
+
+void
+gfc_add_include_path (const char *path, bool use_for_modules, bool file_dir,
+		      bool warn)
+{
+  add_path_to_list (&include_dirs, path, use_for_modules, file_dir, warn);
+
+  /* For '#include "..."' these directories are automatically searched.  */
+  if (!file_dir)
+    gfc_cpp_add_include_path (xstrdup(path), true);
+}
+
+
+void
+gfc_add_intrinsic_modules_path (const char *path)
+{
+  add_path_to_list (&intrinsic_modules_dirs, path, true, false, false);
+}
+
+
+/* Release resources allocated for options.  */
+
+void
+gfc_release_include_path (void)
+{
+  gfc_directorylist *p;
+
+  while (include_dirs != NULL)
+    {
+      p = include_dirs;
+      include_dirs = include_dirs->next;
+      free (p->path);
+      free (p);
+    }
+
+  while (intrinsic_modules_dirs != NULL)
+    {
+      p = intrinsic_modules_dirs;
+      intrinsic_modules_dirs = intrinsic_modules_dirs->next;
+      free (p->path);
+      free (p);
+    }
+
+  free (gfc_option.module_dir);
+}
+
+
+static FILE *
+open_included_file (const char *name, gfc_directorylist *list,
+		    bool module, bool system)
+{
+  char *fullname;
+  gfc_directorylist *p;
+  FILE *f;
+
+  for (p = list; p; p = p->next)
+    {
+      if (module && !p->use_for_modules)
+	continue;
+
+      fullname = (char *) alloca(strlen (p->path) + strlen (name) + 1);
+      strcpy (fullname, p->path);
+      strcat (fullname, name);
+
+      f = gfc_open_file (fullname);
+      if (f != NULL)
+	{
+	  if (gfc_cpp_makedep ())
+	    gfc_cpp_add_dep (fullname, system);
+
+	  return f;
+	}
+    }
+
+  return NULL;
+}
+
+
+/* Opens file for reading, searching through the include directories
+   given if necessary.  If the include_cwd argument is true, we try
+   to open the file in the current directory first.  */
+
+FILE *
+gfc_open_included_file (const char *name, bool include_cwd, bool module)
+{
+  FILE *f = NULL;
+
+  if (IS_ABSOLUTE_PATH (name) || include_cwd)
+    {
+      f = gfc_open_file (name);
+      if (f && gfc_cpp_makedep ())
+	gfc_cpp_add_dep (name, false);
+    }
+
+  if (!f)
+    f = open_included_file (name, include_dirs, module, false);
+
+  return f;
+}
+
+
+/* Test to see if we're at the end of the main source file.  */
+
+int
+gfc_at_end (void)
+{
+  return end_flag;
+}
+
+
+/* Test to see if we're at the end of the current file.  */
+
+int
+gfc_at_eof (void)
+{
+  if (gfc_at_end ())
+    return 1;
+
+  if (line_head == NULL)
+    return 1;			/* Null file */
+
+  if (gfc_current_locus.lb == NULL)
+    return 1;
+
+  return 0;
+}
+
+
+/* Test to see if we're at the beginning of a new line.  */
+
+int
+gfc_at_bol (void)
+{
+  if (gfc_at_eof ())
+    return 1;
+
+  return (gfc_current_locus.nextc == gfc_current_locus.lb->line);
+}
+
+
+/* Test to see if we're at the end of a line.  */
+
+int
+gfc_at_eol (void)
+{
+  if (gfc_at_eof ())
+    return 1;
+
+  return (*gfc_current_locus.nextc == '\0');
+}
+
+static void
+add_file_change (const char *filename, int line)
+{
+  if (file_changes_count == file_changes_allocated)
+    {
+      if (file_changes_allocated)
+	file_changes_allocated *= 2;
+      else
+	file_changes_allocated = 16;
+      file_changes = XRESIZEVEC (struct gfc_file_change, file_changes,
+				 file_changes_allocated);
+    }
+  file_changes[file_changes_count].filename = filename;
+  file_changes[file_changes_count].lb = NULL;
+  file_changes[file_changes_count++].line = line;
+}
+
+static void
+report_file_change (gfc_linebuf *lb)
+{
+  size_t c = file_changes_cur;
+  while (c < file_changes_count
+	 && file_changes[c].lb == lb)
+    {
+      if (file_changes[c].filename)
+	(*debug_hooks->start_source_file) (file_changes[c].line,
+					   file_changes[c].filename);
+      else
+	(*debug_hooks->end_source_file) (file_changes[c].line);
+      ++c;
+    }
+  file_changes_cur = c;
+}
+
+void
+gfc_start_source_files (void)
+{
+  /* If the debugger wants the name of the main source file,
+     we give it.  */
+  if (debug_hooks->start_end_main_source_file)
+    (*debug_hooks->start_source_file) (0, gfc_source_file);
+
+  file_changes_cur = 0;
+  report_file_change (gfc_current_locus.lb);
+}
+
+void
+gfc_end_source_files (void)
+{
+  report_file_change (NULL);
+
+  if (debug_hooks->start_end_main_source_file)
+    (*debug_hooks->end_source_file) (0);
+}
+
+/* Advance the current line pointer to the next line.  */
+
+void
+gfc_advance_line (void)
+{
+  if (gfc_at_end ())
+    return;
+
+  if (gfc_current_locus.lb == NULL) 
+    {
+      end_flag = 1;
+      return;
+    } 
+
+  if (gfc_current_locus.lb->next
+      && !gfc_current_locus.lb->next->dbg_emitted)
+    {
+      report_file_change (gfc_current_locus.lb->next);
+      gfc_current_locus.lb->next->dbg_emitted = true;
+    }
+
+  gfc_current_locus.lb = gfc_current_locus.lb->next;
+
+  if (gfc_current_locus.lb != NULL)	 
+    gfc_current_locus.nextc = gfc_current_locus.lb->line;
+  else 
+    {
+      gfc_current_locus.nextc = NULL;
+      end_flag = 1;
+    }       
+}
+
+
+/* Get the next character from the input, advancing gfc_current_file's
+   locus.  When we hit the end of the line or the end of the file, we
+   start returning a '\n' in order to complete the current statement.
+   No Fortran line conventions are implemented here.
+
+   Requiring explicit advances to the next line prevents the parse
+   pointer from being on the wrong line if the current statement ends
+   prematurely.  */
+
+static gfc_char_t
+next_char (void)
+{
+  gfc_char_t c;
+  
+  if (gfc_current_locus.nextc == NULL)
+    return '\n';
+
+  c = *gfc_current_locus.nextc++;
+  if (c == '\0')
+    {
+      gfc_current_locus.nextc--; /* Remain on this line.  */
+      c = '\n';
+    }
+
+  return c;
+}
+
+
+/* Skip a comment.  When we come here the parse pointer is positioned
+   immediately after the comment character.  If we ever implement
+   compiler directives within comments, here is where we parse the
+   directive.  */
+
+static void
+skip_comment_line (void)
+{
+  gfc_char_t c;
+
+  do
+    {
+      c = next_char ();
+    }
+  while (c != '\n');
+
+  gfc_advance_line ();
+}
+
+
+int
+gfc_define_undef_line (void)
+{
+  char *tmp;
+
+  /* All lines beginning with '#' are either #define or #undef.  */
+  if (debug_info_level != DINFO_LEVEL_VERBOSE || gfc_peek_ascii_char () != '#')
+    return 0;
+
+  if (wide_strncmp (gfc_current_locus.nextc, "#define ", 8) == 0)
+    {
+      tmp = gfc_widechar_to_char (&gfc_current_locus.nextc[8], -1);
+      (*debug_hooks->define) (gfc_linebuf_linenum (gfc_current_locus.lb),
+			      tmp);
+      free (tmp);
+    }
+
+  if (wide_strncmp (gfc_current_locus.nextc, "#undef ", 7) == 0)
+    {
+      tmp = gfc_widechar_to_char (&gfc_current_locus.nextc[7], -1);
+      (*debug_hooks->undef) (gfc_linebuf_linenum (gfc_current_locus.lb),
+			     tmp);
+      free (tmp);
+    }
+
+  /* Skip the rest of the line.  */
+  skip_comment_line ();
+
+  return 1;
+}
+
+
+/* Return true if GCC$ was matched.  */
+static bool
+skip_gcc_attribute (locus start)
+{
+  bool r = false;
+  char c;
+  locus old_loc = gfc_current_locus;
+
+  if ((c = next_char ()) == 'g' || c == 'G')
+    if ((c = next_char ()) == 'c' || c == 'C')
+      if ((c = next_char ()) == 'c' || c == 'C')
+	if ((c = next_char ()) == '$')
+	  r = true;
+
+  if (r == false)
+    gfc_current_locus = old_loc;
+  else
+   {
+      gcc_attribute_flag = 1;
+      gcc_attribute_locus = old_loc;
+      gfc_current_locus = start;
+   }
+
+  return r;
+}
+
+
+
+/* Comment lines are null lines, lines containing only blanks or lines
+   on which the first nonblank line is a '!'.
+   Return true if !$ openmp conditional compilation sentinel was
+   seen.  */
+
+static bool
+skip_free_comments (void)
+{
+  locus start;
+  gfc_char_t c;
+  int at_bol;
+
+  for (;;)
+    {
+      at_bol = gfc_at_bol ();
+      start = gfc_current_locus;
+      if (gfc_at_eof ())
+	break;
+
+      do
+	c = next_char ();
+      while (gfc_is_whitespace (c));
+
+      if (c == '\n')
+	{
+	  gfc_advance_line ();
+	  continue;
+	}
+
+      if (c == '!')
+	{
+	  /* Keep the !GCC$ line.  */
+		  if (at_bol && skip_gcc_attribute (start))
+	    return false;
+
+	  /* If -fopenmp, we need to handle here 2 things:
+	     1) don't treat !$omp as comments, but directives
+	     2) handle OpenMP conditional compilation, where
+		!$ should be treated as 2 spaces (for initial lines
+		only if followed by space).  */
+	  if (gfc_option.gfc_flag_openmp && at_bol)
+	    {
+	      locus old_loc = gfc_current_locus;
+	      if (next_char () == '$')
+		{
+		  c = next_char ();
+		  if (c == 'o' || c == 'O')
+		    {
+		      if (((c = next_char ()) == 'm' || c == 'M')
+			  && ((c = next_char ()) == 'p' || c == 'P'))
+			{
+			  if ((c = next_char ()) == ' ' || c == '\t'
+			      || continue_flag)
+			    {
+			      while (gfc_is_whitespace (c))
+				c = next_char ();
+			      if (c != '\n' && c != '!')
+				{
+				  openmp_flag = 1;
+				  openmp_locus = old_loc;
+				  gfc_current_locus = start;
+				  return false;
+				}
+			    }
+			  else
+			    gfc_warning_now ("!$OMP at %C starts a commented "
+					     "line as it neither is followed "
+					     "by a space nor is a "
+					     "continuation line");
+			}
+		      gfc_current_locus = old_loc;
+		      next_char ();
+		      c = next_char ();
+		    }
+		  if (continue_flag || c == ' ' || c == '\t')
+		    {
+		      gfc_current_locus = old_loc;
+		      next_char ();
+		      openmp_flag = 0;
+		      return true;
+		    }
+		}
+	      gfc_current_locus = old_loc;
+	    }
+	  skip_comment_line ();
+	  continue;
+	}
+
+      break;
+    }
+
+  if (openmp_flag && at_bol)
+    openmp_flag = 0;
+
+  gcc_attribute_flag = 0;
+  gfc_current_locus = start;
+  return false;
+}
+
+
+/* Skip comment lines in fixed source mode.  We have the same rules as
+   in skip_free_comment(), except that we can have a 'c', 'C' or '*'
+   in column 1, and a '!' cannot be in column 6.  Also, we deal with
+   lines with 'd' or 'D' in column 1, if the user requested this.  */
+
+static void
+skip_fixed_comments (void)
+{
+  locus start;
+  int col;
+  gfc_char_t c;
+
+  if (! gfc_at_bol ())
+    {
+      start = gfc_current_locus;
+      if (! gfc_at_eof ())
+	{
+	  do
+	    c = next_char ();
+	  while (gfc_is_whitespace (c));
+
+	  if (c == '\n')
+	    gfc_advance_line ();
+	  else if (c == '!')
+	    skip_comment_line ();
+	}
+
+      if (! gfc_at_bol ())
+	{
+	  gfc_current_locus = start;
+	  return;
+	}
+    }
+
+  for (;;)
+    {
+      start = gfc_current_locus;
+      if (gfc_at_eof ())
+	break;
+
+      c = next_char ();
+      if (c == '\n')
+	{
+	  gfc_advance_line ();
+	  continue;
+	}
+
+      if (c == '!' || c == 'c' || c == 'C' || c == '*')
+	{
+	  if (skip_gcc_attribute (start))
+	    {
+	      /* Canonicalize to *$omp.  */
+	      *start.nextc = '*';
+	      return;
+	    }
+
+	  /* If -fopenmp, we need to handle here 2 things:
+	     1) don't treat !$omp|c$omp|*$omp as comments, but directives
+	     2) handle OpenMP conditional compilation, where
+		!$|c$|*$ should be treated as 2 spaces if the characters
+		in columns 3 to 6 are valid fixed form label columns
+		characters.  */
+	  if (gfc_current_locus.lb != NULL
+	      && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
+	    continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
+
+	  if (gfc_option.gfc_flag_openmp)
+	    {
+	      if (next_char () == '$')
+		{
+		  c = next_char ();
+		  if (c == 'o' || c == 'O')
+		    {
+		      if (((c = next_char ()) == 'm' || c == 'M')
+			  && ((c = next_char ()) == 'p' || c == 'P'))
+			{
+			  c = next_char ();
+			  if (c != '\n'
+			      && ((openmp_flag && continue_flag)
+				  || c == ' ' || c == '\t' || c == '0'))
+			    {
+			      do
+				c = next_char ();
+			      while (gfc_is_whitespace (c));
+			      if (c != '\n' && c != '!')
+				{
+				  /* Canonicalize to *$omp.  */
+				  *start.nextc = '*';
+				  openmp_flag = 1;
+				  gfc_current_locus = start;
+				  return;
+				}
+			    }
+			}
+		    }
+		  else
+		    {
+		      int digit_seen = 0;
+
+		      for (col = 3; col < 6; col++, c = next_char ())
+			if (c == ' ')
+			  continue;
+			else if (c == '\t')
+			  {
+			    col = 6;
+			    break;
+			  }
+			else if (c < '0' || c > '9')
+			  break;
+			else
+			  digit_seen = 1;
+
+		      if (col == 6 && c != '\n'
+			  && ((continue_flag && !digit_seen)
+			      || c == ' ' || c == '\t' || c == '0'))
+			{
+			  gfc_current_locus = start;
+			  start.nextc[0] = ' ';
+			  start.nextc[1] = ' ';
+			  continue;
+			}
+		    }
+		}
+	      gfc_current_locus = start;
+	    }
+	  skip_comment_line ();
+	  continue;
+	}
+
+      if (gfc_option.flag_d_lines != -1 && (c == 'd' || c == 'D'))
+	{
+	  if (gfc_option.flag_d_lines == 0)
+	    {
+	      skip_comment_line ();
+	      continue;
+	    }
+	  else
+	    *start.nextc = c = ' ';
+	}
+
+      col = 1;
+
+      while (gfc_is_whitespace (c))
+	{
+	  c = next_char ();
+	  col++;
+	}
+
+      if (c == '\n')
+	{
+	  gfc_advance_line ();
+	  continue;
+	}
+
+      if (col != 6 && c == '!')
+	{
+	  if (gfc_current_locus.lb != NULL
+	      && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
+	    continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
+	  skip_comment_line ();
+	  continue;
+	}
+
+      break;
+    }
+
+  openmp_flag = 0;
+  gcc_attribute_flag = 0;
+  gfc_current_locus = start;
+}
+
+
+/* Skips the current line if it is a comment.  */
+
+void
+gfc_skip_comments (void)
+{
+  if (gfc_current_form == FORM_FREE)
+    skip_free_comments ();
+  else
+    skip_fixed_comments ();
+}
+
+
+/* Get the next character from the input, taking continuation lines
+   and end-of-line comments into account.  This implies that comment
+   lines between continued lines must be eaten here.  For higher-level
+   subroutines, this flattens continued lines into a single logical
+   line.  The in_string flag denotes whether we're inside a character
+   context or not.  */
+
+gfc_char_t
+gfc_next_char_literal (gfc_instring in_string)
+{
+  locus old_loc;
+  int i, prev_openmp_flag;
+  gfc_char_t c;
+
+  continue_flag = 0;
+
+restart:
+  c = next_char ();
+  if (gfc_at_end ())
+    {
+      continue_count = 0;
+      return c;
+    }
+
+  if (gfc_current_form == FORM_FREE)
+    {
+      bool openmp_cond_flag;
+
+      if (!in_string && c == '!')
+	{
+	  if (gcc_attribute_flag
+	      && memcmp (&gfc_current_locus, &gcc_attribute_locus,
+		 sizeof (gfc_current_locus)) == 0)
+	    goto done;
+
+	  if (openmp_flag
+	      && memcmp (&gfc_current_locus, &openmp_locus,
+		 sizeof (gfc_current_locus)) == 0)
+	    goto done;
+
+	  /* This line can't be continued */
+	  do
+	    {
+	      c = next_char ();
+	    }
+	  while (c != '\n');
+
+	  /* Avoid truncation warnings for comment ending lines.  */
+	  gfc_current_locus.lb->truncated = 0;
+
+	  goto done;
+	}
+
+      /* Check to see if the continuation line was truncated.  */
+      if (gfc_option.warn_line_truncation && gfc_current_locus.lb != NULL
+	  && gfc_current_locus.lb->truncated)
+	{
+	  int maxlen = gfc_option.free_line_length;
+	  gfc_char_t *current_nextc = gfc_current_locus.nextc;
+
+	  gfc_current_locus.lb->truncated = 0;
+	  gfc_current_locus.nextc =  gfc_current_locus.lb->line + maxlen;
+	  gfc_warning_now ("Line truncated at %L", &gfc_current_locus);
+	  gfc_current_locus.nextc = current_nextc;
+	}
+
+      if (c != '&')
+	goto done;
+
+      /* If the next nonblank character is a ! or \n, we've got a
+	 continuation line.  */
+      old_loc = gfc_current_locus;
+
+      c = next_char ();
+      while (gfc_is_whitespace (c))
+	c = next_char ();
+
+      /* Character constants to be continued cannot have commentary
+	 after the '&'.  */
+
+      if (in_string && c != '\n')
+	{
+	  gfc_current_locus = old_loc;
+	  c = '&';
+	  goto done;
+	}
+
+      if (c != '!' && c != '\n')
+	{
+	  gfc_current_locus = old_loc;
+	  c = '&';
+	  goto done;
+	}
+
+      prev_openmp_flag = openmp_flag;
+      continue_flag = 1;
+      if (c == '!')
+	skip_comment_line ();
+      else
+	gfc_advance_line ();
+      
+      if (gfc_at_eof ())
+	goto not_continuation;
+
+      /* We've got a continuation line.  If we are on the very next line after
+	 the last continuation, increment the continuation line count and
+	 check whether the limit has been exceeded.  */
+      if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1)
+	{
+	  if (++continue_count == gfc_option.max_continue_free)
+	    {
+	      if (gfc_notification_std (GFC_STD_GNU) || pedantic)
+		gfc_warning ("Limit of %d continuations exceeded in "
+			     "statement at %C", gfc_option.max_continue_free);
+	    }
+	}
+
+      /* Now find where it continues. First eat any comment lines.  */
+      openmp_cond_flag = skip_free_comments ();
+
+      if (gfc_current_locus.lb != NULL
+	  && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
+	continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
+
+      if (prev_openmp_flag != openmp_flag)
+	{
+	  gfc_current_locus = old_loc;
+	  openmp_flag = prev_openmp_flag;
+	  c = '&';
+	  goto done;
+	}
+
+      /* Now that we have a non-comment line, probe ahead for the
+	 first non-whitespace character.  If it is another '&', then
+	 reading starts at the next character, otherwise we must back
+	 up to where the whitespace started and resume from there.  */
+
+      old_loc = gfc_current_locus;
+
+      c = next_char ();
+      while (gfc_is_whitespace (c))
+	c = next_char ();
+
+      if (openmp_flag)
+	{
+	  for (i = 0; i < 5; i++, c = next_char ())
+	    {
+	      gcc_assert (gfc_wide_tolower (c) == (unsigned char) "!$omp"[i]);
+	      if (i == 4)
+		old_loc = gfc_current_locus;
+	    }
+	  while (gfc_is_whitespace (c))
+	    c = next_char ();
+	}
+
+      if (c != '&')
+	{
+	  if (in_string)
+	    {
+	      gfc_current_locus.nextc--;
+	      if (gfc_option.warn_ampersand && in_string == INSTRING_WARN)
+		gfc_warning ("Missing '&' in continued character "
+			     "constant at %C");
+	    }
+	  /* Both !$omp and !$ -fopenmp continuation lines have & on the
+	     continuation line only optionally.  */
+	  else if (openmp_flag || openmp_cond_flag)
+	    gfc_current_locus.nextc--;
+	  else
+	    {
+	      c = ' ';
+	      gfc_current_locus = old_loc;
+	      goto done;
+	    }
+	}
+    }
+  else /* Fixed form.  */
+    {
+      /* Fixed form continuation.  */
+      if (!in_string && c == '!')
+	{
+	  /* Skip comment at end of line.  */
+	  do
+	    {
+	      c = next_char ();
+	    }
+	  while (c != '\n');
+
+	  /* Avoid truncation warnings for comment ending lines.  */
+	  gfc_current_locus.lb->truncated = 0;
+	}
+
+      if (c != '\n')
+	goto done;
+
+      /* Check to see if the continuation line was truncated.  */
+      if (gfc_option.warn_line_truncation && gfc_current_locus.lb != NULL
+	  && gfc_current_locus.lb->truncated)
+	{
+	  gfc_current_locus.lb->truncated = 0;
+	  gfc_warning_now ("Line truncated at %L", &gfc_current_locus);
+	}
+
+      prev_openmp_flag = openmp_flag;
+      continue_flag = 1;
+      old_loc = gfc_current_locus;
+
+      gfc_advance_line ();
+      skip_fixed_comments ();
+
+      /* See if this line is a continuation line.  */
+      if (openmp_flag != prev_openmp_flag)
+	{
+	  openmp_flag = prev_openmp_flag;
+	  goto not_continuation;
+	}
+
+      if (!openmp_flag)
+	for (i = 0; i < 5; i++)
+	  {
+	    c = next_char ();
+	    if (c != ' ')
+	      goto not_continuation;
+	  }
+      else
+	for (i = 0; i < 5; i++)
+	  {
+	    c = next_char ();
+	    if (gfc_wide_tolower (c) != (unsigned char) "*$omp"[i])
+	      goto not_continuation;
+	  }
+
+      c = next_char ();
+      if (c == '0' || c == ' ' || c == '\n')
+	goto not_continuation;
+
+      /* We've got a continuation line.  If we are on the very next line after
+	 the last continuation, increment the continuation line count and
+	 check whether the limit has been exceeded.  */
+      if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1)
+	{
+	  if (++continue_count == gfc_option.max_continue_fixed)
+	    {
+	      if (gfc_notification_std (GFC_STD_GNU) || pedantic)
+		gfc_warning ("Limit of %d continuations exceeded in "
+			     "statement at %C",
+			     gfc_option.max_continue_fixed);
+	    }
+	}
+
+      if (gfc_current_locus.lb != NULL
+	  && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
+	continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
+    }
+
+  /* Ready to read first character of continuation line, which might
+     be another continuation line!  */
+  goto restart;
+
+not_continuation:
+  c = '\n';
+  gfc_current_locus = old_loc;
+
+done:
+  if (c == '\n')
+    continue_count = 0;
+  continue_flag = 0;
+  return c;
+}
+
+
+/* Get the next character of input, folded to lowercase.  In fixed
+   form mode, we also ignore spaces.  When matcher subroutines are
+   parsing character literals, they have to call
+   gfc_next_char_literal().  */
+
+gfc_char_t
+gfc_next_char (void)
+{
+  gfc_char_t c;
+
+  do
+    {
+      c = gfc_next_char_literal (NONSTRING);
+    }
+  while (gfc_current_form == FORM_FIXED && gfc_is_whitespace (c));
+
+  return gfc_wide_tolower (c);
+}
+
+char
+gfc_next_ascii_char (void)
+{
+  gfc_char_t c = gfc_next_char ();
+
+  return (gfc_wide_fits_in_byte (c) ? (unsigned char) c
+				    : (unsigned char) UCHAR_MAX);
+}
+
+
+gfc_char_t
+gfc_peek_char (void)
+{
+  locus old_loc;
+  gfc_char_t c;
+
+  old_loc = gfc_current_locus;
+  c = gfc_next_char ();
+  gfc_current_locus = old_loc;
+
+  return c;
+}
+
+
+char
+gfc_peek_ascii_char (void)
+{
+  gfc_char_t c = gfc_peek_char ();
+
+  return (gfc_wide_fits_in_byte (c) ? (unsigned char) c
+				    : (unsigned char) UCHAR_MAX);
+}
+
+
+/* Recover from an error.  We try to get past the current statement
+   and get lined up for the next.  The next statement follows a '\n'
+   or a ';'.  We also assume that we are not within a character
+   constant, and deal with finding a '\'' or '"'.  */
+
+void
+gfc_error_recovery (void)
+{
+  gfc_char_t c, delim;
+
+  if (gfc_at_eof ())
+    return;
+
+  for (;;)
+    {
+      c = gfc_next_char ();
+      if (c == '\n' || c == ';')
+	break;
+
+      if (c != '\'' && c != '"')
+	{
+	  if (gfc_at_eof ())
+	    break;
+	  continue;
+	}
+      delim = c;
+
+      for (;;)
+	{
+	  c = next_char ();
+
+	  if (c == delim)
+	    break;
+	  if (c == '\n')
+	    return;
+	  if (c == '\\')
+	    {
+	      c = next_char ();
+	      if (c == '\n')
+		return;
+	    }
+	}
+      if (gfc_at_eof ())
+	break;
+    }
+}
+
+
+/* Read ahead until the next character to be read is not whitespace.  */
+
+void
+gfc_gobble_whitespace (void)
+{
+  static int linenum = 0;
+  locus old_loc;
+  gfc_char_t c;
+
+  do
+    {
+      old_loc = gfc_current_locus;
+      c = gfc_next_char_literal (NONSTRING);
+      /* Issue a warning for nonconforming tabs.  We keep track of the line
+	 number because the Fortran matchers will often back up and the same
+	 line will be scanned multiple times.  */
+      if (!gfc_option.warn_tabs && c == '\t')
+	{
+	  int cur_linenum = LOCATION_LINE (gfc_current_locus.lb->location);
+	  if (cur_linenum != linenum)
+	    {
+	      linenum = cur_linenum;
+	      gfc_warning_now ("Nonconforming tab character at %C");
+	    }
+	}
+    }
+  while (gfc_is_whitespace (c));
+
+  gfc_current_locus = old_loc;
+}
+
+
+/* Load a single line into pbuf.
+
+   If pbuf points to a NULL pointer, it is allocated.
+   We truncate lines that are too long, unless we're dealing with
+   preprocessor lines or if the option -ffixed-line-length-none is set,
+   in which case we reallocate the buffer to fit the entire line, if
+   need be.
+   In fixed mode, we expand a tab that occurs within the statement
+   label region to expand to spaces that leave the next character in
+   the source region.
+
+   If first_char is not NULL, it's a pointer to a single char value holding
+   the first character of the line, which has already been read by the
+   caller.  This avoids the use of ungetc().
+
+   load_line returns whether the line was truncated.
+
+   NOTE: The error machinery isn't available at this point, so we can't
+	 easily report line and column numbers consistent with other 
+	 parts of gfortran.  */
+
+static int
+load_line (FILE *input, gfc_char_t **pbuf, int *pbuflen, const int *first_char)
+{
+  static int linenum = 0, current_line = 1;
+  int c, maxlen, i, preprocessor_flag, buflen = *pbuflen;
+  int trunc_flag = 0, seen_comment = 0;
+  int seen_printable = 0, seen_ampersand = 0, quoted = ' ';
+  gfc_char_t *buffer;
+  bool found_tab = false;
+
+  /* Determine the maximum allowed line length.  */
+  if (gfc_current_form == FORM_FREE)
+    maxlen = gfc_option.free_line_length;
+  else if (gfc_current_form == FORM_FIXED)
+    maxlen = gfc_option.fixed_line_length;
+  else
+    maxlen = 72;
+
+  if (*pbuf == NULL)
+    {
+      /* Allocate the line buffer, storing its length into buflen.
+	 Note that if maxlen==0, indicating that arbitrary-length lines
+	 are allowed, the buffer will be reallocated if this length is
+	 insufficient; since 132 characters is the length of a standard
+	 free-form line, we use that as a starting guess.  */
+      if (maxlen > 0)
+	buflen = maxlen;
+      else
+	buflen = 132;
+
+      *pbuf = gfc_get_wide_string (buflen + 1);
+    }
+
+  i = 0;
+  buffer = *pbuf;
+
+  if (first_char)
+    c = *first_char;
+  else
+    c = getc (input);
+
+  /* In order to not truncate preprocessor lines, we have to
+     remember that this is one.  */
+  preprocessor_flag = (c == '#' ? 1 : 0);
+
+  for (;;)
+    {
+      if (c == EOF)
+	break;
+
+      if (c == '\n')
+	{
+	  /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3.  */
+	  if (gfc_current_form == FORM_FREE 
+	      && !seen_printable && seen_ampersand)
+	    {
+	      if (pedantic)
+		gfc_error_now ("'&' not allowed by itself in line %d",
+			       current_line);
+	      else
+		gfc_warning_now ("'&' not allowed by itself in line %d",
+				 current_line);
+	    }
+	  break;
+	}
+
+      if (c == '\r' || c == '\0')
+	goto next_char;			/* Gobble characters.  */
+
+      if (c == '&')
+	{
+	  if (seen_ampersand)
+	    {
+	      seen_ampersand = 0;
+	      seen_printable = 1;
+	    }
+	  else
+	    seen_ampersand = 1;
+	}
+
+      if ((c != '&' && c != '!' && c != ' ') || (c == '!' && !seen_ampersand))
+	seen_printable = 1;
+
+      /* Is this a fixed-form comment?  */
+      if (gfc_current_form == FORM_FIXED && i == 0
+	  && (c == '*' || c == 'c' || c == 'd'))
+	seen_comment = 1;
+
+      if (quoted == ' ')
+	{
+	  if (c == '\'' || c == '"')
+	    quoted = c;
+	}
+      else if (c == quoted)
+	quoted = ' ';
+
+      /* Is this a free-form comment?  */
+      if (c == '!' && quoted == ' ')
+        seen_comment = 1;
+
+      /* Vendor extension: "<tab>1" marks a continuation line.  */
+      if (found_tab)
+	{
+	  found_tab = false;
+	  if (c >= '1' && c <= '9')
+	    {
+	      *(buffer-1) = c;
+	      goto next_char;
+	    }
+	}
+
+      if (gfc_current_form == FORM_FIXED && c == '\t' && i < 6)
+	{
+	  found_tab = true;
+
+	  if (!gfc_option.warn_tabs && seen_comment == 0
+	      && current_line != linenum)
+	    {
+	      linenum = current_line;
+	      gfc_warning_now ("Nonconforming tab character in column %d "
+			       "of line %d", i+1, linenum);
+	    }
+
+	  while (i < 6)
+	    {
+	      *buffer++ = ' ';
+	      i++;
+	    }
+
+	  goto next_char;
+	}
+
+      *buffer++ = c;
+      i++;
+
+      if (maxlen == 0 || preprocessor_flag)
+	{
+	  if (i >= buflen)
+	    {
+	      /* Reallocate line buffer to double size to hold the
+		overlong line.  */
+	      buflen = buflen * 2;
+	      *pbuf = XRESIZEVEC (gfc_char_t, *pbuf, (buflen + 1));
+	      buffer = (*pbuf) + i;
+	    }
+	}
+      else if (i >= maxlen)
+	{
+	  bool trunc_warn = true;
+
+	  /* Enhancement, if the very next non-space character is an ampersand
+	     or comment that we would otherwise warn about, don't mark as
+	     truncated.  */
+
+	  /* Truncate the rest of the line.  */
+	  for (;;)
+	    {
+	      c = getc (input);
+	      if (c == '\r' || c == ' ')
+	        continue;
+
+	      if (c == '\n' || c == EOF)
+		break;
+
+	      if (!trunc_warn && c != '!')
+		trunc_warn = true;
+
+	      if (trunc_warn && ((gfc_current_form == FORM_FIXED && c == '&')
+		  || c == '!'))
+		trunc_warn = false;
+
+	      if (c == '!')
+		seen_comment = 1;
+
+	      if (trunc_warn && !seen_comment)
+		trunc_flag = 1;
+	    }
+
+	  c = '\n';
+	  continue;
+	}
+
+next_char:
+      c = getc (input);
+    }
+
+  /* Pad lines to the selected line length in fixed form.  */
+  if (gfc_current_form == FORM_FIXED
+      && gfc_option.fixed_line_length != 0
+      && !preprocessor_flag
+      && c != EOF)
+    {
+      while (i++ < maxlen)
+	*buffer++ = ' ';
+    }
+
+  *buffer = '\0';
+  *pbuflen = buflen;
+  current_line++;
+
+  return trunc_flag;
+}
+
+
+/* Get a gfc_file structure, initialize it and add it to
+   the file stack.  */
+
+static gfc_file *
+get_file (const char *name, enum lc_reason reason ATTRIBUTE_UNUSED)
+{
+  gfc_file *f;
+
+  f = XCNEW (gfc_file);
+
+  f->filename = xstrdup (name);
+
+  f->next = file_head;
+  file_head = f;
+
+  f->up = current_file;
+  if (current_file != NULL)
+    f->inclusion_line = current_file->line;
+
+  linemap_add (line_table, reason, false, f->filename, 1);
+
+  return f;
+}
+
+
+/* Deal with a line from the C preprocessor. The
+   initial octothorp has already been seen.  */
+
+static void
+preprocessor_line (gfc_char_t *c)
+{
+  bool flag[5];
+  int i, line;
+  gfc_char_t *wide_filename;
+  gfc_file *f;
+  int escaped, unescape;
+  char *filename;
+
+  c++;
+  while (*c == ' ' || *c == '\t')
+    c++;
+
+  if (*c < '0' || *c > '9')
+    goto bad_cpp_line;
+
+  line = wide_atoi (c);
+
+  c = wide_strchr (c, ' ');
+  if (c == NULL)
+    {
+      /* No file name given.  Set new line number.  */
+      current_file->line = line;
+      return;
+    }
+
+  /* Skip spaces.  */
+  while (*c == ' ' || *c == '\t')
+    c++;
+
+  /* Skip quote.  */
+  if (*c != '"')
+    goto bad_cpp_line;
+  ++c;
+
+  wide_filename = c;
+
+  /* Make filename end at quote.  */
+  unescape = 0;
+  escaped = false;
+  while (*c && ! (!escaped && *c == '"'))
+    {
+      if (escaped)
+	escaped = false;
+      else if (*c == '\\')
+	{
+	  escaped = true;
+	  unescape++;
+	}
+      ++c;
+    }
+
+  if (! *c)
+    /* Preprocessor line has no closing quote.  */
+    goto bad_cpp_line;
+
+  *c++ = '\0';
+
+  /* Undo effects of cpp_quote_string.  */
+  if (unescape)
+    {
+      gfc_char_t *s = wide_filename;
+      gfc_char_t *d = gfc_get_wide_string (c - wide_filename - unescape);
+
+      wide_filename = d;
+      while (*s)
+	{
+	  if (*s == '\\')
+	    *d++ = *++s;
+	  else
+	    *d++ = *s;
+	  s++;
+	}
+      *d = '\0';
+    }
+
+  /* Get flags.  */
+
+  flag[1] = flag[2] = flag[3] = flag[4] = false;
+
+  for (;;)
+    {
+      c = wide_strchr (c, ' ');
+      if (c == NULL)
+	break;
+
+      c++;
+      i = wide_atoi (c);
+
+      if (1 <= i && i <= 4)
+	flag[i] = true;
+    }
+
+  /* Convert the filename in wide characters into a filename in narrow
+     characters.  */
+  filename = gfc_widechar_to_char (wide_filename, -1);
+
+  /* Interpret flags.  */
+
+  if (flag[1]) /* Starting new file.  */
+    {
+      f = get_file (filename, LC_RENAME);
+      add_file_change (f->filename, f->inclusion_line);
+      current_file = f;
+    }
+
+  if (flag[2]) /* Ending current file.  */
+    {
+      if (!current_file->up
+	  || filename_cmp (current_file->up->filename, filename) != 0)
+	{
+	  gfc_warning_now ("%s:%d: file %s left but not entered",
+			   current_file->filename, current_file->line,
+			   filename);
+	  if (unescape)
+	    free (wide_filename);
+	  free (filename);
+	  return;
+	}
+
+      add_file_change (NULL, line);
+      current_file = current_file->up;
+      linemap_add (line_table, LC_RENAME, false, current_file->filename,
+		   current_file->line);
+    }
+
+  /* The name of the file can be a temporary file produced by
+     cpp. Replace the name if it is different.  */
+
+  if (filename_cmp (current_file->filename, filename) != 0)
+    {
+       /* FIXME: we leak the old filename because a pointer to it may be stored
+          in the linemap.  Alternative could be using GC or updating linemap to
+          point to the new name, but there is no API for that currently. */
+      current_file->filename = xstrdup (filename);
+    }
+
+  /* Set new line number.  */
+  current_file->line = line;
+  if (unescape)
+    free (wide_filename);
+  free (filename);
+  return;
+
+ bad_cpp_line:
+  gfc_warning_now ("%s:%d: Illegal preprocessor directive",
+		   current_file->filename, current_file->line);
+  current_file->line++;
+}
+
+
+static bool load_file (const char *, const char *, bool);
+
+/* include_line()-- Checks a line buffer to see if it is an include
+   line.  If so, we call load_file() recursively to load the included
+   file.  We never return a syntax error because a statement like
+   "include = 5" is perfectly legal.  We return false if no include was
+   processed or true if we matched an include.  */
+
+static bool
+include_line (gfc_char_t *line)
+{
+  gfc_char_t quote, *c, *begin, *stop;
+  char *filename;
+
+  c = line;
+
+  if (gfc_option.gfc_flag_openmp)
+    {
+      if (gfc_current_form == FORM_FREE)
+	{
+	  while (*c == ' ' || *c == '\t')
+	    c++;
+	  if (*c == '!' && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
+	    c += 3;
+	}
+      else
+	{
+	  if ((*c == '!' || *c == 'c' || *c == 'C' || *c == '*')
+	      && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
+	    c += 3;
+	}
+    }
+
+  while (*c == ' ' || *c == '\t')
+    c++;
+
+  if (gfc_wide_strncasecmp (c, "include", 7))
+    return false;
+
+  c += 7;
+  while (*c == ' ' || *c == '\t')
+    c++;
+
+  /* Find filename between quotes.  */
+  
+  quote = *c++;
+  if (quote != '"' && quote != '\'')
+    return false;
+
+  begin = c;
+
+  while (*c != quote && *c != '\0')
+    c++;
+
+  if (*c == '\0')
+    return false;
+
+  stop = c++;
+  
+  while (*c == ' ' || *c == '\t')
+    c++;
+
+  if (*c != '\0' && *c != '!')
+    return false;
+
+  /* We have an include line at this point.  */
+
+  *stop = '\0'; /* It's ok to trash the buffer, as this line won't be
+		   read by anything else.  */
+
+  filename = gfc_widechar_to_char (begin, -1);
+  if (!load_file (filename, NULL, false))
+    exit (FATAL_EXIT_CODE);
+
+  free (filename);
+  return true;
+}
+
+
+/* Load a file into memory by calling load_line until the file ends.  */
+
+static bool
+load_file (const char *realfilename, const char *displayedname, bool initial)
+{
+  gfc_char_t *line;
+  gfc_linebuf *b;
+  gfc_file *f;
+  FILE *input;
+  int len, line_len;
+  bool first_line;
+  const char *filename;
+  /* If realfilename and displayedname are different and non-null then
+     surely realfilename is the preprocessed form of
+     displayedname.  */
+  bool preprocessed_p = (realfilename && displayedname
+			 && strcmp (realfilename, displayedname));
+
+  filename = displayedname ? displayedname : realfilename;
+
+  for (f = current_file; f; f = f->up)
+    if (filename_cmp (filename, f->filename) == 0)
+      {
+	fprintf (stderr, "%s:%d: Error: File '%s' is being included "
+		 "recursively\n", current_file->filename, current_file->line,
+		 filename);
+	return false;
+      }
+
+  if (initial)
+    {
+      if (gfc_src_file)
+	{
+	  input = gfc_src_file;
+	  gfc_src_file = NULL;
+	}
+      else
+	input = gfc_open_file (realfilename);
+      if (input == NULL)
+	{
+	  gfc_error_now ("Can't open file '%s'", filename);
+	  return false;
+	}
+    }
+  else
+    {
+      input = gfc_open_included_file (realfilename, false, false);
+      if (input == NULL)
+	{
+	  fprintf (stderr, "%s:%d: Error: Can't open included file '%s'\n",
+		   current_file->filename, current_file->line, filename);
+	  return false;
+	}
+    }
+
+  /* Load the file.
+
+     A "non-initial" file means a file that is being included.  In
+     that case we are creating an LC_ENTER map.
+
+     An "initial" file means a main file; one that is not included.
+     That file has already got at least one (surely more) line map(s)
+     created by gfc_init.  So the subsequent map created in that case
+     must have LC_RENAME reason.
+
+     This latter case is not true for a preprocessed file.  In that
+     case, although the file is "initial", the line maps created by
+     gfc_init was used during the preprocessing of the file.  Now that
+     the preprocessing is over and we are being fed the result of that
+     preprocessing, we need to create a brand new line map for the
+     preprocessed file, so the reason is going to be LC_ENTER.  */
+
+  f = get_file (filename, (initial && !preprocessed_p) ? LC_RENAME : LC_ENTER);
+  if (!initial)
+    add_file_change (f->filename, f->inclusion_line);
+  current_file = f;
+  current_file->line = 1;
+  line = NULL;
+  line_len = 0;
+  first_line = true;
+
+  if (initial && gfc_src_preprocessor_lines[0])
+    {
+      preprocessor_line (gfc_src_preprocessor_lines[0]);
+      free (gfc_src_preprocessor_lines[0]);
+      gfc_src_preprocessor_lines[0] = NULL;
+      if (gfc_src_preprocessor_lines[1])
+	{
+	  preprocessor_line (gfc_src_preprocessor_lines[1]);
+	  free (gfc_src_preprocessor_lines[1]);
+	  gfc_src_preprocessor_lines[1] = NULL;
+	}
+    }
+
+  for (;;)
+    {
+      int trunc = load_line (input, &line, &line_len, NULL);
+
+      len = gfc_wide_strlen (line);
+      if (feof (input) && len == 0)
+	break;
+
+      /* If this is the first line of the file, it can contain a byte
+	 order mark (BOM), which we will ignore:
+	   FF FE is UTF-16 little endian,
+	   FE FF is UTF-16 big endian,
+	   EF BB BF is UTF-8.  */
+      if (first_line
+	  && ((line_len >= 2 && line[0] == (unsigned char) '\xFF'
+			     && line[1] == (unsigned char) '\xFE')
+	      || (line_len >= 2 && line[0] == (unsigned char) '\xFE'
+			        && line[1] == (unsigned char) '\xFF')
+	      || (line_len >= 3 && line[0] == (unsigned char) '\xEF'
+				&& line[1] == (unsigned char) '\xBB'
+				&& line[2] == (unsigned char) '\xBF')))
+	{
+	  int n = line[1] == (unsigned char) '\xBB' ? 3 : 2;
+	  gfc_char_t *new_char = gfc_get_wide_string (line_len);
+
+	  wide_strcpy (new_char, &line[n]);
+	  free (line);
+	  line = new_char;
+	  len -= n;
+	}
+
+      /* There are three things this line can be: a line of Fortran
+	 source, an include line or a C preprocessor directive.  */
+
+      if (line[0] == '#')
+	{
+	  /* When -g3 is specified, it's possible that we emit #define
+	     and #undef lines, which we need to pass to the middle-end
+	     so that it can emit correct debug info.  */
+	  if (debug_info_level == DINFO_LEVEL_VERBOSE
+	      && (wide_strncmp (line, "#define ", 8) == 0
+		  || wide_strncmp (line, "#undef ", 7) == 0))
+	    ;
+	  else
+	    {
+	      preprocessor_line (line);
+	      continue;
+	    }
+	}
+
+      /* Preprocessed files have preprocessor lines added before the byte
+         order mark, so first_line is not about the first line of the file
+	 but the first line that's not a preprocessor line.  */
+      first_line = false;
+
+      if (include_line (line))
+	{
+	  current_file->line++;
+	  continue;
+	}
+
+      /* Add line.  */
+
+      b = XCNEWVAR (gfc_linebuf, gfc_linebuf_header_size
+		    + (len + 1) * sizeof (gfc_char_t));
+
+      b->location
+	= linemap_line_start (line_table, current_file->line++, 120);
+      b->file = current_file;
+      b->truncated = trunc;
+      wide_strcpy (b->line, line);
+
+      if (line_head == NULL)
+	line_head = b;
+      else
+	line_tail->next = b;
+
+      line_tail = b;
+
+      while (file_changes_cur < file_changes_count)
+	file_changes[file_changes_cur++].lb = b;
+    }
+
+  /* Release the line buffer allocated in load_line.  */
+  free (line);
+
+  fclose (input);
+
+  if (!initial)
+    add_file_change (NULL, current_file->inclusion_line + 1);
+  current_file = current_file->up;
+  linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
+  return true;
+}
+
+
+/* Open a new file and start scanning from that file. Returns true
+   if everything went OK, false otherwise.  If form == FORM_UNKNOWN
+   it tries to determine the source form from the filename, defaulting
+   to free form.  */
+
+bool
+gfc_new_file (void)
+{
+  bool result;
+
+  if (gfc_cpp_enabled ())
+    {
+      result = gfc_cpp_preprocess (gfc_source_file);
+      if (!gfc_cpp_preprocess_only ())
+        result = load_file (gfc_cpp_temporary_file (), gfc_source_file, true);
+    }
+  else
+    result = load_file (gfc_source_file, NULL, true);
+
+  gfc_current_locus.lb = line_head;
+  gfc_current_locus.nextc = (line_head == NULL) ? NULL : line_head->line;
+
+#if 0 /* Debugging aid.  */
+  for (; line_head; line_head = line_head->next)
+    printf ("%s:%3d %s\n", LOCATION_FILE (line_head->location),
+	    LOCATION_LINE (line_head->location), line_head->line);
+
+  exit (SUCCESS_EXIT_CODE);
+#endif
+
+  return result;
+}
+
+static char *
+unescape_filename (const char *ptr)
+{
+  const char *p = ptr, *s;
+  char *d, *ret;
+  int escaped, unescape = 0;
+
+  /* Make filename end at quote.  */
+  escaped = false;
+  while (*p && ! (! escaped && *p == '"'))
+    {
+      if (escaped)
+	escaped = false;
+      else if (*p == '\\')
+	{
+	  escaped = true;
+	  unescape++;
+	}
+      ++p;
+    }
+
+  if (!*p || p[1])
+    return NULL;
+
+  /* Undo effects of cpp_quote_string.  */
+  s = ptr;
+  d = XCNEWVEC (char, p + 1 - ptr - unescape);
+  ret = d;
+
+  while (s != p)
+    {
+      if (*s == '\\')
+	*d++ = *++s;
+      else
+	*d++ = *s;
+      s++;
+    }
+  *d = '\0';
+  return ret;
+}
+
+/* For preprocessed files, if the first tokens are of the form # NUM.
+   handle the directives so we know the original file name.  */
+
+const char *
+gfc_read_orig_filename (const char *filename, const char **canon_source_file)
+{
+  int c, len;
+  char *dirname, *tmp;
+
+  gfc_src_file = gfc_open_file (filename);
+  if (gfc_src_file == NULL)
+    return NULL;
+
+  c = getc (gfc_src_file);
+
+  if (c != '#')
+    return NULL;
+
+  len = 0;
+  load_line (gfc_src_file, &gfc_src_preprocessor_lines[0], &len, &c);
+
+  if (wide_strncmp (gfc_src_preprocessor_lines[0], "# 1 \"", 5) != 0)
+    return NULL;
+
+  tmp = gfc_widechar_to_char (&gfc_src_preprocessor_lines[0][5], -1);
+  filename = unescape_filename (tmp);
+  free (tmp);
+  if (filename == NULL)
+    return NULL;
+
+  c = getc (gfc_src_file);
+
+  if (c != '#')
+    return filename;
+
+  len = 0;
+  load_line (gfc_src_file, &gfc_src_preprocessor_lines[1], &len, &c);
+
+  if (wide_strncmp (gfc_src_preprocessor_lines[1], "# 1 \"", 5) != 0)
+    return filename;
+
+  tmp = gfc_widechar_to_char (&gfc_src_preprocessor_lines[1][5], -1);
+  dirname = unescape_filename (tmp);
+  free (tmp);
+  if (dirname == NULL)
+    return filename;
+
+  len = strlen (dirname);
+  if (len < 3 || dirname[len - 1] != '/' || dirname[len - 2] != '/')
+    {
+      free (dirname);
+      return filename;
+    }
+  dirname[len - 2] = '\0';
+  set_src_pwd (dirname);
+
+  if (! IS_ABSOLUTE_PATH (filename))
+    {
+      char *p = XCNEWVEC (char, len + strlen (filename));
+
+      memcpy (p, dirname, len - 2);
+      p[len - 2] = '/';
+      strcpy (p + len - 1, filename);
+      *canon_source_file = p;
+    }
+
+  free (dirname);
+  return filename;
+}
diff --git a/gcc-4.9/gcc/fortran/scanner.h b/gcc-4.9/gcc/fortran/scanner.h
new file mode 100644
index 000000000..661cdcbc6
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/scanner.h
@@ -0,0 +1,32 @@
+/* Character scanner header.
+   Copyright (C) 2013-2014 Free Software Foundation, Inc.
+   Contributed by Janne Blomqvist
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+
+/* Structure for holding module and include file search path.  */
+typedef struct gfc_directorylist
+{
+  char *path;
+  bool use_for_modules;
+  struct gfc_directorylist *next;
+}
+gfc_directorylist;
+
+/* List of include file search directories.  */
+extern gfc_directorylist *include_dirs, *intrinsic_modules_dirs;
diff --git a/gcc-4.9/gcc/fortran/simplify.c b/gcc-4.9/gcc/fortran/simplify.c
new file mode 100644
index 000000000..96d0f21f3
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/simplify.c
@@ -0,0 +1,6844 @@
+/* Simplify intrinsic functions at compile-time.
+   Copyright (C) 2000-2014 Free Software Foundation, Inc.
+   Contributed by Andy Vaught & Katherine Holcomb
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "flags.h"
+#include "gfortran.h"
+#include "arith.h"
+#include "intrinsic.h"
+#include "target-memory.h"
+#include "constructor.h"
+#include "tm.h"		/* For BITS_PER_UNIT.  */
+#include "version.h"	/* For version_string.  */
+
+
+gfc_expr gfc_bad_expr;
+
+static gfc_expr *simplify_size (gfc_expr *, gfc_expr *, int);
+
+
+/* Note that 'simplification' is not just transforming expressions.
+   For functions that are not simplified at compile time, range
+   checking is done if possible.
+
+   The return convention is that each simplification function returns:
+
+     A new expression node corresponding to the simplified arguments.
+     The original arguments are destroyed by the caller, and must not
+     be a part of the new expression.
+
+     NULL pointer indicating that no simplification was possible and
+     the original expression should remain intact.
+
+     An expression pointer to gfc_bad_expr (a static placeholder)
+     indicating that some error has prevented simplification.  The
+     error is generated within the function and should be propagated
+     upwards
+
+   By the time a simplification function gets control, it has been
+   decided that the function call is really supposed to be the
+   intrinsic.  No type checking is strictly necessary, since only
+   valid types will be passed on.  On the other hand, a simplification
+   subroutine may have to look at the type of an argument as part of
+   its processing.
+
+   Array arguments are only passed to these subroutines that implement
+   the simplification of transformational intrinsics.
+
+   The functions in this file don't have much comment with them, but
+   everything is reasonably straight-forward.  The Standard, chapter 13
+   is the best comment you'll find for this file anyway.  */
+
+/* Range checks an expression node.  If all goes well, returns the
+   node, otherwise returns &gfc_bad_expr and frees the node.  */
+
+static gfc_expr *
+range_check (gfc_expr *result, const char *name)
+{
+  if (result == NULL)
+    return &gfc_bad_expr;
+
+  if (result->expr_type != EXPR_CONSTANT)
+    return result;
+
+  switch (gfc_range_check (result))
+    {
+      case ARITH_OK:
+	return result;
+
+      case ARITH_OVERFLOW:
+	gfc_error ("Result of %s overflows its kind at %L", name,
+		   &result->where);
+	break;
+
+      case ARITH_UNDERFLOW:
+	gfc_error ("Result of %s underflows its kind at %L", name,
+		   &result->where);
+	break;
+
+      case ARITH_NAN:
+	gfc_error ("Result of %s is NaN at %L", name, &result->where);
+	break;
+
+      default:
+	gfc_error ("Result of %s gives range error for its kind at %L", name,
+		   &result->where);
+	break;
+    }
+
+  gfc_free_expr (result);
+  return &gfc_bad_expr;
+}
+
+
+/* A helper function that gets an optional and possibly missing
+   kind parameter.  Returns the kind, -1 if something went wrong.  */
+
+static int
+get_kind (bt type, gfc_expr *k, const char *name, int default_kind)
+{
+  int kind;
+
+  if (k == NULL)
+    return default_kind;
+
+  if (k->expr_type != EXPR_CONSTANT)
+    {
+      gfc_error ("KIND parameter of %s at %L must be an initialization "
+		 "expression", name, &k->where);
+      return -1;
+    }
+
+  if (gfc_extract_int (k, &kind) != NULL
+      || gfc_validate_kind (type, kind, true) < 0)
+    {
+      gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where);
+      return -1;
+    }
+
+  return kind;
+}
+
+
+/* Converts an mpz_t signed variable into an unsigned one, assuming
+   two's complement representations and a binary width of bitsize.
+   The conversion is a no-op unless x is negative; otherwise, it can
+   be accomplished by masking out the high bits.  */
+
+static void
+convert_mpz_to_unsigned (mpz_t x, int bitsize)
+{
+  mpz_t mask;
+
+  if (mpz_sgn (x) < 0)
+    {
+      /* Confirm that no bits above the signed range are unset.  */
+      gcc_assert (mpz_scan0 (x, bitsize-1) == ULONG_MAX);
+
+      mpz_init_set_ui (mask, 1);
+      mpz_mul_2exp (mask, mask, bitsize);
+      mpz_sub_ui (mask, mask, 1);
+
+      mpz_and (x, x, mask);
+
+      mpz_clear (mask);
+    }
+  else
+    {
+      /* Confirm that no bits above the signed range are set.  */
+      gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX);
+    }
+}
+
+
+/* Converts an mpz_t unsigned variable into a signed one, assuming
+   two's complement representations and a binary width of bitsize.
+   If the bitsize-1 bit is set, this is taken as a sign bit and
+   the number is converted to the corresponding negative number.  */
+
+static void
+convert_mpz_to_signed (mpz_t x, int bitsize)
+{
+  mpz_t mask;
+
+  /* Confirm that no bits above the unsigned range are set.  */
+  gcc_assert (mpz_scan1 (x, bitsize) == ULONG_MAX);
+
+  if (mpz_tstbit (x, bitsize - 1) == 1)
+    {
+      mpz_init_set_ui (mask, 1);
+      mpz_mul_2exp (mask, mask, bitsize);
+      mpz_sub_ui (mask, mask, 1);
+
+      /* We negate the number by hand, zeroing the high bits, that is
+	 make it the corresponding positive number, and then have it
+	 negated by GMP, giving the correct representation of the
+	 negative number.  */
+      mpz_com (x, x);
+      mpz_add_ui (x, x, 1);
+      mpz_and (x, x, mask);
+
+      mpz_neg (x, x);
+
+      mpz_clear (mask);
+    }
+}
+
+
+/* In-place convert BOZ to REAL of the specified kind.  */
+
+static gfc_expr *
+convert_boz (gfc_expr *x, int kind)
+{
+  if (x && x->ts.type == BT_INTEGER && x->is_boz)
+    {
+      gfc_typespec ts;
+      gfc_clear_ts (&ts);
+      ts.type = BT_REAL;
+      ts.kind = kind;
+
+      if (!gfc_convert_boz (x, &ts))
+	return &gfc_bad_expr;
+    }
+
+  return x;
+}
+
+
+/* Test that the expression is an constant array.  */
+
+static bool
+is_constant_array_expr (gfc_expr *e)
+{
+  gfc_constructor *c;
+
+  if (e == NULL)
+    return true;
+
+  if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
+    return false;
+
+  for (c = gfc_constructor_first (e->value.constructor);
+       c; c = gfc_constructor_next (c))
+    if (c->expr->expr_type != EXPR_CONSTANT
+	  && c->expr->expr_type != EXPR_STRUCTURE)
+      return false;
+
+  return true;
+}
+
+
+/* Initialize a transformational result expression with a given value.  */
+
+static void
+init_result_expr (gfc_expr *e, int init, gfc_expr *array)
+{
+  if (e && e->expr_type == EXPR_ARRAY)
+    {
+      gfc_constructor *ctor = gfc_constructor_first (e->value.constructor);
+      while (ctor)
+	{
+	  init_result_expr (ctor->expr, init, array);
+	  ctor = gfc_constructor_next (ctor);
+	}
+    }
+  else if (e && e->expr_type == EXPR_CONSTANT)
+    {
+      int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+      int length;
+      gfc_char_t *string;
+
+      switch (e->ts.type)
+	{
+	  case BT_LOGICAL:
+	    e->value.logical = (init ? 1 : 0);
+	    break;
+
+	  case BT_INTEGER:
+	    if (init == INT_MIN)
+	      mpz_set (e->value.integer, gfc_integer_kinds[i].min_int);
+	    else if (init == INT_MAX)
+	      mpz_set (e->value.integer, gfc_integer_kinds[i].huge);
+	    else
+	      mpz_set_si (e->value.integer, init);
+	    break;
+
+	  case BT_REAL:
+	    if (init == INT_MIN)
+	      {
+		mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
+		mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
+	      }
+	    else if (init == INT_MAX)
+	      mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
+	    else
+	      mpfr_set_si (e->value.real, init, GFC_RND_MODE);
+	    break;
+
+	  case BT_COMPLEX:
+	    mpc_set_si (e->value.complex, init, GFC_MPC_RND_MODE);
+	    break;
+
+	  case BT_CHARACTER:
+	    if (init == INT_MIN)
+	      {
+		gfc_expr *len = gfc_simplify_len (array, NULL);
+		gfc_extract_int (len, &length);
+		string = gfc_get_wide_string (length + 1);
+		gfc_wide_memset (string, 0, length);
+	      }
+	    else if (init == INT_MAX)
+	      {
+		gfc_expr *len = gfc_simplify_len (array, NULL);
+		gfc_extract_int (len, &length);
+		string = gfc_get_wide_string (length + 1);
+		gfc_wide_memset (string, 255, length);
+	      }
+	    else
+	      {
+		length = 0;
+		string = gfc_get_wide_string (1);
+	      }
+
+	    string[length] = '\0';
+	    e->value.character.length = length;
+	    e->value.character.string = string;
+	    break;
+
+	  default:
+	    gcc_unreachable();
+	}
+    }
+  else
+    gcc_unreachable();
+}
+
+
+/* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul;
+   if conj_a is true, the matrix_a is complex conjugated.  */
+
+static gfc_expr *
+compute_dot_product (gfc_expr *matrix_a, int stride_a, int offset_a,
+		     gfc_expr *matrix_b, int stride_b, int offset_b,
+		     bool conj_a)
+{
+  gfc_expr *result, *a, *b, *c;
+
+  result = gfc_get_constant_expr (matrix_a->ts.type, matrix_a->ts.kind,
+				  &matrix_a->where);
+  init_result_expr (result, 0, NULL);
+
+  a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a);
+  b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b);
+  while (a && b)
+    {
+      /* Copying of expressions is required as operands are free'd
+	 by the gfc_arith routines.  */
+      switch (result->ts.type)
+	{
+	  case BT_LOGICAL:
+	    result = gfc_or (result,
+			     gfc_and (gfc_copy_expr (a),
+				      gfc_copy_expr (b)));
+	    break;
+
+	  case BT_INTEGER:
+	  case BT_REAL:
+	  case BT_COMPLEX:
+	    if (conj_a && a->ts.type == BT_COMPLEX)
+	      c = gfc_simplify_conjg (a);
+	    else
+	      c = gfc_copy_expr (a);
+	    result = gfc_add (result, gfc_multiply (c, gfc_copy_expr (b)));
+	    break;
+
+	  default:
+	    gcc_unreachable();
+	}
+
+      offset_a += stride_a;
+      a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a);
+
+      offset_b += stride_b;
+      b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b);
+    }
+
+  return result;
+}
+
+
+/* Build a result expression for transformational intrinsics,
+   depending on DIM. */
+
+static gfc_expr *
+transformational_result (gfc_expr *array, gfc_expr *dim, bt type,
+			 int kind, locus* where)
+{
+  gfc_expr *result;
+  int i, nelem;
+
+  if (!dim || array->rank == 1)
+    return gfc_get_constant_expr (type, kind, where);
+
+  result = gfc_get_array_expr (type, kind, where);
+  result->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
+  result->rank = array->rank - 1;
+
+  /* gfc_array_size() would count the number of elements in the constructor,
+     we have not built those yet.  */
+  nelem = 1;
+  for  (i = 0; i < result->rank; ++i)
+    nelem *= mpz_get_ui (result->shape[i]);
+
+  for (i = 0; i < nelem; ++i)
+    {
+      gfc_constructor_append_expr (&result->value.constructor,
+				   gfc_get_constant_expr (type, kind, where),
+				   NULL);
+    }
+
+  return result;
+}
+
+
+typedef gfc_expr* (*transformational_op)(gfc_expr*, gfc_expr*);
+
+/* Wrapper function, implements 'op1 += 1'. Only called if MASK
+   of COUNT intrinsic is .TRUE..
+
+   Interface and implementation mimics arith functions as
+   gfc_add, gfc_multiply, etc.  */
+
+static gfc_expr* gfc_count (gfc_expr *op1, gfc_expr *op2)
+{
+  gfc_expr *result;
+
+  gcc_assert (op1->ts.type == BT_INTEGER);
+  gcc_assert (op2->ts.type == BT_LOGICAL);
+  gcc_assert (op2->value.logical);
+
+  result = gfc_copy_expr (op1);
+  mpz_add_ui (result->value.integer, result->value.integer, 1);
+
+  gfc_free_expr (op1);
+  gfc_free_expr (op2);
+  return result;
+}
+
+
+/* Transforms an ARRAY with operation OP, according to MASK, to a
+   scalar RESULT. E.g. called if
+
+     REAL, PARAMETER :: array(n, m) = ...
+     REAL, PARAMETER :: s = SUM(array)
+
+  where OP == gfc_add().  */
+
+static gfc_expr *
+simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
+				   transformational_op op)
+{
+  gfc_expr *a, *m;
+  gfc_constructor *array_ctor, *mask_ctor;
+
+  /* Shortcut for constant .FALSE. MASK.  */
+  if (mask
+      && mask->expr_type == EXPR_CONSTANT
+      && !mask->value.logical)
+    return result;
+
+  array_ctor = gfc_constructor_first (array->value.constructor);
+  mask_ctor = NULL;
+  if (mask && mask->expr_type == EXPR_ARRAY)
+    mask_ctor = gfc_constructor_first (mask->value.constructor);
+
+  while (array_ctor)
+    {
+      a = array_ctor->expr;
+      array_ctor = gfc_constructor_next (array_ctor);
+
+      /* A constant MASK equals .TRUE. here and can be ignored.  */
+      if (mask_ctor)
+	{
+	  m = mask_ctor->expr;
+	  mask_ctor = gfc_constructor_next (mask_ctor);
+	  if (!m->value.logical)
+	    continue;
+	}
+
+      result = op (result, gfc_copy_expr (a));
+    }
+
+  return result;
+}
+
+/* Transforms an ARRAY with operation OP, according to MASK, to an
+   array RESULT. E.g. called if
+
+     REAL, PARAMETER :: array(n, m) = ...
+     REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
+
+  where OP == gfc_multiply(). The result might be post processed using post_op. */
+
+static gfc_expr *
+simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim,
+				  gfc_expr *mask, transformational_op op,
+				  transformational_op post_op)
+{
+  mpz_t size;
+  int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
+  gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
+  gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
+
+  int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
+      sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
+      tmpstride[GFC_MAX_DIMENSIONS];
+
+  /* Shortcut for constant .FALSE. MASK.  */
+  if (mask
+      && mask->expr_type == EXPR_CONSTANT
+      && !mask->value.logical)
+    return result;
+
+  /* Build an indexed table for array element expressions to minimize
+     linked-list traversal. Masked elements are set to NULL.  */
+  gfc_array_size (array, &size);
+  arraysize = mpz_get_ui (size);
+  mpz_clear (size);
+
+  arrayvec = XCNEWVEC (gfc_expr*, arraysize);
+
+  array_ctor = gfc_constructor_first (array->value.constructor);
+  mask_ctor = NULL;
+  if (mask && mask->expr_type == EXPR_ARRAY)
+    mask_ctor = gfc_constructor_first (mask->value.constructor);
+
+  for (i = 0; i < arraysize; ++i)
+    {
+      arrayvec[i] = array_ctor->expr;
+      array_ctor = gfc_constructor_next (array_ctor);
+
+      if (mask_ctor)
+	{
+	  if (!mask_ctor->expr->value.logical)
+	    arrayvec[i] = NULL;
+
+	  mask_ctor = gfc_constructor_next (mask_ctor);
+	}
+    }
+
+  /* Same for the result expression.  */
+  gfc_array_size (result, &size);
+  resultsize = mpz_get_ui (size);
+  mpz_clear (size);
+
+  resultvec = XCNEWVEC (gfc_expr*, resultsize);
+  result_ctor = gfc_constructor_first (result->value.constructor);
+  for (i = 0; i < resultsize; ++i)
+    {
+      resultvec[i] = result_ctor->expr;
+      result_ctor = gfc_constructor_next (result_ctor);
+    }
+
+  gfc_extract_int (dim, &dim_index);
+  dim_index -= 1;               /* zero-base index */
+  dim_extent = 0;
+  dim_stride = 0;
+
+  for (i = 0, n = 0; i < array->rank; ++i)
+    {
+      count[i] = 0;
+      tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
+      if (i == dim_index)
+	{
+	  dim_extent = mpz_get_si (array->shape[i]);
+	  dim_stride = tmpstride[i];
+	  continue;
+	}
+
+      extent[n] = mpz_get_si (array->shape[i]);
+      sstride[n] = tmpstride[i];
+      dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
+      n += 1;
+    }
+
+  done = false;
+  base = arrayvec;
+  dest = resultvec;
+  while (!done)
+    {
+      for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
+	if (*src)
+	  *dest = op (*dest, gfc_copy_expr (*src));
+
+      count[0]++;
+      base += sstride[0];
+      dest += dstride[0];
+
+      n = 0;
+      while (!done && count[n] == extent[n])
+	{
+	  count[n] = 0;
+	  base -= sstride[n] * extent[n];
+	  dest -= dstride[n] * extent[n];
+
+	  n++;
+	  if (n < result->rank)
+	    {
+	      count [n]++;
+	      base += sstride[n];
+	      dest += dstride[n];
+	    }
+	  else
+	    done = true;
+       }
+    }
+
+  /* Place updated expression in result constructor.  */
+  result_ctor = gfc_constructor_first (result->value.constructor);
+  for (i = 0; i < resultsize; ++i)
+    {
+      if (post_op)
+	result_ctor->expr = post_op (result_ctor->expr, resultvec[i]);
+      else
+	result_ctor->expr = resultvec[i];
+      result_ctor = gfc_constructor_next (result_ctor);
+    }
+
+  free (arrayvec);
+  free (resultvec);
+  return result;
+}
+
+
+static gfc_expr *
+simplify_transformation (gfc_expr *array, gfc_expr *dim, gfc_expr *mask,
+			 int init_val, transformational_op op)
+{
+  gfc_expr *result;
+
+  if (!is_constant_array_expr (array)
+      || !gfc_is_constant_expr (dim))
+    return NULL;
+
+  if (mask
+      && !is_constant_array_expr (mask)
+      && mask->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = transformational_result (array, dim, array->ts.type,
+				    array->ts.kind, &array->where);
+  init_result_expr (result, init_val, NULL);
+
+  return !dim || array->rank == 1 ?
+    simplify_transformation_to_scalar (result, array, mask, op) :
+    simplify_transformation_to_array (result, array, dim, mask, op, NULL);
+}
+
+
+/********************** Simplification functions *****************************/
+
+gfc_expr *
+gfc_simplify_abs (gfc_expr *e)
+{
+  gfc_expr *result;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  switch (e->ts.type)
+    {
+      case BT_INTEGER:
+	result = gfc_get_constant_expr (BT_INTEGER, e->ts.kind, &e->where);
+	mpz_abs (result->value.integer, e->value.integer);
+	return range_check (result, "IABS");
+
+      case BT_REAL:
+	result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
+	mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE);
+	return range_check (result, "ABS");
+
+      case BT_COMPLEX:
+	gfc_set_model_kind (e->ts.kind);
+	result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
+	mpc_abs (result->value.real, e->value.complex, GFC_RND_MODE);
+	return range_check (result, "CABS");
+
+      default:
+	gfc_internal_error ("gfc_simplify_abs(): Bad type");
+    }
+}
+
+
+static gfc_expr *
+simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii)
+{
+  gfc_expr *result;
+  int kind;
+  bool too_large = false;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind);
+  if (kind == -1)
+    return &gfc_bad_expr;
+
+  if (mpz_cmp_si (e->value.integer, 0) < 0)
+    {
+      gfc_error ("Argument of %s function at %L is negative", name,
+		 &e->where);
+      return &gfc_bad_expr;
+    }
+
+  if (ascii && gfc_option.warn_surprising
+      && mpz_cmp_si (e->value.integer, 127) > 0)
+    gfc_warning ("Argument of %s function at %L outside of range [0,127]",
+		 name, &e->where);
+
+  if (kind == 1 && mpz_cmp_si (e->value.integer, 255) > 0)
+    too_large = true;
+  else if (kind == 4)
+    {
+      mpz_t t;
+      mpz_init_set_ui (t, 2);
+      mpz_pow_ui (t, t, 32);
+      mpz_sub_ui (t, t, 1);
+      if (mpz_cmp (e->value.integer, t) > 0)
+	too_large = true;
+      mpz_clear (t);
+    }
+
+  if (too_large)
+    {
+      gfc_error ("Argument of %s function at %L is too large for the "
+		 "collating sequence of kind %d", name, &e->where, kind);
+      return &gfc_bad_expr;
+    }
+
+  result = gfc_get_character_expr (kind, &e->where, NULL, 1);
+  result->value.character.string[0] = mpz_get_ui (e->value.integer);
+
+  return result;
+}
+
+
+
+/* We use the processor's collating sequence, because all
+   systems that gfortran currently works on are ASCII.  */
+
+gfc_expr *
+gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
+{
+  return simplify_achar_char (e, k, "ACHAR", true);
+}
+
+
+gfc_expr *
+gfc_simplify_acos (gfc_expr *x)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  switch (x->ts.type)
+    {
+      case BT_REAL:
+	if (mpfr_cmp_si (x->value.real, 1) > 0
+	    || mpfr_cmp_si (x->value.real, -1) < 0)
+	  {
+	    gfc_error ("Argument of ACOS at %L must be between -1 and 1",
+		       &x->where);
+	    return &gfc_bad_expr;
+	  }
+	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+	mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
+	break;
+
+      case BT_COMPLEX:
+	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+	mpc_acos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+	break;
+
+      default:
+	gfc_internal_error ("in gfc_simplify_acos(): Bad type");
+    }
+
+  return range_check (result, "ACOS");
+}
+
+gfc_expr *
+gfc_simplify_acosh (gfc_expr *x)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  switch (x->ts.type)
+    {
+      case BT_REAL:
+	if (mpfr_cmp_si (x->value.real, 1) < 0)
+	  {
+	    gfc_error ("Argument of ACOSH at %L must not be less than 1",
+		       &x->where);
+	    return &gfc_bad_expr;
+	  }
+
+	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+	mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
+	break;
+
+      case BT_COMPLEX:
+	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+	mpc_acosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+	break;
+
+      default:
+	gfc_internal_error ("in gfc_simplify_acosh(): Bad type");
+    }
+
+  return range_check (result, "ACOSH");
+}
+
+gfc_expr *
+gfc_simplify_adjustl (gfc_expr *e)
+{
+  gfc_expr *result;
+  int count, i, len;
+  gfc_char_t ch;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  len = e->value.character.length;
+
+  for (count = 0, i = 0; i < len; ++i)
+    {
+      ch = e->value.character.string[i];
+      if (ch != ' ')
+	break;
+      ++count;
+    }
+
+  result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len);
+  for (i = 0; i < len - count; ++i)
+    result->value.character.string[i] = e->value.character.string[count + i];
+
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_adjustr (gfc_expr *e)
+{
+  gfc_expr *result;
+  int count, i, len;
+  gfc_char_t ch;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  len = e->value.character.length;
+
+  for (count = 0, i = len - 1; i >= 0; --i)
+    {
+      ch = e->value.character.string[i];
+      if (ch != ' ')
+	break;
+      ++count;
+    }
+
+  result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len);
+  for (i = 0; i < count; ++i)
+    result->value.character.string[i] = ' ';
+
+  for (i = count; i < len; ++i)
+    result->value.character.string[i] = e->value.character.string[i - count];
+
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_aimag (gfc_expr *e)
+{
+  gfc_expr *result;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
+  mpfr_set (result->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE);
+
+  return range_check (result, "AIMAG");
+}
+
+
+gfc_expr *
+gfc_simplify_aint (gfc_expr *e, gfc_expr *k)
+{
+  gfc_expr *rtrunc, *result;
+  int kind;
+
+  kind = get_kind (BT_REAL, k, "AINT", e->ts.kind);
+  if (kind == -1)
+    return &gfc_bad_expr;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  rtrunc = gfc_copy_expr (e);
+  mpfr_trunc (rtrunc->value.real, e->value.real);
+
+  result = gfc_real2real (rtrunc, kind);
+
+  gfc_free_expr (rtrunc);
+
+  return range_check (result, "AINT");
+}
+
+
+gfc_expr *
+gfc_simplify_all (gfc_expr *mask, gfc_expr *dim)
+{
+  return simplify_transformation (mask, dim, NULL, true, gfc_and);
+}
+
+
+gfc_expr *
+gfc_simplify_dint (gfc_expr *e)
+{
+  gfc_expr *rtrunc, *result;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  rtrunc = gfc_copy_expr (e);
+  mpfr_trunc (rtrunc->value.real, e->value.real);
+
+  result = gfc_real2real (rtrunc, gfc_default_double_kind);
+
+  gfc_free_expr (rtrunc);
+
+  return range_check (result, "DINT");
+}
+
+
+gfc_expr *
+gfc_simplify_dreal (gfc_expr *e)
+{
+  gfc_expr *result = NULL;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
+  mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
+
+  return range_check (result, "DREAL");
+}
+
+
+gfc_expr *
+gfc_simplify_anint (gfc_expr *e, gfc_expr *k)
+{
+  gfc_expr *result;
+  int kind;
+
+  kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind);
+  if (kind == -1)
+    return &gfc_bad_expr;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (e->ts.type, kind, &e->where);
+  mpfr_round (result->value.real, e->value.real);
+
+  return range_check (result, "ANINT");
+}
+
+
+gfc_expr *
+gfc_simplify_and (gfc_expr *x, gfc_expr *y)
+{
+  gfc_expr *result;
+  int kind;
+
+  if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
+
+  switch (x->ts.type)
+    {
+      case BT_INTEGER:
+	result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
+	mpz_and (result->value.integer, x->value.integer, y->value.integer);
+	return range_check (result, "AND");
+
+      case BT_LOGICAL:
+	return gfc_get_logical_expr (kind, &x->where,
+				     x->value.logical && y->value.logical);
+
+      default:
+	gcc_unreachable ();
+    }
+}
+
+
+gfc_expr *
+gfc_simplify_any (gfc_expr *mask, gfc_expr *dim)
+{
+  return simplify_transformation (mask, dim, NULL, false, gfc_or);
+}
+
+
+gfc_expr *
+gfc_simplify_dnint (gfc_expr *e)
+{
+  gfc_expr *result;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &e->where);
+  mpfr_round (result->value.real, e->value.real);
+
+  return range_check (result, "DNINT");
+}
+
+
+gfc_expr *
+gfc_simplify_asin (gfc_expr *x)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  switch (x->ts.type)
+    {
+      case BT_REAL:
+	if (mpfr_cmp_si (x->value.real, 1) > 0
+	    || mpfr_cmp_si (x->value.real, -1) < 0)
+	  {
+	    gfc_error ("Argument of ASIN at %L must be between -1 and 1",
+		       &x->where);
+	    return &gfc_bad_expr;
+	  }
+	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+	mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
+	break;
+
+      case BT_COMPLEX:
+	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+	mpc_asin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+	break;
+
+      default:
+	gfc_internal_error ("in gfc_simplify_asin(): Bad type");
+    }
+
+  return range_check (result, "ASIN");
+}
+
+
+gfc_expr *
+gfc_simplify_asinh (gfc_expr *x)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+  switch (x->ts.type)
+    {
+      case BT_REAL:
+	mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
+	break;
+
+      case BT_COMPLEX:
+	mpc_asinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+	break;
+
+      default:
+	gfc_internal_error ("in gfc_simplify_asinh(): Bad type");
+    }
+
+  return range_check (result, "ASINH");
+}
+
+
+gfc_expr *
+gfc_simplify_atan (gfc_expr *x)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+  switch (x->ts.type)
+    {
+      case BT_REAL:
+	mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
+	break;
+
+      case BT_COMPLEX:
+	mpc_atan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+	break;
+
+      default:
+	gfc_internal_error ("in gfc_simplify_atan(): Bad type");
+    }
+
+  return range_check (result, "ATAN");
+}
+
+
+gfc_expr *
+gfc_simplify_atanh (gfc_expr *x)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  switch (x->ts.type)
+    {
+      case BT_REAL:
+	if (mpfr_cmp_si (x->value.real, 1) >= 0
+	    || mpfr_cmp_si (x->value.real, -1) <= 0)
+	  {
+	    gfc_error ("Argument of ATANH at %L must be inside the range -1 "
+		       "to 1", &x->where);
+	    return &gfc_bad_expr;
+	  }
+	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+	mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
+	break;
+
+      case BT_COMPLEX:
+	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+	mpc_atanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+	break;
+
+      default:
+	gfc_internal_error ("in gfc_simplify_atanh(): Bad type");
+    }
+
+  return range_check (result, "ATANH");
+}
+
+
+gfc_expr *
+gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  if (mpfr_sgn (y->value.real) == 0 && mpfr_sgn (x->value.real) == 0)
+    {
+      gfc_error ("If first argument of ATAN2 %L is zero, then the "
+		 "second argument must not be zero", &x->where);
+      return &gfc_bad_expr;
+    }
+
+  result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+  mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
+
+  return range_check (result, "ATAN2");
+}
+
+
+gfc_expr *
+gfc_simplify_bessel_j0 (gfc_expr *x)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+  mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE);
+
+  return range_check (result, "BESSEL_J0");
+}
+
+
+gfc_expr *
+gfc_simplify_bessel_j1 (gfc_expr *x)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+  mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE);
+
+  return range_check (result, "BESSEL_J1");
+}
+
+
+gfc_expr *
+gfc_simplify_bessel_jn (gfc_expr *order, gfc_expr *x)
+{
+  gfc_expr *result;
+  long n;
+
+  if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  n = mpz_get_si (order->value.integer);
+  result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+  mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE);
+
+  return range_check (result, "BESSEL_JN");
+}
+
+
+/* Simplify transformational form of JN and YN.  */
+
+static gfc_expr *
+gfc_simplify_bessel_n2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x,
+			bool jn)
+{
+  gfc_expr *result;
+  gfc_expr *e;
+  long n1, n2;
+  int i;
+  mpfr_t x2rev, last1, last2;
+
+  if (x->expr_type != EXPR_CONSTANT || order1->expr_type != EXPR_CONSTANT
+      || order2->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  n1 = mpz_get_si (order1->value.integer);
+  n2 = mpz_get_si (order2->value.integer);
+  result = gfc_get_array_expr (x->ts.type, x->ts.kind, &x->where);
+  result->rank = 1;
+  result->shape = gfc_get_shape (1);
+  mpz_init_set_ui (result->shape[0], MAX (n2-n1+1, 0));
+
+  if (n2 < n1)
+    return result;
+
+  /* Special case: x == 0; it is J0(0.0) == 1, JN(N > 0, 0.0) == 0; and
+     YN(N, 0.0) = -Inf.  */
+
+  if (mpfr_cmp_ui (x->value.real, 0.0) == 0)
+    {
+      if (!jn && gfc_option.flag_range_check)
+	{
+	  gfc_error ("Result of BESSEL_YN is -INF at %L", &result->where);
+ 	  gfc_free_expr (result);
+	  return &gfc_bad_expr;
+	}
+
+      if (jn && n1 == 0)
+	{
+	  e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+	  mpfr_set_ui (e->value.real, 1, GFC_RND_MODE);
+	  gfc_constructor_append_expr (&result->value.constructor, e,
+				       &x->where);
+	  n1++;
+	}
+
+      for (i = n1; i <= n2; i++)
+	{
+	  e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+	  if (jn)
+	    mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
+	  else
+	    mpfr_set_inf (e->value.real, -1);
+	  gfc_constructor_append_expr (&result->value.constructor, e,
+				       &x->where);
+	}
+
+      return result;
+    }
+
+  /* Use the faster but more verbose recurrence algorithm. Bessel functions
+     are stable for downward recursion and Neumann functions are stable
+     for upward recursion. It is
+       x2rev = 2.0/x,
+       J(N-1, x) = x2rev * N * J(N, x) - J(N+1, x),
+       Y(N+1, x) = x2rev * N * Y(N, x) - Y(N-1, x).
+     Cf. http://dlmf.nist.gov/10.74#iv and http://dlmf.nist.gov/10.6#E1  */
+
+  gfc_set_model_kind (x->ts.kind);
+
+  /* Get first recursion anchor.  */
+
+  mpfr_init (last1);
+  if (jn)
+    mpfr_jn (last1, n2, x->value.real, GFC_RND_MODE);
+  else
+    mpfr_yn (last1, n1, x->value.real, GFC_RND_MODE);
+
+  e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+  mpfr_set (e->value.real, last1, GFC_RND_MODE);
+  if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
+    {
+      mpfr_clear (last1);
+      gfc_free_expr (e);
+      gfc_free_expr (result);
+      return &gfc_bad_expr;
+    }
+  gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
+
+  if (n1 == n2)
+    {
+      mpfr_clear (last1);
+      return result;
+    }
+
+  /* Get second recursion anchor.  */
+
+  mpfr_init (last2);
+  if (jn)
+    mpfr_jn (last2, n2-1, x->value.real, GFC_RND_MODE);
+  else
+    mpfr_yn (last2, n1+1, x->value.real, GFC_RND_MODE);
+
+  e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+  mpfr_set (e->value.real, last2, GFC_RND_MODE);
+  if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
+    {
+      mpfr_clear (last1);
+      mpfr_clear (last2);
+      gfc_free_expr (e);
+      gfc_free_expr (result);
+      return &gfc_bad_expr;
+    }
+  if (jn)
+    gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, -2);
+  else
+    gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
+
+  if (n1 + 1 == n2)
+    {
+      mpfr_clear (last1);
+      mpfr_clear (last2);
+      return result;
+    }
+
+  /* Start actual recursion.  */
+
+  mpfr_init (x2rev);
+  mpfr_ui_div (x2rev, 2, x->value.real, GFC_RND_MODE);
+
+  for (i = 2; i <= n2-n1; i++)
+    {
+      e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+      /* Special case: For YN, if the previous N gave -INF, set
+	 also N+1 to -INF.  */
+      if (!jn && !gfc_option.flag_range_check && mpfr_inf_p (last2))
+	{
+	  mpfr_set_inf (e->value.real, -1);
+	  gfc_constructor_append_expr (&result->value.constructor, e,
+				       &x->where);
+	  continue;
+	}
+
+      mpfr_mul_si (e->value.real, x2rev, jn ? (n2-i+1) : (n1+i-1),
+		   GFC_RND_MODE);
+      mpfr_mul (e->value.real, e->value.real, last2, GFC_RND_MODE);
+      mpfr_sub (e->value.real, e->value.real, last1, GFC_RND_MODE);
+
+      if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
+	{
+	  /* Range_check frees "e" in that case.  */
+	  e = NULL;
+	  goto error;
+	}
+
+      if (jn)
+	gfc_constructor_insert_expr (&result->value.constructor, e, &x->where,
+				     -i-1);
+      else
+	gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
+
+      mpfr_set (last1, last2, GFC_RND_MODE);
+      mpfr_set (last2, e->value.real, GFC_RND_MODE);
+    }
+
+  mpfr_clear (last1);
+  mpfr_clear (last2);
+  mpfr_clear (x2rev);
+  return result;
+
+error:
+  mpfr_clear (last1);
+  mpfr_clear (last2);
+  mpfr_clear (x2rev);
+  gfc_free_expr (e);
+  gfc_free_expr (result);
+  return &gfc_bad_expr;
+}
+
+
+gfc_expr *
+gfc_simplify_bessel_jn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x)
+{
+  return gfc_simplify_bessel_n2 (order1, order2, x, true);
+}
+
+
+gfc_expr *
+gfc_simplify_bessel_y0 (gfc_expr *x)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+  mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE);
+
+  return range_check (result, "BESSEL_Y0");
+}
+
+
+gfc_expr *
+gfc_simplify_bessel_y1 (gfc_expr *x)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+  mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE);
+
+  return range_check (result, "BESSEL_Y1");
+}
+
+
+gfc_expr *
+gfc_simplify_bessel_yn (gfc_expr *order, gfc_expr *x)
+{
+  gfc_expr *result;
+  long n;
+
+  if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  n = mpz_get_si (order->value.integer);
+  result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+  mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE);
+
+  return range_check (result, "BESSEL_YN");
+}
+
+
+gfc_expr *
+gfc_simplify_bessel_yn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x)
+{
+  return gfc_simplify_bessel_n2 (order1, order2, x, false);
+}
+
+
+gfc_expr *
+gfc_simplify_bit_size (gfc_expr *e)
+{
+  int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+  return gfc_get_int_expr (e->ts.kind, &e->where,
+			   gfc_integer_kinds[i].bit_size);
+}
+
+
+gfc_expr *
+gfc_simplify_btest (gfc_expr *e, gfc_expr *bit)
+{
+  int b;
+
+  if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  if (gfc_extract_int (bit, &b) != NULL || b < 0)
+    return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, false);
+
+  return gfc_get_logical_expr (gfc_default_logical_kind, &e->where,
+			       mpz_tstbit (e->value.integer, b));
+}
+
+
+static int
+compare_bitwise (gfc_expr *i, gfc_expr *j)
+{
+  mpz_t x, y;
+  int k, res;
+
+  gcc_assert (i->ts.type == BT_INTEGER);
+  gcc_assert (j->ts.type == BT_INTEGER);
+
+  mpz_init_set (x, i->value.integer);
+  k = gfc_validate_kind (i->ts.type, i->ts.kind, false);
+  convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
+
+  mpz_init_set (y, j->value.integer);
+  k = gfc_validate_kind (j->ts.type, j->ts.kind, false);
+  convert_mpz_to_unsigned (y, gfc_integer_kinds[k].bit_size);
+
+  res = mpz_cmp (x, y);
+  mpz_clear (x);
+  mpz_clear (y);
+  return res;
+}
+
+
+gfc_expr *
+gfc_simplify_bge (gfc_expr *i, gfc_expr *j)
+{
+  if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
+			       compare_bitwise (i, j) >= 0);
+}
+
+
+gfc_expr *
+gfc_simplify_bgt (gfc_expr *i, gfc_expr *j)
+{
+  if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
+			       compare_bitwise (i, j) > 0);
+}
+
+
+gfc_expr *
+gfc_simplify_ble (gfc_expr *i, gfc_expr *j)
+{
+  if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
+			       compare_bitwise (i, j) <= 0);
+}
+
+
+gfc_expr *
+gfc_simplify_blt (gfc_expr *i, gfc_expr *j)
+{
+  if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
+			       compare_bitwise (i, j) < 0);
+}
+
+
+gfc_expr *
+gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
+{
+  gfc_expr *ceil, *result;
+  int kind;
+
+  kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind);
+  if (kind == -1)
+    return &gfc_bad_expr;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  ceil = gfc_copy_expr (e);
+  mpfr_ceil (ceil->value.real, e->value.real);
+
+  result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
+  gfc_mpfr_to_mpz (result->value.integer, ceil->value.real, &e->where);
+
+  gfc_free_expr (ceil);
+
+  return range_check (result, "CEILING");
+}
+
+
+gfc_expr *
+gfc_simplify_char (gfc_expr *e, gfc_expr *k)
+{
+  return simplify_achar_char (e, k, "CHAR", false);
+}
+
+
+/* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX.  */
+
+static gfc_expr *
+simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
+{
+  gfc_expr *result;
+
+  if (convert_boz (x, kind) == &gfc_bad_expr)
+    return &gfc_bad_expr;
+
+  if (convert_boz (y, kind) == &gfc_bad_expr)
+    return &gfc_bad_expr;
+
+  if (x->expr_type != EXPR_CONSTANT
+      || (y != NULL && y->expr_type != EXPR_CONSTANT))
+    return NULL;
+
+  result = gfc_get_constant_expr (BT_COMPLEX, kind, &x->where);
+
+  switch (x->ts.type)
+    {
+      case BT_INTEGER:
+	mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE);
+	break;
+
+      case BT_REAL:
+	mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE);
+	break;
+
+      case BT_COMPLEX:
+	mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+	break;
+
+      default:
+	gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
+    }
+
+  if (!y)
+    return range_check (result, name);
+
+  switch (y->ts.type)
+    {
+      case BT_INTEGER:
+	mpfr_set_z (mpc_imagref (result->value.complex),
+		    y->value.integer, GFC_RND_MODE);
+	break;
+
+      case BT_REAL:
+	mpfr_set (mpc_imagref (result->value.complex),
+		  y->value.real, GFC_RND_MODE);
+	break;
+
+      default:
+	gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
+    }
+
+  return range_check (result, name);
+}
+
+
+gfc_expr *
+gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
+{
+  int kind;
+
+  kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_complex_kind);
+  if (kind == -1)
+    return &gfc_bad_expr;
+
+  return simplify_cmplx ("CMPLX", x, y, kind);
+}
+
+
+gfc_expr *
+gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
+{
+  int kind;
+
+  if (x->ts.type == BT_INTEGER && y->ts.type == BT_INTEGER)
+    kind = gfc_default_complex_kind;
+  else if (x->ts.type == BT_REAL || y->ts.type == BT_INTEGER)
+    kind = x->ts.kind;
+  else if (x->ts.type == BT_INTEGER || y->ts.type == BT_REAL)
+    kind = y->ts.kind;
+  else if (x->ts.type == BT_REAL && y->ts.type == BT_REAL)
+    kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
+  else
+    gcc_unreachable ();
+
+  return simplify_cmplx ("COMPLEX", x, y, kind);
+}
+
+
+gfc_expr *
+gfc_simplify_conjg (gfc_expr *e)
+{
+  gfc_expr *result;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_copy_expr (e);
+  mpc_conj (result->value.complex, result->value.complex, GFC_MPC_RND_MODE);
+
+  return range_check (result, "CONJG");
+}
+
+
+gfc_expr *
+gfc_simplify_cos (gfc_expr *x)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+  switch (x->ts.type)
+    {
+      case BT_REAL:
+	mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
+	break;
+
+      case BT_COMPLEX:
+	gfc_set_model_kind (x->ts.kind);
+	mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+	break;
+
+      default:
+	gfc_internal_error ("in gfc_simplify_cos(): Bad type");
+    }
+
+  return range_check (result, "COS");
+}
+
+
+gfc_expr *
+gfc_simplify_cosh (gfc_expr *x)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+  switch (x->ts.type)
+    {
+      case BT_REAL:
+	mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
+	break;
+
+      case BT_COMPLEX:
+	mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+	break;
+
+      default:
+	gcc_unreachable ();
+    }
+
+  return range_check (result, "COSH");
+}
+
+
+gfc_expr *
+gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
+{
+  gfc_expr *result;
+
+  if (!is_constant_array_expr (mask)
+      || !gfc_is_constant_expr (dim)
+      || !gfc_is_constant_expr (kind))
+    return NULL;
+
+  result = transformational_result (mask, dim,
+				    BT_INTEGER,
+				    get_kind (BT_INTEGER, kind, "COUNT",
+					      gfc_default_integer_kind),
+				    &mask->where);
+
+  init_result_expr (result, 0, NULL);
+
+  /* Passing MASK twice, once as data array, once as mask.
+     Whenever gfc_count is called, '1' is added to the result.  */
+  return !dim || mask->rank == 1 ?
+    simplify_transformation_to_scalar (result, mask, mask, gfc_count) :
+    simplify_transformation_to_array (result, mask, dim, mask, gfc_count, NULL);
+}
+
+
+gfc_expr *
+gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
+{
+  return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
+}
+
+
+gfc_expr *
+gfc_simplify_dble (gfc_expr *e)
+{
+  gfc_expr *result = NULL;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  if (convert_boz (e, gfc_default_double_kind) == &gfc_bad_expr)
+    return &gfc_bad_expr;
+
+  result = gfc_convert_constant (e, BT_REAL, gfc_default_double_kind);
+  if (result == &gfc_bad_expr)
+    return &gfc_bad_expr;
+
+  return range_check (result, "DBLE");
+}
+
+
+gfc_expr *
+gfc_simplify_digits (gfc_expr *x)
+{
+  int i, digits;
+
+  i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
+
+  switch (x->ts.type)
+    {
+      case BT_INTEGER:
+	digits = gfc_integer_kinds[i].digits;
+	break;
+
+      case BT_REAL:
+      case BT_COMPLEX:
+	digits = gfc_real_kinds[i].digits;
+	break;
+
+      default:
+	gcc_unreachable ();
+    }
+
+  return gfc_get_int_expr (gfc_default_integer_kind, NULL, digits);
+}
+
+
+gfc_expr *
+gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
+{
+  gfc_expr *result;
+  int kind;
+
+  if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
+  result = gfc_get_constant_expr (x->ts.type, kind, &x->where);
+
+  switch (x->ts.type)
+    {
+      case BT_INTEGER:
+	if (mpz_cmp (x->value.integer, y->value.integer) > 0)
+	  mpz_sub (result->value.integer, x->value.integer, y->value.integer);
+	else
+	  mpz_set_ui (result->value.integer, 0);
+
+	break;
+
+      case BT_REAL:
+	if (mpfr_cmp (x->value.real, y->value.real) > 0)
+	  mpfr_sub (result->value.real, x->value.real, y->value.real,
+		    GFC_RND_MODE);
+	else
+	  mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
+
+	break;
+
+      default:
+	gfc_internal_error ("gfc_simplify_dim(): Bad type");
+    }
+
+  return range_check (result, "DIM");
+}
+
+
+gfc_expr*
+gfc_simplify_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
+{
+  if (!is_constant_array_expr (vector_a)
+      || !is_constant_array_expr (vector_b))
+    return NULL;
+
+  gcc_assert (vector_a->rank == 1);
+  gcc_assert (vector_b->rank == 1);
+  gcc_assert (gfc_compare_types (&vector_a->ts, &vector_b->ts));
+
+  return compute_dot_product (vector_a, 1, 0, vector_b, 1, 0, true);
+}
+
+
+gfc_expr *
+gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
+{
+  gfc_expr *a1, *a2, *result;
+
+  if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  a1 = gfc_real2real (x, gfc_default_double_kind);
+  a2 = gfc_real2real (y, gfc_default_double_kind);
+
+  result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &x->where);
+  mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE);
+
+  gfc_free_expr (a2);
+  gfc_free_expr (a1);
+
+  return range_check (result, "DPROD");
+}
+
+
+static gfc_expr *
+simplify_dshift (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg,
+		      bool right)
+{
+  gfc_expr *result;
+  int i, k, size, shift;
+
+  if (arg1->expr_type != EXPR_CONSTANT || arg2->expr_type != EXPR_CONSTANT
+      || shiftarg->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  k = gfc_validate_kind (BT_INTEGER, arg1->ts.kind, false);
+  size = gfc_integer_kinds[k].bit_size;
+
+  gfc_extract_int (shiftarg, &shift);
+
+  /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT).  */
+  if (right)
+    shift = size - shift;
+
+  result = gfc_get_constant_expr (BT_INTEGER, arg1->ts.kind, &arg1->where);
+  mpz_set_ui (result->value.integer, 0);
+
+  for (i = 0; i < shift; i++)
+    if (mpz_tstbit (arg2->value.integer, size - shift + i))
+      mpz_setbit (result->value.integer, i);
+
+  for (i = 0; i < size - shift; i++)
+    if (mpz_tstbit (arg1->value.integer, i))
+      mpz_setbit (result->value.integer, shift + i);
+
+  /* Convert to a signed value.  */
+  convert_mpz_to_signed (result->value.integer, size);
+
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_dshiftr (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg)
+{
+  return simplify_dshift (arg1, arg2, shiftarg, true);
+}
+
+
+gfc_expr *
+gfc_simplify_dshiftl (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg)
+{
+  return simplify_dshift (arg1, arg2, shiftarg, false);
+}
+
+
+gfc_expr *
+gfc_simplify_erf (gfc_expr *x)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+  mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE);
+
+  return range_check (result, "ERF");
+}
+
+
+gfc_expr *
+gfc_simplify_erfc (gfc_expr *x)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+  mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE);
+
+  return range_check (result, "ERFC");
+}
+
+
+/* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2).  */
+
+#define MAX_ITER 200
+#define ARG_LIMIT 12
+
+/* Calculate ERFC_SCALED directly by its definition:
+
+     ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
+
+   using a large precision for intermediate results.  This is used for all
+   but large values of the argument.  */
+static void
+fullprec_erfc_scaled (mpfr_t res, mpfr_t arg)
+{
+  mp_prec_t prec;
+  mpfr_t a, b;
+
+  prec = mpfr_get_default_prec ();
+  mpfr_set_default_prec (10 * prec);
+
+  mpfr_init (a);
+  mpfr_init (b);
+
+  mpfr_set (a, arg, GFC_RND_MODE);
+  mpfr_sqr (b, a, GFC_RND_MODE);
+  mpfr_exp (b, b, GFC_RND_MODE);
+  mpfr_erfc (a, a, GFC_RND_MODE);
+  mpfr_mul (a, a, b, GFC_RND_MODE);
+
+  mpfr_set (res, a, GFC_RND_MODE);
+  mpfr_set_default_prec (prec);
+
+  mpfr_clear (a);
+  mpfr_clear (b);
+}
+
+/* Calculate ERFC_SCALED using a power series expansion in 1/arg:
+
+    ERFC_SCALED(x) = 1 / (x * sqrt(pi))
+                     * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
+                                          / (2 * x**2)**n)
+
+  This is used for large values of the argument.  Intermediate calculations
+  are performed with twice the precision.  We don't do a fixed number of
+  iterations of the sum, but stop when it has converged to the required
+  precision.  */
+static void
+asympt_erfc_scaled (mpfr_t res, mpfr_t arg)
+{
+  mpfr_t sum, x, u, v, w, oldsum, sumtrunc;
+  mpz_t num;
+  mp_prec_t prec;
+  unsigned i;
+
+  prec = mpfr_get_default_prec ();
+  mpfr_set_default_prec (2 * prec);
+
+  mpfr_init (sum);
+  mpfr_init (x);
+  mpfr_init (u);
+  mpfr_init (v);
+  mpfr_init (w);
+  mpz_init (num);
+
+  mpfr_init (oldsum);
+  mpfr_init (sumtrunc);
+  mpfr_set_prec (oldsum, prec);
+  mpfr_set_prec (sumtrunc, prec);
+
+  mpfr_set (x, arg, GFC_RND_MODE);
+  mpfr_set_ui (sum, 1, GFC_RND_MODE);
+  mpz_set_ui (num, 1);
+
+  mpfr_set (u, x, GFC_RND_MODE);
+  mpfr_sqr (u, u, GFC_RND_MODE);
+  mpfr_mul_ui (u, u, 2, GFC_RND_MODE);
+  mpfr_pow_si (u, u, -1, GFC_RND_MODE);
+
+  for (i = 1; i < MAX_ITER; i++)
+  {
+    mpfr_set (oldsum, sum, GFC_RND_MODE);
+
+    mpz_mul_ui (num, num, 2 * i - 1);
+    mpz_neg (num, num);
+
+    mpfr_set (w, u, GFC_RND_MODE);
+    mpfr_pow_ui (w, w, i, GFC_RND_MODE);
+
+    mpfr_set_z (v, num, GFC_RND_MODE);
+    mpfr_mul (v, v, w, GFC_RND_MODE);
+
+    mpfr_add (sum, sum, v, GFC_RND_MODE);
+
+    mpfr_set (sumtrunc, sum, GFC_RND_MODE);
+    if (mpfr_cmp (sumtrunc, oldsum) == 0)
+      break;
+  }
+
+  /* We should have converged by now; otherwise, ARG_LIMIT is probably
+     set too low.  */
+  gcc_assert (i < MAX_ITER);
+
+  /* Divide by x * sqrt(Pi).  */
+  mpfr_const_pi (u, GFC_RND_MODE);
+  mpfr_sqrt (u, u, GFC_RND_MODE);
+  mpfr_mul (u, u, x, GFC_RND_MODE);
+  mpfr_div (sum, sum, u, GFC_RND_MODE);
+
+  mpfr_set (res, sum, GFC_RND_MODE);
+  mpfr_set_default_prec (prec);
+
+  mpfr_clears (sum, x, u, v, w, oldsum, sumtrunc, NULL);
+  mpz_clear (num);
+}
+
+
+gfc_expr *
+gfc_simplify_erfc_scaled (gfc_expr *x)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+  if (mpfr_cmp_d (x->value.real, ARG_LIMIT) >= 0)
+    asympt_erfc_scaled (result->value.real, x->value.real);
+  else
+    fullprec_erfc_scaled (result->value.real, x->value.real);
+
+  return range_check (result, "ERFC_SCALED");
+}
+
+#undef MAX_ITER
+#undef ARG_LIMIT
+
+
+gfc_expr *
+gfc_simplify_epsilon (gfc_expr *e)
+{
+  gfc_expr *result;
+  int i;
+
+  i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+
+  result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
+  mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
+
+  return range_check (result, "EPSILON");
+}
+
+
+gfc_expr *
+gfc_simplify_exp (gfc_expr *x)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+  switch (x->ts.type)
+    {
+      case BT_REAL:
+	mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
+	break;
+
+      case BT_COMPLEX:
+	gfc_set_model_kind (x->ts.kind);
+	mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+	break;
+
+      default:
+	gfc_internal_error ("in gfc_simplify_exp(): Bad type");
+    }
+
+  return range_check (result, "EXP");
+}
+
+
+gfc_expr *
+gfc_simplify_exponent (gfc_expr *x)
+{
+  int i;
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+				  &x->where);
+
+  gfc_set_model (x->value.real);
+
+  if (mpfr_sgn (x->value.real) == 0)
+    {
+      mpz_set_ui (result->value.integer, 0);
+      return result;
+    }
+
+  i = (int) mpfr_get_exp (x->value.real);
+  mpz_set_si (result->value.integer, i);
+
+  return range_check (result, "EXPONENT");
+}
+
+
+gfc_expr *
+gfc_simplify_float (gfc_expr *a)
+{
+  gfc_expr *result;
+
+  if (a->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  if (a->is_boz)
+    {
+      if (convert_boz (a, gfc_default_real_kind) == &gfc_bad_expr)
+	return &gfc_bad_expr;
+
+      result = gfc_copy_expr (a);
+    }
+  else
+    result = gfc_int2real (a, gfc_default_real_kind);
+
+  return range_check (result, "FLOAT");
+}
+
+
+static bool
+is_last_ref_vtab (gfc_expr *e)
+{
+  gfc_ref *ref;
+  gfc_component *comp = NULL;
+
+  if (e->expr_type != EXPR_VARIABLE)
+    return false;
+
+  for (ref = e->ref; ref; ref = ref->next)
+    if (ref->type == REF_COMPONENT)
+      comp = ref->u.c.component;
+
+  if (!e->ref || !comp)
+    return e->symtree->n.sym->attr.vtab;
+
+  if (comp->name[0] == '_' && strcmp (comp->name, "_vptr") == 0)
+    return true;
+
+  return false;
+}
+
+
+gfc_expr *
+gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold)
+{
+  /* Avoid simplification of resolved symbols.  */
+  if (is_last_ref_vtab (a) || is_last_ref_vtab (mold))
+    return NULL;
+
+  if (a->ts.type == BT_DERIVED && mold->ts.type == BT_DERIVED)
+    return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
+				 gfc_type_is_extension_of (mold->ts.u.derived,
+							   a->ts.u.derived));
+
+  if (UNLIMITED_POLY (a) || UNLIMITED_POLY (mold))
+    return NULL;
+
+  /* Return .false. if the dynamic type can never be the same.  */
+  if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS
+       && !gfc_type_is_extension_of
+			(mold->ts.u.derived->components->ts.u.derived,
+			 a->ts.u.derived->components->ts.u.derived)
+       && !gfc_type_is_extension_of
+			(a->ts.u.derived->components->ts.u.derived,
+			 mold->ts.u.derived->components->ts.u.derived))
+      || (a->ts.type == BT_DERIVED && mold->ts.type == BT_CLASS
+	  && !gfc_type_is_extension_of
+			(a->ts.u.derived,
+			 mold->ts.u.derived->components->ts.u.derived)
+	  && !gfc_type_is_extension_of
+			(mold->ts.u.derived->components->ts.u.derived,
+			 a->ts.u.derived))
+      || (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED
+	  && !gfc_type_is_extension_of
+			(mold->ts.u.derived,
+			 a->ts.u.derived->components->ts.u.derived)))
+    return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
+
+  if (mold->ts.type == BT_DERIVED
+      && gfc_type_is_extension_of (mold->ts.u.derived,
+				   a->ts.u.derived->components->ts.u.derived))
+    return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, true);
+
+  return NULL;
+}
+
+
+gfc_expr *
+gfc_simplify_same_type_as (gfc_expr *a, gfc_expr *b)
+{
+  /* Avoid simplification of resolved symbols.  */
+  if (is_last_ref_vtab (a) || is_last_ref_vtab (b))
+    return NULL;
+
+  /* Return .false. if the dynamic type can never be the
+     same.  */
+  if (((a->ts.type == BT_CLASS && gfc_expr_attr (a).class_ok)
+       || (b->ts.type == BT_CLASS && gfc_expr_attr (b).class_ok))
+      && !gfc_type_compatible (&a->ts, &b->ts)
+      && !gfc_type_compatible (&b->ts, &a->ts))
+    return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
+
+  if (a->ts.type != BT_DERIVED || b->ts.type != BT_DERIVED)
+     return NULL;
+
+  return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
+			       gfc_compare_derived_types (a->ts.u.derived,
+							  b->ts.u.derived));
+}
+
+
+gfc_expr *
+gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
+{
+  gfc_expr *result;
+  mpfr_t floor;
+  int kind;
+
+  kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
+  if (kind == -1)
+    gfc_internal_error ("gfc_simplify_floor(): Bad kind");
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  gfc_set_model_kind (kind);
+
+  mpfr_init (floor);
+  mpfr_floor (floor, e->value.real);
+
+  result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
+  gfc_mpfr_to_mpz (result->value.integer, floor, &e->where);
+
+  mpfr_clear (floor);
+
+  return range_check (result, "FLOOR");
+}
+
+
+gfc_expr *
+gfc_simplify_fraction (gfc_expr *x)
+{
+  gfc_expr *result;
+
+#if MPFR_VERSION < MPFR_VERSION_NUM(3,1,0)
+  mpfr_t absv, exp, pow2;
+#else
+  mpfr_exp_t e;
+#endif
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
+
+#if MPFR_VERSION < MPFR_VERSION_NUM(3,1,0)
+
+  /* MPFR versions before 3.1.0 do not include mpfr_frexp.  
+     TODO: remove the kludge when MPFR 3.1.0 or newer will be required */
+
+  if (mpfr_sgn (x->value.real) == 0)
+    {
+      mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
+      return result;
+    }
+
+  gfc_set_model_kind (x->ts.kind);
+  mpfr_init (exp);
+  mpfr_init (absv);
+  mpfr_init (pow2);
+
+  mpfr_abs (absv, x->value.real, GFC_RND_MODE);
+  mpfr_log2 (exp, absv, GFC_RND_MODE);
+
+  mpfr_trunc (exp, exp);
+  mpfr_add_ui (exp, exp, 1, GFC_RND_MODE);
+
+  mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
+
+  mpfr_div (result->value.real, x->value.real, pow2, GFC_RND_MODE);
+
+  mpfr_clears (exp, absv, pow2, NULL);
+
+#else
+
+  mpfr_frexp (&e, result->value.real, x->value.real, GFC_RND_MODE);
+
+#endif
+
+  return range_check (result, "FRACTION");
+}
+
+
+gfc_expr *
+gfc_simplify_gamma (gfc_expr *x)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+  mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE);
+
+  return range_check (result, "GAMMA");
+}
+
+
+gfc_expr *
+gfc_simplify_huge (gfc_expr *e)
+{
+  gfc_expr *result;
+  int i;
+
+  i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+  result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
+
+  switch (e->ts.type)
+    {
+      case BT_INTEGER:
+	mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
+	break;
+
+      case BT_REAL:
+	mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
+	break;
+
+      default:
+	gcc_unreachable ();
+    }
+
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_hypot (gfc_expr *x, gfc_expr *y)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+  mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
+  return range_check (result, "HYPOT");
+}
+
+
+/* We use the processor's collating sequence, because all
+   systems that gfortran currently works on are ASCII.  */
+
+gfc_expr *
+gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
+{
+  gfc_expr *result;
+  gfc_char_t index;
+  int k;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  if (e->value.character.length != 1)
+    {
+      gfc_error ("Argument of IACHAR at %L must be of length one", &e->where);
+      return &gfc_bad_expr;
+    }
+
+  index = e->value.character.string[0];
+
+  if (gfc_option.warn_surprising && index > 127)
+    gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
+		 &e->where);
+
+  k = get_kind (BT_INTEGER, kind, "IACHAR", gfc_default_integer_kind);
+  if (k == -1)
+    return &gfc_bad_expr;
+
+  result = gfc_get_int_expr (k, &e->where, index);
+
+  return range_check (result, "IACHAR");
+}
+
+
+static gfc_expr *
+do_bit_and (gfc_expr *result, gfc_expr *e)
+{
+  gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
+  gcc_assert (result->ts.type == BT_INTEGER
+	      && result->expr_type == EXPR_CONSTANT);
+
+  mpz_and (result->value.integer, result->value.integer, e->value.integer);
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_iall (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+  return simplify_transformation (array, dim, mask, -1, do_bit_and);
+}
+
+
+static gfc_expr *
+do_bit_ior (gfc_expr *result, gfc_expr *e)
+{
+  gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
+  gcc_assert (result->ts.type == BT_INTEGER
+	      && result->expr_type == EXPR_CONSTANT);
+
+  mpz_ior (result->value.integer, result->value.integer, e->value.integer);
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_iany (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+  return simplify_transformation (array, dim, mask, 0, do_bit_ior);
+}
+
+
+gfc_expr *
+gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
+  mpz_and (result->value.integer, x->value.integer, y->value.integer);
+
+  return range_check (result, "IAND");
+}
+
+
+gfc_expr *
+gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
+{
+  gfc_expr *result;
+  int k, pos;
+
+  if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  gfc_extract_int (y, &pos);
+
+  k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
+
+  result = gfc_copy_expr (x);
+
+  convert_mpz_to_unsigned (result->value.integer,
+			   gfc_integer_kinds[k].bit_size);
+
+  mpz_clrbit (result->value.integer, pos);
+
+  convert_mpz_to_signed (result->value.integer,
+			 gfc_integer_kinds[k].bit_size);
+
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
+{
+  gfc_expr *result;
+  int pos, len;
+  int i, k, bitsize;
+  int *bits;
+
+  if (x->expr_type != EXPR_CONSTANT
+      || y->expr_type != EXPR_CONSTANT
+      || z->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  gfc_extract_int (y, &pos);
+  gfc_extract_int (z, &len);
+
+  k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
+
+  bitsize = gfc_integer_kinds[k].bit_size;
+
+  if (pos + len > bitsize)
+    {
+      gfc_error ("Sum of second and third arguments of IBITS exceeds "
+		 "bit size at %L", &y->where);
+      return &gfc_bad_expr;
+    }
+
+  result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+  convert_mpz_to_unsigned (result->value.integer,
+			   gfc_integer_kinds[k].bit_size);
+
+  bits = XCNEWVEC (int, bitsize);
+
+  for (i = 0; i < bitsize; i++)
+    bits[i] = 0;
+
+  for (i = 0; i < len; i++)
+    bits[i] = mpz_tstbit (x->value.integer, i + pos);
+
+  for (i = 0; i < bitsize; i++)
+    {
+      if (bits[i] == 0)
+	mpz_clrbit (result->value.integer, i);
+      else if (bits[i] == 1)
+	mpz_setbit (result->value.integer, i);
+      else
+	gfc_internal_error ("IBITS: Bad bit");
+    }
+
+  free (bits);
+
+  convert_mpz_to_signed (result->value.integer,
+			 gfc_integer_kinds[k].bit_size);
+
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
+{
+  gfc_expr *result;
+  int k, pos;
+
+  if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  gfc_extract_int (y, &pos);
+
+  k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
+
+  result = gfc_copy_expr (x);
+
+  convert_mpz_to_unsigned (result->value.integer,
+			   gfc_integer_kinds[k].bit_size);
+
+  mpz_setbit (result->value.integer, pos);
+
+  convert_mpz_to_signed (result->value.integer,
+			 gfc_integer_kinds[k].bit_size);
+
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
+{
+  gfc_expr *result;
+  gfc_char_t index;
+  int k;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  if (e->value.character.length != 1)
+    {
+      gfc_error ("Argument of ICHAR at %L must be of length one", &e->where);
+      return &gfc_bad_expr;
+    }
+
+  index = e->value.character.string[0];
+
+  k = get_kind (BT_INTEGER, kind, "ICHAR", gfc_default_integer_kind);
+  if (k == -1)
+    return &gfc_bad_expr;
+
+  result = gfc_get_int_expr (k, &e->where, index);
+
+  return range_check (result, "ICHAR");
+}
+
+
+gfc_expr *
+gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
+  mpz_xor (result->value.integer, x->value.integer, y->value.integer);
+
+  return range_check (result, "IEOR");
+}
+
+
+gfc_expr *
+gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
+{
+  gfc_expr *result;
+  int back, len, lensub;
+  int i, j, k, count, index = 0, start;
+
+  if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT
+      || ( b != NULL && b->expr_type !=  EXPR_CONSTANT))
+    return NULL;
+
+  if (b != NULL && b->value.logical != 0)
+    back = 1;
+  else
+    back = 0;
+
+  k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind);
+  if (k == -1)
+    return &gfc_bad_expr;
+
+  result = gfc_get_constant_expr (BT_INTEGER, k, &x->where);
+
+  len = x->value.character.length;
+  lensub = y->value.character.length;
+
+  if (len < lensub)
+    {
+      mpz_set_si (result->value.integer, 0);
+      return result;
+    }
+
+  if (back == 0)
+    {
+      if (lensub == 0)
+	{
+	  mpz_set_si (result->value.integer, 1);
+	  return result;
+	}
+      else if (lensub == 1)
+	{
+	  for (i = 0; i < len; i++)
+	    {
+	      for (j = 0; j < lensub; j++)
+		{
+		  if (y->value.character.string[j]
+		      == x->value.character.string[i])
+		    {
+		      index = i + 1;
+		      goto done;
+		    }
+		}
+	    }
+	}
+      else
+	{
+	  for (i = 0; i < len; i++)
+	    {
+	      for (j = 0; j < lensub; j++)
+		{
+		  if (y->value.character.string[j]
+		      == x->value.character.string[i])
+		    {
+		      start = i;
+		      count = 0;
+
+		      for (k = 0; k < lensub; k++)
+			{
+			  if (y->value.character.string[k]
+			      == x->value.character.string[k + start])
+			    count++;
+			}
+
+		      if (count == lensub)
+			{
+			  index = start + 1;
+			  goto done;
+			}
+		    }
+		}
+	    }
+	}
+
+    }
+  else
+    {
+      if (lensub == 0)
+	{
+	  mpz_set_si (result->value.integer, len + 1);
+	  return result;
+	}
+      else if (lensub == 1)
+	{
+	  for (i = 0; i < len; i++)
+	    {
+	      for (j = 0; j < lensub; j++)
+		{
+		  if (y->value.character.string[j]
+		      == x->value.character.string[len - i])
+		    {
+		      index = len - i + 1;
+		      goto done;
+		    }
+		}
+	    }
+	}
+      else
+	{
+	  for (i = 0; i < len; i++)
+	    {
+	      for (j = 0; j < lensub; j++)
+		{
+		  if (y->value.character.string[j]
+		      == x->value.character.string[len - i])
+		    {
+		      start = len - i;
+		      if (start <= len - lensub)
+			{
+			  count = 0;
+			  for (k = 0; k < lensub; k++)
+			    if (y->value.character.string[k]
+			        == x->value.character.string[k + start])
+			      count++;
+
+			  if (count == lensub)
+			    {
+			      index = start + 1;
+			      goto done;
+			    }
+			}
+		      else
+			{
+			  continue;
+			}
+		    }
+		}
+	    }
+	}
+    }
+
+done:
+  mpz_set_si (result->value.integer, index);
+  return range_check (result, "INDEX");
+}
+
+
+static gfc_expr *
+simplify_intconv (gfc_expr *e, int kind, const char *name)
+{
+  gfc_expr *result = NULL;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_convert_constant (e, BT_INTEGER, kind);
+  if (result == &gfc_bad_expr)
+    return &gfc_bad_expr;
+
+  return range_check (result, name);
+}
+
+
+gfc_expr *
+gfc_simplify_int (gfc_expr *e, gfc_expr *k)
+{
+  int kind;
+
+  kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
+  if (kind == -1)
+    return &gfc_bad_expr;
+
+  return simplify_intconv (e, kind, "INT");
+}
+
+gfc_expr *
+gfc_simplify_int2 (gfc_expr *e)
+{
+  return simplify_intconv (e, 2, "INT2");
+}
+
+
+gfc_expr *
+gfc_simplify_int8 (gfc_expr *e)
+{
+  return simplify_intconv (e, 8, "INT8");
+}
+
+
+gfc_expr *
+gfc_simplify_long (gfc_expr *e)
+{
+  return simplify_intconv (e, 4, "LONG");
+}
+
+
+gfc_expr *
+gfc_simplify_ifix (gfc_expr *e)
+{
+  gfc_expr *rtrunc, *result;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  rtrunc = gfc_copy_expr (e);
+  mpfr_trunc (rtrunc->value.real, e->value.real);
+
+  result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+				  &e->where);
+  gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
+
+  gfc_free_expr (rtrunc);
+
+  return range_check (result, "IFIX");
+}
+
+
+gfc_expr *
+gfc_simplify_idint (gfc_expr *e)
+{
+  gfc_expr *rtrunc, *result;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  rtrunc = gfc_copy_expr (e);
+  mpfr_trunc (rtrunc->value.real, e->value.real);
+
+  result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+				  &e->where);
+  gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
+
+  gfc_free_expr (rtrunc);
+
+  return range_check (result, "IDINT");
+}
+
+
+gfc_expr *
+gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
+  mpz_ior (result->value.integer, x->value.integer, y->value.integer);
+
+  return range_check (result, "IOR");
+}
+
+
+static gfc_expr *
+do_bit_xor (gfc_expr *result, gfc_expr *e)
+{
+  gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
+  gcc_assert (result->ts.type == BT_INTEGER
+	      && result->expr_type == EXPR_CONSTANT);
+
+  mpz_xor (result->value.integer, result->value.integer, e->value.integer);
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+  return simplify_transformation (array, dim, mask, 0, do_bit_xor);
+}
+
+
+gfc_expr *
+gfc_simplify_is_iostat_end (gfc_expr *x)
+{
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
+			       mpz_cmp_si (x->value.integer,
+					   LIBERROR_END) == 0);
+}
+
+
+gfc_expr *
+gfc_simplify_is_iostat_eor (gfc_expr *x)
+{
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
+			       mpz_cmp_si (x->value.integer,
+					   LIBERROR_EOR) == 0);
+}
+
+
+gfc_expr *
+gfc_simplify_isnan (gfc_expr *x)
+{
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
+			       mpfr_nan_p (x->value.real));
+}
+
+
+/* Performs a shift on its first argument.  Depending on the last
+   argument, the shift can be arithmetic, i.e. with filling from the
+   left like in the SHIFTA intrinsic.  */
+static gfc_expr *
+simplify_shift (gfc_expr *e, gfc_expr *s, const char *name,
+		bool arithmetic, int direction)
+{
+  gfc_expr *result;
+  int ashift, *bits, i, k, bitsize, shift;
+
+  if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  gfc_extract_int (s, &shift);
+
+  k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
+  bitsize = gfc_integer_kinds[k].bit_size;
+
+  result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
+
+  if (shift == 0)
+    {
+      mpz_set (result->value.integer, e->value.integer);
+      return result;
+    }
+
+  if (direction > 0 && shift < 0)
+    {
+      /* Left shift, as in SHIFTL.  */
+      gfc_error ("Second argument of %s is negative at %L", name, &e->where);
+      return &gfc_bad_expr;
+    }
+  else if (direction < 0)
+    {
+      /* Right shift, as in SHIFTR or SHIFTA.  */
+      if (shift < 0)
+	{
+	  gfc_error ("Second argument of %s is negative at %L",
+		     name, &e->where);
+	  return &gfc_bad_expr;
+	}
+
+      shift = -shift;
+    }
+
+  ashift = (shift >= 0 ? shift : -shift);
+
+  if (ashift > bitsize)
+    {
+      gfc_error ("Magnitude of second argument of %s exceeds bit size "
+		 "at %L", name, &e->where);
+      return &gfc_bad_expr;
+    }
+
+  bits = XCNEWVEC (int, bitsize);
+
+  for (i = 0; i < bitsize; i++)
+    bits[i] = mpz_tstbit (e->value.integer, i);
+
+  if (shift > 0)
+    {
+      /* Left shift.  */
+      for (i = 0; i < shift; i++)
+	mpz_clrbit (result->value.integer, i);
+
+      for (i = 0; i < bitsize - shift; i++)
+	{
+	  if (bits[i] == 0)
+	    mpz_clrbit (result->value.integer, i + shift);
+	  else
+	    mpz_setbit (result->value.integer, i + shift);
+	}
+    }
+  else
+    {
+      /* Right shift.  */
+      if (arithmetic && bits[bitsize - 1])
+	for (i = bitsize - 1; i >= bitsize - ashift; i--)
+	  mpz_setbit (result->value.integer, i);
+      else
+	for (i = bitsize - 1; i >= bitsize - ashift; i--)
+	  mpz_clrbit (result->value.integer, i);
+
+      for (i = bitsize - 1; i >= ashift; i--)
+	{
+	  if (bits[i] == 0)
+	    mpz_clrbit (result->value.integer, i - ashift);
+	  else
+	    mpz_setbit (result->value.integer, i - ashift);
+	}
+    }
+
+  convert_mpz_to_signed (result->value.integer, bitsize);
+  free (bits);
+
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
+{
+  return simplify_shift (e, s, "ISHFT", false, 0);
+}
+
+
+gfc_expr *
+gfc_simplify_lshift (gfc_expr *e, gfc_expr *s)
+{
+  return simplify_shift (e, s, "LSHIFT", false, 1);
+}
+
+
+gfc_expr *
+gfc_simplify_rshift (gfc_expr *e, gfc_expr *s)
+{
+  return simplify_shift (e, s, "RSHIFT", true, -1);
+}
+
+
+gfc_expr *
+gfc_simplify_shifta (gfc_expr *e, gfc_expr *s)
+{
+  return simplify_shift (e, s, "SHIFTA", true, -1);
+}
+
+
+gfc_expr *
+gfc_simplify_shiftl (gfc_expr *e, gfc_expr *s)
+{
+  return simplify_shift (e, s, "SHIFTL", false, 1);
+}
+
+
+gfc_expr *
+gfc_simplify_shiftr (gfc_expr *e, gfc_expr *s)
+{
+  return simplify_shift (e, s, "SHIFTR", false, -1);
+}
+
+
+gfc_expr *
+gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
+{
+  gfc_expr *result;
+  int shift, ashift, isize, ssize, delta, k;
+  int i, *bits;
+
+  if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  gfc_extract_int (s, &shift);
+
+  k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+  isize = gfc_integer_kinds[k].bit_size;
+
+  if (sz != NULL)
+    {
+      if (sz->expr_type != EXPR_CONSTANT)
+	return NULL;
+
+      gfc_extract_int (sz, &ssize);
+
+    }
+  else
+    ssize = isize;
+
+  if (shift >= 0)
+    ashift = shift;
+  else
+    ashift = -shift;
+
+  if (ashift > ssize)
+    {
+      if (sz == NULL)
+	gfc_error ("Magnitude of second argument of ISHFTC exceeds "
+		   "BIT_SIZE of first argument at %L", &s->where);
+      return &gfc_bad_expr;
+    }
+
+  result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
+
+  mpz_set (result->value.integer, e->value.integer);
+
+  if (shift == 0)
+    return result;
+
+  convert_mpz_to_unsigned (result->value.integer, isize);
+
+  bits = XCNEWVEC (int, ssize);
+
+  for (i = 0; i < ssize; i++)
+    bits[i] = mpz_tstbit (e->value.integer, i);
+
+  delta = ssize - ashift;
+
+  if (shift > 0)
+    {
+      for (i = 0; i < delta; i++)
+	{
+	  if (bits[i] == 0)
+	    mpz_clrbit (result->value.integer, i + shift);
+	  else
+	    mpz_setbit (result->value.integer, i + shift);
+	}
+
+      for (i = delta; i < ssize; i++)
+	{
+	  if (bits[i] == 0)
+	    mpz_clrbit (result->value.integer, i - delta);
+	  else
+	    mpz_setbit (result->value.integer, i - delta);
+	}
+    }
+  else
+    {
+      for (i = 0; i < ashift; i++)
+	{
+	  if (bits[i] == 0)
+	    mpz_clrbit (result->value.integer, i + delta);
+	  else
+	    mpz_setbit (result->value.integer, i + delta);
+	}
+
+      for (i = ashift; i < ssize; i++)
+	{
+	  if (bits[i] == 0)
+	    mpz_clrbit (result->value.integer, i + shift);
+	  else
+	    mpz_setbit (result->value.integer, i + shift);
+	}
+    }
+
+  convert_mpz_to_signed (result->value.integer, isize);
+
+  free (bits);
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_kind (gfc_expr *e)
+{
+  return gfc_get_int_expr (gfc_default_integer_kind, NULL, e->ts.kind);
+}
+
+
+static gfc_expr *
+simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
+		    gfc_array_spec *as, gfc_ref *ref, bool coarray)
+{
+  gfc_expr *l, *u, *result;
+  int k;
+
+  k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
+		gfc_default_integer_kind);
+  if (k == -1)
+    return &gfc_bad_expr;
+
+  result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
+
+  /* For non-variables, LBOUND(expr, DIM=n) = 1 and
+     UBOUND(expr, DIM=n) = SIZE(expr, DIM=n).  */
+  if (!coarray && array->expr_type != EXPR_VARIABLE)
+    {
+      if (upper)
+	{
+	  gfc_expr* dim = result;
+	  mpz_set_si (dim->value.integer, d);
+
+	  result = simplify_size (array, dim, k);
+	  gfc_free_expr (dim);
+	  if (!result)
+	    goto returnNull;
+	}
+      else
+	mpz_set_si (result->value.integer, 1);
+
+      goto done;
+    }
+
+  /* Otherwise, we have a variable expression.  */
+  gcc_assert (array->expr_type == EXPR_VARIABLE);
+  gcc_assert (as);
+
+  if (!gfc_resolve_array_spec (as, 0))
+    return NULL;
+
+  /* The last dimension of an assumed-size array is special.  */
+  if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
+      || (coarray && d == as->rank + as->corank
+	  && (!upper || gfc_option.coarray == GFC_FCOARRAY_SINGLE)))
+    {
+      if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
+	{
+	  gfc_free_expr (result);
+	  return gfc_copy_expr (as->lower[d-1]);
+	}
+
+      goto returnNull;
+    }
+
+  result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
+
+  /* Then, we need to know the extent of the given dimension.  */
+  if (coarray || ref->u.ar.type == AR_FULL)
+    {
+      l = as->lower[d-1];
+      u = as->upper[d-1];
+
+      if (l->expr_type != EXPR_CONSTANT || u == NULL
+	  || u->expr_type != EXPR_CONSTANT)
+	goto returnNull;
+
+      if (mpz_cmp (l->value.integer, u->value.integer) > 0)
+	{
+	  /* Zero extent.  */
+	  if (upper)
+	    mpz_set_si (result->value.integer, 0);
+	  else
+	    mpz_set_si (result->value.integer, 1);
+	}
+      else
+	{
+	  /* Nonzero extent.  */
+	  if (upper)
+	    mpz_set (result->value.integer, u->value.integer);
+	  else
+	    mpz_set (result->value.integer, l->value.integer);
+	}
+    }
+  else
+    {
+      if (upper)
+	{
+	  if (!gfc_ref_dimen_size (&ref->u.ar, d - 1, &result->value.integer, NULL))
+	    goto returnNull;
+	}
+      else
+	mpz_set_si (result->value.integer, (long int) 1);
+    }
+
+done:
+  return range_check (result, upper ? "UBOUND" : "LBOUND");
+
+returnNull:
+  gfc_free_expr (result);
+  return NULL;
+}
+
+
+static gfc_expr *
+simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
+{
+  gfc_ref *ref;
+  gfc_array_spec *as;
+  int d;
+
+  if (array->ts.type == BT_CLASS)
+    return NULL;
+
+  if (array->expr_type != EXPR_VARIABLE)
+    {
+      as = NULL;
+      ref = NULL;
+      goto done;
+    }
+
+  /* Follow any component references.  */
+  as = array->symtree->n.sym->as;
+  for (ref = array->ref; ref; ref = ref->next)
+    {
+      switch (ref->type)
+	{
+	case REF_ARRAY:
+	  switch (ref->u.ar.type)
+	    {
+	    case AR_ELEMENT:
+	      as = NULL;
+	      continue;
+
+	    case AR_FULL:
+	      /* We're done because 'as' has already been set in the
+		 previous iteration.  */
+	      if (!ref->next)
+		goto done;
+
+	    /* Fall through.  */
+
+	    case AR_UNKNOWN:
+	      return NULL;
+
+	    case AR_SECTION:
+	      as = ref->u.ar.as;
+	      goto done;
+	    }
+
+	  gcc_unreachable ();
+
+	case REF_COMPONENT:
+	  as = ref->u.c.component->as;
+	  continue;
+
+	case REF_SUBSTRING:
+	  continue;
+	}
+    }
+
+  gcc_unreachable ();
+
+ done:
+
+  if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE
+	     || as->type == AS_ASSUMED_RANK))
+    return NULL;
+
+  if (dim == NULL)
+    {
+      /* Multi-dimensional bounds.  */
+      gfc_expr *bounds[GFC_MAX_DIMENSIONS];
+      gfc_expr *e;
+      int k;
+
+      /* UBOUND(ARRAY) is not valid for an assumed-size array.  */
+      if (upper && as && as->type == AS_ASSUMED_SIZE)
+	{
+	  /* An error message will be emitted in
+	     check_assumed_size_reference (resolve.c).  */
+	  return &gfc_bad_expr;
+	}
+
+      /* Simplify the bounds for each dimension.  */
+      for (d = 0; d < array->rank; d++)
+	{
+	  bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref,
+					  false);
+	  if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
+	    {
+	      int j;
+
+	      for (j = 0; j < d; j++)
+		gfc_free_expr (bounds[j]);
+	      return bounds[d];
+	    }
+	}
+
+      /* Allocate the result expression.  */
+      k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
+		    gfc_default_integer_kind);
+      if (k == -1)
+	return &gfc_bad_expr;
+
+      e = gfc_get_array_expr (BT_INTEGER, k, &array->where);
+
+      /* The result is a rank 1 array; its size is the rank of the first
+	 argument to {L,U}BOUND.  */
+      e->rank = 1;
+      e->shape = gfc_get_shape (1);
+      mpz_init_set_ui (e->shape[0], array->rank);
+
+      /* Create the constructor for this array.  */
+      for (d = 0; d < array->rank; d++)
+	gfc_constructor_append_expr (&e->value.constructor,
+				     bounds[d], &e->where);
+
+      return e;
+    }
+  else
+    {
+      /* A DIM argument is specified.  */
+      if (dim->expr_type != EXPR_CONSTANT)
+	return NULL;
+
+      d = mpz_get_si (dim->value.integer);
+
+      if ((d < 1 || d > array->rank)
+	  || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper))
+	{
+	  gfc_error ("DIM argument at %L is out of bounds", &dim->where);
+	  return &gfc_bad_expr;
+	}
+
+      if (as && as->type == AS_ASSUMED_RANK)
+	return NULL;
+
+      return simplify_bound_dim (array, kind, d, upper, as, ref, false);
+    }
+}
+
+
+static gfc_expr *
+simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
+{
+  gfc_ref *ref;
+  gfc_array_spec *as;
+  int d;
+
+  if (array->expr_type != EXPR_VARIABLE)
+    return NULL;
+
+  /* Follow any component references.  */
+  as = (array->ts.type == BT_CLASS && array->ts.u.derived->components)
+       ? array->ts.u.derived->components->as
+       : array->symtree->n.sym->as;
+  for (ref = array->ref; ref; ref = ref->next)
+    {
+      switch (ref->type)
+	{
+	case REF_ARRAY:
+	  switch (ref->u.ar.type)
+	    {
+	    case AR_ELEMENT:
+	      if (ref->u.ar.as->corank > 0)
+		{
+		  gcc_assert (as == ref->u.ar.as);
+		  goto done;
+		}
+	      as = NULL;
+	      continue;
+
+	    case AR_FULL:
+	      /* We're done because 'as' has already been set in the
+		 previous iteration.  */
+	      if (!ref->next)
+	        goto done;
+
+	    /* Fall through.  */
+
+	    case AR_UNKNOWN:
+	      return NULL;
+
+	    case AR_SECTION:
+	      as = ref->u.ar.as;
+	      goto done;
+	    }
+
+	  gcc_unreachable ();
+
+	case REF_COMPONENT:
+	  as = ref->u.c.component->as;
+	  continue;
+
+	case REF_SUBSTRING:
+	  continue;
+	}
+    }
+
+  if (!as)
+    gcc_unreachable ();
+
+ done:
+
+  if (as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE)
+    return NULL;
+
+  if (dim == NULL)
+    {
+      /* Multi-dimensional cobounds.  */
+      gfc_expr *bounds[GFC_MAX_DIMENSIONS];
+      gfc_expr *e;
+      int k;
+
+      /* Simplify the cobounds for each dimension.  */
+      for (d = 0; d < as->corank; d++)
+	{
+	  bounds[d] = simplify_bound_dim (array, kind, d + 1 + as->rank,
+					  upper, as, ref, true);
+	  if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
+	    {
+	      int j;
+
+	      for (j = 0; j < d; j++)
+		gfc_free_expr (bounds[j]);
+	      return bounds[d];
+	    }
+	}
+
+      /* Allocate the result expression.  */
+      e = gfc_get_expr ();
+      e->where = array->where;
+      e->expr_type = EXPR_ARRAY;
+      e->ts.type = BT_INTEGER;
+      k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND",
+		    gfc_default_integer_kind);
+      if (k == -1)
+	{
+	  gfc_free_expr (e);
+	  return &gfc_bad_expr;
+	}
+      e->ts.kind = k;
+
+      /* The result is a rank 1 array; its size is the rank of the first
+	 argument to {L,U}COBOUND.  */
+      e->rank = 1;
+      e->shape = gfc_get_shape (1);
+      mpz_init_set_ui (e->shape[0], as->corank);
+
+      /* Create the constructor for this array.  */
+      for (d = 0; d < as->corank; d++)
+	gfc_constructor_append_expr (&e->value.constructor,
+				     bounds[d], &e->where);
+      return e;
+    }
+  else
+    {
+      /* A DIM argument is specified.  */
+      if (dim->expr_type != EXPR_CONSTANT)
+	return NULL;
+
+      d = mpz_get_si (dim->value.integer);
+
+      if (d < 1 || d > as->corank)
+	{
+	  gfc_error ("DIM argument at %L is out of bounds", &dim->where);
+	  return &gfc_bad_expr;
+	}
+
+      return simplify_bound_dim (array, kind, d+as->rank, upper, as, ref, true);
+    }
+}
+
+
+gfc_expr *
+gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
+  return simplify_bound (array, dim, kind, 0);
+}
+
+
+gfc_expr *
+gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
+  return simplify_cobound (array, dim, kind, 0);
+}
+
+gfc_expr *
+gfc_simplify_leadz (gfc_expr *e)
+{
+  unsigned long lz, bs;
+  int i;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+  bs = gfc_integer_kinds[i].bit_size;
+  if (mpz_cmp_si (e->value.integer, 0) == 0)
+    lz = bs;
+  else if (mpz_cmp_si (e->value.integer, 0) < 0)
+    lz = 0;
+  else
+    lz = bs - mpz_sizeinbase (e->value.integer, 2);
+
+  return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
+}
+
+
+gfc_expr *
+gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
+{
+  gfc_expr *result;
+  int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
+
+  if (k == -1)
+    return &gfc_bad_expr;
+
+  if (e->expr_type == EXPR_CONSTANT)
+    {
+      result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
+      mpz_set_si (result->value.integer, e->value.character.length);
+      return range_check (result, "LEN");
+    }
+  else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
+	   && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
+	   && e->ts.u.cl->length->ts.type == BT_INTEGER)
+    {
+      result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
+      mpz_set (result->value.integer, e->ts.u.cl->length->value.integer);
+      return range_check (result, "LEN");
+    }
+  else
+    return NULL;
+}
+
+
+gfc_expr *
+gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
+{
+  gfc_expr *result;
+  int count, len, i;
+  int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
+
+  if (k == -1)
+    return &gfc_bad_expr;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  len = e->value.character.length;
+  for (count = 0, i = 1; i <= len; i++)
+    if (e->value.character.string[len - i] == ' ')
+      count++;
+    else
+      break;
+
+  result = gfc_get_int_expr (k, &e->where, len - count);
+  return range_check (result, "LEN_TRIM");
+}
+
+gfc_expr *
+gfc_simplify_lgamma (gfc_expr *x)
+{
+  gfc_expr *result;
+  int sg;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+  mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
+
+  return range_check (result, "LGAMMA");
+}
+
+
+gfc_expr *
+gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
+{
+  if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
+			       gfc_compare_string (a, b) >= 0);
+}
+
+
+gfc_expr *
+gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
+{
+  if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
+			       gfc_compare_string (a, b) > 0);
+}
+
+
+gfc_expr *
+gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
+{
+  if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
+			       gfc_compare_string (a, b) <= 0);
+}
+
+
+gfc_expr *
+gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
+{
+  if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
+			       gfc_compare_string (a, b) < 0);
+}
+
+
+gfc_expr *
+gfc_simplify_log (gfc_expr *x)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+  switch (x->ts.type)
+    {
+    case BT_REAL:
+      if (mpfr_sgn (x->value.real) <= 0)
+	{
+	  gfc_error ("Argument of LOG at %L cannot be less than or equal "
+		     "to zero", &x->where);
+	  gfc_free_expr (result);
+	  return &gfc_bad_expr;
+	}
+
+      mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
+      break;
+
+    case BT_COMPLEX:
+      if ((mpfr_sgn (mpc_realref (x->value.complex)) == 0)
+	  && (mpfr_sgn (mpc_imagref (x->value.complex)) == 0))
+	{
+	  gfc_error ("Complex argument of LOG at %L cannot be zero",
+		     &x->where);
+	  gfc_free_expr (result);
+	  return &gfc_bad_expr;
+	}
+
+      gfc_set_model_kind (x->ts.kind);
+      mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+      break;
+
+    default:
+      gfc_internal_error ("gfc_simplify_log: bad type");
+    }
+
+  return range_check (result, "LOG");
+}
+
+
+gfc_expr *
+gfc_simplify_log10 (gfc_expr *x)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  if (mpfr_sgn (x->value.real) <= 0)
+    {
+      gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
+		 "to zero", &x->where);
+      return &gfc_bad_expr;
+    }
+
+  result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+  mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
+
+  return range_check (result, "LOG10");
+}
+
+
+gfc_expr *
+gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
+{
+  int kind;
+
+  kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
+  if (kind < 0)
+    return &gfc_bad_expr;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  return gfc_get_logical_expr (kind, &e->where, e->value.logical);
+}
+
+
+gfc_expr*
+gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
+{
+  gfc_expr *result;
+  int row, result_rows, col, result_columns;
+  int stride_a, offset_a, stride_b, offset_b;
+
+  if (!is_constant_array_expr (matrix_a)
+      || !is_constant_array_expr (matrix_b))
+    return NULL;
+
+  gcc_assert (gfc_compare_types (&matrix_a->ts, &matrix_b->ts));
+  result = gfc_get_array_expr (matrix_a->ts.type,
+			       matrix_a->ts.kind,
+			       &matrix_a->where);
+
+  if (matrix_a->rank == 1 && matrix_b->rank == 2)
+    {
+      result_rows = 1;
+      result_columns = mpz_get_si (matrix_b->shape[1]);
+      stride_a = 1;
+      stride_b = mpz_get_si (matrix_b->shape[0]);
+
+      result->rank = 1;
+      result->shape = gfc_get_shape (result->rank);
+      mpz_init_set_si (result->shape[0], result_columns);
+    }
+  else if (matrix_a->rank == 2 && matrix_b->rank == 1)
+    {
+      result_rows = mpz_get_si (matrix_a->shape[0]);
+      result_columns = 1;
+      stride_a = mpz_get_si (matrix_a->shape[0]);
+      stride_b = 1;
+
+      result->rank = 1;
+      result->shape = gfc_get_shape (result->rank);
+      mpz_init_set_si (result->shape[0], result_rows);
+    }
+  else if (matrix_a->rank == 2 && matrix_b->rank == 2)
+    {
+      result_rows = mpz_get_si (matrix_a->shape[0]);
+      result_columns = mpz_get_si (matrix_b->shape[1]);
+      stride_a = mpz_get_si (matrix_a->shape[0]);
+      stride_b = mpz_get_si (matrix_b->shape[0]);
+
+      result->rank = 2;
+      result->shape = gfc_get_shape (result->rank);
+      mpz_init_set_si (result->shape[0], result_rows);
+      mpz_init_set_si (result->shape[1], result_columns);
+    }
+  else
+    gcc_unreachable();
+
+  offset_a = offset_b = 0;
+  for (col = 0; col < result_columns; ++col)
+    {
+      offset_a = 0;
+
+      for (row = 0; row < result_rows; ++row)
+	{
+	  gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a,
+					     matrix_b, 1, offset_b, false);
+	  gfc_constructor_append_expr (&result->value.constructor,
+				       e, NULL);
+
+	  offset_a += 1;
+        }
+
+      offset_b += stride_b;
+    }
+
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg)
+{
+  gfc_expr *result;
+  int kind, arg, k;
+  const char *s;
+
+  if (i->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind);
+  if (kind == -1)
+    return &gfc_bad_expr;
+  k = gfc_validate_kind (BT_INTEGER, kind, false);
+
+  s = gfc_extract_int (i, &arg);
+  gcc_assert (!s);
+
+  result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
+
+  /* MASKR(n) = 2^n - 1 */
+  mpz_set_ui (result->value.integer, 1);
+  mpz_mul_2exp (result->value.integer, result->value.integer, arg);
+  mpz_sub_ui (result->value.integer, result->value.integer, 1);
+
+  convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
+
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg)
+{
+  gfc_expr *result;
+  int kind, arg, k;
+  const char *s;
+  mpz_t z;
+
+  if (i->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind);
+  if (kind == -1)
+    return &gfc_bad_expr;
+  k = gfc_validate_kind (BT_INTEGER, kind, false);
+
+  s = gfc_extract_int (i, &arg);
+  gcc_assert (!s);
+
+  result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
+
+  /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
+  mpz_init_set_ui (z, 1);
+  mpz_mul_2exp (z, z, gfc_integer_kinds[k].bit_size);
+  mpz_set_ui (result->value.integer, 1);
+  mpz_mul_2exp (result->value.integer, result->value.integer,
+		gfc_integer_kinds[k].bit_size - arg);
+  mpz_sub (result->value.integer, z, result->value.integer);
+  mpz_clear (z);
+
+  convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
+
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
+{
+  gfc_expr * result;
+  gfc_constructor *tsource_ctor, *fsource_ctor, *mask_ctor;
+
+  if (mask->expr_type == EXPR_CONSTANT)
+    return gfc_get_parentheses (gfc_copy_expr (mask->value.logical
+					       ? tsource : fsource));
+
+  if (!mask->rank || !is_constant_array_expr (mask)
+      || !is_constant_array_expr (tsource) || !is_constant_array_expr (fsource))
+    return NULL;
+
+  result = gfc_get_array_expr (tsource->ts.type, tsource->ts.kind,
+			       &tsource->where);
+  if (tsource->ts.type == BT_DERIVED)
+    result->ts.u.derived = tsource->ts.u.derived;
+  else if (tsource->ts.type == BT_CHARACTER)
+    result->ts.u.cl = tsource->ts.u.cl;
+
+  tsource_ctor = gfc_constructor_first (tsource->value.constructor);
+  fsource_ctor = gfc_constructor_first (fsource->value.constructor);
+  mask_ctor = gfc_constructor_first (mask->value.constructor);
+
+  while (mask_ctor)
+    {
+      if (mask_ctor->expr->value.logical)
+	gfc_constructor_append_expr (&result->value.constructor,
+				     gfc_copy_expr (tsource_ctor->expr),
+				     NULL);
+      else
+	gfc_constructor_append_expr (&result->value.constructor,
+				     gfc_copy_expr (fsource_ctor->expr),
+				     NULL);
+      tsource_ctor = gfc_constructor_next (tsource_ctor);
+      fsource_ctor = gfc_constructor_next (fsource_ctor);
+      mask_ctor = gfc_constructor_next (mask_ctor);
+    }
+
+  result->shape = gfc_get_shape (1);
+  gfc_array_size (result, &result->shape[0]);
+
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr)
+{
+  mpz_t arg1, arg2, mask;
+  gfc_expr *result;
+
+  if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT
+      || mask_expr->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (BT_INTEGER, i->ts.kind, &i->where);
+
+  /* Convert all argument to unsigned.  */
+  mpz_init_set (arg1, i->value.integer);
+  mpz_init_set (arg2, j->value.integer);
+  mpz_init_set (mask, mask_expr->value.integer);
+
+  /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))).  */
+  mpz_and (arg1, arg1, mask);
+  mpz_com (mask, mask);
+  mpz_and (arg2, arg2, mask);
+  mpz_ior (result->value.integer, arg1, arg2);
+
+  mpz_clear (arg1);
+  mpz_clear (arg2);
+  mpz_clear (mask);
+
+  return result;
+}
+
+
+/* Selects between current value and extremum for simplify_min_max
+   and simplify_minval_maxval.  */
+static void
+min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign)
+{
+  switch (arg->ts.type)
+    {
+      case BT_INTEGER:
+	if (mpz_cmp (arg->value.integer,
+			extremum->value.integer) * sign > 0)
+	mpz_set (extremum->value.integer, arg->value.integer);
+	break;
+
+      case BT_REAL:
+	/* We need to use mpfr_min and mpfr_max to treat NaN properly.  */
+	if (sign > 0)
+	  mpfr_max (extremum->value.real, extremum->value.real,
+		      arg->value.real, GFC_RND_MODE);
+	else
+	  mpfr_min (extremum->value.real, extremum->value.real,
+		      arg->value.real, GFC_RND_MODE);
+	break;
+
+      case BT_CHARACTER:
+#define LENGTH(x) ((x)->value.character.length)
+#define STRING(x) ((x)->value.character.string)
+	if (LENGTH (extremum) < LENGTH(arg))
+	  {
+	    gfc_char_t *tmp = STRING(extremum);
+
+	    STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
+	    memcpy (STRING(extremum), tmp,
+		      LENGTH(extremum) * sizeof (gfc_char_t));
+	    gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
+			       LENGTH(arg) - LENGTH(extremum));
+	    STRING(extremum)[LENGTH(arg)] = '\0';  /* For debugger  */
+	    LENGTH(extremum) = LENGTH(arg);
+	    free (tmp);
+	  }
+
+	if (gfc_compare_string (arg, extremum) * sign > 0)
+	  {
+	    free (STRING(extremum));
+	    STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
+	    memcpy (STRING(extremum), STRING(arg),
+		      LENGTH(arg) * sizeof (gfc_char_t));
+	    gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
+			       LENGTH(extremum) - LENGTH(arg));
+	    STRING(extremum)[LENGTH(extremum)] = '\0';  /* For debugger  */
+	  }
+#undef LENGTH
+#undef STRING
+	break;
+
+      default:
+	gfc_internal_error ("simplify_min_max(): Bad type in arglist");
+    }
+}
+
+
+/* This function is special since MAX() can take any number of
+   arguments.  The simplified expression is a rewritten version of the
+   argument list containing at most one constant element.  Other
+   constant elements are deleted.  Because the argument list has
+   already been checked, this function always succeeds.  sign is 1 for
+   MAX(), -1 for MIN().  */
+
+static gfc_expr *
+simplify_min_max (gfc_expr *expr, int sign)
+{
+  gfc_actual_arglist *arg, *last, *extremum;
+  gfc_intrinsic_sym * specific;
+
+  last = NULL;
+  extremum = NULL;
+  specific = expr->value.function.isym;
+
+  arg = expr->value.function.actual;
+
+  for (; arg; last = arg, arg = arg->next)
+    {
+      if (arg->expr->expr_type != EXPR_CONSTANT)
+	continue;
+
+      if (extremum == NULL)
+	{
+	  extremum = arg;
+	  continue;
+	}
+
+      min_max_choose (arg->expr, extremum->expr, sign);
+
+      /* Delete the extra constant argument.  */
+      last->next = arg->next;
+
+      arg->next = NULL;
+      gfc_free_actual_arglist (arg);
+      arg = last;
+    }
+
+  /* If there is one value left, replace the function call with the
+     expression.  */
+  if (expr->value.function.actual->next != NULL)
+    return NULL;
+
+  /* Convert to the correct type and kind.  */
+  if (expr->ts.type != BT_UNKNOWN)
+    return gfc_convert_constant (expr->value.function.actual->expr,
+	expr->ts.type, expr->ts.kind);
+
+  if (specific->ts.type != BT_UNKNOWN)
+    return gfc_convert_constant (expr->value.function.actual->expr,
+	specific->ts.type, specific->ts.kind);
+
+  return gfc_copy_expr (expr->value.function.actual->expr);
+}
+
+
+gfc_expr *
+gfc_simplify_min (gfc_expr *e)
+{
+  return simplify_min_max (e, -1);
+}
+
+
+gfc_expr *
+gfc_simplify_max (gfc_expr *e)
+{
+  return simplify_min_max (e, 1);
+}
+
+
+/* This is a simplified version of simplify_min_max to provide
+   simplification of minval and maxval for a vector.  */
+
+static gfc_expr *
+simplify_minval_maxval (gfc_expr *expr, int sign)
+{
+  gfc_constructor *c, *extremum;
+  gfc_intrinsic_sym * specific;
+
+  extremum = NULL;
+  specific = expr->value.function.isym;
+
+  for (c = gfc_constructor_first (expr->value.constructor);
+       c; c = gfc_constructor_next (c))
+    {
+      if (c->expr->expr_type != EXPR_CONSTANT)
+	return NULL;
+
+      if (extremum == NULL)
+	{
+	  extremum = c;
+	  continue;
+	}
+
+      min_max_choose (c->expr, extremum->expr, sign);
+     }
+
+  if (extremum == NULL)
+    return NULL;
+
+  /* Convert to the correct type and kind.  */
+  if (expr->ts.type != BT_UNKNOWN)
+    return gfc_convert_constant (extremum->expr,
+	expr->ts.type, expr->ts.kind);
+
+  if (specific->ts.type != BT_UNKNOWN)
+    return gfc_convert_constant (extremum->expr,
+	specific->ts.type, specific->ts.kind);
+
+  return gfc_copy_expr (extremum->expr);
+}
+
+
+gfc_expr *
+gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
+{
+  if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
+    return NULL;
+
+  return simplify_minval_maxval (array, -1);
+}
+
+
+gfc_expr *
+gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
+{
+  if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
+    return NULL;
+
+  return simplify_minval_maxval (array, 1);
+}
+
+
+gfc_expr *
+gfc_simplify_maxexponent (gfc_expr *x)
+{
+  int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
+  return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
+			   gfc_real_kinds[i].max_exponent);
+}
+
+
+gfc_expr *
+gfc_simplify_minexponent (gfc_expr *x)
+{
+  int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
+  return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
+			   gfc_real_kinds[i].min_exponent);
+}
+
+
+gfc_expr *
+gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
+{
+  gfc_expr *result;
+  int kind;
+
+  if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
+  result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
+
+  switch (a->ts.type)
+    {
+      case BT_INTEGER:
+	if (mpz_cmp_ui (p->value.integer, 0) == 0)
+	  {
+	    /* Result is processor-dependent.  */
+	    gfc_error ("Second argument MOD at %L is zero", &a->where);
+	    gfc_free_expr (result);
+	    return &gfc_bad_expr;
+	  }
+	mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
+	break;
+
+      case BT_REAL:
+	if (mpfr_cmp_ui (p->value.real, 0) == 0)
+	  {
+	    /* Result is processor-dependent.  */
+	    gfc_error ("Second argument of MOD at %L is zero", &p->where);
+	    gfc_free_expr (result);
+	    return &gfc_bad_expr;
+	  }
+
+	gfc_set_model_kind (kind);
+	mpfr_fmod (result->value.real, a->value.real, p->value.real,
+		   GFC_RND_MODE);
+	break;
+
+      default:
+	gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
+    }
+
+  return range_check (result, "MOD");
+}
+
+
+gfc_expr *
+gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
+{
+  gfc_expr *result;
+  int kind;
+
+  if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
+  result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
+
+  switch (a->ts.type)
+    {
+      case BT_INTEGER:
+	if (mpz_cmp_ui (p->value.integer, 0) == 0)
+	  {
+	    /* Result is processor-dependent. This processor just opts
+	      to not handle it at all.  */
+	    gfc_error ("Second argument of MODULO at %L is zero", &a->where);
+	    gfc_free_expr (result);
+	    return &gfc_bad_expr;
+	  }
+	mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
+
+	break;
+
+      case BT_REAL:
+	if (mpfr_cmp_ui (p->value.real, 0) == 0)
+	  {
+	    /* Result is processor-dependent.  */
+	    gfc_error ("Second argument of MODULO at %L is zero", &p->where);
+	    gfc_free_expr (result);
+	    return &gfc_bad_expr;
+	  }
+
+	gfc_set_model_kind (kind);
+	mpfr_fmod (result->value.real, a->value.real, p->value.real,
+		   GFC_RND_MODE);
+	if (mpfr_cmp_ui (result->value.real, 0) != 0)
+	  {
+	    if (mpfr_signbit (a->value.real) != mpfr_signbit (p->value.real))
+	      mpfr_add (result->value.real, result->value.real, p->value.real,
+			GFC_RND_MODE);
+	  }
+	else
+	  mpfr_copysign (result->value.real, result->value.real,
+			 p->value.real, GFC_RND_MODE);
+	break;
+
+      default:
+	gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
+    }
+
+  return range_check (result, "MODULO");
+}
+
+
+/* Exists for the sole purpose of consistency with other intrinsics.  */
+gfc_expr *
+gfc_simplify_mvbits (gfc_expr *f  ATTRIBUTE_UNUSED,
+		     gfc_expr *fp ATTRIBUTE_UNUSED,
+		     gfc_expr *l  ATTRIBUTE_UNUSED,
+		     gfc_expr *to ATTRIBUTE_UNUSED,
+		     gfc_expr *tp ATTRIBUTE_UNUSED)
+{
+  return NULL;
+}
+
+
+gfc_expr *
+gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
+{
+  gfc_expr *result;
+  mp_exp_t emin, emax;
+  int kind;
+
+  if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_copy_expr (x);
+
+  /* Save current values of emin and emax.  */
+  emin = mpfr_get_emin ();
+  emax = mpfr_get_emax ();
+
+  /* Set emin and emax for the current model number.  */
+  kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
+  mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent -
+		mpfr_get_prec(result->value.real) + 1);
+  mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1);
+  mpfr_check_range (result->value.real, 0, GMP_RNDU);
+
+  if (mpfr_sgn (s->value.real) > 0)
+    {
+      mpfr_nextabove (result->value.real);
+      mpfr_subnormalize (result->value.real, 0, GMP_RNDU);
+    }
+  else
+    {
+      mpfr_nextbelow (result->value.real);
+      mpfr_subnormalize (result->value.real, 0, GMP_RNDD);
+    }
+
+  mpfr_set_emin (emin);
+  mpfr_set_emax (emax);
+
+  /* Only NaN can occur. Do not use range check as it gives an
+     error for denormal numbers.  */
+  if (mpfr_nan_p (result->value.real) && gfc_option.flag_range_check)
+    {
+      gfc_error ("Result of NEAREST is NaN at %L", &result->where);
+      gfc_free_expr (result);
+      return &gfc_bad_expr;
+    }
+
+  return result;
+}
+
+
+static gfc_expr *
+simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
+{
+  gfc_expr *itrunc, *result;
+  int kind;
+
+  kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
+  if (kind == -1)
+    return &gfc_bad_expr;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  itrunc = gfc_copy_expr (e);
+  mpfr_round (itrunc->value.real, e->value.real);
+
+  result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
+  gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
+
+  gfc_free_expr (itrunc);
+
+  return range_check (result, name);
+}
+
+
+gfc_expr *
+gfc_simplify_new_line (gfc_expr *e)
+{
+  gfc_expr *result;
+
+  result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1);
+  result->value.character.string[0] = '\n';
+
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
+{
+  return simplify_nint ("NINT", e, k);
+}
+
+
+gfc_expr *
+gfc_simplify_idnint (gfc_expr *e)
+{
+  return simplify_nint ("IDNINT", e, NULL);
+}
+
+
+static gfc_expr *
+add_squared (gfc_expr *result, gfc_expr *e)
+{
+  mpfr_t tmp;
+
+  gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
+  gcc_assert (result->ts.type == BT_REAL
+	      && result->expr_type == EXPR_CONSTANT);
+
+  gfc_set_model_kind (result->ts.kind);
+  mpfr_init (tmp);
+  mpfr_pow_ui (tmp, e->value.real, 2, GFC_RND_MODE);
+  mpfr_add (result->value.real, result->value.real, tmp,
+	    GFC_RND_MODE);
+  mpfr_clear (tmp);
+
+  return result;
+}
+
+
+static gfc_expr *
+do_sqrt (gfc_expr *result, gfc_expr *e)
+{
+  gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
+  gcc_assert (result->ts.type == BT_REAL
+	      && result->expr_type == EXPR_CONSTANT);
+
+  mpfr_set (result->value.real, e->value.real, GFC_RND_MODE);
+  mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim)
+{
+  gfc_expr *result;
+
+  if (!is_constant_array_expr (e)
+      || (dim != NULL && !gfc_is_constant_expr (dim)))
+    return NULL;
+
+  result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where);
+  init_result_expr (result, 0, NULL);
+
+  if (!dim || e->rank == 1)
+    {
+      result = simplify_transformation_to_scalar (result, e, NULL,
+						  add_squared);
+      mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
+    }
+  else
+    result = simplify_transformation_to_array (result, e, dim, NULL,
+					       add_squared, &do_sqrt);
+
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_not (gfc_expr *e)
+{
+  gfc_expr *result;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
+  mpz_com (result->value.integer, e->value.integer);
+
+  return range_check (result, "NOT");
+}
+
+
+gfc_expr *
+gfc_simplify_null (gfc_expr *mold)
+{
+  gfc_expr *result;
+
+  if (mold)
+    {
+      result = gfc_copy_expr (mold);
+      result->expr_type = EXPR_NULL;
+    }
+  else
+    result = gfc_get_null_expr (NULL);
+
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_num_images (void)
+{
+  gfc_expr *result;
+
+  if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+    {
+      gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+      return &gfc_bad_expr;
+    }
+
+  if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
+    return NULL;
+
+  /* FIXME: gfc_current_locus is wrong.  */
+  result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+				  &gfc_current_locus);
+  mpz_set_si (result->value.integer, 1);
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_or (gfc_expr *x, gfc_expr *y)
+{
+  gfc_expr *result;
+  int kind;
+
+  if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
+
+  switch (x->ts.type)
+    {
+      case BT_INTEGER:
+	result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
+	mpz_ior (result->value.integer, x->value.integer, y->value.integer);
+	return range_check (result, "OR");
+
+      case BT_LOGICAL:
+	return gfc_get_logical_expr (kind, &x->where,
+				     x->value.logical || y->value.logical);
+      default:
+	gcc_unreachable();
+    }
+}
+
+
+gfc_expr *
+gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
+{
+  gfc_expr *result;
+  gfc_constructor *array_ctor, *mask_ctor, *vector_ctor;
+
+  if (!is_constant_array_expr (array)
+      || !is_constant_array_expr (vector)
+      || (!gfc_is_constant_expr (mask)
+          && !is_constant_array_expr (mask)))
+    return NULL;
+
+  result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
+  if (array->ts.type == BT_DERIVED)
+    result->ts.u.derived = array->ts.u.derived;
+
+  array_ctor = gfc_constructor_first (array->value.constructor);
+  vector_ctor = vector
+		  ? gfc_constructor_first (vector->value.constructor)
+		  : NULL;
+
+  if (mask->expr_type == EXPR_CONSTANT
+      && mask->value.logical)
+    {
+      /* Copy all elements of ARRAY to RESULT.  */
+      while (array_ctor)
+	{
+	  gfc_constructor_append_expr (&result->value.constructor,
+				       gfc_copy_expr (array_ctor->expr),
+				       NULL);
+
+	  array_ctor = gfc_constructor_next (array_ctor);
+	  vector_ctor = gfc_constructor_next (vector_ctor);
+	}
+    }
+  else if (mask->expr_type == EXPR_ARRAY)
+    {
+      /* Copy only those elements of ARRAY to RESULT whose
+	 MASK equals .TRUE..  */
+      mask_ctor = gfc_constructor_first (mask->value.constructor);
+      while (mask_ctor)
+	{
+	  if (mask_ctor->expr->value.logical)
+	    {
+	      gfc_constructor_append_expr (&result->value.constructor,
+					   gfc_copy_expr (array_ctor->expr),
+					   NULL);
+	      vector_ctor = gfc_constructor_next (vector_ctor);
+	    }
+
+	  array_ctor = gfc_constructor_next (array_ctor);
+	  mask_ctor = gfc_constructor_next (mask_ctor);
+	}
+    }
+
+  /* Append any left-over elements from VECTOR to RESULT.  */
+  while (vector_ctor)
+    {
+      gfc_constructor_append_expr (&result->value.constructor,
+				   gfc_copy_expr (vector_ctor->expr),
+				   NULL);
+      vector_ctor = gfc_constructor_next (vector_ctor);
+    }
+
+  result->shape = gfc_get_shape (1);
+  gfc_array_size (result, &result->shape[0]);
+
+  if (array->ts.type == BT_CHARACTER)
+    result->ts.u.cl = array->ts.u.cl;
+
+  return result;
+}
+
+
+static gfc_expr *
+do_xor (gfc_expr *result, gfc_expr *e)
+{
+  gcc_assert (e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT);
+  gcc_assert (result->ts.type == BT_LOGICAL
+	      && result->expr_type == EXPR_CONSTANT);
+
+  result->value.logical = result->value.logical != e->value.logical;
+  return result;
+}
+
+
+
+gfc_expr *
+gfc_simplify_parity (gfc_expr *e, gfc_expr *dim)
+{
+  return simplify_transformation (e, dim, NULL, 0, do_xor);
+}
+
+
+gfc_expr *
+gfc_simplify_popcnt (gfc_expr *e)
+{
+  int res, k;
+  mpz_t x;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+
+  /* Convert argument to unsigned, then count the '1' bits.  */
+  mpz_init_set (x, e->value.integer);
+  convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
+  res = mpz_popcount (x);
+  mpz_clear (x);
+
+  return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res);
+}
+
+
+gfc_expr *
+gfc_simplify_poppar (gfc_expr *e)
+{
+  gfc_expr *popcnt;
+  const char *s;
+  int i;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  popcnt = gfc_simplify_popcnt (e);
+  gcc_assert (popcnt);
+
+  s = gfc_extract_int (popcnt, &i);
+  gcc_assert (!s);
+
+  return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i % 2);
+}
+
+
+gfc_expr *
+gfc_simplify_precision (gfc_expr *e)
+{
+  int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+  return gfc_get_int_expr (gfc_default_integer_kind, &e->where,
+			   gfc_real_kinds[i].precision);
+}
+
+
+gfc_expr *
+gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+  return simplify_transformation (array, dim, mask, 1, gfc_multiply);
+}
+
+
+gfc_expr *
+gfc_simplify_radix (gfc_expr *e)
+{
+  int i;
+  i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+
+  switch (e->ts.type)
+    {
+      case BT_INTEGER:
+	i = gfc_integer_kinds[i].radix;
+	break;
+
+      case BT_REAL:
+	i = gfc_real_kinds[i].radix;
+	break;
+
+      default:
+	gcc_unreachable ();
+    }
+
+  return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
+}
+
+
+gfc_expr *
+gfc_simplify_range (gfc_expr *e)
+{
+  int i;
+  i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+
+  switch (e->ts.type)
+    {
+      case BT_INTEGER:
+	i = gfc_integer_kinds[i].range;
+	break;
+
+      case BT_REAL:
+      case BT_COMPLEX:
+	i = gfc_real_kinds[i].range;
+	break;
+
+      default:
+	gcc_unreachable ();
+    }
+
+  return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
+}
+
+
+gfc_expr *
+gfc_simplify_rank (gfc_expr *e)
+{
+  /* Assumed rank.  */
+  if (e->rank == -1)
+    return NULL;
+
+  return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank);
+}
+
+
+gfc_expr *
+gfc_simplify_real (gfc_expr *e, gfc_expr *k)
+{
+  gfc_expr *result = NULL;
+  int kind;
+
+  if (e->ts.type == BT_COMPLEX)
+    kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
+  else
+    kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
+
+  if (kind == -1)
+    return &gfc_bad_expr;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  if (convert_boz (e, kind) == &gfc_bad_expr)
+    return &gfc_bad_expr;
+
+  result = gfc_convert_constant (e, BT_REAL, kind);
+  if (result == &gfc_bad_expr)
+    return &gfc_bad_expr;
+
+  return range_check (result, "REAL");
+}
+
+
+gfc_expr *
+gfc_simplify_realpart (gfc_expr *e)
+{
+  gfc_expr *result;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
+  mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
+
+  return range_check (result, "REALPART");
+}
+
+gfc_expr *
+gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
+{
+  gfc_expr *result;
+  int i, j, len, ncop, nlen;
+  mpz_t ncopies;
+  bool have_length = false;
+
+  /* If NCOPIES isn't a constant, there's nothing we can do.  */
+  if (n->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  /* If NCOPIES is negative, it's an error.  */
+  if (mpz_sgn (n->value.integer) < 0)
+    {
+      gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
+		 &n->where);
+      return &gfc_bad_expr;
+    }
+
+  /* If we don't know the character length, we can do no more.  */
+  if (e->ts.u.cl && e->ts.u.cl->length
+	&& e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+    {
+      len = mpz_get_si (e->ts.u.cl->length->value.integer);
+      have_length = true;
+    }
+  else if (e->expr_type == EXPR_CONSTANT
+	     && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
+    {
+      len = e->value.character.length;
+    }
+  else
+    return NULL;
+
+  /* If the source length is 0, any value of NCOPIES is valid
+     and everything behaves as if NCOPIES == 0.  */
+  mpz_init (ncopies);
+  if (len == 0)
+    mpz_set_ui (ncopies, 0);
+  else
+    mpz_set (ncopies, n->value.integer);
+
+  /* Check that NCOPIES isn't too large.  */
+  if (len)
+    {
+      mpz_t max, mlen;
+      int i;
+
+      /* Compute the maximum value allowed for NCOPIES: huge(cl) / len.  */
+      mpz_init (max);
+      i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
+
+      if (have_length)
+	{
+	  mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
+		      e->ts.u.cl->length->value.integer);
+	}
+      else
+	{
+	  mpz_init_set_si (mlen, len);
+	  mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
+	  mpz_clear (mlen);
+	}
+
+      /* The check itself.  */
+      if (mpz_cmp (ncopies, max) > 0)
+	{
+	  mpz_clear (max);
+	  mpz_clear (ncopies);
+	  gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
+		     &n->where);
+	  return &gfc_bad_expr;
+	}
+
+      mpz_clear (max);
+    }
+  mpz_clear (ncopies);
+
+  /* For further simplification, we need the character string to be
+     constant.  */
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  if (len ||
+      (e->ts.u.cl->length &&
+       mpz_sgn (e->ts.u.cl->length->value.integer)) != 0)
+    {
+      const char *res = gfc_extract_int (n, &ncop);
+      gcc_assert (res == NULL);
+    }
+  else
+    ncop = 0;
+
+  if (ncop == 0)
+    return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0);
+
+  len = e->value.character.length;
+  nlen = ncop * len;
+
+  result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen);
+  for (i = 0; i < ncop; i++)
+    for (j = 0; j < len; j++)
+      result->value.character.string[j+i*len]= e->value.character.string[j];
+
+  result->value.character.string[nlen] = '\0';	/* For debugger */
+  return result;
+}
+
+
+/* This one is a bear, but mainly has to do with shuffling elements.  */
+
+gfc_expr *
+gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
+		      gfc_expr *pad, gfc_expr *order_exp)
+{
+  int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
+  int i, rank, npad, x[GFC_MAX_DIMENSIONS];
+  mpz_t index, size;
+  unsigned long j;
+  size_t nsource;
+  gfc_expr *e, *result;
+
+  /* Check that argument expression types are OK.  */
+  if (!is_constant_array_expr (source)
+      || !is_constant_array_expr (shape_exp)
+      || !is_constant_array_expr (pad)
+      || !is_constant_array_expr (order_exp))
+    return NULL;
+
+  /* Proceed with simplification, unpacking the array.  */
+
+  mpz_init (index);
+  rank = 0;
+
+  for (;;)
+    {
+      e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank);
+      if (e == NULL)
+	break;
+
+      gfc_extract_int (e, &shape[rank]);
+
+      gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS);
+      gcc_assert (shape[rank] >= 0);
+
+      rank++;
+    }
+
+  gcc_assert (rank > 0);
+
+  /* Now unpack the order array if present.  */
+  if (order_exp == NULL)
+    {
+      for (i = 0; i < rank; i++)
+	order[i] = i;
+    }
+  else
+    {
+      for (i = 0; i < rank; i++)
+	x[i] = 0;
+
+      for (i = 0; i < rank; i++)
+	{
+	  e = gfc_constructor_lookup_expr (order_exp->value.constructor, i);
+	  gcc_assert (e);
+
+	  gfc_extract_int (e, &order[i]);
+
+	  gcc_assert (order[i] >= 1 && order[i] <= rank);
+	  order[i]--;
+	  gcc_assert (x[order[i]] == 0);
+	  x[order[i]] = 1;
+	}
+    }
+
+  /* Count the elements in the source and padding arrays.  */
+
+  npad = 0;
+  if (pad != NULL)
+    {
+      gfc_array_size (pad, &size);
+      npad = mpz_get_ui (size);
+      mpz_clear (size);
+    }
+
+  gfc_array_size (source, &size);
+  nsource = mpz_get_ui (size);
+  mpz_clear (size);
+
+  /* If it weren't for that pesky permutation we could just loop
+     through the source and round out any shortage with pad elements.
+     But no, someone just had to have the compiler do something the
+     user should be doing.  */
+
+  for (i = 0; i < rank; i++)
+    x[i] = 0;
+
+  result = gfc_get_array_expr (source->ts.type, source->ts.kind,
+			       &source->where);
+  if (source->ts.type == BT_DERIVED)
+    result->ts.u.derived = source->ts.u.derived;
+  result->rank = rank;
+  result->shape = gfc_get_shape (rank);
+  for (i = 0; i < rank; i++)
+    mpz_init_set_ui (result->shape[i], shape[i]);
+
+  while (nsource > 0 || npad > 0)
+    {
+      /* Figure out which element to extract.  */
+      mpz_set_ui (index, 0);
+
+      for (i = rank - 1; i >= 0; i--)
+	{
+	  mpz_add_ui (index, index, x[order[i]]);
+	  if (i != 0)
+	    mpz_mul_ui (index, index, shape[order[i - 1]]);
+	}
+
+      if (mpz_cmp_ui (index, INT_MAX) > 0)
+	gfc_internal_error ("Reshaped array too large at %C");
+
+      j = mpz_get_ui (index);
+
+      if (j < nsource)
+	e = gfc_constructor_lookup_expr (source->value.constructor, j);
+      else
+	{
+	  gcc_assert (npad > 0);
+
+	  j = j - nsource;
+	  j = j % npad;
+	  e = gfc_constructor_lookup_expr (pad->value.constructor, j);
+	}
+      gcc_assert (e);
+
+      gfc_constructor_append_expr (&result->value.constructor,
+				   gfc_copy_expr (e), &e->where);
+
+      /* Calculate the next element.  */
+      i = 0;
+
+inc:
+      if (++x[i] < shape[i])
+	continue;
+      x[i++] = 0;
+      if (i < rank)
+	goto inc;
+
+      break;
+    }
+
+  mpz_clear (index);
+
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_rrspacing (gfc_expr *x)
+{
+  gfc_expr *result;
+  int i;
+  long int e, p;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
+
+  result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
+  mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
+
+  /* Special case x = -0 and 0.  */
+  if (mpfr_sgn (result->value.real) == 0)
+    {
+      mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
+      return result;
+    }
+
+  /* | x * 2**(-e) | * 2**p.  */
+  e = - (long int) mpfr_get_exp (x->value.real);
+  mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
+
+  p = (long int) gfc_real_kinds[i].digits;
+  mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
+
+  return range_check (result, "RRSPACING");
+}
+
+
+gfc_expr *
+gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
+{
+  int k, neg_flag, power, exp_range;
+  mpfr_t scale, radix;
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
+
+  if (mpfr_sgn (x->value.real) == 0)
+    {
+      mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
+      return result;
+    }
+
+  k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
+
+  exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
+
+  /* This check filters out values of i that would overflow an int.  */
+  if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
+      || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
+    {
+      gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
+      gfc_free_expr (result);
+      return &gfc_bad_expr;
+    }
+
+  /* Compute scale = radix ** power.  */
+  power = mpz_get_si (i->value.integer);
+
+  if (power >= 0)
+    neg_flag = 0;
+  else
+    {
+      neg_flag = 1;
+      power = -power;
+    }
+
+  gfc_set_model_kind (x->ts.kind);
+  mpfr_init (scale);
+  mpfr_init (radix);
+  mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
+  mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
+
+  if (neg_flag)
+    mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
+  else
+    mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
+
+  mpfr_clears (scale, radix, NULL);
+
+  return range_check (result, "SCALE");
+}
+
+
+/* Variants of strspn and strcspn that operate on wide characters.  */
+
+static size_t
+wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
+{
+  size_t i = 0;
+  const gfc_char_t *c;
+
+  while (s1[i])
+    {
+      for (c = s2; *c; c++)
+	{
+	  if (s1[i] == *c)
+	    break;
+	}
+      if (*c == '\0')
+	break;
+      i++;
+    }
+
+  return i;
+}
+
+static size_t
+wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
+{
+  size_t i = 0;
+  const gfc_char_t *c;
+
+  while (s1[i])
+    {
+      for (c = s2; *c; c++)
+	{
+	  if (s1[i] == *c)
+	    break;
+	}
+      if (*c)
+	break;
+      i++;
+    }
+
+  return i;
+}
+
+
+gfc_expr *
+gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
+{
+  gfc_expr *result;
+  int back;
+  size_t i;
+  size_t indx, len, lenc;
+  int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
+
+  if (k == -1)
+    return &gfc_bad_expr;
+
+  if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT
+      || ( b != NULL && b->expr_type !=  EXPR_CONSTANT))
+    return NULL;
+
+  if (b != NULL && b->value.logical != 0)
+    back = 1;
+  else
+    back = 0;
+
+  len = e->value.character.length;
+  lenc = c->value.character.length;
+
+  if (len == 0 || lenc == 0)
+    {
+      indx = 0;
+    }
+  else
+    {
+      if (back == 0)
+	{
+	  indx = wide_strcspn (e->value.character.string,
+			       c->value.character.string) + 1;
+	  if (indx > len)
+	    indx = 0;
+	}
+      else
+	{
+	  i = 0;
+	  for (indx = len; indx > 0; indx--)
+	    {
+	      for (i = 0; i < lenc; i++)
+		{
+		  if (c->value.character.string[i]
+		      == e->value.character.string[indx - 1])
+		    break;
+		}
+	      if (i < lenc)
+		break;
+	    }
+	}
+    }
+
+  result = gfc_get_int_expr (k, &e->where, indx);
+  return range_check (result, "SCAN");
+}
+
+
+gfc_expr *
+gfc_simplify_selected_char_kind (gfc_expr *e)
+{
+  int kind;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  if (gfc_compare_with_Cstring (e, "ascii", false) == 0
+      || gfc_compare_with_Cstring (e, "default", false) == 0)
+    kind = 1;
+  else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0)
+    kind = 4;
+  else
+    kind = -1;
+
+  return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
+}
+
+
+gfc_expr *
+gfc_simplify_selected_int_kind (gfc_expr *e)
+{
+  int i, kind, range;
+
+  if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
+    return NULL;
+
+  kind = INT_MAX;
+
+  for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
+    if (gfc_integer_kinds[i].range >= range
+	&& gfc_integer_kinds[i].kind < kind)
+      kind = gfc_integer_kinds[i].kind;
+
+  if (kind == INT_MAX)
+    kind = -1;
+
+  return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
+}
+
+
+gfc_expr *
+gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx)
+{
+  int range, precision, radix, i, kind, found_precision, found_range,
+      found_radix;
+  locus *loc = &gfc_current_locus;
+
+  if (p == NULL)
+    precision = 0;
+  else
+    {
+      if (p->expr_type != EXPR_CONSTANT
+	  || gfc_extract_int (p, &precision) != NULL)
+	return NULL;
+      loc = &p->where;
+    }
+
+  if (q == NULL)
+    range = 0;
+  else
+    {
+      if (q->expr_type != EXPR_CONSTANT
+	  || gfc_extract_int (q, &range) != NULL)
+	return NULL;
+
+      if (!loc)
+	loc = &q->where;
+    }
+
+  if (rdx == NULL)
+    radix = 0;
+  else
+    {
+      if (rdx->expr_type != EXPR_CONSTANT
+	  || gfc_extract_int (rdx, &radix) != NULL)
+	return NULL;
+
+      if (!loc)
+	loc = &rdx->where;
+    }
+
+  kind = INT_MAX;
+  found_precision = 0;
+  found_range = 0;
+  found_radix = 0;
+
+  for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+    {
+      if (gfc_real_kinds[i].precision >= precision)
+	found_precision = 1;
+
+      if (gfc_real_kinds[i].range >= range)
+	found_range = 1;
+
+      if (gfc_real_kinds[i].radix >= radix)
+	found_radix = 1;
+
+      if (gfc_real_kinds[i].precision >= precision
+	  && gfc_real_kinds[i].range >= range
+	  && gfc_real_kinds[i].radix >= radix && gfc_real_kinds[i].kind < kind)
+	kind = gfc_real_kinds[i].kind;
+    }
+
+  if (kind == INT_MAX)
+    {
+      if (found_radix && found_range && !found_precision)
+	kind = -1;
+      else if (found_radix && found_precision && !found_range)
+	kind = -2;
+      else if (found_radix && !found_precision && !found_range)
+	kind = -3;
+      else if (found_radix)
+	kind = -4;
+      else
+	kind = -5;
+    }
+
+  return gfc_get_int_expr (gfc_default_integer_kind, loc, kind);
+}
+
+
+gfc_expr *
+gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
+{
+  gfc_expr *result;
+  mpfr_t exp, absv, log2, pow2, frac;
+  unsigned long exp2;
+
+  if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
+
+  if (mpfr_sgn (x->value.real) == 0)
+    {
+      mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
+      return result;
+    }
+
+  gfc_set_model_kind (x->ts.kind);
+  mpfr_init (absv);
+  mpfr_init (log2);
+  mpfr_init (exp);
+  mpfr_init (pow2);
+  mpfr_init (frac);
+
+  mpfr_abs (absv, x->value.real, GFC_RND_MODE);
+  mpfr_log2 (log2, absv, GFC_RND_MODE);
+
+  mpfr_trunc (log2, log2);
+  mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
+
+  /* Old exponent value, and fraction.  */
+  mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
+
+  mpfr_div (frac, absv, pow2, GFC_RND_MODE);
+
+  /* New exponent.  */
+  exp2 = (unsigned long) mpz_get_d (i->value.integer);
+  mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
+
+  mpfr_clears (absv, log2, pow2, frac, NULL);
+
+  return range_check (result, "SET_EXPONENT");
+}
+
+
+gfc_expr *
+gfc_simplify_shape (gfc_expr *source, gfc_expr *kind)
+{
+  mpz_t shape[GFC_MAX_DIMENSIONS];
+  gfc_expr *result, *e, *f;
+  gfc_array_ref *ar;
+  int n;
+  bool t;
+  int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind);
+
+  if (source->rank == -1)
+    return NULL;
+
+  result = gfc_get_array_expr (BT_INTEGER, k, &source->where);
+
+  if (source->rank == 0)
+    return result;
+
+  if (source->expr_type == EXPR_VARIABLE)
+    {
+      ar = gfc_find_array_ref (source);
+      t = gfc_array_ref_shape (ar, shape);
+    }
+  else if (source->shape)
+    {
+      t = true;
+      for (n = 0; n < source->rank; n++)
+	{
+	  mpz_init (shape[n]);
+	  mpz_set (shape[n], source->shape[n]);
+	}
+    }
+  else
+    t = false;
+
+  for (n = 0; n < source->rank; n++)
+    {
+      e = gfc_get_constant_expr (BT_INTEGER, k, &source->where);
+
+      if (t)
+	mpz_set (e->value.integer, shape[n]);
+      else
+	{
+	  mpz_set_ui (e->value.integer, n + 1);
+
+	  f = simplify_size (source, e, k);
+	  gfc_free_expr (e);
+	  if (f == NULL)
+	    {
+	      gfc_free_expr (result);
+	      return NULL;
+	    }
+	  else
+	    e = f;
+	}
+
+      if (e == &gfc_bad_expr || range_check (e, "SHAPE") == &gfc_bad_expr)
+	{
+	  gfc_free_expr (result);
+	  if (t)
+	    gfc_clear_shape (shape, source->rank);
+	  return &gfc_bad_expr;
+	}
+
+      gfc_constructor_append_expr (&result->value.constructor, e, NULL);
+    }
+
+  if (t)
+    gfc_clear_shape (shape, source->rank);
+
+  return result;
+}
+
+
+static gfc_expr *
+simplify_size (gfc_expr *array, gfc_expr *dim, int k)
+{
+  mpz_t size;
+  gfc_expr *return_value;
+  int d;
+
+  /* For unary operations, the size of the result is given by the size
+     of the operand.  For binary ones, it's the size of the first operand
+     unless it is scalar, then it is the size of the second.  */
+  if (array->expr_type == EXPR_OP && !array->value.op.uop)
+    {
+      gfc_expr* replacement;
+      gfc_expr* simplified;
+
+      switch (array->value.op.op)
+	{
+	  /* Unary operations.  */
+	  case INTRINSIC_NOT:
+	  case INTRINSIC_UPLUS:
+	  case INTRINSIC_UMINUS:
+	  case INTRINSIC_PARENTHESES:
+	    replacement = array->value.op.op1;
+	    break;
+
+	  /* Binary operations.  If any one of the operands is scalar, take
+	     the other one's size.  If both of them are arrays, it does not
+	     matter -- try to find one with known shape, if possible.  */
+	  default:
+	    if (array->value.op.op1->rank == 0)
+	      replacement = array->value.op.op2;
+	    else if (array->value.op.op2->rank == 0)
+	      replacement = array->value.op.op1;
+	    else
+	      {
+		simplified = simplify_size (array->value.op.op1, dim, k);
+		if (simplified)
+		  return simplified;
+
+		replacement = array->value.op.op2;
+	      }
+	    break;
+	}
+
+      /* Try to reduce it directly if possible.  */
+      simplified = simplify_size (replacement, dim, k);
+
+      /* Otherwise, we build a new SIZE call.  This is hopefully at least
+	 simpler than the original one.  */
+      if (!simplified)
+	{
+	  gfc_expr *kind = gfc_get_int_expr (gfc_default_integer_kind, NULL, k);
+	  simplified = gfc_build_intrinsic_call (gfc_current_ns,
+						 GFC_ISYM_SIZE, "size",
+						 array->where, 3,
+						 gfc_copy_expr (replacement),
+						 gfc_copy_expr (dim),
+						 kind);
+	}
+      return simplified;
+    }
+
+  if (dim == NULL)
+    {
+      if (!gfc_array_size (array, &size))
+	return NULL;
+    }
+  else
+    {
+      if (dim->expr_type != EXPR_CONSTANT)
+	return NULL;
+
+      d = mpz_get_ui (dim->value.integer) - 1;
+      if (!gfc_array_dimen_size (array, d, &size))
+	return NULL;
+    }
+
+  return_value = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
+  mpz_set (return_value->value.integer, size);
+  mpz_clear (size);
+
+  return return_value;
+}
+
+
+gfc_expr *
+gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
+  gfc_expr *result;
+  int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
+
+  if (k == -1)
+    return &gfc_bad_expr;
+
+  result = simplify_size (array, dim, k);
+  if (result == NULL || result == &gfc_bad_expr)
+    return result;
+
+  return range_check (result, "SIZE");
+}
+
+
+/* SIZEOF and C_SIZEOF return the size in bytes of an array element
+   multiplied by the array size.  */
+
+gfc_expr *
+gfc_simplify_sizeof (gfc_expr *x)
+{
+  gfc_expr *result = NULL;
+  mpz_t array_size;
+
+  if (x->ts.type == BT_CLASS || x->ts.deferred)
+    return NULL;
+
+  if (x->ts.type == BT_CHARACTER
+      && (!x->ts.u.cl || !x->ts.u.cl->length
+	  || x->ts.u.cl->length->expr_type != EXPR_CONSTANT))
+    return NULL;
+
+  if (x->rank && x->expr_type != EXPR_ARRAY
+      && !gfc_array_size (x, &array_size))
+    return NULL;
+
+  result = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
+				  &x->where);
+  mpz_set_si (result->value.integer, gfc_target_expr_size (x));
+
+  return result;
+}
+
+
+/* STORAGE_SIZE returns the size in bits of a single array element.  */
+
+gfc_expr *
+gfc_simplify_storage_size (gfc_expr *x,
+			   gfc_expr *kind)
+{
+  gfc_expr *result = NULL;
+  int k;
+
+  if (x->ts.type == BT_CLASS || x->ts.deferred)
+    return NULL;
+
+  if (x->ts.type == BT_CHARACTER && x->expr_type != EXPR_CONSTANT
+      && (!x->ts.u.cl || !x->ts.u.cl->length
+	  || x->ts.u.cl->length->expr_type != EXPR_CONSTANT))
+    return NULL;
+
+  k = get_kind (BT_INTEGER, kind, "STORAGE_SIZE", gfc_default_integer_kind);
+  if (k == -1)
+    return &gfc_bad_expr;
+
+  result = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
+				  &x->where);
+
+  mpz_set_si (result->value.integer, gfc_element_size (x));
+
+  mpz_mul_ui (result->value.integer, result->value.integer, BITS_PER_UNIT);
+
+  return range_check (result, "STORAGE_SIZE");
+}
+
+
+gfc_expr *
+gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+  switch (x->ts.type)
+    {
+      case BT_INTEGER:
+	mpz_abs (result->value.integer, x->value.integer);
+	if (mpz_sgn (y->value.integer) < 0)
+	  mpz_neg (result->value.integer, result->value.integer);
+	break;
+
+      case BT_REAL:
+	if (gfc_option.flag_sign_zero)
+	  mpfr_copysign (result->value.real, x->value.real, y->value.real,
+			GFC_RND_MODE);
+	else
+	  mpfr_setsign (result->value.real, x->value.real,
+			mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
+	break;
+
+      default:
+	gfc_internal_error ("Bad type in gfc_simplify_sign");
+    }
+
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_sin (gfc_expr *x)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+  switch (x->ts.type)
+    {
+      case BT_REAL:
+	mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
+	break;
+
+      case BT_COMPLEX:
+	gfc_set_model (x->value.real);
+	mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+	break;
+
+      default:
+	gfc_internal_error ("in gfc_simplify_sin(): Bad type");
+    }
+
+  return range_check (result, "SIN");
+}
+
+
+gfc_expr *
+gfc_simplify_sinh (gfc_expr *x)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+  switch (x->ts.type)
+    {
+      case BT_REAL:
+	mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
+	break;
+
+      case BT_COMPLEX:
+	mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+	break;
+
+      default:
+	gcc_unreachable ();
+    }
+
+  return range_check (result, "SINH");
+}
+
+
+/* The argument is always a double precision real that is converted to
+   single precision.  TODO: Rounding!  */
+
+gfc_expr *
+gfc_simplify_sngl (gfc_expr *a)
+{
+  gfc_expr *result;
+
+  if (a->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_real2real (a, gfc_default_real_kind);
+  return range_check (result, "SNGL");
+}
+
+
+gfc_expr *
+gfc_simplify_spacing (gfc_expr *x)
+{
+  gfc_expr *result;
+  int i;
+  long int en, ep;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
+
+  result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
+
+  /* Special case x = 0 and -0.  */
+  mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
+  if (mpfr_sgn (result->value.real) == 0)
+    {
+      mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
+      return result;
+    }
+
+  /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
+     are the radix, exponent of x, and precision.  This excludes the
+     possibility of subnormal numbers.  Fortran 2003 states the result is
+     b**max(e - p, emin - 1).  */
+
+  ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
+  en = (long int) gfc_real_kinds[i].min_exponent - 1;
+  en = en > ep ? en : ep;
+
+  mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
+  mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
+
+  return range_check (result, "SPACING");
+}
+
+
+gfc_expr *
+gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr)
+{
+  gfc_expr *result = 0L;
+  int i, j, dim, ncopies;
+  mpz_t size;
+
+  if ((!gfc_is_constant_expr (source)
+       && !is_constant_array_expr (source))
+      || !gfc_is_constant_expr (dim_expr)
+      || !gfc_is_constant_expr (ncopies_expr))
+    return NULL;
+
+  gcc_assert (dim_expr->ts.type == BT_INTEGER);
+  gfc_extract_int (dim_expr, &dim);
+  dim -= 1;   /* zero-base DIM */
+
+  gcc_assert (ncopies_expr->ts.type == BT_INTEGER);
+  gfc_extract_int (ncopies_expr, &ncopies);
+  ncopies = MAX (ncopies, 0);
+
+  /* Do not allow the array size to exceed the limit for an array
+     constructor.  */
+  if (source->expr_type == EXPR_ARRAY)
+    {
+      if (!gfc_array_size (source, &size))
+	gfc_internal_error ("Failure getting length of a constant array.");
+    }
+  else
+    mpz_init_set_ui (size, 1);
+
+  if (mpz_get_si (size)*ncopies > gfc_option.flag_max_array_constructor)
+    return NULL;
+
+  if (source->expr_type == EXPR_CONSTANT)
+    {
+      gcc_assert (dim == 0);
+
+      result = gfc_get_array_expr (source->ts.type, source->ts.kind,
+				   &source->where);
+      if (source->ts.type == BT_DERIVED)
+	result->ts.u.derived = source->ts.u.derived;
+      result->rank = 1;
+      result->shape = gfc_get_shape (result->rank);
+      mpz_init_set_si (result->shape[0], ncopies);
+
+      for (i = 0; i < ncopies; ++i)
+        gfc_constructor_append_expr (&result->value.constructor,
+				     gfc_copy_expr (source), NULL);
+    }
+  else if (source->expr_type == EXPR_ARRAY)
+    {
+      int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS];
+      gfc_constructor *source_ctor;
+
+      gcc_assert (source->rank < GFC_MAX_DIMENSIONS);
+      gcc_assert (dim >= 0 && dim <= source->rank);
+
+      result = gfc_get_array_expr (source->ts.type, source->ts.kind,
+				   &source->where);
+      if (source->ts.type == BT_DERIVED)
+	result->ts.u.derived = source->ts.u.derived;
+      result->rank = source->rank + 1;
+      result->shape = gfc_get_shape (result->rank);
+
+      for (i = 0, j = 0; i < result->rank; ++i)
+	{
+	  if (i != dim)
+	    mpz_init_set (result->shape[i], source->shape[j++]);
+	  else
+	    mpz_init_set_si (result->shape[i], ncopies);
+
+	  extent[i] = mpz_get_si (result->shape[i]);
+	  rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1];
+	}
+
+      offset = 0;
+      for (source_ctor = gfc_constructor_first (source->value.constructor);
+           source_ctor; source_ctor = gfc_constructor_next (source_ctor))
+	{
+	  for (i = 0; i < ncopies; ++i)
+	    gfc_constructor_insert_expr (&result->value.constructor,
+					 gfc_copy_expr (source_ctor->expr),
+					 NULL, offset + i * rstride[dim]);
+
+	  offset += (dim == 0 ? ncopies : 1);
+	}
+    }
+  else
+    /* FIXME: Returning here avoids a regression in array_simplify_1.f90.
+       Replace NULL with gcc_unreachable() after implementing
+       gfc_simplify_cshift(). */
+    return NULL;
+
+  if (source->ts.type == BT_CHARACTER)
+    result->ts.u.cl = source->ts.u.cl;
+
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_sqrt (gfc_expr *e)
+{
+  gfc_expr *result = NULL;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  switch (e->ts.type)
+    {
+      case BT_REAL:
+	if (mpfr_cmp_si (e->value.real, 0) < 0)
+	  {
+	    gfc_error ("Argument of SQRT at %L has a negative value",
+		       &e->where);
+	    return &gfc_bad_expr;
+	  }
+	result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
+	mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
+	break;
+
+      case BT_COMPLEX:
+	gfc_set_model (e->value.real);
+
+	result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
+	mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
+	break;
+
+      default:
+	gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
+    }
+
+  return range_check (result, "SQRT");
+}
+
+
+gfc_expr *
+gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+  return simplify_transformation (array, dim, mask, 0, gfc_add);
+}
+
+
+gfc_expr *
+gfc_simplify_tan (gfc_expr *x)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+  switch (x->ts.type)
+    {
+      case BT_REAL:
+	mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
+	break;
+
+      case BT_COMPLEX:
+	mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+	break;
+
+      default:
+	gcc_unreachable ();
+    }
+
+  return range_check (result, "TAN");
+}
+
+
+gfc_expr *
+gfc_simplify_tanh (gfc_expr *x)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+  switch (x->ts.type)
+    {
+      case BT_REAL:
+	mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
+	break;
+
+      case BT_COMPLEX:
+	mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+	break;
+
+      default:
+	gcc_unreachable ();
+    }
+
+  return range_check (result, "TANH");
+}
+
+
+gfc_expr *
+gfc_simplify_tiny (gfc_expr *e)
+{
+  gfc_expr *result;
+  int i;
+
+  i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
+
+  result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
+  mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
+
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_trailz (gfc_expr *e)
+{
+  unsigned long tz, bs;
+  int i;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+  bs = gfc_integer_kinds[i].bit_size;
+  tz = mpz_scan1 (e->value.integer, 0);
+
+  return gfc_get_int_expr (gfc_default_integer_kind,
+			   &e->where, MIN (tz, bs));
+}
+
+
+gfc_expr *
+gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
+{
+  gfc_expr *result;
+  gfc_expr *mold_element;
+  size_t source_size;
+  size_t result_size;
+  size_t buffer_size;
+  mpz_t tmp;
+  unsigned char *buffer;
+  size_t result_length;
+
+
+  if (!gfc_is_constant_expr (source)
+	|| (gfc_init_expr_flag && !gfc_is_constant_expr (mold))
+	|| !gfc_is_constant_expr (size))
+    return NULL;
+
+  if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size, 
+				     &result_size, &result_length))
+    return NULL;
+
+  /* Calculate the size of the source.  */
+  if (source->expr_type == EXPR_ARRAY
+      && !gfc_array_size (source, &tmp))
+    gfc_internal_error ("Failure getting length of a constant array.");
+
+  /* Create an empty new expression with the appropriate characteristics.  */
+  result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind,
+				  &source->where);
+  result->ts = mold->ts;
+
+  mold_element = mold->expr_type == EXPR_ARRAY
+		 ? gfc_constructor_first (mold->value.constructor)->expr
+		 : mold;
+
+  /* Set result character length, if needed.  Note that this needs to be
+     set even for array expressions, in order to pass this information into
+     gfc_target_interpret_expr.  */
+  if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
+    result->value.character.length = mold_element->value.character.length;
+
+  /* Set the number of elements in the result, and determine its size.  */
+
+  if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
+    {
+      result->expr_type = EXPR_ARRAY;
+      result->rank = 1;
+      result->shape = gfc_get_shape (1);
+      mpz_init_set_ui (result->shape[0], result_length);
+    }
+  else
+    result->rank = 0;
+
+  /* Allocate the buffer to store the binary version of the source.  */
+  buffer_size = MAX (source_size, result_size);
+  buffer = (unsigned char*)alloca (buffer_size);
+  memset (buffer, 0, buffer_size);
+
+  /* Now write source to the buffer.  */
+  gfc_target_encode_expr (source, buffer, buffer_size);
+
+  /* And read the buffer back into the new expression.  */
+  gfc_target_interpret_expr (buffer, buffer_size, result, false);
+
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_transpose (gfc_expr *matrix)
+{
+  int row, matrix_rows, col, matrix_cols;
+  gfc_expr *result;
+
+  if (!is_constant_array_expr (matrix))
+    return NULL;
+
+  gcc_assert (matrix->rank == 2);
+
+  result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind,
+			       &matrix->where);
+  result->rank = 2;
+  result->shape = gfc_get_shape (result->rank);
+  mpz_set (result->shape[0], matrix->shape[1]);
+  mpz_set (result->shape[1], matrix->shape[0]);
+
+  if (matrix->ts.type == BT_CHARACTER)
+    result->ts.u.cl = matrix->ts.u.cl;
+  else if (matrix->ts.type == BT_DERIVED)
+    result->ts.u.derived = matrix->ts.u.derived;
+
+  matrix_rows = mpz_get_si (matrix->shape[0]);
+  matrix_cols = mpz_get_si (matrix->shape[1]);
+  for (row = 0; row < matrix_rows; ++row)
+    for (col = 0; col < matrix_cols; ++col)
+      {
+	gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor,
+						   col * matrix_rows + row);
+	gfc_constructor_insert_expr (&result->value.constructor,
+				     gfc_copy_expr (e), &matrix->where,
+				     row * matrix_cols + col);
+      }
+
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_trim (gfc_expr *e)
+{
+  gfc_expr *result;
+  int count, i, len, lentrim;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  len = e->value.character.length;
+  for (count = 0, i = 1; i <= len; ++i)
+    {
+      if (e->value.character.string[len - i] == ' ')
+	count++;
+      else
+	break;
+    }
+
+  lentrim = len - count;
+
+  result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim);
+  for (i = 0; i < lentrim; i++)
+    result->value.character.string[i] = e->value.character.string[i];
+
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
+{
+  gfc_expr *result;
+  gfc_ref *ref;
+  gfc_array_spec *as;
+  gfc_constructor *sub_cons;
+  bool first_image;
+  int d;
+
+  if (!is_constant_array_expr (sub))
+    return NULL;
+
+  /* Follow any component references.  */
+  as = coarray->symtree->n.sym->as;
+  for (ref = coarray->ref; ref; ref = ref->next)
+    if (ref->type == REF_COMPONENT)
+      as = ref->u.ar.as;
+
+  if (as->type == AS_DEFERRED)
+    return NULL;
+
+  /* "valid sequence of cosubscripts" are required; thus, return 0 unless
+     the cosubscript addresses the first image.  */
+
+  sub_cons = gfc_constructor_first (sub->value.constructor);
+  first_image = true;
+
+  for (d = 1; d <= as->corank; d++)
+    {
+      gfc_expr *ca_bound;
+      int cmp;
+
+      gcc_assert (sub_cons != NULL);
+
+      ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
+				     NULL, true);
+      if (ca_bound == NULL)
+	return NULL;
+
+      if (ca_bound == &gfc_bad_expr)
+	return ca_bound;
+
+      cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer);
+
+      if (cmp == 0)
+	{
+          gfc_free_expr (ca_bound);
+	  sub_cons = gfc_constructor_next (sub_cons);
+	  continue;
+	}
+
+      first_image = false;
+
+      if (cmp > 0)
+	{
+	  gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
+		     "SUB has %ld and COARRAY lower bound is %ld)",
+		     &coarray->where, d,
+		     mpz_get_si (sub_cons->expr->value.integer),
+		     mpz_get_si (ca_bound->value.integer));
+	  gfc_free_expr (ca_bound);
+	  return &gfc_bad_expr;
+	}
+
+      gfc_free_expr (ca_bound);
+
+      /* Check whether upperbound is valid for the multi-images case.  */
+      if (d < as->corank)
+	{
+	  ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as,
+					 NULL, true);
+	  if (ca_bound == &gfc_bad_expr)
+	    return ca_bound;
+
+	  if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT
+	      && mpz_cmp (ca_bound->value.integer,
+			  sub_cons->expr->value.integer) < 0)
+	  {
+	    gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
+		       "SUB has %ld and COARRAY upper bound is %ld)",
+		       &coarray->where, d,
+		       mpz_get_si (sub_cons->expr->value.integer),
+		       mpz_get_si (ca_bound->value.integer));
+	    gfc_free_expr (ca_bound);
+	    return &gfc_bad_expr;
+	  }
+
+	  if (ca_bound)
+	    gfc_free_expr (ca_bound);
+	}
+
+      sub_cons = gfc_constructor_next (sub_cons);
+    }
+
+  gcc_assert (sub_cons == NULL);
+
+  if (gfc_option.coarray != GFC_FCOARRAY_SINGLE && !first_image)
+    return NULL;
+
+  result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+				  &gfc_current_locus);
+  if (first_image)
+    mpz_set_si (result->value.integer, 1);
+  else
+    mpz_set_si (result->value.integer, 0);
+
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
+{
+  if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
+    return NULL;
+
+  if (coarray == NULL)
+    {
+      gfc_expr *result;
+      /* FIXME: gfc_current_locus is wrong.  */
+      result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+				      &gfc_current_locus);
+      mpz_set_si (result->value.integer, 1);
+      return result;
+    }
+
+  /* For -fcoarray=single, this_image(A) is the same as lcobound(A).  */
+  return simplify_cobound (coarray, dim, NULL, 0);
+}
+
+
+gfc_expr *
+gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
+  return simplify_bound (array, dim, kind, 1);
+}
+
+gfc_expr *
+gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
+  return simplify_cobound (array, dim, kind, 1);
+}
+
+
+gfc_expr *
+gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
+{
+  gfc_expr *result, *e;
+  gfc_constructor *vector_ctor, *mask_ctor, *field_ctor;
+
+  if (!is_constant_array_expr (vector)
+      || !is_constant_array_expr (mask)
+      || (!gfc_is_constant_expr (field)
+	  && !is_constant_array_expr (field)))
+    return NULL;
+
+  result = gfc_get_array_expr (vector->ts.type, vector->ts.kind,
+			       &vector->where);
+  if (vector->ts.type == BT_DERIVED)
+    result->ts.u.derived = vector->ts.u.derived;
+  result->rank = mask->rank;
+  result->shape = gfc_copy_shape (mask->shape, mask->rank);
+
+  if (vector->ts.type == BT_CHARACTER)
+    result->ts.u.cl = vector->ts.u.cl;
+
+  vector_ctor = gfc_constructor_first (vector->value.constructor);
+  mask_ctor = gfc_constructor_first (mask->value.constructor);
+  field_ctor
+    = field->expr_type == EXPR_ARRAY
+			    ? gfc_constructor_first (field->value.constructor)
+			    : NULL;
+
+  while (mask_ctor)
+    {
+      if (mask_ctor->expr->value.logical)
+	{
+	  gcc_assert (vector_ctor);
+	  e = gfc_copy_expr (vector_ctor->expr);
+	  vector_ctor = gfc_constructor_next (vector_ctor);
+	}
+      else if (field->expr_type == EXPR_ARRAY)
+	e = gfc_copy_expr (field_ctor->expr);
+      else
+	e = gfc_copy_expr (field);
+
+      gfc_constructor_append_expr (&result->value.constructor, e, NULL);
+
+      mask_ctor = gfc_constructor_next (mask_ctor);
+      field_ctor = gfc_constructor_next (field_ctor);
+    }
+
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
+{
+  gfc_expr *result;
+  int back;
+  size_t index, len, lenset;
+  size_t i;
+  int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
+
+  if (k == -1)
+    return &gfc_bad_expr;
+
+  if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT
+      || ( b != NULL && b->expr_type !=  EXPR_CONSTANT))
+    return NULL;
+
+  if (b != NULL && b->value.logical != 0)
+    back = 1;
+  else
+    back = 0;
+
+  result = gfc_get_constant_expr (BT_INTEGER, k, &s->where);
+
+  len = s->value.character.length;
+  lenset = set->value.character.length;
+
+  if (len == 0)
+    {
+      mpz_set_ui (result->value.integer, 0);
+      return result;
+    }
+
+  if (back == 0)
+    {
+      if (lenset == 0)
+	{
+	  mpz_set_ui (result->value.integer, 1);
+	  return result;
+	}
+
+      index = wide_strspn (s->value.character.string,
+			   set->value.character.string) + 1;
+      if (index > len)
+	index = 0;
+
+    }
+  else
+    {
+      if (lenset == 0)
+	{
+	  mpz_set_ui (result->value.integer, len);
+	  return result;
+	}
+      for (index = len; index > 0; index --)
+	{
+	  for (i = 0; i < lenset; i++)
+	    {
+	      if (s->value.character.string[index - 1]
+		  == set->value.character.string[i])
+		break;
+	    }
+	  if (i == lenset)
+	    break;
+	}
+    }
+
+  mpz_set_ui (result->value.integer, index);
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
+{
+  gfc_expr *result;
+  int kind;
+
+  if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
+
+  switch (x->ts.type)
+    {
+      case BT_INTEGER:
+	result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
+	mpz_xor (result->value.integer, x->value.integer, y->value.integer);
+	return range_check (result, "XOR");
+
+      case BT_LOGICAL:
+	return gfc_get_logical_expr (kind, &x->where,
+				     (x->value.logical && !y->value.logical)
+				     || (!x->value.logical && y->value.logical));
+
+      default:
+	gcc_unreachable ();
+    }
+}
+
+
+/****************** Constant simplification *****************/
+
+/* Master function to convert one constant to another.  While this is
+   used as a simplification function, it requires the destination type
+   and kind information which is supplied by a special case in
+   do_simplify().  */
+
+gfc_expr *
+gfc_convert_constant (gfc_expr *e, bt type, int kind)
+{
+  gfc_expr *g, *result, *(*f) (gfc_expr *, int);
+  gfc_constructor *c;
+
+  switch (e->ts.type)
+    {
+    case BT_INTEGER:
+      switch (type)
+	{
+	case BT_INTEGER:
+	  f = gfc_int2int;
+	  break;
+	case BT_REAL:
+	  f = gfc_int2real;
+	  break;
+	case BT_COMPLEX:
+	  f = gfc_int2complex;
+	  break;
+	case BT_LOGICAL:
+	  f = gfc_int2log;
+	  break;
+	default:
+	  goto oops;
+	}
+      break;
+
+    case BT_REAL:
+      switch (type)
+	{
+	case BT_INTEGER:
+	  f = gfc_real2int;
+	  break;
+	case BT_REAL:
+	  f = gfc_real2real;
+	  break;
+	case BT_COMPLEX:
+	  f = gfc_real2complex;
+	  break;
+	default:
+	  goto oops;
+	}
+      break;
+
+    case BT_COMPLEX:
+      switch (type)
+	{
+	case BT_INTEGER:
+	  f = gfc_complex2int;
+	  break;
+	case BT_REAL:
+	  f = gfc_complex2real;
+	  break;
+	case BT_COMPLEX:
+	  f = gfc_complex2complex;
+	  break;
+
+	default:
+	  goto oops;
+	}
+      break;
+
+    case BT_LOGICAL:
+      switch (type)
+	{
+	case BT_INTEGER:
+	  f = gfc_log2int;
+	  break;
+	case BT_LOGICAL:
+	  f = gfc_log2log;
+	  break;
+	default:
+	  goto oops;
+	}
+      break;
+
+    case BT_HOLLERITH:
+      switch (type)
+	{
+	case BT_INTEGER:
+	  f = gfc_hollerith2int;
+	  break;
+
+	case BT_REAL:
+	  f = gfc_hollerith2real;
+	  break;
+
+	case BT_COMPLEX:
+	  f = gfc_hollerith2complex;
+	  break;
+
+	case BT_CHARACTER:
+	  f = gfc_hollerith2character;
+	  break;
+
+	case BT_LOGICAL:
+	  f = gfc_hollerith2logical;
+	  break;
+
+	default:
+	  goto oops;
+	}
+      break;
+
+    default:
+    oops:
+      gfc_internal_error ("gfc_convert_constant(): Unexpected type");
+    }
+
+  result = NULL;
+
+  switch (e->expr_type)
+    {
+    case EXPR_CONSTANT:
+      result = f (e, kind);
+      if (result == NULL)
+	return &gfc_bad_expr;
+      break;
+
+    case EXPR_ARRAY:
+      if (!gfc_is_constant_expr (e))
+	break;
+
+      result = gfc_get_array_expr (type, kind, &e->where);
+      result->shape = gfc_copy_shape (e->shape, e->rank);
+      result->rank = e->rank;
+
+      for (c = gfc_constructor_first (e->value.constructor);
+	   c; c = gfc_constructor_next (c))
+	{
+	  gfc_expr *tmp;
+	  if (c->iterator == NULL)
+	    tmp = f (c->expr, kind);
+	  else
+	    {
+	      g = gfc_convert_constant (c->expr, type, kind);
+	      if (g == &gfc_bad_expr)
+	        {
+		  gfc_free_expr (result);
+		  return g;
+		}
+	      tmp = g;
+	    }
+
+	  if (tmp == NULL)
+	    {
+	      gfc_free_expr (result);
+	      return NULL;
+	    }
+
+	  gfc_constructor_append_expr (&result->value.constructor,
+				       tmp, &c->where);
+	}
+
+      break;
+
+    default:
+      break;
+    }
+
+  return result;
+}
+
+
+/* Function for converting character constants.  */
+gfc_expr *
+gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
+{
+  gfc_expr *result;
+  int i;
+
+  if (!gfc_is_constant_expr (e))
+    return NULL;
+
+  if (e->expr_type == EXPR_CONSTANT)
+    {
+      /* Simple case of a scalar.  */
+      result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where);
+      if (result == NULL)
+	return &gfc_bad_expr;
+
+      result->value.character.length = e->value.character.length;
+      result->value.character.string
+	= gfc_get_wide_string (e->value.character.length + 1);
+      memcpy (result->value.character.string, e->value.character.string,
+	      (e->value.character.length + 1) * sizeof (gfc_char_t));
+
+      /* Check we only have values representable in the destination kind.  */
+      for (i = 0; i < result->value.character.length; i++)
+	if (!gfc_check_character_range (result->value.character.string[i],
+					kind))
+	  {
+	    gfc_error ("Character '%s' in string at %L cannot be converted "
+		       "into character kind %d",
+		       gfc_print_wide_char (result->value.character.string[i]),
+		       &e->where, kind);
+	    return &gfc_bad_expr;
+	  }
+
+      return result;
+    }
+  else if (e->expr_type == EXPR_ARRAY)
+    {
+      /* For an array constructor, we convert each constructor element.  */
+      gfc_constructor *c;
+
+      result = gfc_get_array_expr (type, kind, &e->where);
+      result->shape = gfc_copy_shape (e->shape, e->rank);
+      result->rank = e->rank;
+      result->ts.u.cl = e->ts.u.cl;
+
+      for (c = gfc_constructor_first (e->value.constructor);
+	   c; c = gfc_constructor_next (c))
+	{
+	  gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind);
+	  if (tmp == &gfc_bad_expr)
+	    {
+	      gfc_free_expr (result);
+	      return &gfc_bad_expr;
+	    }
+
+	  if (tmp == NULL)
+	    {
+	      gfc_free_expr (result);
+	      return NULL;
+	    }
+
+	  gfc_constructor_append_expr (&result->value.constructor,
+				       tmp, &c->where);
+	}
+
+      return result;
+    }
+  else
+    return NULL;
+}
+
+
+gfc_expr *
+gfc_simplify_compiler_options (void)
+{
+  char *str;
+  gfc_expr *result;
+
+  str = gfc_get_option_string ();
+  result = gfc_get_character_expr (gfc_default_character_kind,
+				   &gfc_current_locus, str, strlen (str));
+  free (str);
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_compiler_version (void)
+{
+  char *buffer;
+  size_t len;
+
+  len = strlen ("GCC version ") + strlen (version_string);
+  buffer = XALLOCAVEC (char, len + 1);
+  snprintf (buffer, len + 1, "GCC version %s", version_string);
+  return gfc_get_character_expr (gfc_default_character_kind,
+                                &gfc_current_locus, buffer, len);
+}
diff --git a/gcc-4.9/gcc/fortran/st.c b/gcc-4.9/gcc/fortran/st.c
new file mode 100644
index 000000000..0e1cc705e
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/st.c
@@ -0,0 +1,253 @@
+/* Build executable statement trees.
+   Copyright (C) 2000-2014 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+/* Executable statements are strung together into a singly linked list
+   of code structures.  These structures are later translated into GCC
+   GENERIC tree structures and from there to executable code for a
+   target.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "gfortran.h"
+
+gfc_code new_st;
+
+
+/* Zeroes out the new_st structure.  */
+
+void
+gfc_clear_new_st (void)
+{
+  memset (&new_st, '\0', sizeof (new_st));
+  new_st.op = EXEC_NOP;
+}
+
+
+/* Get a gfc_code structure, initialized with the current locus
+   and a statement code 'op'.  */
+
+gfc_code *
+gfc_get_code (gfc_exec_op op)
+{
+  gfc_code *c;
+
+  c = XCNEW (gfc_code);
+  c->op = op;
+  c->loc = gfc_current_locus;
+  return c;
+}
+
+
+/* Given some part of a gfc_code structure, append a set of code to
+   its tail, returning a pointer to the new tail.  */
+
+gfc_code *
+gfc_append_code (gfc_code *tail, gfc_code *new_code)
+{
+  if (tail != NULL)
+    {
+      while (tail->next != NULL)
+	tail = tail->next;
+
+      tail->next = new_code;
+    }
+
+  while (new_code->next != NULL)
+    new_code = new_code->next;
+
+  return new_code;
+}
+
+
+/* Free a single code structure, but not the actual structure itself.  */
+
+void
+gfc_free_statement (gfc_code *p)
+{
+  if (p->expr1)
+    gfc_free_expr (p->expr1);
+  if (p->expr2)
+    gfc_free_expr (p->expr2);
+
+  switch (p->op)
+    {
+    case EXEC_NOP:
+    case EXEC_END_BLOCK:
+    case EXEC_END_NESTED_BLOCK:
+    case EXEC_ASSIGN:
+    case EXEC_INIT_ASSIGN:
+    case EXEC_GOTO:
+    case EXEC_CYCLE:
+    case EXEC_RETURN:
+    case EXEC_END_PROCEDURE:
+    case EXEC_IF:
+    case EXEC_PAUSE:
+    case EXEC_STOP:
+    case EXEC_ERROR_STOP:
+    case EXEC_EXIT:
+    case EXEC_WHERE:
+    case EXEC_IOLENGTH:
+    case EXEC_POINTER_ASSIGN:
+    case EXEC_DO_WHILE:
+    case EXEC_CONTINUE:
+    case EXEC_TRANSFER:
+    case EXEC_LABEL_ASSIGN:
+    case EXEC_ENTRY:
+    case EXEC_ARITHMETIC_IF:
+    case EXEC_CRITICAL:
+    case EXEC_SYNC_ALL:
+    case EXEC_SYNC_IMAGES:
+    case EXEC_SYNC_MEMORY:
+    case EXEC_LOCK:
+    case EXEC_UNLOCK:
+      break;
+
+    case EXEC_BLOCK:
+      gfc_free_namespace (p->ext.block.ns);
+      gfc_free_association_list (p->ext.block.assoc);
+      break;
+
+    case EXEC_COMPCALL:
+    case EXEC_CALL_PPC:
+    case EXEC_CALL:
+    case EXEC_ASSIGN_CALL:
+      gfc_free_actual_arglist (p->ext.actual);
+      break;
+
+    case EXEC_SELECT:
+    case EXEC_SELECT_TYPE:
+      if (p->ext.block.case_list)
+	gfc_free_case_list (p->ext.block.case_list);
+      break;
+
+    case EXEC_DO:
+      gfc_free_iterator (p->ext.iterator, 1);
+      break;
+
+    case EXEC_ALLOCATE:
+    case EXEC_DEALLOCATE:
+      gfc_free_alloc_list (p->ext.alloc.list);
+      break;
+
+    case EXEC_OPEN:
+      gfc_free_open (p->ext.open);
+      break;
+
+    case EXEC_CLOSE:
+      gfc_free_close (p->ext.close);
+      break;
+
+    case EXEC_BACKSPACE:
+    case EXEC_ENDFILE:
+    case EXEC_REWIND:
+    case EXEC_FLUSH:
+      gfc_free_filepos (p->ext.filepos);
+      break;
+
+    case EXEC_INQUIRE:
+      gfc_free_inquire (p->ext.inquire);
+      break;
+
+    case EXEC_WAIT:
+      gfc_free_wait (p->ext.wait);
+      break;
+
+    case EXEC_READ:
+    case EXEC_WRITE:
+      gfc_free_dt (p->ext.dt);
+      break;
+
+    case EXEC_DT_END:
+      /* The ext.dt member is a duplicate pointer and doesn't need to
+	 be freed.  */
+      break;
+
+    case EXEC_DO_CONCURRENT:
+    case EXEC_FORALL:
+      gfc_free_forall_iterator (p->ext.forall_iterator);
+      break;
+
+    case EXEC_OMP_DO:
+    case EXEC_OMP_END_SINGLE:
+    case EXEC_OMP_PARALLEL:
+    case EXEC_OMP_PARALLEL_DO:
+    case EXEC_OMP_PARALLEL_SECTIONS:
+    case EXEC_OMP_SECTIONS:
+    case EXEC_OMP_SINGLE:
+    case EXEC_OMP_TASK:
+    case EXEC_OMP_WORKSHARE:
+    case EXEC_OMP_PARALLEL_WORKSHARE:
+      gfc_free_omp_clauses (p->ext.omp_clauses);
+      break;
+
+    case EXEC_OMP_CRITICAL:
+      free (CONST_CAST (char *, p->ext.omp_name));
+      break;
+
+    case EXEC_OMP_FLUSH:
+      gfc_free_namelist (p->ext.omp_namelist);
+      break;
+
+    case EXEC_OMP_ATOMIC:
+    case EXEC_OMP_BARRIER:
+    case EXEC_OMP_MASTER:
+    case EXEC_OMP_ORDERED:
+    case EXEC_OMP_END_NOWAIT:
+    case EXEC_OMP_TASKWAIT:
+    case EXEC_OMP_TASKYIELD:
+      break;
+
+    default:
+      gfc_internal_error ("gfc_free_statement(): Bad statement");
+    }
+}
+
+
+/* Free a code statement and all other code structures linked to it.  */
+
+void
+gfc_free_statements (gfc_code *p)
+{
+  gfc_code *q;
+
+  for (; p; p = q)
+    {
+      q = p->next;
+
+      if (p->block)
+	gfc_free_statements (p->block);
+      gfc_free_statement (p);
+      free (p);
+    }
+}
+
+
+/* Free an association list (of an ASSOCIATE statement).  */
+
+void
+gfc_free_association_list (gfc_association_list* assoc)
+{
+  if (!assoc)
+    return;
+
+  gfc_free_association_list (assoc->next);
+  free (assoc);
+}
diff --git a/gcc-4.9/gcc/fortran/symbol.c b/gcc-4.9/gcc/fortran/symbol.c
new file mode 100644
index 000000000..19d792e08
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/symbol.c
@@ -0,0 +1,4579 @@
+/* Maintain binary trees of symbols.
+   Copyright (C) 2000-2014 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "flags.h"
+#include "gfortran.h"
+#include "parse.h"
+#include "match.h"
+#include "constructor.h"
+
+
+/* Strings for all symbol attributes.  We use these for dumping the
+   parse tree, in error messages, and also when reading and writing
+   modules.  */
+
+const mstring flavors[] =
+{
+  minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM),
+  minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE),
+  minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER),
+  minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE),
+  minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST),
+  minit (NULL, -1)
+};
+
+const mstring procedures[] =
+{
+    minit ("UNKNOWN-PROC", PROC_UNKNOWN),
+    minit ("MODULE-PROC", PROC_MODULE),
+    minit ("INTERNAL-PROC", PROC_INTERNAL),
+    minit ("DUMMY-PROC", PROC_DUMMY),
+    minit ("INTRINSIC-PROC", PROC_INTRINSIC),
+    minit ("EXTERNAL-PROC", PROC_EXTERNAL),
+    minit ("STATEMENT-PROC", PROC_ST_FUNCTION),
+    minit (NULL, -1)
+};
+
+const mstring intents[] =
+{
+    minit ("UNKNOWN-INTENT", INTENT_UNKNOWN),
+    minit ("IN", INTENT_IN),
+    minit ("OUT", INTENT_OUT),
+    minit ("INOUT", INTENT_INOUT),
+    minit (NULL, -1)
+};
+
+const mstring access_types[] =
+{
+    minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN),
+    minit ("PUBLIC", ACCESS_PUBLIC),
+    minit ("PRIVATE", ACCESS_PRIVATE),
+    minit (NULL, -1)
+};
+
+const mstring ifsrc_types[] =
+{
+    minit ("UNKNOWN", IFSRC_UNKNOWN),
+    minit ("DECL", IFSRC_DECL),
+    minit ("BODY", IFSRC_IFBODY)
+};
+
+const mstring save_status[] =
+{
+    minit ("UNKNOWN", SAVE_NONE),
+    minit ("EXPLICIT-SAVE", SAVE_EXPLICIT),
+    minit ("IMPLICIT-SAVE", SAVE_IMPLICIT),
+};
+
+/* This is to make sure the backend generates setup code in the correct
+   order.  */
+
+static int next_dummy_order = 1;
+
+
+gfc_namespace *gfc_current_ns;
+gfc_namespace *gfc_global_ns_list;
+
+gfc_gsymbol *gfc_gsym_root = NULL;
+
+gfc_dt_list *gfc_derived_types;
+
+static gfc_undo_change_set default_undo_chgset_var = { vNULL, vNULL, NULL };
+static gfc_undo_change_set *latest_undo_chgset = &default_undo_chgset_var;
+
+
+/*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
+
+/* The following static variable indicates whether a particular element has
+   been explicitly set or not.  */
+
+static int new_flag[GFC_LETTERS];
+
+
+/* Handle a correctly parsed IMPLICIT NONE.  */
+
+void
+gfc_set_implicit_none (void)
+{
+  int i;
+
+  if (gfc_current_ns->seen_implicit_none)
+    {
+      gfc_error ("Duplicate IMPLICIT NONE statement at %C");
+      return;
+    }
+
+  gfc_current_ns->seen_implicit_none = 1;
+
+  for (i = 0; i < GFC_LETTERS; i++)
+    {
+      gfc_clear_ts (&gfc_current_ns->default_type[i]);
+      gfc_current_ns->set_flag[i] = 1;
+    }
+}
+
+
+/* Reset the implicit range flags.  */
+
+void
+gfc_clear_new_implicit (void)
+{
+  int i;
+
+  for (i = 0; i < GFC_LETTERS; i++)
+    new_flag[i] = 0;
+}
+
+
+/* Prepare for a new implicit range.  Sets flags in new_flag[].  */
+
+bool
+gfc_add_new_implicit_range (int c1, int c2)
+{
+  int i;
+
+  c1 -= 'a';
+  c2 -= 'a';
+
+  for (i = c1; i <= c2; i++)
+    {
+      if (new_flag[i])
+	{
+	  gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
+		     i + 'A');
+	  return false;
+	}
+
+      new_flag[i] = 1;
+    }
+
+  return true;
+}
+
+
+/* Add a matched implicit range for gfc_set_implicit().  Check if merging
+   the new implicit types back into the existing types will work.  */
+
+bool
+gfc_merge_new_implicit (gfc_typespec *ts)
+{
+  int i;
+
+  if (gfc_current_ns->seen_implicit_none)
+    {
+      gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
+      return false;
+    }
+
+  for (i = 0; i < GFC_LETTERS; i++)
+    {
+      if (new_flag[i])
+	{
+	  if (gfc_current_ns->set_flag[i])
+	    {
+	      gfc_error ("Letter %c already has an IMPLICIT type at %C",
+			 i + 'A');
+	      return false;
+	    }
+
+	  gfc_current_ns->default_type[i] = *ts;
+	  gfc_current_ns->implicit_loc[i] = gfc_current_locus;
+	  gfc_current_ns->set_flag[i] = 1;
+	}
+    }
+  return true;
+}
+
+
+/* Given a symbol, return a pointer to the typespec for its default type.  */
+
+gfc_typespec *
+gfc_get_default_type (const char *name, gfc_namespace *ns)
+{
+  char letter;
+
+  letter = name[0];
+
+  if (gfc_option.flag_allow_leading_underscore && letter == '_')
+    gfc_internal_error ("Option -fallow-leading-underscore is for use only by "
+			"gfortran developers, and should not be used for "
+			"implicitly typed variables");
+
+  if (letter < 'a' || letter > 'z')
+    gfc_internal_error ("gfc_get_default_type(): Bad symbol '%s'", name);
+
+  if (ns == NULL)
+    ns = gfc_current_ns;
+
+  return &ns->default_type[letter - 'a'];
+}
+
+
+/* Given a pointer to a symbol, set its type according to the first
+   letter of its name.  Fails if the letter in question has no default
+   type.  */
+
+bool
+gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
+{
+  gfc_typespec *ts;
+
+  if (sym->ts.type != BT_UNKNOWN)
+    gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
+
+  ts = gfc_get_default_type (sym->name, ns);
+
+  if (ts->type == BT_UNKNOWN)
+    {
+      if (error_flag && !sym->attr.untyped)
+	{
+	  gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
+		     sym->name, &sym->declared_at);
+	  sym->attr.untyped = 1; /* Ensure we only give an error once.  */
+	}
+
+      return false;
+    }
+
+  sym->ts = *ts;
+  sym->attr.implicit_type = 1;
+
+  if (ts->type == BT_CHARACTER && ts->u.cl)
+    sym->ts.u.cl = gfc_new_charlen (sym->ns, ts->u.cl);
+  else if (ts->type == BT_CLASS
+	   && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
+    return false;
+
+  if (sym->attr.is_bind_c == 1 && gfc_option.warn_c_binding_type)
+    {
+      /* BIND(C) variables should not be implicitly declared.  */
+      gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
+                       "not be C interoperable", sym->name, &sym->declared_at);
+      sym->ts.f90_type = sym->ts.type;
+    }
+
+  if (sym->attr.dummy != 0)
+    {
+      if (sym->ns->proc_name != NULL
+	  && (sym->ns->proc_name->attr.subroutine != 0
+	      || sym->ns->proc_name->attr.function != 0)
+	  && sym->ns->proc_name->attr.is_bind_c != 0
+	  && gfc_option.warn_c_binding_type)
+        {
+          /* Dummy args to a BIND(C) routine may not be interoperable if
+             they are implicitly typed.  */
+          gfc_warning_now ("Implicitly declared variable '%s' at %L may not "
+                           "be C interoperable but it is a dummy argument to "
+                           "the BIND(C) procedure '%s' at %L", sym->name,
+                           &(sym->declared_at), sym->ns->proc_name->name,
+                           &(sym->ns->proc_name->declared_at));
+          sym->ts.f90_type = sym->ts.type;
+        }
+    }
+  
+  return true;
+}
+
+
+/* This function is called from parse.c(parse_progunit) to check the
+   type of the function is not implicitly typed in the host namespace
+   and to implicitly type the function result, if necessary.  */
+
+void
+gfc_check_function_type (gfc_namespace *ns)
+{
+  gfc_symbol *proc = ns->proc_name;
+
+  if (!proc->attr.contained || proc->result->attr.implicit_type)
+    return;
+
+  if (proc->result->ts.type == BT_UNKNOWN && proc->result->ts.interface == NULL)
+    {
+      if (gfc_set_default_type (proc->result, 0, gfc_current_ns))
+	{
+	  if (proc->result != proc)
+	    {
+	      proc->ts = proc->result->ts;
+	      proc->as = gfc_copy_array_spec (proc->result->as);
+	      proc->attr.dimension = proc->result->attr.dimension;
+	      proc->attr.pointer = proc->result->attr.pointer;
+	      proc->attr.allocatable = proc->result->attr.allocatable;
+	    }
+	}
+      else if (!proc->result->attr.proc_pointer)
+	{
+	  gfc_error ("Function result '%s' at %L has no IMPLICIT type",
+		     proc->result->name, &proc->result->declared_at);
+	  proc->result->attr.untyped = 1;
+	}
+    }
+}
+
+
+/******************** Symbol attribute stuff *********************/
+
+/* This is a generic conflict-checker.  We do this to avoid having a
+   single conflict in two places.  */
+
+#define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
+#define conf2(a) if (attr->a) { a2 = a; goto conflict; }
+#define conf_std(a, b, std) if (attr->a && attr->b)\
+                              {\
+                                a1 = a;\
+                                a2 = b;\
+                                standard = std;\
+                                goto conflict_std;\
+                              }
+
+static bool
+check_conflict (symbol_attribute *attr, const char *name, locus *where)
+{
+  static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
+    *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
+    *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
+    *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
+    *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
+    *privat = "PRIVATE", *recursive = "RECURSIVE",
+    *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
+    *publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
+    *function = "FUNCTION", *subroutine = "SUBROUTINE",
+    *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
+    *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
+    *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
+    *volatile_ = "VOLATILE", *is_protected = "PROTECTED",
+    *is_bind_c = "BIND(C)", *procedure = "PROCEDURE",
+    *proc_pointer = "PROCEDURE POINTER", *abstract = "ABSTRACT",
+    *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION",
+    *contiguous = "CONTIGUOUS", *generic = "GENERIC";
+  static const char *threadprivate = "THREADPRIVATE";
+
+  const char *a1, *a2;
+  int standard;
+
+  if (where == NULL)
+    where = &gfc_current_locus;
+
+  if (attr->pointer && attr->intent != INTENT_UNKNOWN)
+    {
+      a1 = pointer;
+      a2 = intent;
+      standard = GFC_STD_F2003;
+      goto conflict_std;
+    }
+
+  if (attr->in_namelist && (attr->allocatable || attr->pointer))
+    {
+      a1 = in_namelist;
+      a2 = attr->allocatable ? allocatable : pointer;
+      standard = GFC_STD_F2003;
+      goto conflict_std;
+    }
+
+  /* Check for attributes not allowed in a BLOCK DATA.  */
+  if (gfc_current_state () == COMP_BLOCK_DATA)
+    {
+      a1 = NULL;
+
+      if (attr->in_namelist)
+	a1 = in_namelist;
+      if (attr->allocatable)
+	a1 = allocatable;
+      if (attr->external)
+	a1 = external;
+      if (attr->optional)
+	a1 = optional;
+      if (attr->access == ACCESS_PRIVATE)
+	a1 = privat;
+      if (attr->access == ACCESS_PUBLIC)
+	a1 = publik;
+      if (attr->intent != INTENT_UNKNOWN)
+	a1 = intent;
+
+      if (a1 != NULL)
+	{
+	  gfc_error
+	    ("%s attribute not allowed in BLOCK DATA program unit at %L",
+	     a1, where);
+	  return false;
+	}
+    }
+
+  if (attr->save == SAVE_EXPLICIT)
+    {
+      conf (dummy, save);
+      conf (in_common, save);
+      conf (result, save);
+
+      switch (attr->flavor)
+	{
+	  case FL_PROGRAM:
+	  case FL_BLOCK_DATA:
+	  case FL_MODULE:
+	  case FL_LABEL:
+	  case FL_DERIVED:
+	  case FL_PARAMETER:
+            a1 = gfc_code2string (flavors, attr->flavor);
+            a2 = save;
+	    goto conflict;
+	  case FL_NAMELIST:
+	    gfc_error ("Namelist group name at %L cannot have the "
+		       "SAVE attribute", where);
+	    return false; 
+	    break;
+	  case FL_PROCEDURE:
+	    /* Conflicts between SAVE and PROCEDURE will be checked at
+	       resolution stage, see "resolve_fl_procedure".  */
+	  case FL_VARIABLE:
+	  default:
+	    break;
+	}
+    }
+
+  conf (dummy, entry);
+  conf (dummy, intrinsic);
+  conf (dummy, threadprivate);
+  conf (pointer, target);
+  conf (pointer, intrinsic);
+  conf (pointer, elemental);
+  conf (allocatable, elemental);
+
+  conf (target, external);
+  conf (target, intrinsic);
+
+  if (!attr->if_source)
+    conf (external, dimension);   /* See Fortran 95's R504.  */
+
+  conf (external, intrinsic);
+  conf (entry, intrinsic);
+
+  if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
+    conf (external, subroutine);
+
+  if (attr->proc_pointer && !gfc_notify_std (GFC_STD_F2003, 
+					     "Procedure pointer at %C"))
+    return false;
+
+  conf (allocatable, pointer);
+  conf_std (allocatable, dummy, GFC_STD_F2003);
+  conf_std (allocatable, function, GFC_STD_F2003);
+  conf_std (allocatable, result, GFC_STD_F2003);
+  conf (elemental, recursive);
+
+  conf (in_common, dummy);
+  conf (in_common, allocatable);
+  conf (in_common, codimension);
+  conf (in_common, result);
+
+  conf (in_equivalence, use_assoc);
+  conf (in_equivalence, codimension);
+  conf (in_equivalence, dummy);
+  conf (in_equivalence, target);
+  conf (in_equivalence, pointer);
+  conf (in_equivalence, function);
+  conf (in_equivalence, result);
+  conf (in_equivalence, entry);
+  conf (in_equivalence, allocatable);
+  conf (in_equivalence, threadprivate);
+
+  conf (dummy, result);
+  conf (entry, result);
+  conf (generic, result);
+
+  conf (function, subroutine);
+
+  if (!function && !subroutine)
+    conf (is_bind_c, dummy);
+
+  conf (is_bind_c, cray_pointer);
+  conf (is_bind_c, cray_pointee);
+  conf (is_bind_c, codimension);
+  conf (is_bind_c, allocatable);
+  conf (is_bind_c, elemental);
+
+  /* Need to also get volatile attr, according to 5.1 of F2003 draft.
+     Parameter conflict caught below.  Also, value cannot be specified
+     for a dummy procedure.  */
+
+  /* Cray pointer/pointee conflicts.  */
+  conf (cray_pointer, cray_pointee);
+  conf (cray_pointer, dimension);
+  conf (cray_pointer, codimension);
+  conf (cray_pointer, contiguous);
+  conf (cray_pointer, pointer);
+  conf (cray_pointer, target);
+  conf (cray_pointer, allocatable);
+  conf (cray_pointer, external);
+  conf (cray_pointer, intrinsic);
+  conf (cray_pointer, in_namelist);
+  conf (cray_pointer, function);
+  conf (cray_pointer, subroutine);
+  conf (cray_pointer, entry);
+
+  conf (cray_pointee, allocatable);
+  conf (cray_pointer, contiguous);
+  conf (cray_pointer, codimension);
+  conf (cray_pointee, intent);
+  conf (cray_pointee, optional);
+  conf (cray_pointee, dummy);
+  conf (cray_pointee, target);
+  conf (cray_pointee, intrinsic);
+  conf (cray_pointee, pointer);
+  conf (cray_pointee, entry);
+  conf (cray_pointee, in_common);
+  conf (cray_pointee, in_equivalence);
+  conf (cray_pointee, threadprivate);
+
+  conf (data, dummy);
+  conf (data, function);
+  conf (data, result);
+  conf (data, allocatable);
+
+  conf (value, pointer)
+  conf (value, allocatable)
+  conf (value, subroutine)
+  conf (value, function)
+  conf (value, volatile_)
+  conf (value, dimension)
+  conf (value, codimension)
+  conf (value, external)
+
+  conf (codimension, result)
+
+  if (attr->value
+      && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
+    {
+      a1 = value;
+      a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
+      goto conflict;
+    }
+
+  conf (is_protected, intrinsic)
+  conf (is_protected, in_common)
+
+  conf (asynchronous, intrinsic)
+  conf (asynchronous, external)
+
+  conf (volatile_, intrinsic)
+  conf (volatile_, external)
+
+  if (attr->volatile_ && attr->intent == INTENT_IN)
+    {
+      a1 = volatile_;
+      a2 = intent_in;
+      goto conflict;
+    }
+
+  conf (procedure, allocatable)
+  conf (procedure, dimension)
+  conf (procedure, codimension)
+  conf (procedure, intrinsic)
+  conf (procedure, target)
+  conf (procedure, value)
+  conf (procedure, volatile_)
+  conf (procedure, asynchronous)
+  conf (procedure, entry)
+
+  conf (proc_pointer, abstract)
+
+  a1 = gfc_code2string (flavors, attr->flavor);
+
+  if (attr->in_namelist
+      && attr->flavor != FL_VARIABLE
+      && attr->flavor != FL_PROCEDURE
+      && attr->flavor != FL_UNKNOWN)
+    {
+      a2 = in_namelist;
+      goto conflict;
+    }
+
+  switch (attr->flavor)
+    {
+    case FL_PROGRAM:
+    case FL_BLOCK_DATA:
+    case FL_MODULE:
+    case FL_LABEL:
+      conf2 (codimension);
+      conf2 (dimension);
+      conf2 (dummy);
+      conf2 (volatile_);
+      conf2 (asynchronous);
+      conf2 (contiguous);
+      conf2 (pointer);
+      conf2 (is_protected);
+      conf2 (target);
+      conf2 (external);
+      conf2 (intrinsic);
+      conf2 (allocatable);
+      conf2 (result);
+      conf2 (in_namelist);
+      conf2 (optional);
+      conf2 (function);
+      conf2 (subroutine);
+      conf2 (threadprivate);
+
+      if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE)
+	{
+	  a2 = attr->access == ACCESS_PUBLIC ? publik : privat;
+	  gfc_error ("%s attribute applied to %s %s at %L", a2, a1,
+	    name, where);
+	  return false;
+	}
+
+      if (attr->is_bind_c)
+	{
+	  gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where);
+	  return false;
+	}
+
+      break;
+
+    case FL_VARIABLE:
+      break;
+
+    case FL_NAMELIST:
+      conf2 (result);
+      break;
+
+    case FL_PROCEDURE:
+      /* Conflicts with INTENT, SAVE and RESULT will be checked
+	 at resolution stage, see "resolve_fl_procedure".  */
+
+      if (attr->subroutine)
+	{
+	  a1 = subroutine;
+	  conf2 (target);
+	  conf2 (allocatable);
+	  conf2 (volatile_);
+	  conf2 (asynchronous);
+	  conf2 (in_namelist);
+	  conf2 (codimension);
+	  conf2 (dimension);
+	  conf2 (function);
+	  if (!attr->proc_pointer)
+	    conf2 (threadprivate);
+	}
+
+      if (!attr->proc_pointer)
+	conf2 (in_common);
+
+      switch (attr->proc)
+	{
+	case PROC_ST_FUNCTION:
+	  conf2 (dummy);
+	  conf2 (target);
+	  break;
+
+	case PROC_MODULE:
+	  conf2 (dummy);
+	  break;
+
+	case PROC_DUMMY:
+	  conf2 (result);
+	  conf2 (threadprivate);
+	  break;
+
+	default:
+	  break;
+	}
+
+      break;
+
+    case FL_DERIVED:
+      conf2 (dummy);
+      conf2 (pointer);
+      conf2 (target);
+      conf2 (external);
+      conf2 (intrinsic);
+      conf2 (allocatable);
+      conf2 (optional);
+      conf2 (entry);
+      conf2 (function);
+      conf2 (subroutine);
+      conf2 (threadprivate);
+      conf2 (result);
+
+      if (attr->intent != INTENT_UNKNOWN)
+	{
+	  a2 = intent;
+	  goto conflict;
+	}
+      break;
+
+    case FL_PARAMETER:
+      conf2 (external);
+      conf2 (intrinsic);
+      conf2 (optional);
+      conf2 (allocatable);
+      conf2 (function);
+      conf2 (subroutine);
+      conf2 (entry);
+      conf2 (contiguous);
+      conf2 (pointer);
+      conf2 (is_protected);
+      conf2 (target);
+      conf2 (dummy);
+      conf2 (in_common);
+      conf2 (value);
+      conf2 (volatile_);
+      conf2 (asynchronous);
+      conf2 (threadprivate);
+      conf2 (value);
+      conf2 (codimension);
+      conf2 (result);
+      if (!attr->is_iso_c)
+	conf2 (is_bind_c);
+      break;
+
+    default:
+      break;
+    }
+
+  return true;
+
+conflict:
+  if (name == NULL)
+    gfc_error ("%s attribute conflicts with %s attribute at %L",
+	       a1, a2, where);
+  else
+    gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
+	       a1, a2, name, where);
+
+  return false;
+
+conflict_std:
+  if (name == NULL)
+    {
+      return gfc_notify_std (standard, "%s attribute "
+                             "with %s attribute at %L", a1, a2,
+                             where);
+    }
+  else
+    {
+      return gfc_notify_std (standard, "%s attribute "
+			     "with %s attribute in '%s' at %L",
+                             a1, a2, name, where);
+    }
+}
+
+#undef conf
+#undef conf2
+#undef conf_std
+
+
+/* Mark a symbol as referenced.  */
+
+void
+gfc_set_sym_referenced (gfc_symbol *sym)
+{
+
+  if (sym->attr.referenced)
+    return;
+
+  sym->attr.referenced = 1;
+
+  /* Remember which order dummy variables are accessed in.  */
+  if (sym->attr.dummy)
+    sym->dummy_order = next_dummy_order++;
+}
+
+
+/* Common subroutine called by attribute changing subroutines in order
+   to prevent them from changing a symbol that has been
+   use-associated.  Returns zero if it is OK to change the symbol,
+   nonzero if not.  */
+
+static int
+check_used (symbol_attribute *attr, const char *name, locus *where)
+{
+
+  if (attr->use_assoc == 0)
+    return 0;
+
+  if (where == NULL)
+    where = &gfc_current_locus;
+
+  if (name == NULL)
+    gfc_error ("Cannot change attributes of USE-associated symbol at %L",
+	       where);
+  else
+    gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
+	       name, where);
+
+  return 1;
+}
+
+
+/* Generate an error because of a duplicate attribute.  */
+
+static void
+duplicate_attr (const char *attr, locus *where)
+{
+
+  if (where == NULL)
+    where = &gfc_current_locus;
+
+  gfc_error ("Duplicate %s attribute specified at %L", attr, where);
+}
+
+
+bool
+gfc_add_ext_attribute (symbol_attribute *attr, ext_attr_id_t ext_attr,
+		       locus *where ATTRIBUTE_UNUSED)
+{
+  attr->ext_attr |= 1 << ext_attr;
+  return true;
+}
+
+
+/* Called from decl.c (attr_decl1) to check attributes, when declared
+   separately.  */
+
+bool
+gfc_add_attribute (symbol_attribute *attr, locus *where)
+{
+  if (check_used (attr, NULL, where))
+    return false;
+
+  return check_conflict (attr, NULL, where);
+}
+
+
+bool
+gfc_add_allocatable (symbol_attribute *attr, locus *where)
+{
+
+  if (check_used (attr, NULL, where))
+    return false;
+
+  if (attr->allocatable)
+    {
+      duplicate_attr ("ALLOCATABLE", where);
+      return false;
+    }
+
+  if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
+      && !gfc_find_state (COMP_INTERFACE))
+    {
+      gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
+		 where);
+      return false;
+    }
+
+  attr->allocatable = 1;
+  return check_conflict (attr, NULL, where);
+}
+
+
+bool
+gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where)
+{
+
+  if (check_used (attr, name, where))
+    return false;
+
+  if (attr->codimension)
+    {
+      duplicate_attr ("CODIMENSION", where);
+      return false;
+    }
+
+  if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
+      && !gfc_find_state (COMP_INTERFACE))
+    {
+      gfc_error ("CODIMENSION specified for '%s' outside its INTERFACE body "
+		 "at %L", name, where);
+      return false;
+    }
+
+  attr->codimension = 1;
+  return check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
+{
+
+  if (check_used (attr, name, where))
+    return false;
+
+  if (attr->dimension)
+    {
+      duplicate_attr ("DIMENSION", where);
+      return false;
+    }
+
+  if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
+      && !gfc_find_state (COMP_INTERFACE))
+    {
+      gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body "
+		 "at %L", name, where);
+      return false;
+    }
+
+  attr->dimension = 1;
+  return check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_contiguous (symbol_attribute *attr, const char *name, locus *where)
+{
+
+  if (check_used (attr, name, where))
+    return false;
+
+  attr->contiguous = 1;
+  return check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_external (symbol_attribute *attr, locus *where)
+{
+
+  if (check_used (attr, NULL, where))
+    return false;
+
+  if (attr->external)
+    {
+      duplicate_attr ("EXTERNAL", where);
+      return false;
+    }
+
+  if (attr->pointer && attr->if_source != IFSRC_IFBODY)
+    {
+      attr->pointer = 0;
+      attr->proc_pointer = 1;
+    }
+
+  attr->external = 1;
+
+  return check_conflict (attr, NULL, where);
+}
+
+
+bool
+gfc_add_intrinsic (symbol_attribute *attr, locus *where)
+{
+
+  if (check_used (attr, NULL, where))
+    return false;
+
+  if (attr->intrinsic)
+    {
+      duplicate_attr ("INTRINSIC", where);
+      return false;
+    }
+
+  attr->intrinsic = 1;
+
+  return check_conflict (attr, NULL, where);
+}
+
+
+bool
+gfc_add_optional (symbol_attribute *attr, locus *where)
+{
+
+  if (check_used (attr, NULL, where))
+    return false;
+
+  if (attr->optional)
+    {
+      duplicate_attr ("OPTIONAL", where);
+      return false;
+    }
+
+  attr->optional = 1;
+  return check_conflict (attr, NULL, where);
+}
+
+
+bool
+gfc_add_pointer (symbol_attribute *attr, locus *where)
+{
+
+  if (check_used (attr, NULL, where))
+    return false;
+
+  if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
+      && !gfc_find_state (COMP_INTERFACE)))
+    {
+      duplicate_attr ("POINTER", where);
+      return false;
+    }
+
+  if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY)
+      || (attr->if_source == IFSRC_IFBODY
+      && !gfc_find_state (COMP_INTERFACE)))
+    attr->proc_pointer = 1;
+  else
+    attr->pointer = 1;
+
+  return check_conflict (attr, NULL, where);
+}
+
+
+bool
+gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
+{
+
+  if (check_used (attr, NULL, where))
+    return false;
+
+  attr->cray_pointer = 1;
+  return check_conflict (attr, NULL, where);
+}
+
+
+bool
+gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
+{
+
+  if (check_used (attr, NULL, where))
+    return false;
+
+  if (attr->cray_pointee)
+    {
+      gfc_error ("Cray Pointee at %L appears in multiple pointer()"
+		 " statements", where);
+      return false;
+    }
+
+  attr->cray_pointee = 1;
+  return check_conflict (attr, NULL, where);
+}
+
+
+bool
+gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
+{
+  if (check_used (attr, name, where))
+    return false;
+
+  if (attr->is_protected)
+    {
+	if (!gfc_notify_std (GFC_STD_LEGACY, 
+			     "Duplicate PROTECTED attribute specified at %L", 
+			     where))
+	  return false;
+    }
+
+  attr->is_protected = 1;
+  return check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
+{
+
+  if (check_used (attr, name, where))
+    return false;
+
+  attr->result = 1;
+  return check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_save (symbol_attribute *attr, save_state s, const char *name,
+	      locus *where)
+{
+
+  if (check_used (attr, name, where))
+    return false;
+
+  if (s == SAVE_EXPLICIT && gfc_pure (NULL))
+    {
+      gfc_error
+	("SAVE attribute at %L cannot be specified in a PURE procedure",
+	 where);
+      return false;
+    }
+
+  if (s == SAVE_EXPLICIT)
+    gfc_unset_implicit_pure (NULL);
+
+  if (s == SAVE_EXPLICIT && attr->save == SAVE_EXPLICIT)
+    {
+	if (!gfc_notify_std (GFC_STD_LEGACY, 
+			     "Duplicate SAVE attribute specified at %L", 
+			     where))
+	  return false;
+    }
+
+  attr->save = s;
+  return check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
+{
+
+  if (check_used (attr, name, where))
+    return false;
+
+  if (attr->value)
+    {
+	if (!gfc_notify_std (GFC_STD_LEGACY, 
+			     "Duplicate VALUE attribute specified at %L", 
+			     where))
+	  return false;
+    }
+
+  attr->value = 1;
+  return check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
+{
+  /* No check_used needed as 11.2.1 of the F2003 standard allows
+     that the local identifier made accessible by a use statement can be
+     given a VOLATILE attribute - unless it is a coarray (F2008, C560).  */
+
+  if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
+    if (!gfc_notify_std (GFC_STD_LEGACY, 
+			 "Duplicate VOLATILE attribute specified at %L", 
+			 where))
+      return false;
+
+  attr->volatile_ = 1;
+  attr->volatile_ns = gfc_current_ns;
+  return check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where)
+{
+  /* No check_used needed as 11.2.1 of the F2003 standard allows
+     that the local identifier made accessible by a use statement can be
+     given a ASYNCHRONOUS attribute.  */
+
+  if (attr->asynchronous && attr->asynchronous_ns == gfc_current_ns)
+    if (!gfc_notify_std (GFC_STD_LEGACY, 
+			 "Duplicate ASYNCHRONOUS attribute specified at %L", 
+			 where))
+      return false;
+
+  attr->asynchronous = 1;
+  attr->asynchronous_ns = gfc_current_ns;
+  return check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
+{
+
+  if (check_used (attr, name, where))
+    return false;
+
+  if (attr->threadprivate)
+    {
+      duplicate_attr ("THREADPRIVATE", where);
+      return false;
+    }
+
+  attr->threadprivate = 1;
+  return check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_target (symbol_attribute *attr, locus *where)
+{
+
+  if (check_used (attr, NULL, where))
+    return false;
+
+  if (attr->target)
+    {
+      duplicate_attr ("TARGET", where);
+      return false;
+    }
+
+  attr->target = 1;
+  return check_conflict (attr, NULL, where);
+}
+
+
+bool
+gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
+{
+
+  if (check_used (attr, name, where))
+    return false;
+
+  /* Duplicate dummy arguments are allowed due to ENTRY statements.  */
+  attr->dummy = 1;
+  return check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
+{
+
+  if (check_used (attr, name, where))
+    return false;
+
+  /* Duplicate attribute already checked for.  */
+  attr->in_common = 1;
+  return check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
+{
+
+  /* Duplicate attribute already checked for.  */
+  attr->in_equivalence = 1;
+  if (!check_conflict (attr, name, where))
+    return false;
+
+  if (attr->flavor == FL_VARIABLE)
+    return true;
+
+  return gfc_add_flavor (attr, FL_VARIABLE, name, where);
+}
+
+
+bool
+gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
+{
+
+  if (check_used (attr, name, where))
+    return false;
+
+  attr->data = 1;
+  return check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
+{
+
+  attr->in_namelist = 1;
+  return check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
+{
+
+  if (check_used (attr, name, where))
+    return false;
+
+  attr->sequence = 1;
+  return check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_elemental (symbol_attribute *attr, locus *where)
+{
+
+  if (check_used (attr, NULL, where))
+    return false;
+
+  if (attr->elemental)
+    {
+      duplicate_attr ("ELEMENTAL", where);
+      return false;
+    }
+
+  attr->elemental = 1;
+  return check_conflict (attr, NULL, where);
+}
+
+
+bool
+gfc_add_pure (symbol_attribute *attr, locus *where)
+{
+
+  if (check_used (attr, NULL, where))
+    return false;
+
+  if (attr->pure)
+    {
+      duplicate_attr ("PURE", where);
+      return false;
+    }
+
+  attr->pure = 1;
+  return check_conflict (attr, NULL, where);
+}
+
+
+bool
+gfc_add_recursive (symbol_attribute *attr, locus *where)
+{
+
+  if (check_used (attr, NULL, where))
+    return false;
+
+  if (attr->recursive)
+    {
+      duplicate_attr ("RECURSIVE", where);
+      return false;
+    }
+
+  attr->recursive = 1;
+  return check_conflict (attr, NULL, where);
+}
+
+
+bool
+gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
+{
+
+  if (check_used (attr, name, where))
+    return false;
+
+  if (attr->entry)
+    {
+      duplicate_attr ("ENTRY", where);
+      return false;
+    }
+
+  attr->entry = 1;
+  return check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
+{
+
+  if (attr->flavor != FL_PROCEDURE
+      && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
+    return false;
+
+  attr->function = 1;
+  return check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
+{
+
+  if (attr->flavor != FL_PROCEDURE
+      && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
+    return false;
+
+  attr->subroutine = 1;
+  return check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
+{
+
+  if (attr->flavor != FL_PROCEDURE
+      && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
+    return false;
+
+  attr->generic = 1;
+  return check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
+{
+
+  if (check_used (attr, NULL, where))
+    return false;
+
+  if (attr->flavor != FL_PROCEDURE
+      && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
+    return false;
+
+  if (attr->procedure)
+    {
+      duplicate_attr ("PROCEDURE", where);
+      return false;
+    }
+
+  attr->procedure = 1;
+
+  return check_conflict (attr, NULL, where);
+}
+
+
+bool
+gfc_add_abstract (symbol_attribute* attr, locus* where)
+{
+  if (attr->abstract)
+    {
+      duplicate_attr ("ABSTRACT", where);
+      return false;
+    }
+
+  attr->abstract = 1;
+
+  return check_conflict (attr, NULL, where);
+}
+
+
+/* Flavors are special because some flavors are not what Fortran
+   considers attributes and can be reaffirmed multiple times.  */
+
+bool
+gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
+		locus *where)
+{
+
+  if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
+       || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
+       || f == FL_NAMELIST) && check_used (attr, name, where))
+    return false;
+
+  if (attr->flavor == f && f == FL_VARIABLE)
+    return true;
+
+  if (attr->flavor != FL_UNKNOWN)
+    {
+      if (where == NULL)
+	where = &gfc_current_locus;
+
+      if (name)
+        gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
+		   gfc_code2string (flavors, attr->flavor), name,
+		   gfc_code2string (flavors, f), where);
+      else
+        gfc_error ("%s attribute conflicts with %s attribute at %L",
+		   gfc_code2string (flavors, attr->flavor),
+		   gfc_code2string (flavors, f), where);
+
+      return false;
+    }
+
+  attr->flavor = f;
+
+  return check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_procedure (symbol_attribute *attr, procedure_type t,
+		   const char *name, locus *where)
+{
+
+  if (check_used (attr, name, where))
+    return false;
+
+  if (attr->flavor != FL_PROCEDURE
+      && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
+    return false;
+
+  if (where == NULL)
+    where = &gfc_current_locus;
+
+  if (attr->proc != PROC_UNKNOWN)
+    {
+      gfc_error ("%s procedure at %L is already declared as %s procedure",
+		 gfc_code2string (procedures, t), where,
+		 gfc_code2string (procedures, attr->proc));
+
+      return false;
+    }
+
+  attr->proc = t;
+
+  /* Statement functions are always scalar and functions.  */
+  if (t == PROC_ST_FUNCTION
+      && ((!attr->function && !gfc_add_function (attr, name, where))
+	  || attr->dimension))
+    return false;
+
+  return check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
+{
+
+  if (check_used (attr, NULL, where))
+    return false;
+
+  if (attr->intent == INTENT_UNKNOWN)
+    {
+      attr->intent = intent;
+      return check_conflict (attr, NULL, where);
+    }
+
+  if (where == NULL)
+    where = &gfc_current_locus;
+
+  gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
+	     gfc_intent_string (attr->intent),
+	     gfc_intent_string (intent), where);
+
+  return false;
+}
+
+
+/* No checks for use-association in public and private statements.  */
+
+bool
+gfc_add_access (symbol_attribute *attr, gfc_access access,
+		const char *name, locus *where)
+{
+
+  if (attr->access == ACCESS_UNKNOWN
+	|| (attr->use_assoc && attr->access != ACCESS_PRIVATE))
+    {
+      attr->access = access;
+      return check_conflict (attr, name, where);
+    }
+
+  if (where == NULL)
+    where = &gfc_current_locus;
+  gfc_error ("ACCESS specification at %L was already specified", where);
+
+  return false;
+}
+
+
+/* Set the is_bind_c field for the given symbol_attribute.  */
+
+bool
+gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
+                   int is_proc_lang_bind_spec)
+{
+
+  if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE)
+    gfc_error_now ("BIND(C) attribute at %L can only be used for "
+		   "variables or common blocks", where);
+  else if (attr->is_bind_c)
+    gfc_error_now ("Duplicate BIND attribute specified at %L", where);
+  else
+    attr->is_bind_c = 1;
+  
+  if (where == NULL)
+    where = &gfc_current_locus;
+   
+  if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) at %L", where))
+    return false;
+
+  return check_conflict (attr, name, where);
+}
+
+
+/* Set the extension field for the given symbol_attribute.  */
+
+bool
+gfc_add_extension (symbol_attribute *attr, locus *where)
+{
+  if (where == NULL)
+    where = &gfc_current_locus;
+
+  if (attr->extension)
+    gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where);
+  else
+    attr->extension = 1;
+
+  if (!gfc_notify_std (GFC_STD_F2003, "EXTENDS at %L", where))
+    return false;
+
+  return true;
+}
+
+
+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;
+
+  if (where == NULL)
+    where = &gfc_current_locus;
+
+  if (sym->attr.if_source != IFSRC_UNKNOWN
+      && sym->attr.if_source != IFSRC_DECL)
+    {
+      gfc_error ("Symbol '%s' at %L already has an explicit interface",
+		 sym->name, where);
+      return false;
+    }
+
+  if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable))
+    {
+      gfc_error ("'%s' at %L has attributes specified outside its INTERFACE "
+		 "body", sym->name, where);
+      return false;
+    }
+
+  sym->formal = formal;
+  sym->attr.if_source = source;
+
+  return true;
+}
+
+
+/* Add a type to a symbol.  */
+
+bool
+gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
+{
+  sym_flavor flavor;
+  bt type;
+
+  if (where == NULL)
+    where = &gfc_current_locus;
+
+  if (sym->result)
+    type = sym->result->ts.type;
+  else
+    type = sym->ts.type;
+
+  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 (sym->attr.use_assoc)
+	gfc_error ("Symbol '%s' at %L conflicts with symbol from module '%s', "
+		   "use-associated at %L", sym->name, where, sym->module,
+		   &sym->declared_at);
+      else
+	gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name,
+		 where, gfc_basic_typename (type));
+      return false;
+    }
+
+  if (sym->attr.procedure && sym->ts.interface)
+    {
+      gfc_error ("Procedure '%s' at %L may not have basic type of %s",
+		 sym->name, where, gfc_basic_typename (ts->type));
+      return false;
+    }
+
+  flavor = sym->attr.flavor;
+
+  if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
+      || flavor == FL_LABEL
+      || (flavor == FL_PROCEDURE && sym->attr.subroutine)
+      || flavor == FL_DERIVED || flavor == FL_NAMELIST)
+    {
+      gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
+      return false;
+    }
+
+  sym->ts = *ts;
+  return true;
+}
+
+
+/* Clears all attributes.  */
+
+void
+gfc_clear_attr (symbol_attribute *attr)
+{
+  memset (attr, 0, sizeof (symbol_attribute));
+}
+
+
+/* Check for missing attributes in the new symbol.  Currently does
+   nothing, but it's not clear that it is unnecessary yet.  */
+
+bool
+gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED,
+		  locus *where ATTRIBUTE_UNUSED)
+{
+
+  return true;
+}
+
+
+/* Copy an attribute to a symbol attribute, bit by bit.  Some
+   attributes have a lot of side-effects but cannot be present given
+   where we are called from, so we ignore some bits.  */
+
+bool
+gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
+{
+  int is_proc_lang_bind_spec;
+  
+  /* In line with the other attributes, we only add bits but do not remove
+     them; cf. also PR 41034.  */
+  dest->ext_attr |= src->ext_attr;
+
+  if (src->allocatable && !gfc_add_allocatable (dest, where))
+    goto fail;
+
+  if (src->dimension && !gfc_add_dimension (dest, NULL, where))
+    goto fail;
+  if (src->codimension && !gfc_add_codimension (dest, NULL, where))
+    goto fail;
+  if (src->contiguous && !gfc_add_contiguous (dest, NULL, where))
+    goto fail;
+  if (src->optional && !gfc_add_optional (dest, where))
+    goto fail;
+  if (src->pointer && !gfc_add_pointer (dest, where))
+    goto fail;
+  if (src->is_protected && !gfc_add_protected (dest, NULL, where))
+    goto fail;
+  if (src->save && !gfc_add_save (dest, src->save, NULL, where))
+    goto fail;
+  if (src->value && !gfc_add_value (dest, NULL, where))
+    goto fail;
+  if (src->volatile_ && !gfc_add_volatile (dest, NULL, where))
+    goto fail;
+  if (src->asynchronous && !gfc_add_asynchronous (dest, NULL, where))
+    goto fail;
+  if (src->threadprivate
+      && !gfc_add_threadprivate (dest, NULL, where))
+    goto fail;
+  if (src->target && !gfc_add_target (dest, where))
+    goto fail;
+  if (src->dummy && !gfc_add_dummy (dest, NULL, where))
+    goto fail;
+  if (src->result && !gfc_add_result (dest, NULL, where))
+    goto fail;
+  if (src->entry)
+    dest->entry = 1;
+
+  if (src->in_namelist && !gfc_add_in_namelist (dest, NULL, where))
+    goto fail;
+
+  if (src->in_common && !gfc_add_in_common (dest, NULL, where))
+    goto fail;
+
+  if (src->generic && !gfc_add_generic (dest, NULL, where))
+    goto fail;
+  if (src->function && !gfc_add_function (dest, NULL, where))
+    goto fail;
+  if (src->subroutine && !gfc_add_subroutine (dest, NULL, where))
+    goto fail;
+
+  if (src->sequence && !gfc_add_sequence (dest, NULL, where))
+    goto fail;
+  if (src->elemental && !gfc_add_elemental (dest, where))
+    goto fail;
+  if (src->pure && !gfc_add_pure (dest, where))
+    goto fail;
+  if (src->recursive && !gfc_add_recursive (dest, where))
+    goto fail;
+
+  if (src->flavor != FL_UNKNOWN
+      && !gfc_add_flavor (dest, src->flavor, NULL, where))
+    goto fail;
+
+  if (src->intent != INTENT_UNKNOWN
+      && !gfc_add_intent (dest, src->intent, where))
+    goto fail;
+
+  if (src->access != ACCESS_UNKNOWN
+      && !gfc_add_access (dest, src->access, NULL, where))
+    goto fail;
+
+  if (!gfc_missing_attr (dest, where))
+    goto fail;
+
+  if (src->cray_pointer && !gfc_add_cray_pointer (dest, where))
+    goto fail;
+  if (src->cray_pointee && !gfc_add_cray_pointee (dest, where))
+    goto fail;
+
+  is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
+  if (src->is_bind_c
+      && !gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec))
+    return false;
+
+  if (src->is_c_interop)
+    dest->is_c_interop = 1;
+  if (src->is_iso_c)
+    dest->is_iso_c = 1;
+  
+  if (src->external && !gfc_add_external (dest, where))
+    goto fail;
+  if (src->intrinsic && !gfc_add_intrinsic (dest, where))
+    goto fail;
+  if (src->proc_pointer)
+    dest->proc_pointer = 1;
+
+  return true;
+
+fail:
+  return false;
+}
+
+
+/************** Component name management ************/
+
+/* Component names of a derived type form their own little namespaces
+   that are separate from all other spaces.  The space is composed of
+   a singly linked list of gfc_component structures whose head is
+   located in the parent symbol.  */
+
+
+/* Add a component name to a symbol.  The call fails if the name is
+   already present.  On success, the component pointer is modified to
+   point to the additional component structure.  */
+
+bool
+gfc_add_component (gfc_symbol *sym, const char *name,
+		   gfc_component **component)
+{
+  gfc_component *p, *tail;
+
+  tail = NULL;
+
+  for (p = sym->components; p; p = p->next)
+    {
+      if (strcmp (p->name, name) == 0)
+	{
+	  gfc_error ("Component '%s' at %C already declared at %L",
+		     name, &p->loc);
+	  return false;
+	}
+
+      tail = p;
+    }
+
+  if (sym->attr.extension
+	&& gfc_find_component (sym->components->ts.u.derived, name, true, true))
+    {
+      gfc_error ("Component '%s' at %C already in the parent type "
+		 "at %L", name, &sym->components->ts.u.derived->declared_at);
+      return false;
+    }
+
+  /* Allocate a new component.  */
+  p = gfc_get_component ();
+
+  if (tail == NULL)
+    sym->components = p;
+  else
+    tail->next = p;
+
+  p->name = gfc_get_string (name);
+  p->loc = gfc_current_locus;
+  p->ts.type = BT_UNKNOWN;
+
+  *component = p;
+  return true;
+}
+
+
+/* Recursive function to switch derived types of all symbol in a
+   namespace.  */
+
+static void
+switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
+{
+  gfc_symbol *sym;
+
+  if (st == NULL)
+    return;
+
+  sym = st->n.sym;
+  if (sym->ts.type == BT_DERIVED && sym->ts.u.derived == from)
+    sym->ts.u.derived = to;
+
+  switch_types (st->left, from, to);
+  switch_types (st->right, from, to);
+}
+
+
+/* This subroutine is called when a derived type is used in order to
+   make the final determination about which version to use.  The
+   standard requires that a type be defined before it is 'used', but
+   such types can appear in IMPLICIT statements before the actual
+   definition.  'Using' in this context means declaring a variable to
+   be that type or using the type constructor.
+
+   If a type is used and the components haven't been defined, then we
+   have to have a derived type in a parent unit.  We find the node in
+   the other namespace and point the symtree node in this namespace to
+   that node.  Further reference to this name point to the correct
+   node.  If we can't find the node in a parent namespace, then we have
+   an error.
+
+   This subroutine takes a pointer to a symbol node and returns a
+   pointer to the translated node or NULL for an error.  Usually there
+   is no translation and we return the node we were passed.  */
+
+gfc_symbol *
+gfc_use_derived (gfc_symbol *sym)
+{
+  gfc_symbol *s;
+  gfc_typespec *t;
+  gfc_symtree *st;
+  int i;
+
+  if (!sym)
+    return NULL;
+
+  if (sym->attr.unlimited_polymorphic)
+    return sym;
+
+  if (sym->attr.generic)
+    sym = gfc_find_dt_in_generic (sym);
+
+  if (sym->components != NULL || sym->attr.zero_comp)
+    return sym;               /* Already defined.  */
+
+  if (sym->ns->parent == NULL)
+    goto bad;
+
+  if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
+    {
+      gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
+      return NULL;
+    }
+
+  if (s == NULL || s->attr.flavor != FL_DERIVED)
+    goto bad;
+
+  /* Get rid of symbol sym, translating all references to s.  */
+  for (i = 0; i < GFC_LETTERS; i++)
+    {
+      t = &sym->ns->default_type[i];
+      if (t->u.derived == sym)
+	t->u.derived = s;
+    }
+
+  st = gfc_find_symtree (sym->ns->sym_root, sym->name);
+  st->n.sym = s;
+
+  s->refs++;
+
+  /* Unlink from list of modified symbols.  */
+  gfc_commit_symbol (sym);
+
+  switch_types (sym->ns->sym_root, sym, s);
+
+  /* TODO: Also have to replace sym -> s in other lists like
+     namelists, common lists and interface lists.  */
+  gfc_free_symbol (sym);
+
+  return s;
+
+bad:
+  gfc_error ("Derived type '%s' at %C is being used before it is defined",
+	     sym->name);
+  return NULL;
+}
+
+
+/* Given a derived type node and a component name, try to locate the
+   component structure.  Returns the NULL pointer if the component is
+   not found or the components are private.  If noaccess is set, no access
+   checks are done.  */
+
+gfc_component *
+gfc_find_component (gfc_symbol *sym, const char *name,
+		    bool noaccess, bool silent)
+{
+  gfc_component *p;
+
+  if (name == NULL || sym == NULL)
+    return NULL;
+
+  sym = gfc_use_derived (sym);
+
+  if (sym == NULL)
+    return NULL;
+
+  for (p = sym->components; p; p = p->next)
+    if (strcmp (p->name, name) == 0)
+      break;
+
+  if (p && sym->attr.use_assoc && !noaccess)
+    {
+      bool is_parent_comp = sym->attr.extension && (p == sym->components);
+      if (p->attr.access == ACCESS_PRIVATE ||
+	  (p->attr.access != ACCESS_PUBLIC
+	   && sym->component_access == ACCESS_PRIVATE
+	   && !is_parent_comp))
+	{
+	  if (!silent)
+	    gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
+		       name, sym->name);
+	  return NULL;
+	}
+    }
+
+  if (p == NULL
+	&& sym->attr.extension
+	&& sym->components->ts.type == BT_DERIVED)
+    {
+      p = gfc_find_component (sym->components->ts.u.derived, name,
+			      noaccess, silent);
+      /* Do not overwrite the error.  */
+      if (p == NULL)
+	return p;
+    }
+
+  if (p == NULL && !silent)
+    gfc_error ("'%s' at %C is not a member of the '%s' structure",
+	       name, sym->name);
+
+  return p;
+}
+
+
+/* Given a symbol, free all of the component structures and everything
+   they point to.  */
+
+static void
+free_components (gfc_component *p)
+{
+  gfc_component *q;
+
+  for (; p; p = q)
+    {
+      q = p->next;
+
+      gfc_free_array_spec (p->as);
+      gfc_free_expr (p->initializer);
+      free (p->tb);
+
+      free (p);
+    }
+}
+
+
+/******************** Statement label management ********************/
+
+/* Comparison function for statement labels, used for managing the
+   binary tree.  */
+
+static int
+compare_st_labels (void *a1, void *b1)
+{
+  int a = ((gfc_st_label *) a1)->value;
+  int b = ((gfc_st_label *) b1)->value;
+
+  return (b - a);
+}
+
+
+/* Free a single gfc_st_label structure, making sure the tree is not
+   messed up.  This function is called only when some parse error
+   occurs.  */
+
+void
+gfc_free_st_label (gfc_st_label *label)
+{
+
+  if (label == NULL)
+    return;
+
+  gfc_delete_bbt (&gfc_current_ns->st_labels, label, compare_st_labels);
+
+  if (label->format != NULL)
+    gfc_free_expr (label->format);
+
+  free (label);
+}
+
+
+/* Free a whole tree of gfc_st_label structures.  */
+
+static void
+free_st_labels (gfc_st_label *label)
+{
+
+  if (label == NULL)
+    return;
+
+  free_st_labels (label->left);
+  free_st_labels (label->right);
+  
+  if (label->format != NULL)
+    gfc_free_expr (label->format);
+  free (label);
+}
+
+
+/* Given a label number, search for and return a pointer to the label
+   structure, creating it if it does not exist.  */
+
+gfc_st_label *
+gfc_get_st_label (int labelno)
+{
+  gfc_st_label *lp;
+  gfc_namespace *ns;
+
+  if (gfc_current_state () == COMP_DERIVED)
+    ns = gfc_current_block ()->f2k_derived;
+  else
+    {
+      /* Find the namespace of the scoping unit:
+	 If we're in a BLOCK construct, jump to the parent namespace.  */
+      ns = gfc_current_ns;
+      while (ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
+	ns = ns->parent;
+    }
+
+  /* First see if the label is already in this namespace.  */
+  lp = ns->st_labels;
+  while (lp)
+    {
+      if (lp->value == labelno)
+	return lp;
+
+      if (lp->value < labelno)
+	lp = lp->left;
+      else
+	lp = lp->right;
+    }
+
+  lp = XCNEW (gfc_st_label);
+
+  lp->value = labelno;
+  lp->defined = ST_LABEL_UNKNOWN;
+  lp->referenced = ST_LABEL_UNKNOWN;
+
+  gfc_insert_bbt (&ns->st_labels, lp, compare_st_labels);
+
+  return lp;
+}
+
+
+/* Called when a statement with a statement label is about to be
+   accepted.  We add the label to the list of the current namespace,
+   making sure it hasn't been defined previously and referenced
+   correctly.  */
+
+void
+gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
+{
+  int labelno;
+
+  labelno = lp->value;
+
+  if (lp->defined != ST_LABEL_UNKNOWN)
+    gfc_error ("Duplicate statement label %d at %L and %L", labelno,
+	       &lp->where, label_locus);
+  else
+    {
+      lp->where = *label_locus;
+
+      switch (type)
+	{
+	case ST_LABEL_FORMAT:
+	  if (lp->referenced == ST_LABEL_TARGET
+	      || lp->referenced == ST_LABEL_DO_TARGET)
+	    gfc_error ("Label %d at %C already referenced as branch target",
+		       labelno);
+	  else
+	    lp->defined = ST_LABEL_FORMAT;
+
+	  break;
+
+	case ST_LABEL_TARGET:
+	case ST_LABEL_DO_TARGET:
+	  if (lp->referenced == ST_LABEL_FORMAT)
+	    gfc_error ("Label %d at %C already referenced as a format label",
+		       labelno);
+	  else
+	    lp->defined = type;
+
+	  if (lp->referenced == ST_LABEL_DO_TARGET && type != ST_LABEL_DO_TARGET
+      	      && !gfc_notify_std (GFC_STD_F95_OBS, "DO termination statement "
+				  "which is not END DO or CONTINUE with "
+				  "label %d at %C", labelno))
+	    return;
+	  break;
+
+	default:
+	  lp->defined = ST_LABEL_BAD_TARGET;
+	  lp->referenced = ST_LABEL_BAD_TARGET;
+	}
+    }
+}
+
+
+/* Reference a label.  Given a label and its type, see if that
+   reference is consistent with what is known about that label,
+   updating the unknown state.  Returns false if something goes
+   wrong.  */
+
+bool
+gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
+{
+  gfc_sl_type label_type;
+  int labelno;
+  bool rc;
+
+  if (lp == NULL)
+    return true;
+
+  labelno = lp->value;
+
+  if (lp->defined != ST_LABEL_UNKNOWN)
+    label_type = lp->defined;
+  else
+    {
+      label_type = lp->referenced;
+      lp->where = gfc_current_locus;
+    }
+
+  if (label_type == ST_LABEL_FORMAT
+      && (type == ST_LABEL_TARGET || type == ST_LABEL_DO_TARGET))
+    {
+      gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
+      rc = false;
+      goto done;
+    }
+
+  if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_DO_TARGET
+       || label_type == ST_LABEL_BAD_TARGET)
+      && type == ST_LABEL_FORMAT)
+    {
+      gfc_error ("Label %d at %C previously used as branch target", labelno);
+      rc = false;
+      goto done;
+    }
+
+  if (lp->referenced == ST_LABEL_DO_TARGET && type == ST_LABEL_DO_TARGET
+      && !gfc_notify_std (GFC_STD_F95_OBS, "Shared DO termination label %d "
+			  "at %C", labelno))
+    return false;
+
+  if (lp->referenced != ST_LABEL_DO_TARGET)
+    lp->referenced = type;
+  rc = true;
+
+done:
+  return rc;
+}
+
+
+/************** Symbol table management subroutines ****************/
+
+/* Basic details: Fortran 95 requires a potentially unlimited number
+   of distinct namespaces when compiling a program unit.  This case
+   occurs during a compilation of internal subprograms because all of
+   the internal subprograms must be read before we can start
+   generating code for the host.
+
+   Given the tricky nature of the Fortran grammar, we must be able to
+   undo changes made to a symbol table if the current interpretation
+   of a statement is found to be incorrect.  Whenever a symbol is
+   looked up, we make a copy of it and link to it.  All of these
+   symbols are kept in a vector so that we can commit or
+   undo the changes at a later time.
+
+   A symtree may point to a symbol node outside of its namespace.  In
+   this case, that symbol has been used as a host associated variable
+   at some previous time.  */
+
+/* Allocate a new namespace structure.  Copies the implicit types from
+   PARENT if PARENT_TYPES is set.  */
+
+gfc_namespace *
+gfc_get_namespace (gfc_namespace *parent, int parent_types)
+{
+  gfc_namespace *ns;
+  gfc_typespec *ts;
+  int in;
+  int i;
+
+  ns = XCNEW (gfc_namespace);
+  ns->sym_root = NULL;
+  ns->uop_root = NULL;
+  ns->tb_sym_root = NULL;
+  ns->finalizers = NULL;
+  ns->default_access = ACCESS_UNKNOWN;
+  ns->parent = parent;
+
+  for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
+    {
+      ns->operator_access[in] = ACCESS_UNKNOWN;
+      ns->tb_op[in] = NULL;
+    }
+
+  /* Initialize default implicit types.  */
+  for (i = 'a'; i <= 'z'; i++)
+    {
+      ns->set_flag[i - 'a'] = 0;
+      ts = &ns->default_type[i - 'a'];
+
+      if (parent_types && ns->parent != NULL)
+	{
+	  /* Copy parent settings.  */
+	  *ts = ns->parent->default_type[i - 'a'];
+	  continue;
+	}
+
+      if (gfc_option.flag_implicit_none != 0)
+	{
+	  gfc_clear_ts (ts);
+	  continue;
+	}
+
+      if ('i' <= i && i <= 'n')
+	{
+	  ts->type = BT_INTEGER;
+	  ts->kind = gfc_default_integer_kind;
+	}
+      else
+	{
+	  ts->type = BT_REAL;
+	  ts->kind = gfc_default_real_kind;
+	}
+    }
+
+  ns->refs = 1;
+
+  return ns;
+}
+
+
+/* Comparison function for symtree nodes.  */
+
+static int
+compare_symtree (void *_st1, void *_st2)
+{
+  gfc_symtree *st1, *st2;
+
+  st1 = (gfc_symtree *) _st1;
+  st2 = (gfc_symtree *) _st2;
+
+  return strcmp (st1->name, st2->name);
+}
+
+
+/* Allocate a new symtree node and associate it with the new symbol.  */
+
+gfc_symtree *
+gfc_new_symtree (gfc_symtree **root, const char *name)
+{
+  gfc_symtree *st;
+
+  st = XCNEW (gfc_symtree);
+  st->name = gfc_get_string (name);
+
+  gfc_insert_bbt (root, st, compare_symtree);
+  return st;
+}
+
+
+/* Delete a symbol from the tree.  Does not free the symbol itself!  */
+
+void
+gfc_delete_symtree (gfc_symtree **root, const char *name)
+{
+  gfc_symtree st, *st0;
+
+  st0 = gfc_find_symtree (*root, name);
+
+  st.name = gfc_get_string (name);
+  gfc_delete_bbt (root, &st, compare_symtree);
+
+  free (st0);
+}
+
+
+/* Given a root symtree node and a name, try to find the symbol within
+   the namespace.  Returns NULL if the symbol is not found.  */
+
+gfc_symtree *
+gfc_find_symtree (gfc_symtree *st, const char *name)
+{
+  int c;
+
+  while (st != NULL)
+    {
+      c = strcmp (name, st->name);
+      if (c == 0)
+	return st;
+
+      st = (c < 0) ? st->left : st->right;
+    }
+
+  return NULL;
+}
+
+
+/* Return a symtree node with a name that is guaranteed to be unique
+   within the namespace and corresponds to an illegal fortran name.  */
+
+gfc_symtree *
+gfc_get_unique_symtree (gfc_namespace *ns)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  static int serial = 0;
+
+  sprintf (name, "@%d", serial++);
+  return gfc_new_symtree (&ns->sym_root, name);
+}
+
+
+/* Given a name find a user operator node, creating it if it doesn't
+   exist.  These are much simpler than symbols because they can't be
+   ambiguous with one another.  */
+
+gfc_user_op *
+gfc_get_uop (const char *name)
+{
+  gfc_user_op *uop;
+  gfc_symtree *st;
+
+  st = gfc_find_symtree (gfc_current_ns->uop_root, name);
+  if (st != NULL)
+    return st->n.uop;
+
+  st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
+
+  uop = st->n.uop = XCNEW (gfc_user_op);
+  uop->name = gfc_get_string (name);
+  uop->access = ACCESS_UNKNOWN;
+  uop->ns = gfc_current_ns;
+
+  return uop;
+}
+
+
+/* Given a name find the user operator node.  Returns NULL if it does
+   not exist.  */
+
+gfc_user_op *
+gfc_find_uop (const char *name, gfc_namespace *ns)
+{
+  gfc_symtree *st;
+
+  if (ns == NULL)
+    ns = gfc_current_ns;
+
+  st = gfc_find_symtree (ns->uop_root, name);
+  return (st == NULL) ? NULL : st->n.uop;
+}
+
+
+/* Remove a gfc_symbol structure and everything it points to.  */
+
+void
+gfc_free_symbol (gfc_symbol *sym)
+{
+
+  if (sym == NULL)
+    return;
+
+  gfc_free_array_spec (sym->as);
+
+  free_components (sym->components);
+
+  gfc_free_expr (sym->value);
+
+  gfc_free_namelist (sym->namelist);
+
+  if (sym->ns != sym->formal_ns)
+    gfc_free_namespace (sym->formal_ns);
+
+  if (!sym->attr.generic_copy)
+    gfc_free_interface (sym->generic);
+
+  gfc_free_formal_arglist (sym->formal);
+
+  gfc_free_namespace (sym->f2k_derived);
+
+  if (sym->common_block && sym->common_block->name[0] != '\0')
+    { 
+      sym->common_block->refs--; 
+      if (sym->common_block->refs == 0)
+	free (sym->common_block);
+    }
+
+  free (sym);
+}
+
+
+/* Decrease the reference counter and free memory when we reach zero.  */
+
+void
+gfc_release_symbol (gfc_symbol *sym)
+{
+  if (sym == NULL)
+    return;
+
+  if (sym->formal_ns != NULL && sym->refs == 2 && sym->formal_ns != sym->ns
+      && (!sym->attr.entry || !sym->module))
+    {
+      /* As formal_ns contains a reference to sym, delete formal_ns just
+	 before the deletion of sym.  */
+      gfc_namespace *ns = sym->formal_ns;
+      sym->formal_ns = NULL;
+      gfc_free_namespace (ns);
+    }
+
+  sym->refs--;
+  if (sym->refs > 0)
+    return;
+
+  gcc_assert (sym->refs == 0);
+  gfc_free_symbol (sym);
+}
+
+
+/* Allocate and initialize a new symbol node.  */
+
+gfc_symbol *
+gfc_new_symbol (const char *name, gfc_namespace *ns)
+{
+  gfc_symbol *p;
+
+  p = XCNEW (gfc_symbol);
+
+  gfc_clear_ts (&p->ts);
+  gfc_clear_attr (&p->attr);
+  p->ns = ns;
+
+  p->declared_at = gfc_current_locus;
+
+  if (strlen (name) > GFC_MAX_SYMBOL_LEN)
+    gfc_internal_error ("new_symbol(): Symbol name too long");
+
+  p->name = gfc_get_string (name);
+
+  /* Make sure flags for symbol being C bound are clear initially.  */
+  p->attr.is_bind_c = 0;
+  p->attr.is_iso_c = 0;
+
+  /* Clear the ptrs we may need.  */
+  p->common_block = NULL;
+  p->f2k_derived = NULL;
+  p->assoc = NULL;
+  
+  return p;
+}
+
+
+/* Generate an error if a symbol is ambiguous.  */
+
+static void
+ambiguous_symbol (const char *name, gfc_symtree *st)
+{
+
+  if (st->n.sym->module)
+    gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
+	       "from module '%s'", name, st->n.sym->name, st->n.sym->module);
+  else
+    gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
+	       "from current program unit", name, st->n.sym->name);
+}
+
+
+/* If we're in a SELECT TYPE block, check if the variable 'st' matches any
+   selector on the stack. If yes, replace it by the corresponding temporary.  */
+
+static void
+select_type_insert_tmp (gfc_symtree **st)
+{
+  gfc_select_type_stack *stack = select_type_stack;
+  for (; stack; stack = stack->prev)
+    if ((*st)->n.sym == stack->selector && stack->tmp)
+      *st = stack->tmp;
+}
+
+
+/* Look for a symtree in the current procedure -- that is, go up to
+   parent namespaces but only if inside a BLOCK.  Returns NULL if not found.  */
+
+gfc_symtree*
+gfc_find_symtree_in_proc (const char* name, gfc_namespace* ns)
+{
+  while (ns)
+    {
+      gfc_symtree* st = gfc_find_symtree (ns->sym_root, name);
+      if (st)
+	return st;
+
+      if (!ns->construct_entities)
+	break;
+      ns = ns->parent;
+    }
+
+  return NULL;
+}
+
+
+/* Search for a symtree starting in the current namespace, resorting to
+   any parent namespaces if requested by a nonzero parent_flag.
+   Returns nonzero if the name is ambiguous.  */
+
+int
+gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
+		   gfc_symtree **result)
+{
+  gfc_symtree *st;
+
+  if (ns == NULL)
+    ns = gfc_current_ns;
+
+  do
+    {
+      st = gfc_find_symtree (ns->sym_root, name);
+      if (st != NULL)
+	{
+	  select_type_insert_tmp (&st);
+
+	  *result = st;
+	  /* Ambiguous generic interfaces are permitted, as long
+	     as the specific interfaces are different.  */
+	  if (st->ambiguous && !st->n.sym->attr.generic)
+	    {
+	      ambiguous_symbol (name, st);
+	      return 1;
+	    }
+
+	  return 0;
+	}
+
+      if (!parent_flag)
+	break;
+
+      /* Don't escape an interface block.  */
+      if (ns && !ns->has_import_set
+          && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
+	break;
+
+      ns = ns->parent;
+    }
+  while (ns != NULL);
+
+  *result = NULL;
+  return 0;
+}
+
+
+/* Same, but returns the symbol instead.  */
+
+int
+gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
+		 gfc_symbol **result)
+{
+  gfc_symtree *st;
+  int i;
+
+  i = gfc_find_sym_tree (name, ns, parent_flag, &st);
+
+  if (st == NULL)
+    *result = NULL;
+  else
+    *result = st->n.sym;
+
+  return i;
+}
+
+
+/* Tells whether there is only one set of changes in the stack.  */
+
+static bool
+single_undo_checkpoint_p (void)
+{
+  if (latest_undo_chgset == &default_undo_chgset_var)
+    {
+      gcc_assert (latest_undo_chgset->previous == NULL);
+      return true;
+    }
+  else
+    {
+      gcc_assert (latest_undo_chgset->previous != NULL);
+      return false;
+    }
+}
+
+/* Save symbol with the information necessary to back it out.  */
+
+static void
+save_symbol_data (gfc_symbol *sym)
+{
+  gfc_symbol *s;
+  unsigned i;
+
+  if (!single_undo_checkpoint_p ())
+    {
+      /* If there is more than one change set, look for the symbol in the
+         current one.  If it is found there, we can reuse it.  */
+      FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s)
+	if (s == sym)
+	  {
+	    gcc_assert (sym->gfc_new || sym->old_symbol != NULL);
+	    return;
+	  }
+    }
+  else if (sym->gfc_new || sym->old_symbol != NULL)
+    return;
+
+  s = XCNEW (gfc_symbol);
+  *s = *sym;
+  sym->old_symbol = s;
+  sym->gfc_new = 0;
+
+  latest_undo_chgset->syms.safe_push (sym);
+}
+
+
+/* Given a name, find a symbol, or create it if it does not exist yet
+   in the current namespace.  If the symbol is found we make sure that
+   it's OK.
+
+   The integer return code indicates
+     0   All OK
+     1   The symbol name was ambiguous
+     2   The name meant to be established was already host associated.
+
+   So if the return value is nonzero, then an error was issued.  */
+
+int
+gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
+		  bool allow_subroutine)
+{
+  gfc_symtree *st;
+  gfc_symbol *p;
+
+  /* This doesn't usually happen during resolution.  */
+  if (ns == NULL)
+    ns = gfc_current_ns;
+
+  /* Try to find the symbol in ns.  */
+  st = gfc_find_symtree (ns->sym_root, name);
+
+  if (st == NULL)
+    {
+      /* If not there, create a new symbol.  */
+      p = gfc_new_symbol (name, ns);
+
+      /* Add to the list of tentative symbols.  */
+      p->old_symbol = NULL;
+      p->mark = 1;
+      p->gfc_new = 1;
+      latest_undo_chgset->syms.safe_push (p);
+
+      st = gfc_new_symtree (&ns->sym_root, name);
+      st->n.sym = p;
+      p->refs++;
+
+    }
+  else
+    {
+      /* Make sure the existing symbol is OK.  Ambiguous
+	 generic interfaces are permitted, as long as the
+	 specific interfaces are different.  */
+      if (st->ambiguous && !st->n.sym->attr.generic)
+	{
+	  ambiguous_symbol (name, st);
+	  return 1;
+	}
+
+      p = st->n.sym;
+      if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
+	  && !(allow_subroutine && p->attr.subroutine)
+	  && !(ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY
+	  && (ns->has_import_set || p->attr.imported)))
+	{
+	  /* Symbol is from another namespace.  */
+	  gfc_error ("Symbol '%s' at %C has already been host associated",
+		     name);
+	  return 2;
+	}
+
+      p->mark = 1;
+
+      /* Copy in case this symbol is changed.  */
+      save_symbol_data (p);
+    }
+
+  *result = st;
+  return 0;
+}
+
+
+int
+gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
+{
+  gfc_symtree *st;
+  int i;
+
+  i = gfc_get_sym_tree (name, ns, &st, false);
+  if (i != 0)
+    return i;
+
+  if (st)
+    *result = st->n.sym;
+  else
+    *result = NULL;
+  return i;
+}
+
+
+/* Subroutine that searches for a symbol, creating it if it doesn't
+   exist, but tries to host-associate the symbol if possible.  */
+
+int
+gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
+{
+  gfc_symtree *st;
+  int i;
+
+  i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
+
+  if (st != NULL)
+    {
+      save_symbol_data (st->n.sym);
+      *result = st;
+      return i;
+    }
+
+  i = gfc_find_sym_tree (name, gfc_current_ns, 1, &st);
+  if (i)
+    return i;
+
+  if (st != NULL)
+    {
+      *result = st;
+      return 0;
+    }
+
+  return gfc_get_sym_tree (name, gfc_current_ns, result, false);
+}
+
+
+int
+gfc_get_ha_symbol (const char *name, gfc_symbol **result)
+{
+  int i;
+  gfc_symtree *st;
+
+  i = gfc_get_ha_sym_tree (name, &st);
+
+  if (st)
+    *result = st->n.sym;
+  else
+    *result = NULL;
+
+  return i;
+}
+
+
+/* Search for the symtree belonging to a gfc_common_head; we cannot use
+   head->name as the common_root symtree's name might be mangled.  */
+
+static gfc_symtree *
+find_common_symtree (gfc_symtree *st, gfc_common_head *head)
+{
+
+  gfc_symtree *result;
+
+  if (st == NULL)
+    return NULL;
+
+  if (st->n.common == head)
+    return st;
+
+  result = find_common_symtree (st->left, head);
+  if (!result)  
+    result = find_common_symtree (st->right, head);
+
+  return result;
+}
+
+
+/* Clear the given storage, and make it the current change set for registering
+   changed symbols.  Its contents are freed after a call to
+   gfc_restore_last_undo_checkpoint or gfc_drop_last_undo_checkpoint, but
+   it is up to the caller to free the storage itself.  It is usually a local
+   variable, so there is nothing to do anyway.  */
+
+void
+gfc_new_undo_checkpoint (gfc_undo_change_set &chg_syms)
+{
+  chg_syms.syms = vNULL;
+  chg_syms.tbps = vNULL;
+  chg_syms.previous = latest_undo_chgset;
+  latest_undo_chgset = &chg_syms;
+}
+
+
+/* Restore previous state of symbol.  Just copy simple stuff.  */
+  
+static void
+restore_old_symbol (gfc_symbol *p)
+{
+  gfc_symbol *old;
+
+  p->mark = 0;
+  old = p->old_symbol;
+
+  p->ts.type = old->ts.type;
+  p->ts.kind = old->ts.kind;
+
+  p->attr = old->attr;
+
+  if (p->value != old->value)
+    {
+      gcc_checking_assert (old->value == NULL);
+      gfc_free_expr (p->value);
+      p->value = NULL;
+    }
+
+  if (p->as != old->as)
+    {
+      if (p->as)
+	gfc_free_array_spec (p->as);
+      p->as = old->as;
+    }
+
+  p->generic = old->generic;
+  p->component_access = old->component_access;
+
+  if (p->namelist != NULL && old->namelist == NULL)
+    {
+      gfc_free_namelist (p->namelist);
+      p->namelist = NULL;
+    }
+  else
+    {
+      if (p->namelist_tail != old->namelist_tail)
+	{
+	  gfc_free_namelist (old->namelist_tail->next);
+	  old->namelist_tail->next = NULL;
+	}
+    }
+
+  p->namelist_tail = old->namelist_tail;
+
+  if (p->formal != old->formal)
+    {
+      gfc_free_formal_arglist (p->formal);
+      p->formal = old->formal;
+    }
+
+  p->old_symbol = old->old_symbol;
+  free (old);
+}
+
+
+/* Frees the internal data of a gfc_undo_change_set structure.  Doesn't free
+   the structure itself.  */
+
+static void
+free_undo_change_set_data (gfc_undo_change_set &cs)
+{
+  cs.syms.release ();
+  cs.tbps.release ();
+}
+
+
+/* Given a change set pointer, free its target's contents and update it with
+   the address of the previous change set.  Note that only the contents are
+   freed, not the target itself (the contents' container).  It is not a problem
+   as the latter will be a local variable usually.  */
+
+static void
+pop_undo_change_set (gfc_undo_change_set *&cs)
+{
+  free_undo_change_set_data (*cs);
+  cs = cs->previous;
+}
+
+
+static void free_old_symbol (gfc_symbol *sym);
+
+
+/* Merges the current change set into the previous one.  The changes themselves
+   are left untouched; only one checkpoint is forgotten.  */
+
+void
+gfc_drop_last_undo_checkpoint (void)
+{
+  gfc_symbol *s, *t;
+  unsigned i, j;
+
+  FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s)
+    {
+      /* No need to loop in this case.  */
+      if (s->old_symbol == NULL)
+        continue;
+
+      /* Remove the duplicate symbols.  */
+      FOR_EACH_VEC_ELT (latest_undo_chgset->previous->syms, j, t)
+	if (t == s)
+	  {
+	    latest_undo_chgset->previous->syms.unordered_remove (j);
+
+	    /* S->OLD_SYMBOL is the backup symbol for S as it was at the
+	       last checkpoint.  We drop that checkpoint, so S->OLD_SYMBOL
+	       shall contain from now on the backup symbol for S as it was
+	       at the checkpoint before.  */
+	    if (s->old_symbol->gfc_new)
+	      {
+		gcc_assert (s->old_symbol->old_symbol == NULL);
+		s->gfc_new = s->old_symbol->gfc_new;
+		free_old_symbol (s);
+	      }
+	    else
+	      restore_old_symbol (s->old_symbol);
+	    break;
+	  }
+    }
+
+  latest_undo_chgset->previous->syms.safe_splice (latest_undo_chgset->syms);
+  latest_undo_chgset->previous->tbps.safe_splice (latest_undo_chgset->tbps);
+
+  pop_undo_change_set (latest_undo_chgset);
+}
+
+
+/* Undoes all the changes made to symbols since the previous checkpoint.
+   This subroutine is made simpler due to the fact that attributes are
+   never removed once added.  */
+
+void
+gfc_restore_last_undo_checkpoint (void)
+{
+  gfc_symbol *p;
+  unsigned i;
+
+  FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
+    {
+      if (p->gfc_new)
+	{
+	  /* Symbol was new.  */
+	  if (p->attr.in_common && p->common_block && p->common_block->head)
+	    {
+	      /* If the symbol was added to any common block, it
+		 needs to be removed to stop the resolver looking
+		 for a (possibly) dead symbol.  */
+
+	      if (p->common_block->head == p && !p->common_next)
+		{
+		  gfc_symtree st, *st0;
+		  st0 = find_common_symtree (p->ns->common_root,
+					     p->common_block);
+		  if (st0)
+		    {
+		      st.name = st0->name;
+		      gfc_delete_bbt (&p->ns->common_root, &st, compare_symtree);
+		      free (st0);
+		    }
+		}
+
+	      if (p->common_block->head == p)
+	        p->common_block->head = p->common_next;
+	      else
+		{
+		  gfc_symbol *cparent, *csym;
+
+		  cparent = p->common_block->head;
+		  csym = cparent->common_next;
+
+		  while (csym != p)
+		    {
+		      cparent = csym;
+		      csym = csym->common_next;
+		    }
+
+		  gcc_assert(cparent->common_next == p);
+
+		  cparent->common_next = csym->common_next;
+		}
+	    }
+
+	  /* The derived type is saved in the symtree with the first
+	     letter capitalized; the all lower-case version to the
+	     derived type contains its associated generic function.  */
+	  if (p->attr.flavor == FL_DERIVED)
+	    gfc_delete_symtree (&p->ns->sym_root, gfc_get_string ("%c%s",
+                        (char) TOUPPER ((unsigned char) p->name[0]),
+                        &p->name[1]));
+	  else
+	    gfc_delete_symtree (&p->ns->sym_root, p->name);
+
+	  gfc_release_symbol (p);
+	}
+      else
+	restore_old_symbol (p);
+    }
+
+  latest_undo_chgset->syms.truncate (0);
+  latest_undo_chgset->tbps.truncate (0);
+
+  if (!single_undo_checkpoint_p ())
+    pop_undo_change_set (latest_undo_chgset);
+}
+
+
+/* Makes sure that there is only one set of changes; in other words we haven't
+   forgotten to pair a call to gfc_new_checkpoint with a call to either
+   gfc_drop_last_undo_checkpoint or gfc_restore_last_undo_checkpoint.  */
+
+static void
+enforce_single_undo_checkpoint (void)
+{
+  gcc_checking_assert (single_undo_checkpoint_p ());
+}
+
+
+/* Undoes all the changes made to symbols in the current statement.  */
+
+void
+gfc_undo_symbols (void)
+{
+  enforce_single_undo_checkpoint ();
+  gfc_restore_last_undo_checkpoint ();
+}
+
+
+/* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
+   components of old_symbol that might need deallocation are the "allocatables"
+   that are restored in gfc_undo_symbols(), with two exceptions: namelist and
+   namelist_tail.  In case these differ between old_symbol and sym, it's just
+   because sym->namelist has gotten a few more items.  */
+
+static void
+free_old_symbol (gfc_symbol *sym)
+{
+
+  if (sym->old_symbol == NULL)
+    return;
+
+  if (sym->old_symbol->as != sym->as) 
+    gfc_free_array_spec (sym->old_symbol->as);
+
+  if (sym->old_symbol->value != sym->value) 
+    gfc_free_expr (sym->old_symbol->value);
+
+  if (sym->old_symbol->formal != sym->formal)
+    gfc_free_formal_arglist (sym->old_symbol->formal);
+
+  free (sym->old_symbol);
+  sym->old_symbol = NULL;
+}
+
+
+/* Makes the changes made in the current statement permanent-- gets
+   rid of undo information.  */
+
+void
+gfc_commit_symbols (void)
+{
+  gfc_symbol *p;
+  gfc_typebound_proc *tbp;
+  unsigned i;
+
+  enforce_single_undo_checkpoint ();
+
+  FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
+    {
+      p->mark = 0;
+      p->gfc_new = 0;
+      free_old_symbol (p);
+    }
+  latest_undo_chgset->syms.truncate (0);
+
+  FOR_EACH_VEC_ELT (latest_undo_chgset->tbps, i, tbp)
+    tbp->error = 0;
+  latest_undo_chgset->tbps.truncate (0);
+}
+
+
+/* Makes the changes made in one symbol permanent -- gets rid of undo
+   information.  */
+
+void
+gfc_commit_symbol (gfc_symbol *sym)
+{
+  gfc_symbol *p;
+  unsigned i;
+
+  enforce_single_undo_checkpoint ();
+
+  FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
+    if (p == sym)
+      {
+	latest_undo_chgset->syms.unordered_remove (i);
+	break;
+      }
+
+  sym->mark = 0;
+  sym->gfc_new = 0;
+
+  free_old_symbol (sym);
+}
+
+
+/* Recursively free trees containing type-bound procedures.  */
+
+static void
+free_tb_tree (gfc_symtree *t)
+{
+  if (t == NULL)
+    return;
+
+  free_tb_tree (t->left);
+  free_tb_tree (t->right);
+
+  /* TODO: Free type-bound procedure structs themselves; probably needs some
+     sort of ref-counting mechanism.  */
+
+  free (t);
+}
+
+
+/* Recursive function that deletes an entire tree and all the common
+   head structures it points to.  */
+
+static void
+free_common_tree (gfc_symtree * common_tree)
+{
+  if (common_tree == NULL)
+    return;
+
+  free_common_tree (common_tree->left);
+  free_common_tree (common_tree->right);
+
+  free (common_tree);
+}  
+
+
+/* Recursive function that deletes an entire tree and all the user
+   operator nodes that it contains.  */
+
+static void
+free_uop_tree (gfc_symtree *uop_tree)
+{
+  if (uop_tree == NULL)
+    return;
+
+  free_uop_tree (uop_tree->left);
+  free_uop_tree (uop_tree->right);
+
+  gfc_free_interface (uop_tree->n.uop->op);
+  free (uop_tree->n.uop);
+  free (uop_tree);
+}
+
+
+/* Recursive function that deletes an entire tree and all the symbols
+   that it contains.  */
+
+static void
+free_sym_tree (gfc_symtree *sym_tree)
+{
+  if (sym_tree == NULL)
+    return;
+
+  free_sym_tree (sym_tree->left);
+  free_sym_tree (sym_tree->right);
+
+  gfc_release_symbol (sym_tree->n.sym);
+  free (sym_tree);
+}
+
+
+/* Free the derived type list.  */
+
+void
+gfc_free_dt_list (void)
+{
+  gfc_dt_list *dt, *n;
+
+  for (dt = gfc_derived_types; dt; dt = n)
+    {
+      n = dt->next;
+      free (dt);
+    }
+
+  gfc_derived_types = NULL;
+}
+
+
+/* Free the gfc_equiv_info's.  */
+
+static void
+gfc_free_equiv_infos (gfc_equiv_info *s)
+{
+  if (s == NULL)
+    return;
+  gfc_free_equiv_infos (s->next);
+  free (s);
+}
+
+
+/* Free the gfc_equiv_lists.  */
+
+static void
+gfc_free_equiv_lists (gfc_equiv_list *l)
+{
+  if (l == NULL)
+    return;
+  gfc_free_equiv_lists (l->next);
+  gfc_free_equiv_infos (l->equiv);
+  free (l);
+}
+
+
+/* Free a finalizer procedure list.  */
+
+void
+gfc_free_finalizer (gfc_finalizer* el)
+{
+  if (el)
+    {
+      gfc_release_symbol (el->proc_sym);
+      free (el);
+    }
+}
+
+static void
+gfc_free_finalizer_list (gfc_finalizer* list)
+{
+  while (list)
+    {
+      gfc_finalizer* current = list;
+      list = list->next;
+      gfc_free_finalizer (current);
+    }
+}
+
+
+/* Create a new gfc_charlen structure and add it to a namespace.
+   If 'old_cl' is given, the newly created charlen will be a copy of it.  */
+
+gfc_charlen*
+gfc_new_charlen (gfc_namespace *ns, gfc_charlen *old_cl)
+{
+  gfc_charlen *cl;
+  cl = gfc_get_charlen ();
+
+  /* Copy old_cl.  */
+  if (old_cl)
+    {
+      /* Put into namespace, but don't allow reject_statement
+	 to free it if old_cl is given.  */
+      gfc_charlen **prev = &ns->cl_list;
+      cl->next = ns->old_cl_list;
+      while (*prev != ns->old_cl_list)
+	prev = &(*prev)->next;
+      *prev = cl;
+      ns->old_cl_list = cl;
+      cl->length = gfc_copy_expr (old_cl->length);
+      cl->length_from_typespec = old_cl->length_from_typespec;
+      cl->backend_decl = old_cl->backend_decl;
+      cl->passed_length = old_cl->passed_length;
+      cl->resolved = old_cl->resolved;
+    }
+  else
+    {
+      /* Put into namespace.  */
+      cl->next = ns->cl_list;
+      ns->cl_list = cl;
+    }
+
+  return cl;
+}
+
+
+/* Free the charlen list from cl to end (end is not freed). 
+   Free the whole list if end is NULL.  */
+
+void
+gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end)
+{
+  gfc_charlen *cl2;
+
+  for (; cl != end; cl = cl2)
+    {
+      gcc_assert (cl);
+
+      cl2 = cl->next;
+      gfc_free_expr (cl->length);
+      free (cl);
+    }
+}
+
+
+/* Free entry list structs.  */
+
+static void
+free_entry_list (gfc_entry_list *el)
+{
+  gfc_entry_list *next;
+
+  if (el == NULL)
+    return;
+
+  next = el->next;
+  free (el);
+  free_entry_list (next);
+}
+
+
+/* Free a namespace structure and everything below it.  Interface
+   lists associated with intrinsic operators are not freed.  These are
+   taken care of when a specific name is freed.  */
+
+void
+gfc_free_namespace (gfc_namespace *ns)
+{
+  gfc_namespace *p, *q;
+  int i;
+
+  if (ns == NULL)
+    return;
+
+  ns->refs--;
+  if (ns->refs > 0)
+    return;
+  gcc_assert (ns->refs == 0);
+
+  gfc_free_statements (ns->code);
+
+  free_sym_tree (ns->sym_root);
+  free_uop_tree (ns->uop_root);
+  free_common_tree (ns->common_root);
+  free_tb_tree (ns->tb_sym_root);
+  free_tb_tree (ns->tb_uop_root);
+  gfc_free_finalizer_list (ns->finalizers);
+  gfc_free_charlen (ns->cl_list, NULL);
+  free_st_labels (ns->st_labels);
+
+  free_entry_list (ns->entries);
+  gfc_free_equiv (ns->equiv);
+  gfc_free_equiv_lists (ns->equiv_lists);
+  gfc_free_use_stmts (ns->use_stmts);
+
+  for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
+    gfc_free_interface (ns->op[i]);
+
+  gfc_free_data (ns->data);
+  p = ns->contained;
+  free (ns);
+
+  /* Recursively free any contained namespaces.  */
+  while (p != NULL)
+    {
+      q = p;
+      p = p->sibling;
+      gfc_free_namespace (q);
+    }
+}
+
+
+void
+gfc_symbol_init_2 (void)
+{
+
+  gfc_current_ns = gfc_get_namespace (NULL, 0);
+}
+
+
+void
+gfc_symbol_done_2 (void)
+{
+  gfc_free_namespace (gfc_current_ns);
+  gfc_current_ns = NULL;
+  gfc_free_dt_list ();
+
+  enforce_single_undo_checkpoint ();
+  free_undo_change_set_data (*latest_undo_chgset);
+}
+
+
+/* Count how many nodes a symtree has.  */
+
+static unsigned
+count_st_nodes (const gfc_symtree *st)
+{
+  unsigned nodes;
+  if (!st)
+    return 0;
+
+  nodes = count_st_nodes (st->left);
+  nodes++;
+  nodes += count_st_nodes (st->right);
+
+  return nodes;
+}
+
+
+/* Convert symtree tree into symtree vector.  */
+
+static unsigned
+fill_st_vector (gfc_symtree *st, gfc_symtree **st_vec, unsigned node_cntr)
+{
+  if (!st)
+    return node_cntr;
+
+  node_cntr = fill_st_vector (st->left, st_vec, node_cntr);
+  st_vec[node_cntr++] = st;
+  node_cntr = fill_st_vector (st->right, st_vec, node_cntr);
+
+  return node_cntr;
+}
+
+
+/* Traverse namespace.  As the functions might modify the symtree, we store the
+   symtree as a vector and operate on this vector.  Note: We assume that
+   sym_func or st_func never deletes nodes from the symtree - only adding is
+   allowed. Additionally, newly added nodes are not traversed.  */
+
+static void
+do_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *),
+		     void (*sym_func) (gfc_symbol *))
+{
+  gfc_symtree **st_vec;
+  unsigned nodes, i, node_cntr;
+
+  gcc_assert ((st_func && !sym_func) || (!st_func && sym_func));
+  nodes = count_st_nodes (st);
+  st_vec = XALLOCAVEC (gfc_symtree *, nodes);
+  node_cntr = 0; 
+  fill_st_vector (st, st_vec, node_cntr);
+
+  if (sym_func)
+    {
+      /* Clear marks.  */
+      for (i = 0; i < nodes; i++)
+	st_vec[i]->n.sym->mark = 0;
+      for (i = 0; i < nodes; i++)
+	if (!st_vec[i]->n.sym->mark)
+	  {
+	    (*sym_func) (st_vec[i]->n.sym);
+	    st_vec[i]->n.sym->mark = 1;
+	  }
+     }
+   else
+      for (i = 0; i < nodes; i++)
+	(*st_func) (st_vec[i]);
+}
+
+
+/* Recursively traverse the symtree nodes.  */
+
+void
+gfc_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *))
+{
+  do_traverse_symtree (st, st_func, NULL);
+}
+
+
+/* Call a given function for all symbols in the namespace.  We take
+   care that each gfc_symbol node is called exactly once.  */
+
+void
+gfc_traverse_ns (gfc_namespace *ns, void (*sym_func) (gfc_symbol *))
+{
+  do_traverse_symtree (ns->sym_root, NULL, sym_func);
+}
+
+
+/* Return TRUE when name is the name of an intrinsic type.  */
+
+bool
+gfc_is_intrinsic_typename (const char *name)
+{
+  if (strcmp (name, "integer") == 0
+      || strcmp (name, "real") == 0
+      || strcmp (name, "character") == 0
+      || strcmp (name, "logical") == 0
+      || strcmp (name, "complex") == 0
+      || strcmp (name, "doubleprecision") == 0
+      || strcmp (name, "doublecomplex") == 0)
+    return true;
+  else
+    return false;
+}
+
+
+/* Return TRUE if the symbol is an automatic variable.  */
+
+static bool
+gfc_is_var_automatic (gfc_symbol *sym)
+{
+  /* Pointer and allocatable variables are never automatic.  */
+  if (sym->attr.pointer || sym->attr.allocatable)
+    return false;
+  /* Check for arrays with non-constant size.  */
+  if (sym->attr.dimension && sym->as
+      && !gfc_is_compile_time_shape (sym->as))
+    return true;
+  /* Check for non-constant length character variables.  */
+  if (sym->ts.type == BT_CHARACTER
+      && sym->ts.u.cl
+      && !gfc_is_constant_expr (sym->ts.u.cl->length))
+    return true;
+  return false;
+}
+
+/* Given a symbol, mark it as SAVEd if it is allowed.  */
+
+static void
+save_symbol (gfc_symbol *sym)
+{
+
+  if (sym->attr.use_assoc)
+    return;
+
+  if (sym->attr.in_common
+      || sym->attr.dummy
+      || sym->attr.result
+      || sym->attr.flavor != FL_VARIABLE)
+    return;
+  /* Automatic objects are not saved.  */
+  if (gfc_is_var_automatic (sym))
+    return;
+  gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, &sym->declared_at);
+}
+
+
+/* Mark those symbols which can be SAVEd as such.  */
+
+void
+gfc_save_all (gfc_namespace *ns)
+{
+  gfc_traverse_ns (ns, save_symbol);
+}
+
+
+/* Make sure that no changes to symbols are pending.  */
+
+void
+gfc_enforce_clean_symbol_state(void)
+{
+  enforce_single_undo_checkpoint ();
+  gcc_assert (latest_undo_chgset->syms.is_empty ());
+}
+
+
+/************** Global symbol handling ************/
+
+
+/* Search a tree for the global symbol.  */
+
+gfc_gsymbol *
+gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
+{
+  int c;
+
+  if (symbol == NULL)
+    return NULL;
+
+  while (symbol)
+    {
+      c = strcmp (name, symbol->name);
+      if (!c)
+	return symbol;
+
+      symbol = (c < 0) ? symbol->left : symbol->right;
+    }
+
+  return NULL;
+}
+
+
+/* Compare two global symbols. Used for managing the BB tree.  */
+
+static int
+gsym_compare (void *_s1, void *_s2)
+{
+  gfc_gsymbol *s1, *s2;
+
+  s1 = (gfc_gsymbol *) _s1;
+  s2 = (gfc_gsymbol *) _s2;
+  return strcmp (s1->name, s2->name);
+}
+
+
+/* Get a global symbol, creating it if it doesn't exist.  */
+
+gfc_gsymbol *
+gfc_get_gsymbol (const char *name)
+{
+  gfc_gsymbol *s;
+
+  s = gfc_find_gsymbol (gfc_gsym_root, name);
+  if (s != NULL)
+    return s;
+
+  s = XCNEW (gfc_gsymbol);
+  s->type = GSYM_UNKNOWN;
+  s->name = gfc_get_string (name);
+
+  gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
+
+  return s;
+}
+
+
+static gfc_symbol *
+get_iso_c_binding_dt (int sym_id)
+{
+  gfc_dt_list *dt_list;
+
+  dt_list = gfc_derived_types;
+
+  /* Loop through the derived types in the name list, searching for
+     the desired symbol from iso_c_binding.  Search the parent namespaces
+     if necessary and requested to (parent_flag).  */
+  while (dt_list != NULL)
+    {
+      if (dt_list->derived->from_intmod != INTMOD_NONE
+	  && dt_list->derived->intmod_sym_id == sym_id)
+        return dt_list->derived;
+
+      dt_list = dt_list->next;
+    }
+
+  return NULL;
+}
+
+
+/* Verifies that the given derived type symbol, derived_sym, is interoperable
+   with C.  This is necessary for any derived type that is BIND(C) and for
+   derived types that are parameters to functions that are BIND(C).  All
+   fields of the derived type are required to be interoperable, and are tested
+   for such.  If an error occurs, the errors are reported here, allowing for
+   multiple errors to be handled for a single derived type.  */
+
+bool
+verify_bind_c_derived_type (gfc_symbol *derived_sym)
+{
+  gfc_component *curr_comp = NULL;
+  bool is_c_interop = false;
+  bool retval = true;
+   
+  if (derived_sym == NULL)
+    gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
+                        "unexpectedly NULL");
+
+  /* If we've already looked at this derived symbol, do not look at it again
+     so we don't repeat warnings/errors.  */
+  if (derived_sym->ts.is_c_interop)
+    return true;
+  
+  /* The derived type must have the BIND attribute to be interoperable
+     J3/04-007, Section 15.2.3.  */
+  if (derived_sym->attr.is_bind_c != 1)
+    {
+      derived_sym->ts.is_c_interop = 0;
+      gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
+                     "attribute to be C interoperable", derived_sym->name,
+                     &(derived_sym->declared_at));
+      retval = false;
+    }
+  
+  curr_comp = derived_sym->components;
+
+  /* Fortran 2003 allows an empty derived type.  C99 appears to disallow an
+     empty struct.  Section 15.2 in Fortran 2003 states:  "The following
+     subclauses define the conditions under which a Fortran entity is
+     interoperable.  If a Fortran entity is interoperable, an equivalent
+     entity may be defined by means of C and the Fortran entity is said
+     to be interoperable with the C entity.  There does not have to be such
+     an interoperating C entity."
+  */
+  if (curr_comp == NULL)
+    {
+      gfc_warning ("Derived type '%s' with BIND(C) attribute at %L is empty, "
+		   "and may be inaccessible by the C companion processor",
+		   derived_sym->name, &(derived_sym->declared_at));
+      derived_sym->ts.is_c_interop = 1;
+      derived_sym->attr.is_bind_c = 1;
+      return true;
+    }
+
+
+  /* Initialize the derived type as being C interoperable.
+     If we find an error in the components, this will be set false.  */
+  derived_sym->ts.is_c_interop = 1;
+  
+  /* Loop through the list of components to verify that the kind of
+     each is a C interoperable type.  */
+  do
+    {
+      /* The components cannot be pointers (fortran sense).  
+         J3/04-007, Section 15.2.3, C1505.	*/
+      if (curr_comp->attr.pointer != 0)
+        {
+          gfc_error ("Component '%s' at %L cannot have the "
+                     "POINTER attribute because it is a member "
+                     "of the BIND(C) derived type '%s' at %L",
+                     curr_comp->name, &(curr_comp->loc),
+                     derived_sym->name, &(derived_sym->declared_at));
+          retval = false;
+        }
+
+      if (curr_comp->attr.proc_pointer != 0)
+	{
+	  gfc_error ("Procedure pointer component '%s' at %L cannot be a member"
+		     " of the BIND(C) derived type '%s' at %L", curr_comp->name,
+		     &curr_comp->loc, derived_sym->name,
+		     &derived_sym->declared_at);
+          retval = false;
+        }
+
+      /* The components cannot be allocatable.
+         J3/04-007, Section 15.2.3, C1505.	*/
+      if (curr_comp->attr.allocatable != 0)
+        {
+          gfc_error ("Component '%s' at %L cannot have the "
+                     "ALLOCATABLE attribute because it is a member "
+                     "of the BIND(C) derived type '%s' at %L",
+                     curr_comp->name, &(curr_comp->loc),
+                     derived_sym->name, &(derived_sym->declared_at));
+          retval = false;
+        }
+      
+      /* BIND(C) derived types must have interoperable components.  */
+      if (curr_comp->ts.type == BT_DERIVED
+	  && curr_comp->ts.u.derived->ts.is_iso_c != 1 
+          && curr_comp->ts.u.derived != derived_sym)
+        {
+          /* This should be allowed; the draft says a derived-type can not
+             have type parameters if it is has the BIND attribute.  Type
+             parameters seem to be for making parameterized derived types.
+             There's no need to verify the type if it is c_ptr/c_funptr.  */
+          retval = verify_bind_c_derived_type (curr_comp->ts.u.derived);
+	}
+      else
+	{
+	  /* Grab the typespec for the given component and test the kind.  */ 
+	  is_c_interop = gfc_verify_c_interop (&(curr_comp->ts));
+	  
+	  if (!is_c_interop)
+	    {
+	      /* Report warning and continue since not fatal.  The
+		 draft does specify a constraint that requires all fields
+		 to interoperate, but if the user says real(4), etc., it
+		 may interoperate with *something* in C, but the compiler
+		 most likely won't know exactly what.  Further, it may not
+		 interoperate with the same data type(s) in C if the user
+		 recompiles with different flags (e.g., -m32 and -m64 on
+		 x86_64 and using integer(4) to claim interop with a
+		 C_LONG).  */
+	      if (derived_sym->attr.is_bind_c == 1
+		  && gfc_option.warn_c_binding_type)
+		/* If the derived type is bind(c), all fields must be
+		   interop.  */
+		gfc_warning ("Component '%s' in derived type '%s' at %L "
+                             "may not be C interoperable, even though "
+                             "derived type '%s' is BIND(C)",
+                             curr_comp->name, derived_sym->name,
+                             &(curr_comp->loc), derived_sym->name);
+	      else if (gfc_option.warn_c_binding_type)
+		/* If derived type is param to bind(c) routine, or to one
+		   of the iso_c_binding procs, it must be interoperable, so
+		   all fields must interop too.	 */
+		gfc_warning ("Component '%s' in derived type '%s' at %L "
+                             "may not be C interoperable",
+                             curr_comp->name, derived_sym->name,
+                             &(curr_comp->loc));
+	    }
+	}
+      
+      curr_comp = curr_comp->next;
+    } while (curr_comp != NULL); 
+
+
+  /* Make sure we don't have conflicts with the attributes.  */
+  if (derived_sym->attr.access == ACCESS_PRIVATE)
+    {
+      gfc_error ("Derived type '%s' at %L cannot be declared with both "
+                 "PRIVATE and BIND(C) attributes", derived_sym->name,
+                 &(derived_sym->declared_at));
+      retval = false;
+    }
+
+  if (derived_sym->attr.sequence != 0)
+    {
+      gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
+                 "attribute because it is BIND(C)", derived_sym->name,
+                 &(derived_sym->declared_at));
+      retval = false;
+    }
+
+  /* Mark the derived type as not being C interoperable if we found an
+     error.  If there were only warnings, proceed with the assumption
+     it's interoperable.  */
+  if (!retval)
+    derived_sym->ts.is_c_interop = 0;
+  
+  return retval;
+}
+
+
+/* Generate symbols for the named constants c_null_ptr and c_null_funptr.  */
+
+static bool
+gen_special_c_interop_ptr (gfc_symbol *tmp_sym, gfc_symtree *dt_symtree)
+{
+  gfc_constructor *c;
+
+  gcc_assert (tmp_sym && dt_symtree && dt_symtree->n.sym);
+  dt_symtree->n.sym->attr.referenced = 1;
+
+  tmp_sym->attr.is_c_interop = 1;
+  tmp_sym->attr.is_bind_c = 1;
+  tmp_sym->ts.is_c_interop = 1;
+  tmp_sym->ts.is_iso_c = 1;
+  tmp_sym->ts.type = BT_DERIVED;
+  tmp_sym->ts.f90_type = BT_VOID;
+  tmp_sym->attr.flavor = FL_PARAMETER;
+  tmp_sym->ts.u.derived = dt_symtree->n.sym;
+  
+  /* Set the c_address field of c_null_ptr and c_null_funptr to
+     the value of NULL.	 */
+  tmp_sym->value = gfc_get_expr ();
+  tmp_sym->value->expr_type = EXPR_STRUCTURE;
+  tmp_sym->value->ts.type = BT_DERIVED;
+  tmp_sym->value->ts.f90_type = BT_VOID;
+  tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
+  gfc_constructor_append_expr (&tmp_sym->value->value.constructor, NULL, NULL);
+  c = gfc_constructor_first (tmp_sym->value->value.constructor);
+  c->expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+  c->expr->ts.is_iso_c = 1;
+
+  return true;
+}
+
+
+/* Add a formal argument, gfc_formal_arglist, to the
+   end of the given list of arguments.	Set the reference to the
+   provided symbol, param_sym, in the argument.  */
+
+static void
+add_formal_arg (gfc_formal_arglist **head,
+                gfc_formal_arglist **tail,
+                gfc_formal_arglist *formal_arg,
+                gfc_symbol *param_sym)
+{
+  /* Put in list, either as first arg or at the tail (curr arg).  */
+  if (*head == NULL)
+    *head = *tail = formal_arg;
+  else
+    {
+      (*tail)->next = formal_arg;
+      (*tail) = formal_arg;
+    }
+   
+  (*tail)->sym = param_sym;
+  (*tail)->next = NULL;
+   
+  return;
+}
+
+
+/* Add a procedure interface to the given symbol (i.e., store a
+   reference to the list of formal arguments).  */
+
+static void
+add_proc_interface (gfc_symbol *sym, ifsrc source, gfc_formal_arglist *formal)
+{
+
+  sym->formal = formal;
+  sym->attr.if_source = source;
+}
+
+
+/* Copy the formal args from an existing symbol, src, into a new
+   symbol, dest.  New formal args are created, and the description of
+   each arg is set according to the existing ones.  This function is
+   used when creating procedure declaration variables from a procedure
+   declaration statement (see match_proc_decl()) to create the formal
+   args based on the args of a given named interface.  */
+
+void
+gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
+{
+  gfc_formal_arglist *head = NULL;
+  gfc_formal_arglist *tail = NULL;
+  gfc_formal_arglist *formal_arg = NULL;
+  gfc_intrinsic_arg *curr_arg = NULL;
+  gfc_formal_arglist *formal_prev = NULL;
+  /* Save current namespace so we can change it for formal args.  */
+  gfc_namespace *parent_ns = gfc_current_ns;
+
+  /* Create a new namespace, which will be the formal ns (namespace
+     of the formal args).  */
+  gfc_current_ns = gfc_get_namespace (parent_ns, 0);
+  gfc_current_ns->proc_name = dest;
+
+  for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
+    {
+      formal_arg = gfc_get_formal_arglist ();
+      gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym));
+
+      /* May need to copy more info for the symbol.  */
+      formal_arg->sym->ts = curr_arg->ts;
+      formal_arg->sym->attr.optional = curr_arg->optional;
+      formal_arg->sym->attr.value = curr_arg->value;
+      formal_arg->sym->attr.intent = curr_arg->intent;
+      formal_arg->sym->attr.flavor = FL_VARIABLE;
+      formal_arg->sym->attr.dummy = 1;
+
+      if (formal_arg->sym->ts.type == BT_CHARACTER)
+	formal_arg->sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+
+      /* If this isn't the first arg, set up the next ptr.  For the
+        last arg built, the formal_arg->next will never get set to
+        anything other than NULL.  */
+      if (formal_prev != NULL)
+	formal_prev->next = formal_arg;
+      else
+	formal_arg->next = NULL;
+
+      formal_prev = formal_arg;
+
+      /* Add arg to list of formal args.  */
+      add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
+
+      /* Validate changes.  */
+      gfc_commit_symbol (formal_arg->sym);
+    }
+
+  /* Add the interface to the symbol.  */
+  add_proc_interface (dest, IFSRC_DECL, head);
+
+  /* Store the formal namespace information.  */
+  if (dest->formal != NULL)
+    /* The current ns should be that for the dest proc.  */
+    dest->formal_ns = gfc_current_ns;
+  /* Restore the current namespace to what it was on entry.  */
+  gfc_current_ns = parent_ns;
+}
+
+
+static int
+std_for_isocbinding_symbol (int id)
+{
+  switch (id)
+    {
+#define NAMED_INTCST(a,b,c,d) \
+      case a:\
+        return d;
+#include "iso-c-binding.def"
+#undef NAMED_INTCST
+
+#define NAMED_FUNCTION(a,b,c,d) \
+      case a:\
+        return d;
+#define NAMED_SUBROUTINE(a,b,c,d) \
+      case a:\
+        return d;
+#include "iso-c-binding.def"
+#undef NAMED_FUNCTION
+#undef NAMED_SUBROUTINE
+
+       default:
+         return GFC_STD_F2003;
+    }
+}
+
+/* Generate the given set of C interoperable kind objects, or all
+   interoperable kinds.  This function will only be given kind objects
+   for valid iso_c_binding defined types because this is verified when
+   the 'use' statement is parsed.  If the user gives an 'only' clause,
+   the specific kinds are looked up; if they don't exist, an error is
+   reported.  If the user does not give an 'only' clause, all
+   iso_c_binding symbols are generated.  If a list of specific kinds
+   is given, it must have a NULL in the first empty spot to mark the
+   end of the list. For C_null_(fun)ptr, dt_symtree has to be set and
+   point to the symtree for c_(fun)ptr.  */
+
+gfc_symtree *
+generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
+			     const char *local_name, gfc_symtree *dt_symtree,
+			     bool hidden)
+{
+  const char *const name = (local_name && local_name[0])
+			   ? local_name : c_interop_kinds_table[s].name;
+  gfc_symtree *tmp_symtree;
+  gfc_symbol *tmp_sym = NULL;
+  int index;
+
+  if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
+    return NULL;
+
+  tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
+  if (hidden
+      && (!tmp_symtree || !tmp_symtree->n.sym
+	  || tmp_symtree->n.sym->from_intmod != INTMOD_ISO_C_BINDING
+	  || tmp_symtree->n.sym->intmod_sym_id != s))
+    tmp_symtree = NULL;
+
+  /* Already exists in this scope so don't re-add it. */
+  if (tmp_symtree != NULL && (tmp_sym = tmp_symtree->n.sym) != NULL
+      && (!tmp_sym->attr.generic
+	  || (tmp_sym = gfc_find_dt_in_generic (tmp_sym)) != NULL)
+      && tmp_sym->from_intmod == INTMOD_ISO_C_BINDING)
+    {
+      if (tmp_sym->attr.flavor == FL_DERIVED
+	  && !get_iso_c_binding_dt (tmp_sym->intmod_sym_id))
+	{
+	  gfc_dt_list *dt_list;
+	  dt_list = gfc_get_dt_list ();
+	  dt_list->derived = tmp_sym;
+	  dt_list->next = gfc_derived_types;
+  	  gfc_derived_types = dt_list;
+        }
+
+      return tmp_symtree;
+    }
+
+  /* Create the sym tree in the current ns.  */
+  if (hidden)
+    {
+      tmp_symtree = gfc_get_unique_symtree (gfc_current_ns);
+      tmp_sym = gfc_new_symbol (name, gfc_current_ns);
+
+      /* Add to the list of tentative symbols.  */
+      latest_undo_chgset->syms.safe_push (tmp_sym);
+      tmp_sym->old_symbol = NULL;
+      tmp_sym->mark = 1;
+      tmp_sym->gfc_new = 1;
+
+      tmp_symtree->n.sym = tmp_sym;
+      tmp_sym->refs++;
+    }
+  else
+    {
+      gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
+      gcc_assert (tmp_symtree);
+      tmp_sym = tmp_symtree->n.sym;
+    }
+
+  /* Say what module this symbol belongs to.  */
+  tmp_sym->module = gfc_get_string (mod_name);
+  tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
+  tmp_sym->intmod_sym_id = s;
+  tmp_sym->attr.is_iso_c = 1;
+  tmp_sym->attr.use_assoc = 1;
+
+  gcc_assert (dt_symtree == NULL || s == ISOCBINDING_NULL_FUNPTR
+	      || s == ISOCBINDING_NULL_PTR);
+
+  switch (s)
+    {
+
+#define NAMED_INTCST(a,b,c,d) case a : 
+#define NAMED_REALCST(a,b,c,d) case a :
+#define NAMED_CMPXCST(a,b,c,d) case a :
+#define NAMED_LOGCST(a,b,c) case a :
+#define NAMED_CHARKNDCST(a,b,c) case a :
+#include "iso-c-binding.def"
+
+	tmp_sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+				 	   c_interop_kinds_table[s].value);
+
+	/* Initialize an integer constant expression node.  */
+	tmp_sym->attr.flavor = FL_PARAMETER;
+	tmp_sym->ts.type = BT_INTEGER;
+	tmp_sym->ts.kind = gfc_default_integer_kind;
+
+	/* Mark this type as a C interoperable one.  */
+	tmp_sym->ts.is_c_interop = 1;
+	tmp_sym->ts.is_iso_c = 1;
+	tmp_sym->value->ts.is_c_interop = 1;
+	tmp_sym->value->ts.is_iso_c = 1;
+	tmp_sym->attr.is_c_interop = 1;
+
+	/* Tell what f90 type this c interop kind is valid.  */
+	tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
+
+	break;
+
+
+#define NAMED_CHARCST(a,b,c) case a :
+#include "iso-c-binding.def"
+
+	/* Initialize an integer constant expression node for the
+	   length of the character.  */
+	tmp_sym->value = gfc_get_character_expr (gfc_default_character_kind,
+						 &gfc_current_locus, NULL, 1);
+	tmp_sym->value->ts.is_c_interop = 1;
+	tmp_sym->value->ts.is_iso_c = 1;
+	tmp_sym->value->value.character.length = 1;
+	tmp_sym->value->value.character.string[0]
+	  = (gfc_char_t) c_interop_kinds_table[s].value;
+	tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+	tmp_sym->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
+						     NULL, 1);
+
+	/* May not need this in both attr and ts, but do need in
+	   attr for writing module file.  */
+	tmp_sym->attr.is_c_interop = 1;
+
+	tmp_sym->attr.flavor = FL_PARAMETER;
+	tmp_sym->ts.type = BT_CHARACTER;
+
+	/* Need to set it to the C_CHAR kind.  */
+	tmp_sym->ts.kind = gfc_default_character_kind;
+
+	/* Mark this type as a C interoperable one.  */
+	tmp_sym->ts.is_c_interop = 1;
+	tmp_sym->ts.is_iso_c = 1;
+
+	/* Tell what f90 type this c interop kind is valid.  */
+	tmp_sym->ts.f90_type = BT_CHARACTER;
+
+	break;
+
+      case ISOCBINDING_PTR:
+      case ISOCBINDING_FUNPTR:
+	{
+	  gfc_symbol *dt_sym;
+	  gfc_dt_list **dt_list_ptr = NULL;
+	  gfc_component *tmp_comp = NULL;
+
+	  /* Generate real derived type.  */
+	  if (hidden)
+	    dt_sym = tmp_sym;
+	  else
+	    {
+	      const char *hidden_name;
+	      gfc_interface *intr, *head;
+
+	      hidden_name = gfc_get_string ("%c%s",
+					    (char) TOUPPER ((unsigned char)
+							      tmp_sym->name[0]),
+					    &tmp_sym->name[1]);
+	      tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
+					      hidden_name);
+	      gcc_assert (tmp_symtree == NULL);
+	      gfc_get_sym_tree (hidden_name, gfc_current_ns, &tmp_symtree, false);
+	      dt_sym = tmp_symtree->n.sym;
+	      dt_sym->name = gfc_get_string (s == ISOCBINDING_PTR
+					    ? "c_ptr" : "c_funptr");
+
+	      /* Generate an artificial generic function.  */
+	      head = tmp_sym->generic;
+	      intr = gfc_get_interface ();
+	      intr->sym = dt_sym;
+	      intr->where = gfc_current_locus;
+	      intr->next = head;
+	      tmp_sym->generic = intr;
+
+	      if (!tmp_sym->attr.generic
+		  && !gfc_add_generic (&tmp_sym->attr, tmp_sym->name, NULL))
+		return NULL;
+
+	      if (!tmp_sym->attr.function
+		  && !gfc_add_function (&tmp_sym->attr, tmp_sym->name, NULL))
+		return NULL;
+	    }
+
+	  /* Say what module this symbol belongs to.  */
+	  dt_sym->module = gfc_get_string (mod_name);
+	  dt_sym->from_intmod = INTMOD_ISO_C_BINDING;
+	  dt_sym->intmod_sym_id = s;
+          dt_sym->attr.use_assoc = 1;
+
+	  /* Initialize an integer constant expression node.  */
+	  dt_sym->attr.flavor = FL_DERIVED;
+	  dt_sym->ts.is_c_interop = 1;
+	  dt_sym->attr.is_c_interop = 1;
+	  dt_sym->attr.private_comp = 1;
+	  dt_sym->component_access = ACCESS_PRIVATE;
+	  dt_sym->ts.is_iso_c = 1;
+	  dt_sym->ts.type = BT_DERIVED;
+	  dt_sym->ts.f90_type = BT_VOID;
+
+	  /* A derived type must have the bind attribute to be
+	     interoperable (J3/04-007, Section 15.2.3), even though
+	     the binding label is not used.  */
+	  dt_sym->attr.is_bind_c = 1;
+
+	  dt_sym->attr.referenced = 1;
+	  dt_sym->ts.u.derived = dt_sym;
+
+	  /* Add the symbol created for the derived type to the current ns.  */
+	  dt_list_ptr = &(gfc_derived_types);
+	  while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
+	    dt_list_ptr = &((*dt_list_ptr)->next);
+
+	  /* There is already at least one derived type in the list, so append
+	     the one we're currently building for c_ptr or c_funptr.  */
+	  if (*dt_list_ptr != NULL)
+	    dt_list_ptr = &((*dt_list_ptr)->next);
+	  (*dt_list_ptr) = gfc_get_dt_list ();
+	  (*dt_list_ptr)->derived = dt_sym;
+	  (*dt_list_ptr)->next = NULL;
+
+	  gfc_add_component (dt_sym, "c_address", &tmp_comp);
+	  if (tmp_comp == NULL)
+	    gcc_unreachable ();
+
+	  tmp_comp->ts.type = BT_INTEGER;
+
+	  /* Set this because the module will need to read/write this field.  */
+	  tmp_comp->ts.f90_type = BT_INTEGER;
+
+	  /* The kinds for c_ptr and c_funptr are the same.  */
+	  index = get_c_kind ("c_ptr", c_interop_kinds_table);
+	  tmp_comp->ts.kind = c_interop_kinds_table[index].value;
+	  tmp_comp->attr.access = ACCESS_PRIVATE;
+
+	  /* Mark the component as C interoperable.  */
+	  tmp_comp->ts.is_c_interop = 1;
+	}
+
+	break;
+
+      case ISOCBINDING_NULL_PTR:
+      case ISOCBINDING_NULL_FUNPTR:
+        gen_special_c_interop_ptr (tmp_sym, dt_symtree);
+        break;
+
+      default:
+	gcc_unreachable ();
+    }
+  gfc_commit_symbol (tmp_sym);
+  return tmp_symtree;
+}
+
+
+/* Check that a symbol is already typed.  If strict is not set, an untyped
+   symbol is acceptable for non-standard-conforming mode.  */
+
+bool
+gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
+			bool strict, locus where)
+{
+  gcc_assert (sym);
+
+  if (gfc_matching_prefix)
+    return true;
+
+  /* Check for the type and try to give it an implicit one.  */
+  if (sym->ts.type == BT_UNKNOWN
+      && !gfc_set_default_type (sym, 0, ns))
+    {
+      if (strict)
+	{
+	  gfc_error ("Symbol '%s' is used before it is typed at %L",
+		     sym->name, &where);
+	  return false;
+	}
+
+      if (!gfc_notify_std (GFC_STD_GNU, "Symbol '%s' is used before"
+			   " it is typed at %L", sym->name, &where))
+	return false;
+    }
+
+  /* Everything is ok.  */
+  return true;
+}
+
+
+/* Construct a typebound-procedure structure.  Those are stored in a tentative
+   list and marked `error' until symbols are committed.  */
+
+gfc_typebound_proc*
+gfc_get_typebound_proc (gfc_typebound_proc *tb0)
+{
+  gfc_typebound_proc *result;
+
+  result = XCNEW (gfc_typebound_proc);
+  if (tb0)
+    *result = *tb0;
+  result->error = 1;
+
+  latest_undo_chgset->tbps.safe_push (result);
+
+  return result;
+}
+
+
+/* Get the super-type of a given derived type.  */
+
+gfc_symbol*
+gfc_get_derived_super_type (gfc_symbol* derived)
+{
+  gcc_assert (derived);
+
+  if (derived->attr.generic)
+    derived = gfc_find_dt_in_generic (derived);
+
+  if (!derived->attr.extension)
+    return NULL;
+
+  gcc_assert (derived->components);
+  gcc_assert (derived->components->ts.type == BT_DERIVED);
+  gcc_assert (derived->components->ts.u.derived);
+
+  if (derived->components->ts.u.derived->attr.generic)
+    return gfc_find_dt_in_generic (derived->components->ts.u.derived);
+
+  return derived->components->ts.u.derived;
+}
+
+
+/* Get the ultimate super-type of a given derived type.  */
+
+gfc_symbol*
+gfc_get_ultimate_derived_super_type (gfc_symbol* derived)
+{
+  if (!derived->attr.extension)
+    return NULL;
+
+  derived = gfc_get_derived_super_type (derived);
+
+  if (derived->attr.extension)
+    return gfc_get_ultimate_derived_super_type (derived);
+  else
+    return derived;
+}
+
+
+/* Check if a derived type t2 is an extension of (or equal to) a type t1.  */
+
+bool
+gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2)
+{
+  while (!gfc_compare_derived_types (t1, t2) && t2->attr.extension)
+    t2 = gfc_get_derived_super_type (t2);
+  return gfc_compare_derived_types (t1, t2);
+}
+
+
+/* Check if two typespecs are type compatible (F03:5.1.1.2):
+   If ts1 is nonpolymorphic, ts2 must be the same type.
+   If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1.  */
+
+bool
+gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
+{
+  bool is_class1 = (ts1->type == BT_CLASS);
+  bool is_class2 = (ts2->type == BT_CLASS);
+  bool is_derived1 = (ts1->type == BT_DERIVED);
+  bool is_derived2 = (ts2->type == BT_DERIVED);
+
+  if (is_class1
+      && ts1->u.derived->components
+      && ts1->u.derived->components->ts.u.derived->attr.unlimited_polymorphic)
+    return 1;
+
+  if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2)
+    return (ts1->type == ts2->type);
+
+  if (is_derived1 && is_derived2)
+    return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
+
+  if (is_derived1 && is_class2)
+    return gfc_compare_derived_types (ts1->u.derived,
+				      ts2->u.derived->components->ts.u.derived);
+  if (is_class1 && is_derived2)
+    return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
+				     ts2->u.derived);
+  else if (is_class1 && is_class2)
+    return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
+				     ts2->u.derived->components->ts.u.derived);
+  else
+    return 0;
+}
+
+
+/* Find the parent-namespace of the current function.  If we're inside
+   BLOCK constructs, it may not be the current one.  */
+
+gfc_namespace*
+gfc_find_proc_namespace (gfc_namespace* ns)
+{
+  while (ns->construct_entities)
+    {
+      ns = ns->parent;
+      gcc_assert (ns);
+    }
+
+  return ns;
+}
+
+
+/* Check if an associate-variable should be translated as an `implicit' pointer
+   internally (if it is associated to a variable and not an array with
+   descriptor).  */
+
+bool
+gfc_is_associate_pointer (gfc_symbol* sym)
+{
+  if (!sym->assoc)
+    return false;
+
+  if (sym->ts.type == BT_CLASS)
+    return true;
+
+  if (!sym->assoc->variable)
+    return false;
+
+  if (sym->attr.dimension && sym->as->type != AS_EXPLICIT)
+    return false;
+
+  return true;
+}
+
+
+gfc_symbol *
+gfc_find_dt_in_generic (gfc_symbol *sym)
+{
+  gfc_interface *intr = NULL;
+
+  if (!sym || sym->attr.flavor == FL_DERIVED)
+    return sym;
+
+  if (sym->attr.generic)
+    for (intr = sym->generic; intr; intr = intr->next)
+      if (intr->sym->attr.flavor == FL_DERIVED)
+        break;
+  return intr ? intr->sym : NULL;
+}
+
+
+/* Get the dummy arguments from a procedure symbol. If it has been declared
+   via a PROCEDURE statement with a named interface, ts.interface will be set
+   and the arguments need to be taken from there.  */
+
+gfc_formal_arglist *
+gfc_sym_get_dummy_args (gfc_symbol *sym)
+{
+  gfc_formal_arglist *dummies;
+
+  dummies = sym->formal;
+  if (dummies == NULL && sym->ts.interface != NULL)
+    dummies = sym->ts.interface->formal;
+
+  return dummies;
+}
diff --git a/gcc-4.9/gcc/fortran/target-memory.c b/gcc-4.9/gcc/fortran/target-memory.c
new file mode 100644
index 000000000..3baebade8
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/target-memory.c
@@ -0,0 +1,802 @@
+/* Simulate storage of variables into target memory.
+   Copyright (C) 2007-2014 Free Software Foundation, Inc.
+   Contributed by Paul Thomas and Brooks Moses
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "flags.h"
+#include "machmode.h"
+#include "tree.h"
+#include "stor-layout.h"
+#include "gfortran.h"
+#include "arith.h"
+#include "constructor.h"
+#include "trans.h"
+#include "trans-const.h"
+#include "trans-types.h"
+#include "target-memory.h"
+
+/* --------------------------------------------------------------- */
+/* Calculate the size of an expression.  */
+
+
+static size_t
+size_integer (int kind)
+{
+  return GET_MODE_SIZE (TYPE_MODE (gfc_get_int_type (kind)));;
+}
+
+
+static size_t
+size_float (int kind)
+{
+  return GET_MODE_SIZE (TYPE_MODE (gfc_get_real_type (kind)));;
+}
+
+
+static size_t
+size_complex (int kind)
+{
+  return 2 * size_float (kind);
+}
+
+
+static size_t
+size_logical (int kind)
+{
+  return GET_MODE_SIZE (TYPE_MODE (gfc_get_logical_type (kind)));;
+}
+
+
+static size_t
+size_character (int length, int kind)
+{
+  int i = gfc_validate_kind (BT_CHARACTER, kind, false);
+  return length * gfc_character_kinds[i].bit_size / 8;
+}
+
+
+/* Return the size of a single element of the given expression.
+   Identical to gfc_target_expr_size for scalars.  */
+
+size_t
+gfc_element_size (gfc_expr *e)
+{
+  tree type;
+
+  switch (e->ts.type)
+    {
+    case BT_INTEGER:
+      return size_integer (e->ts.kind);
+    case BT_REAL:
+      return size_float (e->ts.kind);
+    case BT_COMPLEX:
+      return size_complex (e->ts.kind);
+    case BT_LOGICAL:
+      return size_logical (e->ts.kind);
+    case BT_CHARACTER:
+      if (e->expr_type == EXPR_CONSTANT)
+	return size_character (e->value.character.length, e->ts.kind);
+      else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
+	       && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
+	       && e->ts.u.cl->length->ts.type == BT_INTEGER)
+	{
+	  int length;
+
+	  gfc_extract_int (e->ts.u.cl->length, &length);
+	  return size_character (length, e->ts.kind);
+	}
+      else
+	return 0;
+
+    case BT_HOLLERITH:
+      return e->representation.length;
+    case BT_DERIVED:
+    case BT_CLASS:
+    case BT_VOID:
+    case BT_ASSUMED:
+      {
+	/* Determine type size without clobbering the typespec for ISO C
+	   binding types.  */
+	gfc_typespec ts;
+	HOST_WIDE_INT size;
+	ts = e->ts;
+	type = gfc_typenode_for_spec (&ts);
+	size = int_size_in_bytes (type);
+	gcc_assert (size >= 0);
+	return size;
+      }
+    default:
+      gfc_internal_error ("Invalid expression in gfc_element_size.");
+      return 0;
+    }
+}
+
+
+/* Return the size of an expression in its target representation.  */
+
+size_t
+gfc_target_expr_size (gfc_expr *e)
+{
+  mpz_t tmp;
+  size_t asz;
+
+  gcc_assert (e != NULL);
+
+  if (e->rank)
+    {
+      if (gfc_array_size (e, &tmp))
+	asz = mpz_get_ui (tmp);
+      else
+	asz = 0;
+    }
+  else
+    asz = 1;
+
+  return asz * gfc_element_size (e);
+}
+
+
+/* The encode_* functions export a value into a buffer, and
+   return the number of bytes of the buffer that have been
+   used.  */
+
+static unsigned HOST_WIDE_INT
+encode_array (gfc_expr *expr, unsigned char *buffer, size_t buffer_size)
+{
+  mpz_t array_size;
+  int i;
+  int ptr = 0;
+
+  gfc_constructor_base ctor = expr->value.constructor;
+
+  gfc_array_size (expr, &array_size);
+  for (i = 0; i < (int)mpz_get_ui (array_size); i++)
+    {
+      ptr += gfc_target_encode_expr (gfc_constructor_lookup_expr (ctor, i),
+				     &buffer[ptr], buffer_size - ptr);
+    }
+
+  mpz_clear (array_size);
+  return ptr;
+}
+
+
+static int
+encode_integer (int kind, mpz_t integer, unsigned char *buffer,
+		size_t buffer_size)
+{
+  return native_encode_expr (gfc_conv_mpz_to_tree (integer, kind),
+			     buffer, buffer_size);
+}
+
+
+static int
+encode_float (int kind, mpfr_t real, unsigned char *buffer, size_t buffer_size)
+{
+  return native_encode_expr (gfc_conv_mpfr_to_tree (real, kind, 0), buffer,
+			     buffer_size);
+}
+
+
+static int
+encode_complex (int kind, mpc_t cmplx,
+		unsigned char *buffer, size_t buffer_size)
+{
+  int size;
+  size = encode_float (kind, mpc_realref (cmplx), &buffer[0], buffer_size);
+  size += encode_float (kind, mpc_imagref (cmplx),
+			&buffer[size], buffer_size - size);
+  return size;
+}
+
+
+static int
+encode_logical (int kind, int logical, unsigned char *buffer, size_t buffer_size)
+{
+  return native_encode_expr (build_int_cst (gfc_get_logical_type (kind),
+					    logical),
+			     buffer, buffer_size);
+}
+
+
+int
+gfc_encode_character (int kind, int length, const gfc_char_t *string,
+		      unsigned char *buffer, size_t buffer_size)
+{
+  size_t elsize = size_character (1, kind);
+  tree type = gfc_get_char_type (kind);
+  int i;
+
+  gcc_assert (buffer_size >= size_character (length, kind));
+
+  for (i = 0; i < length; i++)
+    native_encode_expr (build_int_cst (type, string[i]), &buffer[i*elsize],
+			elsize);
+
+  return length;
+}
+
+
+static unsigned HOST_WIDE_INT
+encode_derived (gfc_expr *source, unsigned char *buffer, size_t buffer_size)
+{
+  gfc_constructor *c;
+  gfc_component *cmp;
+  int ptr;
+  tree type;
+  HOST_WIDE_INT size;
+
+  type = gfc_typenode_for_spec (&source->ts);
+
+  for (c = gfc_constructor_first (source->value.constructor),
+       cmp = source->ts.u.derived->components;
+       c;
+       c = gfc_constructor_next (c), cmp = cmp->next)
+    {
+      gcc_assert (cmp);
+      if (!c->expr)
+	continue;
+      ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
+	    + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
+
+      if (c->expr->expr_type == EXPR_NULL)
+	{
+	  size = int_size_in_bytes (TREE_TYPE (cmp->backend_decl));
+	  gcc_assert (size >= 0);
+	  memset (&buffer[ptr], 0, size);
+	}
+      else
+	gfc_target_encode_expr (c->expr, &buffer[ptr],
+				buffer_size - ptr);
+    }
+
+  size = int_size_in_bytes (type);
+  gcc_assert (size >= 0);
+  return size;
+}
+
+
+/* Write a constant expression in binary form to a buffer.  */
+unsigned HOST_WIDE_INT
+gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
+			size_t buffer_size)
+{
+  if (source == NULL)
+    return 0;
+
+  if (source->expr_type == EXPR_ARRAY)
+    return encode_array (source, buffer, buffer_size);
+
+  gcc_assert (source->expr_type == EXPR_CONSTANT
+	      || source->expr_type == EXPR_STRUCTURE
+	      || source->expr_type == EXPR_SUBSTRING);
+
+  /* If we already have a target-memory representation, we use that rather
+     than recreating one.  */
+  if (source->representation.string)
+    {
+      memcpy (buffer, source->representation.string,
+	      source->representation.length);
+      return source->representation.length;
+    }
+
+  switch (source->ts.type)
+    {
+    case BT_INTEGER:
+      return encode_integer (source->ts.kind, source->value.integer, buffer,
+			     buffer_size);
+    case BT_REAL:
+      return encode_float (source->ts.kind, source->value.real, buffer,
+			   buffer_size);
+    case BT_COMPLEX:
+      return encode_complex (source->ts.kind, source->value.complex,
+			     buffer, buffer_size);
+    case BT_LOGICAL:
+      return encode_logical (source->ts.kind, source->value.logical, buffer,
+			     buffer_size);
+    case BT_CHARACTER:
+      if (source->expr_type == EXPR_CONSTANT || source->ref == NULL)
+	return gfc_encode_character (source->ts.kind,
+				     source->value.character.length,
+				     source->value.character.string,
+				     buffer, buffer_size);
+      else
+	{
+	  int start, end;
+
+	  gcc_assert (source->expr_type == EXPR_SUBSTRING);
+	  gfc_extract_int (source->ref->u.ss.start, &start);
+	  gfc_extract_int (source->ref->u.ss.end, &end);
+	  return gfc_encode_character (source->ts.kind, MAX(end - start + 1, 0),
+				       &source->value.character.string[start-1],
+				       buffer, buffer_size);
+	}
+
+    case BT_DERIVED:
+      if (source->ts.u.derived->ts.f90_type == BT_VOID)
+	{
+	  gfc_constructor *c;
+	  gcc_assert (source->expr_type == EXPR_STRUCTURE);
+	  c = gfc_constructor_first (source->value.constructor);
+	  gcc_assert (c->expr->expr_type == EXPR_CONSTANT
+		      && c->expr->ts.type == BT_INTEGER);
+	  return encode_integer (gfc_index_integer_kind, c->expr->value.integer,
+				 buffer, buffer_size);
+	}
+
+      return encode_derived (source, buffer, buffer_size);
+    default:
+      gfc_internal_error ("Invalid expression in gfc_target_encode_expr.");
+      return 0;
+    }
+}
+
+
+static int
+interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
+{
+  gfc_constructor_base base = NULL;
+  int array_size = 1;
+  int i;
+  int ptr = 0;
+
+  /* Calculate array size from its shape and rank.  */
+  gcc_assert (result->rank > 0 && result->shape);
+
+  for (i = 0; i < result->rank; i++)
+    array_size *= (int)mpz_get_ui (result->shape[i]);
+
+  /* Iterate over array elements, producing constructors.  */
+  for (i = 0; i < array_size; i++)
+    {
+      gfc_expr *e = gfc_get_constant_expr (result->ts.type, result->ts.kind,
+					   &result->where);
+      e->ts = result->ts;
+
+      if (e->ts.type == BT_CHARACTER)
+	e->value.character.length = result->value.character.length;
+
+      gfc_constructor_append_expr (&base, e, &result->where);
+
+      ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e,
+					true);
+    }
+
+  result->value.constructor = base;
+  return ptr;
+}
+
+
+int
+gfc_interpret_integer (int kind, unsigned char *buffer, size_t buffer_size,
+		   mpz_t integer)
+{
+  mpz_init (integer);
+  gfc_conv_tree_to_mpz (integer,
+			native_interpret_expr (gfc_get_int_type (kind),
+					       buffer, buffer_size));
+  return size_integer (kind);
+}
+
+
+int
+gfc_interpret_float (int kind, unsigned char *buffer, size_t buffer_size,
+		     mpfr_t real)
+{
+  gfc_set_model_kind (kind);
+  mpfr_init (real);
+  gfc_conv_tree_to_mpfr (real,
+			 native_interpret_expr (gfc_get_real_type (kind),
+						buffer, buffer_size));
+
+  return size_float (kind);
+}
+
+
+int
+gfc_interpret_complex (int kind, unsigned char *buffer, size_t buffer_size,
+		       mpc_t complex)
+{
+  int size;
+  size = gfc_interpret_float (kind, &buffer[0], buffer_size,
+			      mpc_realref (complex));
+  size += gfc_interpret_float (kind, &buffer[size], buffer_size - size,
+			       mpc_imagref (complex));
+  return size;
+}
+
+
+int
+gfc_interpret_logical (int kind, unsigned char *buffer, size_t buffer_size,
+		   int *logical)
+{
+  tree t = native_interpret_expr (gfc_get_logical_type (kind), buffer,
+				  buffer_size);
+  *logical = tree_to_double_int (t).is_zero () ? 0 : 1;
+  return size_logical (kind);
+}
+
+
+int
+gfc_interpret_character (unsigned char *buffer, size_t buffer_size,
+			 gfc_expr *result)
+{
+  int i;
+
+  if (result->ts.u.cl && result->ts.u.cl->length)
+    result->value.character.length =
+      (int) mpz_get_ui (result->ts.u.cl->length->value.integer);
+
+  gcc_assert (buffer_size >= size_character (result->value.character.length,
+					     result->ts.kind));
+  result->value.character.string =
+    gfc_get_wide_string (result->value.character.length + 1);
+
+  if (result->ts.kind == gfc_default_character_kind)
+    for (i = 0; i < result->value.character.length; i++)
+      result->value.character.string[i] = (gfc_char_t) buffer[i];
+  else
+    {
+      mpz_t integer;
+      unsigned bytes = size_character (1, result->ts.kind);
+      mpz_init (integer);
+      gcc_assert (bytes <= sizeof (unsigned long));
+
+      for (i = 0; i < result->value.character.length; i++)
+	{
+	  gfc_conv_tree_to_mpz (integer,
+	    native_interpret_expr (gfc_get_char_type (result->ts.kind),
+				   &buffer[bytes*i], buffer_size-bytes*i));
+	  result->value.character.string[i]
+	    = (gfc_char_t) mpz_get_ui (integer);
+	}
+
+      mpz_clear (integer);
+    }
+
+  result->value.character.string[result->value.character.length] = '\0';
+
+  return result->value.character.length;
+}
+
+
+int
+gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
+{
+  gfc_component *cmp;
+  int ptr;
+  tree type;
+
+  /* The attributes of the derived type need to be bolted to the floor.  */
+  result->expr_type = EXPR_STRUCTURE;
+
+  cmp = result->ts.u.derived->components;
+
+  if (result->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
+      && (result->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
+	  || result->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
+    {
+      gfc_constructor *c;
+      gfc_expr *e;
+      /* Needed as gfc_typenode_for_spec as gfc_typenode_for_spec
+	 sets this to BT_INTEGER.  */
+      result->ts.type = BT_DERIVED;
+      e = gfc_get_constant_expr (cmp->ts.type, cmp->ts.kind, &result->where);
+      c = gfc_constructor_append_expr (&result->value.constructor, e, NULL);
+      c->n.component = cmp;
+      gfc_target_interpret_expr (buffer, buffer_size, e, true);
+      e->ts.is_iso_c = 1;
+      return int_size_in_bytes (ptr_type_node);
+    }
+
+  type = gfc_typenode_for_spec (&result->ts);
+
+  /* Run through the derived type components.  */
+  for (;cmp; cmp = cmp->next)
+    {
+      gfc_constructor *c;
+      gfc_expr *e = gfc_get_constant_expr (cmp->ts.type, cmp->ts.kind,
+					   &result->where);
+      e->ts = cmp->ts;
+
+      /* Copy shape, if needed.  */
+      if (cmp->as && cmp->as->rank)
+	{
+	  int n;
+
+	  e->expr_type = EXPR_ARRAY;
+	  e->rank = cmp->as->rank;
+
+	  e->shape = gfc_get_shape (e->rank);
+	  for (n = 0; n < e->rank; n++)
+	     {
+	       mpz_init_set_ui (e->shape[n], 1);
+	       mpz_add (e->shape[n], e->shape[n],
+			cmp->as->upper[n]->value.integer);
+	       mpz_sub (e->shape[n], e->shape[n],
+			cmp->as->lower[n]->value.integer);
+	     }
+	}
+
+      c = gfc_constructor_append_expr (&result->value.constructor, e, NULL);
+
+      /* The constructor points to the component.  */
+      c->n.component = cmp;
+
+      /* Calculate the offset, which consists of the FIELD_OFFSET in
+	 bytes, which appears in multiples of DECL_OFFSET_ALIGN-bit-sized,
+	 and additional bits of FIELD_BIT_OFFSET. The code assumes that all
+	 sizes of the components are multiples of BITS_PER_UNIT,
+	 i.e. there are, e.g., no bit fields.  */
+
+      gcc_assert (cmp->backend_decl);
+      ptr = TREE_INT_CST_LOW (DECL_FIELD_BIT_OFFSET (cmp->backend_decl));
+      gcc_assert (ptr % 8 == 0);
+      ptr = ptr/8 + TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl));
+
+      gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e, true);
+    }
+
+  return int_size_in_bytes (type);
+}
+
+
+/* Read a binary buffer to a constant expression.  */
+int
+gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size,
+			   gfc_expr *result, bool convert_widechar)
+{
+  if (result->expr_type == EXPR_ARRAY)
+    return interpret_array (buffer, buffer_size, result);
+
+  switch (result->ts.type)
+    {
+    case BT_INTEGER:
+      result->representation.length =
+        gfc_interpret_integer (result->ts.kind, buffer, buffer_size,
+			       result->value.integer);
+      break;
+
+    case BT_REAL:
+      result->representation.length =
+        gfc_interpret_float (result->ts.kind, buffer, buffer_size,
+    			     result->value.real);
+      break;
+
+    case BT_COMPLEX:
+      result->representation.length =
+        gfc_interpret_complex (result->ts.kind, buffer, buffer_size,
+			       result->value.complex);
+      break;
+
+    case BT_LOGICAL:
+      result->representation.length =
+        gfc_interpret_logical (result->ts.kind, buffer, buffer_size,
+			       &result->value.logical);
+      break;
+
+    case BT_CHARACTER:
+      result->representation.length =
+        gfc_interpret_character (buffer, buffer_size, result);
+      break;
+
+    case BT_CLASS:
+      result->ts = CLASS_DATA (result)->ts;
+      /* Fall through.  */
+    case BT_DERIVED:
+      result->representation.length =
+        gfc_interpret_derived (buffer, buffer_size, result);
+      gcc_assert (result->representation.length >= 0);
+      break;
+
+    default:
+      gfc_internal_error ("Invalid expression in gfc_target_interpret_expr.");
+      break;
+    }
+
+  if (result->ts.type == BT_CHARACTER && convert_widechar)
+    result->representation.string
+      = gfc_widechar_to_char (result->value.character.string,
+			      result->value.character.length);
+  else
+    {
+      result->representation.string =
+        XCNEWVEC (char, result->representation.length + 1);
+      memcpy (result->representation.string, buffer,
+	      result->representation.length);
+      result->representation.string[result->representation.length] = '\0';
+    }
+
+  return result->representation.length;
+}
+
+
+/* --------------------------------------------------------------- */
+/* Two functions used by trans-common.c to write overlapping
+   equivalence initializers to a buffer.  This is added to the union
+   and the original initializers freed.  */
+
+
+/* Writes the values of a constant expression to a char buffer. If another
+   unequal initializer has already been written to the buffer, this is an
+   error.  */
+
+static size_t
+expr_to_char (gfc_expr *e, unsigned char *data, unsigned char *chk, size_t len)
+{
+  int i;
+  int ptr;
+  gfc_constructor *c;
+  gfc_component *cmp;
+  unsigned char *buffer;
+
+  if (e == NULL)
+    return 0;
+
+  /* Take a derived type, one component at a time, using the offsets from the backend
+     declaration.  */
+  if (e->ts.type == BT_DERIVED)
+    {
+      for (c = gfc_constructor_first (e->value.constructor),
+	   cmp = e->ts.u.derived->components;
+	   c; c = gfc_constructor_next (c), cmp = cmp->next)
+	{
+	  gcc_assert (cmp && cmp->backend_decl);
+	  if (!c->expr)
+	    continue;
+	    ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
+			+ TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
+	  expr_to_char (c->expr, &data[ptr], &chk[ptr], len);
+	}
+      return len;
+    }
+
+  /* Otherwise, use the target-memory machinery to write a bitwise image, appropriate
+     to the target, in a buffer and check off the initialized part of the buffer.  */
+  len = gfc_target_expr_size (e);
+  buffer = (unsigned char*)alloca (len);
+  len = gfc_target_encode_expr (e, buffer, len);
+
+    for (i = 0; i < (int)len; i++)
+    {
+      if (chk[i] && (buffer[i] != data[i]))
+	{
+	  gfc_error ("Overlapping unequal initializers in EQUIVALENCE "
+		     "at %L", &e->where);
+	  return 0;
+	}
+      chk[i] = 0xFF;
+    }
+
+  memcpy (data, buffer, len);
+  return len;
+}
+
+
+/* Writes the values from the equivalence initializers to a char* array
+   that will be written to the constructor to make the initializer for
+   the union declaration.  */
+
+size_t
+gfc_merge_initializers (gfc_typespec ts, gfc_expr *e, unsigned char *data,
+			unsigned char *chk, size_t length)
+{
+  size_t len = 0;
+  gfc_constructor * c;
+
+  switch (e->expr_type)
+    {
+    case EXPR_CONSTANT:
+    case EXPR_STRUCTURE:
+      len = expr_to_char (e, &data[0], &chk[0], length);
+
+      break;
+
+    case EXPR_ARRAY:
+      for (c = gfc_constructor_first (e->value.constructor);
+	   c; c = gfc_constructor_next (c))
+	{
+	  size_t elt_size = gfc_target_expr_size (c->expr);
+
+	  if (mpz_cmp_si (c->offset, 0) != 0)
+	    len = elt_size * (size_t)mpz_get_si (c->offset);
+
+	  len = len + gfc_merge_initializers (ts, c->expr, &data[len],
+					      &chk[len], length - len);
+	}
+      break;
+
+    default:
+      return 0;
+    }
+
+  return len;
+}
+
+
+/* Transfer the bitpattern of a (integer) BOZ to real or complex variables.
+   When successful, no BOZ or nothing to do, true is returned.  */
+
+bool
+gfc_convert_boz (gfc_expr *expr, gfc_typespec *ts)
+{
+  size_t buffer_size, boz_bit_size, ts_bit_size;
+  int index;
+  unsigned char *buffer;
+
+  if (!expr->is_boz)
+    return true;
+
+  gcc_assert (expr->expr_type == EXPR_CONSTANT
+	      && expr->ts.type == BT_INTEGER);
+
+  /* Don't convert BOZ to logical, character, derived etc.  */
+  if (ts->type == BT_REAL)
+    {
+      buffer_size = size_float (ts->kind);
+      ts_bit_size = buffer_size * 8;
+    }
+  else if (ts->type == BT_COMPLEX)
+    {
+      buffer_size = size_complex (ts->kind);
+      ts_bit_size = buffer_size * 8 / 2;
+    }
+  else
+    return true;
+
+  /* Convert BOZ to the smallest possible integer kind.  */
+  boz_bit_size = mpz_sizeinbase (expr->value.integer, 2);
+
+  if (boz_bit_size > ts_bit_size)
+    {
+      gfc_error_now ("BOZ constant at %L is too large (%ld vs %ld bits)",
+		     &expr->where, (long) boz_bit_size, (long) ts_bit_size);
+      return false;
+    }
+
+  for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
+    if ((unsigned) gfc_integer_kinds[index].bit_size >= ts_bit_size)
+      break;
+
+  expr->ts.kind = gfc_integer_kinds[index].kind;
+  buffer_size = MAX (buffer_size, size_integer (expr->ts.kind));
+
+  buffer = (unsigned char*)alloca (buffer_size);
+  encode_integer (expr->ts.kind, expr->value.integer, buffer, buffer_size);
+  mpz_clear (expr->value.integer);
+
+  if (ts->type == BT_REAL)
+    {
+      mpfr_init (expr->value.real);
+      gfc_interpret_float (ts->kind, buffer, buffer_size, expr->value.real);
+    }
+  else
+    {
+      mpc_init2 (expr->value.complex, mpfr_get_default_prec());
+      gfc_interpret_complex (ts->kind, buffer, buffer_size,
+			     expr->value.complex);
+    }
+  expr->is_boz = 0;
+  expr->ts.type = ts->type;
+  expr->ts.kind = ts->kind;
+
+  return true;
+}
diff --git a/gcc-4.9/gcc/fortran/target-memory.h b/gcc-4.9/gcc/fortran/target-memory.h
new file mode 100644
index 000000000..c976be376
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/target-memory.h
@@ -0,0 +1,51 @@
+/* Simulate storage of variables into target memory, header.
+   Copyright (C) 2007-2014 Free Software Foundation, Inc.
+   Contributed by Paul Thomas and Brooks Moses
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+#ifndef GFC_TARGET_MEMORY_H
+#define GFC_TARGET_MEMORY_H
+
+/* Convert a BOZ to REAL or COMPLEX.  */
+bool gfc_convert_boz (gfc_expr *, gfc_typespec *);
+
+size_t gfc_element_size (gfc_expr *);
+size_t gfc_target_expr_size (gfc_expr *);
+
+/* Write a constant expression in binary form to a target buffer.  */
+int gfc_encode_character (int, int, const gfc_char_t *, unsigned char *,
+			  size_t);
+unsigned HOST_WIDE_INT gfc_target_encode_expr (gfc_expr *, unsigned char *,
+					       size_t);
+
+/* Read a target buffer into a constant expression.  */
+
+int gfc_interpret_integer (int, unsigned char *, size_t, mpz_t);
+int gfc_interpret_float (int, unsigned char *, size_t, mpfr_t);
+int gfc_interpret_complex (int, unsigned char *, size_t, mpc_t);
+int gfc_interpret_logical (int, unsigned char *, size_t, int *);
+int gfc_interpret_character (unsigned char *, size_t, gfc_expr *);
+int gfc_interpret_derived (unsigned char *, size_t, gfc_expr *);
+int gfc_target_interpret_expr (unsigned char *, size_t, gfc_expr *, bool);
+
+/* Merge overlapping equivalence initializers for trans-common.c. */
+size_t gfc_merge_initializers (gfc_typespec, gfc_expr *,
+			       unsigned char *, unsigned char *,
+			       size_t);
+
+#endif /* GFC_TARGET_MEMORY_H  */
diff --git a/gcc-4.9/gcc/fortran/trans-array.c b/gcc-4.9/gcc/fortran/trans-array.c
new file mode 100644
index 000000000..8c4afb098
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/trans-array.c
@@ -0,0 +1,9100 @@
+/* Array translation routines
+   Copyright (C) 2002-2014 Free Software Foundation, Inc.
+   Contributed by Paul Brook <paul@nowt.org>
+   and Steven Bosscher <s.bosscher@student.tudelft.nl>
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+/* trans-array.c-- Various array related code, including scalarization,
+                   allocation, initialization and other support routines.  */
+
+/* How the scalarizer works.
+   In gfortran, array expressions use the same core routines as scalar
+   expressions.
+   First, a Scalarization State (SS) chain is built.  This is done by walking
+   the expression tree, and building a linear list of the terms in the
+   expression.  As the tree is walked, scalar subexpressions are translated.
+
+   The scalarization parameters are stored in a gfc_loopinfo structure.
+   First the start and stride of each term is calculated by
+   gfc_conv_ss_startstride.  During this process the expressions for the array
+   descriptors and data pointers are also translated.
+
+   If the expression is an assignment, we must then resolve any dependencies.
+   In Fortran all the rhs values of an assignment must be evaluated before
+   any assignments take place.  This can require a temporary array to store the
+   values.  We also require a temporary when we are passing array expressions
+   or vector subscripts as procedure parameters.
+
+   Array sections are passed without copying to a temporary.  These use the
+   scalarizer to determine the shape of the section.  The flag
+   loop->array_parameter tells the scalarizer that the actual values and loop
+   variables will not be required.
+
+   The function gfc_conv_loop_setup generates the scalarization setup code.
+   It determines the range of the scalarizing loop variables.  If a temporary
+   is required, this is created and initialized.  Code for scalar expressions
+   taken outside the loop is also generated at this time.  Next the offset and
+   scaling required to translate from loop variables to array indices for each
+   term is calculated.
+
+   A call to gfc_start_scalarized_body marks the start of the scalarized
+   expression.  This creates a scope and declares the loop variables.  Before
+   calling this gfc_make_ss_chain_used must be used to indicate which terms
+   will be used inside this loop.
+
+   The scalar gfc_conv_* functions are then used to build the main body of the
+   scalarization loop.  Scalarization loop variables and precalculated scalar
+   values are automatically substituted.  Note that gfc_advance_se_ss_chain
+   must be used, rather than changing the se->ss directly.
+
+   For assignment expressions requiring a temporary two sub loops are
+   generated.  The first stores the result of the expression in the temporary,
+   the second copies it to the result.  A call to
+   gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
+   the start of the copying loop.  The temporary may be less than full rank.
+
+   Finally gfc_trans_scalarizing_loops is called to generate the implicit do
+   loops.  The loops are added to the pre chain of the loopinfo.  The post
+   chain may still contain cleanup code.
+
+   After the loop code has been added into its parent scope gfc_cleanup_loop
+   is called to free all the SS allocated by the scalarizer.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "tree.h"
+#include "gimple-expr.h"
+#include "diagnostic-core.h"	/* For internal_error/fatal_error.  */
+#include "flags.h"
+#include "gfortran.h"
+#include "constructor.h"
+#include "trans.h"
+#include "trans-stmt.h"
+#include "trans-types.h"
+#include "trans-array.h"
+#include "trans-const.h"
+#include "dependency.h"
+
+static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
+
+/* The contents of this structure aren't actually used, just the address.  */
+static gfc_ss gfc_ss_terminator_var;
+gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
+
+
+static tree
+gfc_array_dataptr_type (tree desc)
+{
+  return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
+}
+
+
+/* Build expressions to access the members of an array descriptor.
+   It's surprisingly easy to mess up here, so never access
+   an array descriptor by "brute force", always use these
+   functions.  This also avoids problems if we change the format
+   of an array descriptor.
+
+   To understand these magic numbers, look at the comments
+   before gfc_build_array_type() in trans-types.c.
+
+   The code within these defines should be the only code which knows the format
+   of an array descriptor.
+
+   Any code just needing to read obtain the bounds of an array should use
+   gfc_conv_array_* rather than the following functions as these will return
+   know constant values, and work with arrays which do not have descriptors.
+
+   Don't forget to #undef these!  */
+
+#define DATA_FIELD 0
+#define OFFSET_FIELD 1
+#define DTYPE_FIELD 2
+#define DIMENSION_FIELD 3
+#define CAF_TOKEN_FIELD 4
+
+#define STRIDE_SUBFIELD 0
+#define LBOUND_SUBFIELD 1
+#define UBOUND_SUBFIELD 2
+
+/* This provides READ-ONLY access to the data field.  The field itself
+   doesn't have the proper type.  */
+
+tree
+gfc_conv_descriptor_data_get (tree desc)
+{
+  tree field, type, t;
+
+  type = TREE_TYPE (desc);
+  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+
+  field = TYPE_FIELDS (type);
+  gcc_assert (DATA_FIELD == 0);
+
+  t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
+		       field, NULL_TREE);
+  t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
+
+  return t;
+}
+
+/* This provides WRITE access to the data field.
+
+   TUPLES_P is true if we are generating tuples.
+
+   This function gets called through the following macros:
+     gfc_conv_descriptor_data_set
+     gfc_conv_descriptor_data_set.  */
+
+void
+gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
+{
+  tree field, type, t;
+
+  type = TREE_TYPE (desc);
+  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+
+  field = TYPE_FIELDS (type);
+  gcc_assert (DATA_FIELD == 0);
+
+  t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
+		       field, NULL_TREE);
+  gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value));
+}
+
+
+/* This provides address access to the data field.  This should only be
+   used by array allocation, passing this on to the runtime.  */
+
+tree
+gfc_conv_descriptor_data_addr (tree desc)
+{
+  tree field, type, t;
+
+  type = TREE_TYPE (desc);
+  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+
+  field = TYPE_FIELDS (type);
+  gcc_assert (DATA_FIELD == 0);
+
+  t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
+		       field, NULL_TREE);
+  return gfc_build_addr_expr (NULL_TREE, t);
+}
+
+static tree
+gfc_conv_descriptor_offset (tree desc)
+{
+  tree type;
+  tree field;
+
+  type = TREE_TYPE (desc);
+  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+
+  field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
+  gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
+
+  return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+			  desc, field, NULL_TREE);
+}
+
+tree
+gfc_conv_descriptor_offset_get (tree desc)
+{
+  return gfc_conv_descriptor_offset (desc);
+}
+
+void
+gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
+				tree value)
+{
+  tree t = gfc_conv_descriptor_offset (desc);
+  gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
+}
+
+
+tree
+gfc_conv_descriptor_dtype (tree desc)
+{
+  tree field;
+  tree type;
+
+  type = TREE_TYPE (desc);
+  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+
+  field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
+  gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
+
+  return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+			  desc, field, NULL_TREE);
+}
+
+
+tree
+gfc_conv_descriptor_rank (tree desc)
+{
+  tree tmp;
+  tree dtype;
+
+  dtype = gfc_conv_descriptor_dtype (desc);
+  tmp = build_int_cst (TREE_TYPE (dtype), GFC_DTYPE_RANK_MASK);
+  tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (dtype),
+			 dtype, tmp);
+  return fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
+}
+
+
+tree
+gfc_get_descriptor_dimension (tree desc)
+{
+  tree type, field;
+
+  type = TREE_TYPE (desc);
+  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+
+  field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
+  gcc_assert (field != NULL_TREE
+	  && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
+	  && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
+
+  return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+			  desc, field, NULL_TREE);
+}
+
+
+static tree
+gfc_conv_descriptor_dimension (tree desc, tree dim)
+{
+  tree tmp;
+
+  tmp = gfc_get_descriptor_dimension (desc);
+
+  return gfc_build_array_ref (tmp, dim, NULL);
+}
+
+
+tree
+gfc_conv_descriptor_token (tree desc)
+{
+  tree type;
+  tree field;
+
+  type = TREE_TYPE (desc);
+  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+  gcc_assert (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE);
+  gcc_assert (gfc_option.coarray == GFC_FCOARRAY_LIB);
+  field = gfc_advance_chain (TYPE_FIELDS (type), CAF_TOKEN_FIELD);
+
+  /* Should be a restricted pointer - except in the finalization wrapper.  */
+  gcc_assert (field != NULL_TREE
+	      && (TREE_TYPE (field) == prvoid_type_node
+		  || TREE_TYPE (field) == pvoid_type_node));
+
+  return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+			  desc, field, NULL_TREE);
+}
+
+
+static tree
+gfc_conv_descriptor_stride (tree desc, tree dim)
+{
+  tree tmp;
+  tree field;
+
+  tmp = gfc_conv_descriptor_dimension (desc, dim);
+  field = TYPE_FIELDS (TREE_TYPE (tmp));
+  field = gfc_advance_chain (field, STRIDE_SUBFIELD);
+  gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
+
+  tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+			 tmp, field, NULL_TREE);
+  return tmp;
+}
+
+tree
+gfc_conv_descriptor_stride_get (tree desc, tree dim)
+{
+  tree type = TREE_TYPE (desc);
+  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+  if (integer_zerop (dim)
+      && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
+	  ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
+	  ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT
+	  ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
+    return gfc_index_one_node;
+
+  return gfc_conv_descriptor_stride (desc, dim);
+}
+
+void
+gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
+				tree dim, tree value)
+{
+  tree t = gfc_conv_descriptor_stride (desc, dim);
+  gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
+}
+
+static tree
+gfc_conv_descriptor_lbound (tree desc, tree dim)
+{
+  tree tmp;
+  tree field;
+
+  tmp = gfc_conv_descriptor_dimension (desc, dim);
+  field = TYPE_FIELDS (TREE_TYPE (tmp));
+  field = gfc_advance_chain (field, LBOUND_SUBFIELD);
+  gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
+
+  tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+			 tmp, field, NULL_TREE);
+  return tmp;
+}
+
+tree
+gfc_conv_descriptor_lbound_get (tree desc, tree dim)
+{
+  return gfc_conv_descriptor_lbound (desc, dim);
+}
+
+void
+gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
+				tree dim, tree value)
+{
+  tree t = gfc_conv_descriptor_lbound (desc, dim);
+  gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
+}
+
+static tree
+gfc_conv_descriptor_ubound (tree desc, tree dim)
+{
+  tree tmp;
+  tree field;
+
+  tmp = gfc_conv_descriptor_dimension (desc, dim);
+  field = TYPE_FIELDS (TREE_TYPE (tmp));
+  field = gfc_advance_chain (field, UBOUND_SUBFIELD);
+  gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
+
+  tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+			 tmp, field, NULL_TREE);
+  return tmp;
+}
+
+tree
+gfc_conv_descriptor_ubound_get (tree desc, tree dim)
+{
+  return gfc_conv_descriptor_ubound (desc, dim);
+}
+
+void
+gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
+				tree dim, tree value)
+{
+  tree t = gfc_conv_descriptor_ubound (desc, dim);
+  gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
+}
+
+/* Build a null array descriptor constructor.  */
+
+tree
+gfc_build_null_descriptor (tree type)
+{
+  tree field;
+  tree tmp;
+
+  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+  gcc_assert (DATA_FIELD == 0);
+  field = TYPE_FIELDS (type);
+
+  /* Set a NULL data pointer.  */
+  tmp = build_constructor_single (type, field, null_pointer_node);
+  TREE_CONSTANT (tmp) = 1;
+  /* All other fields are ignored.  */
+
+  return tmp;
+}
+
+
+/* Modify a descriptor such that the lbound of a given dimension is the value
+   specified.  This also updates ubound and offset accordingly.  */
+
+void
+gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
+				  int dim, tree new_lbound)
+{
+  tree offs, ubound, lbound, stride;
+  tree diff, offs_diff;
+
+  new_lbound = fold_convert (gfc_array_index_type, new_lbound);
+
+  offs = gfc_conv_descriptor_offset_get (desc);
+  lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
+  ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
+  stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
+
+  /* Get difference (new - old) by which to shift stuff.  */
+  diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			  new_lbound, lbound);
+
+  /* Shift ubound and offset accordingly.  This has to be done before
+     updating the lbound, as they depend on the lbound expression!  */
+  ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			    ubound, diff);
+  gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
+  offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			       diff, stride);
+  offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			  offs, offs_diff);
+  gfc_conv_descriptor_offset_set (block, desc, offs);
+
+  /* Finally set lbound to value we want.  */
+  gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
+}
+
+
+/* Cleanup those #defines.  */
+
+#undef DATA_FIELD
+#undef OFFSET_FIELD
+#undef DTYPE_FIELD
+#undef DIMENSION_FIELD
+#undef CAF_TOKEN_FIELD
+#undef STRIDE_SUBFIELD
+#undef LBOUND_SUBFIELD
+#undef UBOUND_SUBFIELD
+
+
+/* Mark a SS chain as used.  Flags specifies in which loops the SS is used.
+   flags & 1 = Main loop body.
+   flags & 2 = temp copy loop.  */
+
+void
+gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
+{
+  for (; ss != gfc_ss_terminator; ss = ss->next)
+    ss->info->useflags = flags;
+}
+
+
+/* Free a gfc_ss chain.  */
+
+void
+gfc_free_ss_chain (gfc_ss * ss)
+{
+  gfc_ss *next;
+
+  while (ss != gfc_ss_terminator)
+    {
+      gcc_assert (ss != NULL);
+      next = ss->next;
+      gfc_free_ss (ss);
+      ss = next;
+    }
+}
+
+
+static void
+free_ss_info (gfc_ss_info *ss_info)
+{
+  int n;
+
+  ss_info->refcount--;
+  if (ss_info->refcount > 0)
+    return;
+
+  gcc_assert (ss_info->refcount == 0);
+
+  switch (ss_info->type)
+    {
+    case GFC_SS_SECTION:
+      for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
+	if (ss_info->data.array.subscript[n])
+	  gfc_free_ss_chain (ss_info->data.array.subscript[n]);
+      break;
+
+    default:
+      break;
+    }
+
+  free (ss_info);
+}
+
+
+/* Free a SS.  */
+
+void
+gfc_free_ss (gfc_ss * ss)
+{
+  free_ss_info (ss->info);
+  free (ss);
+}
+
+
+/* Creates and initializes an array type gfc_ss struct.  */
+
+gfc_ss *
+gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type)
+{
+  gfc_ss *ss;
+  gfc_ss_info *ss_info;
+  int i;
+
+  ss_info = gfc_get_ss_info ();
+  ss_info->refcount++;
+  ss_info->type = type;
+  ss_info->expr = expr;
+
+  ss = gfc_get_ss ();
+  ss->info = ss_info;
+  ss->next = next;
+  ss->dimen = dimen;
+  for (i = 0; i < ss->dimen; i++)
+    ss->dim[i] = i;
+
+  return ss;
+}
+
+
+/* Creates and initializes a temporary type gfc_ss struct.  */
+
+gfc_ss *
+gfc_get_temp_ss (tree type, tree string_length, int dimen)
+{
+  gfc_ss *ss;
+  gfc_ss_info *ss_info;
+  int i;
+
+  ss_info = gfc_get_ss_info ();
+  ss_info->refcount++;
+  ss_info->type = GFC_SS_TEMP;
+  ss_info->string_length = string_length;
+  ss_info->data.temp.type = type;
+
+  ss = gfc_get_ss ();
+  ss->info = ss_info;
+  ss->next = gfc_ss_terminator;
+  ss->dimen = dimen;
+  for (i = 0; i < ss->dimen; i++)
+    ss->dim[i] = i;
+
+  return ss;
+}
+
+
+/* Creates and initializes a scalar type gfc_ss struct.  */
+
+gfc_ss *
+gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr)
+{
+  gfc_ss *ss;
+  gfc_ss_info *ss_info;
+
+  ss_info = gfc_get_ss_info ();
+  ss_info->refcount++;
+  ss_info->type = GFC_SS_SCALAR;
+  ss_info->expr = expr;
+
+  ss = gfc_get_ss ();
+  ss->info = ss_info;
+  ss->next = next;
+
+  return ss;
+}
+
+
+/* Free all the SS associated with a loop.  */
+
+void
+gfc_cleanup_loop (gfc_loopinfo * loop)
+{
+  gfc_loopinfo *loop_next, **ploop;
+  gfc_ss *ss;
+  gfc_ss *next;
+
+  ss = loop->ss;
+  while (ss != gfc_ss_terminator)
+    {
+      gcc_assert (ss != NULL);
+      next = ss->loop_chain;
+      gfc_free_ss (ss);
+      ss = next;
+    }
+
+  /* Remove reference to self in the parent loop.  */
+  if (loop->parent)
+    for (ploop = &loop->parent->nested; *ploop; ploop = &(*ploop)->next)
+      if (*ploop == loop)
+	{
+	  *ploop = loop->next;
+	  break;
+	}
+
+  /* Free non-freed nested loops.  */
+  for (loop = loop->nested; loop; loop = loop_next)
+    {
+      loop_next = loop->next;
+      gfc_cleanup_loop (loop);
+      free (loop);
+    }
+}
+
+
+static void
+set_ss_loop (gfc_ss *ss, gfc_loopinfo *loop)
+{
+  int n;
+
+  for (; ss != gfc_ss_terminator; ss = ss->next)
+    {
+      ss->loop = loop;
+
+      if (ss->info->type == GFC_SS_SCALAR
+	  || ss->info->type == GFC_SS_REFERENCE
+	  || ss->info->type == GFC_SS_TEMP)
+	continue;
+
+      for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
+	if (ss->info->data.array.subscript[n] != NULL)
+	  set_ss_loop (ss->info->data.array.subscript[n], loop);
+    }
+}
+
+
+/* Associate a SS chain with a loop.  */
+
+void
+gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
+{
+  gfc_ss *ss;
+  gfc_loopinfo *nested_loop;
+
+  if (head == gfc_ss_terminator)
+    return;
+
+  set_ss_loop (head, loop);
+
+  ss = head;
+  for (; ss && ss != gfc_ss_terminator; ss = ss->next)
+    {
+      if (ss->nested_ss)
+	{
+	  nested_loop = ss->nested_ss->loop;
+
+	  /* More than one ss can belong to the same loop.  Hence, we add the
+	     loop to the chain only if it is different from the previously
+	     added one, to avoid duplicate nested loops.  */
+	  if (nested_loop != loop->nested)
+	    {
+	      gcc_assert (nested_loop->parent == NULL);
+	      nested_loop->parent = loop;
+
+	      gcc_assert (nested_loop->next == NULL);
+	      nested_loop->next = loop->nested;
+	      loop->nested = nested_loop;
+	    }
+	  else
+	    gcc_assert (nested_loop->parent == loop);
+	}
+
+      if (ss->next == gfc_ss_terminator)
+	ss->loop_chain = loop->ss;
+      else
+	ss->loop_chain = ss->next;
+    }
+  gcc_assert (ss == gfc_ss_terminator);
+  loop->ss = head;
+}
+
+
+/* Generate an initializer for a static pointer or allocatable array.  */
+
+void
+gfc_trans_static_array_pointer (gfc_symbol * sym)
+{
+  tree type;
+
+  gcc_assert (TREE_STATIC (sym->backend_decl));
+  /* Just zero the data member.  */
+  type = TREE_TYPE (sym->backend_decl);
+  DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
+}
+
+
+/* If the bounds of SE's loop have not yet been set, see if they can be
+   determined from array spec AS, which is the array spec of a called
+   function.  MAPPING maps the callee's dummy arguments to the values
+   that the caller is passing.  Add any initialization and finalization
+   code to SE.  */
+
+void
+gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
+				     gfc_se * se, gfc_array_spec * as)
+{
+  int n, dim, total_dim;
+  gfc_se tmpse;
+  gfc_ss *ss;
+  tree lower;
+  tree upper;
+  tree tmp;
+
+  total_dim = 0;
+
+  if (!as || as->type != AS_EXPLICIT)
+    return;
+
+  for (ss = se->ss; ss; ss = ss->parent)
+    {
+      total_dim += ss->loop->dimen;
+      for (n = 0; n < ss->loop->dimen; n++)
+	{
+	  /* The bound is known, nothing to do.  */
+	  if (ss->loop->to[n] != NULL_TREE)
+	    continue;
+
+	  dim = ss->dim[n];
+	  gcc_assert (dim < as->rank);
+	  gcc_assert (ss->loop->dimen <= as->rank);
+
+	  /* Evaluate the lower bound.  */
+	  gfc_init_se (&tmpse, NULL);
+	  gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
+	  gfc_add_block_to_block (&se->pre, &tmpse.pre);
+	  gfc_add_block_to_block (&se->post, &tmpse.post);
+	  lower = fold_convert (gfc_array_index_type, tmpse.expr);
+
+	  /* ...and the upper bound.  */
+	  gfc_init_se (&tmpse, NULL);
+	  gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
+	  gfc_add_block_to_block (&se->pre, &tmpse.pre);
+	  gfc_add_block_to_block (&se->post, &tmpse.post);
+	  upper = fold_convert (gfc_array_index_type, tmpse.expr);
+
+	  /* Set the upper bound of the loop to UPPER - LOWER.  */
+	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				 gfc_array_index_type, upper, lower);
+	  tmp = gfc_evaluate_now (tmp, &se->pre);
+	  ss->loop->to[n] = tmp;
+	}
+    }
+
+  gcc_assert (total_dim == as->rank);
+}
+
+
+/* Generate code to allocate an array temporary, or create a variable to
+   hold the data.  If size is NULL, zero the descriptor so that the
+   callee will allocate the array.  If DEALLOC is true, also generate code to
+   free the array afterwards.
+
+   If INITIAL is not NULL, it is packed using internal_pack and the result used
+   as data instead of allocating a fresh, unitialized area of memory.
+
+   Initialization code is added to PRE and finalization code to POST.
+   DYNAMIC is true if the caller may want to extend the array later
+   using realloc.  This prevents us from putting the array on the stack.  */
+
+static void
+gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
+				  gfc_array_info * info, tree size, tree nelem,
+				  tree initial, bool dynamic, bool dealloc)
+{
+  tree tmp;
+  tree desc;
+  bool onstack;
+
+  desc = info->descriptor;
+  info->offset = gfc_index_zero_node;
+  if (size == NULL_TREE || integer_zerop (size))
+    {
+      /* A callee allocated array.  */
+      gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
+      onstack = FALSE;
+    }
+  else
+    {
+      /* Allocate the temporary.  */
+      onstack = !dynamic && initial == NULL_TREE
+			 && (gfc_option.flag_stack_arrays
+			     || gfc_can_put_var_on_stack (size));
+
+      if (onstack)
+	{
+	  /* Make a temporary variable to hold the data.  */
+	  tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem),
+				 nelem, gfc_index_one_node);
+	  tmp = gfc_evaluate_now (tmp, pre);
+	  tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
+				  tmp);
+	  tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
+				  tmp);
+	  tmp = gfc_create_var (tmp, "A");
+	  /* If we're here only because of -fstack-arrays we have to
+	     emit a DECL_EXPR to make the gimplifier emit alloca calls.  */
+	  if (!gfc_can_put_var_on_stack (size))
+	    gfc_add_expr_to_block (pre,
+				   fold_build1_loc (input_location,
+						    DECL_EXPR, TREE_TYPE (tmp),
+						    tmp));
+	  tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+	  gfc_conv_descriptor_data_set (pre, desc, tmp);
+	}
+      else
+	{
+	  /* Allocate memory to hold the data or call internal_pack.  */
+	  if (initial == NULL_TREE)
+	    {
+	      tmp = gfc_call_malloc (pre, NULL, size);
+	      tmp = gfc_evaluate_now (tmp, pre);
+	    }
+	  else
+	    {
+	      tree packed;
+	      tree source_data;
+	      tree was_packed;
+	      stmtblock_t do_copying;
+
+	      tmp = TREE_TYPE (initial); /* Pointer to descriptor.  */
+	      gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
+	      tmp = TREE_TYPE (tmp); /* The descriptor itself.  */
+	      tmp = gfc_get_element_type (tmp);
+	      gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
+	      packed = gfc_create_var (build_pointer_type (tmp), "data");
+
+	      tmp = build_call_expr_loc (input_location,
+				     gfor_fndecl_in_pack, 1, initial);
+	      tmp = fold_convert (TREE_TYPE (packed), tmp);
+	      gfc_add_modify (pre, packed, tmp);
+
+	      tmp = build_fold_indirect_ref_loc (input_location,
+					     initial);
+	      source_data = gfc_conv_descriptor_data_get (tmp);
+
+	      /* internal_pack may return source->data without any allocation
+		 or copying if it is already packed.  If that's the case, we
+		 need to allocate and copy manually.  */
+
+	      gfc_start_block (&do_copying);
+	      tmp = gfc_call_malloc (&do_copying, NULL, size);
+	      tmp = fold_convert (TREE_TYPE (packed), tmp);
+	      gfc_add_modify (&do_copying, packed, tmp);
+	      tmp = gfc_build_memcpy_call (packed, source_data, size);
+	      gfc_add_expr_to_block (&do_copying, tmp);
+
+	      was_packed = fold_build2_loc (input_location, EQ_EXPR,
+					    boolean_type_node, packed,
+					    source_data);
+	      tmp = gfc_finish_block (&do_copying);
+	      tmp = build3_v (COND_EXPR, was_packed, tmp,
+			      build_empty_stmt (input_location));
+	      gfc_add_expr_to_block (pre, tmp);
+
+	      tmp = fold_convert (pvoid_type_node, packed);
+	    }
+
+	  gfc_conv_descriptor_data_set (pre, desc, tmp);
+	}
+    }
+  info->data = gfc_conv_descriptor_data_get (desc);
+
+  /* The offset is zero because we create temporaries with a zero
+     lower bound.  */
+  gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
+
+  if (dealloc && !onstack)
+    {
+      /* Free the temporary.  */
+      tmp = gfc_conv_descriptor_data_get (desc);
+      tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
+      gfc_add_expr_to_block (post, tmp);
+    }
+}
+
+
+/* Get the scalarizer array dimension corresponding to actual array dimension
+   given by ARRAY_DIM.
+
+   For example, if SS represents the array ref a(1,:,:,1), it is a
+   bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
+   and 1 for ARRAY_DIM=2.
+   If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
+   scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
+   ARRAY_DIM=3.
+   If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
+   array.  If called on the inner ss, the result would be respectively 0,1,2 for
+   ARRAY_DIM=0,1,2.  If called on the outer ss, the result would be 0,1
+   for ARRAY_DIM=1,2.  */
+
+static int
+get_scalarizer_dim_for_array_dim (gfc_ss *ss, int array_dim)
+{
+  int array_ref_dim;
+  int n;
+
+  array_ref_dim = 0;
+
+  for (; ss; ss = ss->parent)
+    for (n = 0; n < ss->dimen; n++)
+      if (ss->dim[n] < array_dim)
+	array_ref_dim++;
+
+  return array_ref_dim;
+}
+
+
+static gfc_ss *
+innermost_ss (gfc_ss *ss)
+{
+  while (ss->nested_ss != NULL)
+    ss = ss->nested_ss;
+
+  return ss;
+}
+
+
+
+/* Get the array reference dimension corresponding to the given loop dimension.
+   It is different from the true array dimension given by the dim array in
+   the case of a partial array reference (i.e. a(:,:,1,:) for example)
+   It is different from the loop dimension in the case of a transposed array.
+   */
+
+static int
+get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
+{
+  return get_scalarizer_dim_for_array_dim (innermost_ss (ss),
+					   ss->dim[loop_dim]);
+}
+
+
+/* Generate code to create and initialize the descriptor for a temporary
+   array.  This is used for both temporaries needed by the scalarizer, and
+   functions returning arrays.  Adjusts the loop variables to be
+   zero-based, and calculates the loop bounds for callee allocated arrays.
+   Allocate the array unless it's callee allocated (we have a callee
+   allocated array if 'callee_alloc' is true, or if loop->to[n] is
+   NULL_TREE for any n).  Also fills in the descriptor, data and offset
+   fields of info if known.  Returns the size of the array, or NULL for a
+   callee allocated array.
+
+   'eltype' == NULL signals that the temporary should be a class object.
+   The 'initial' expression is used to obtain the size of the dynamic
+   type; otherwise the allocation and initialization proceeds as for any
+   other expression
+
+   PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
+   gfc_trans_allocate_array_storage.  */
+
+tree
+gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
+			     tree eltype, tree initial, bool dynamic,
+			     bool dealloc, bool callee_alloc, locus * where)
+{
+  gfc_loopinfo *loop;
+  gfc_ss *s;
+  gfc_array_info *info;
+  tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
+  tree type;
+  tree desc;
+  tree tmp;
+  tree size;
+  tree nelem;
+  tree cond;
+  tree or_expr;
+  tree class_expr = NULL_TREE;
+  int n, dim, tmp_dim;
+  int total_dim = 0;
+
+  /* This signals a class array for which we need the size of the
+     dynamic type.  Generate an eltype and then the class expression.  */
+  if (eltype == NULL_TREE && initial)
+    {
+      gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial)));
+      class_expr = build_fold_indirect_ref_loc (input_location, initial);
+      eltype = TREE_TYPE (class_expr);
+      eltype = gfc_get_element_type (eltype);
+      /* Obtain the structure (class) expression.  */
+      class_expr = TREE_OPERAND (class_expr, 0);
+      gcc_assert (class_expr);
+    }
+
+  memset (from, 0, sizeof (from));
+  memset (to, 0, sizeof (to));
+
+  info = &ss->info->data.array;
+
+  gcc_assert (ss->dimen > 0);
+  gcc_assert (ss->loop->dimen == ss->dimen);
+
+  if (gfc_option.warn_array_temp && where)
+    gfc_warning ("Creating array temporary at %L", where);
+
+  /* Set the lower bound to zero.  */
+  for (s = ss; s; s = s->parent)
+    {
+      loop = s->loop;
+
+      total_dim += loop->dimen;
+      for (n = 0; n < loop->dimen; n++)
+	{
+	  dim = s->dim[n];
+
+	  /* Callee allocated arrays may not have a known bound yet.  */
+	  if (loop->to[n])
+	    loop->to[n] = gfc_evaluate_now (
+			fold_build2_loc (input_location, MINUS_EXPR,
+					 gfc_array_index_type,
+					 loop->to[n], loop->from[n]),
+			pre);
+	  loop->from[n] = gfc_index_zero_node;
+
+	  /* We have just changed the loop bounds, we must clear the
+	     corresponding specloop, so that delta calculation is not skipped
+	     later in gfc_set_delta.  */
+	  loop->specloop[n] = NULL;
+
+	  /* We are constructing the temporary's descriptor based on the loop
+	     dimensions.  As the dimensions may be accessed in arbitrary order
+	     (think of transpose) the size taken from the n'th loop may not map
+	     to the n'th dimension of the array.  We need to reconstruct loop
+	     infos in the right order before using it to set the descriptor
+	     bounds.  */
+	  tmp_dim = get_scalarizer_dim_for_array_dim (ss, dim);
+	  from[tmp_dim] = loop->from[n];
+	  to[tmp_dim] = loop->to[n];
+
+	  info->delta[dim] = gfc_index_zero_node;
+	  info->start[dim] = gfc_index_zero_node;
+	  info->end[dim] = gfc_index_zero_node;
+	  info->stride[dim] = gfc_index_one_node;
+	}
+    }
+
+  /* Initialize the descriptor.  */
+  type =
+    gfc_get_array_type_bounds (eltype, total_dim, 0, from, to, 1,
+			       GFC_ARRAY_UNKNOWN, true);
+  desc = gfc_create_var (type, "atmp");
+  GFC_DECL_PACKED_ARRAY (desc) = 1;
+
+  info->descriptor = desc;
+  size = gfc_index_one_node;
+
+  /* Fill in the array dtype.  */
+  tmp = gfc_conv_descriptor_dtype (desc);
+  gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+
+  /*
+     Fill in the bounds and stride.  This is a packed array, so:
+
+     size = 1;
+     for (n = 0; n < rank; n++)
+       {
+	 stride[n] = size
+	 delta = ubound[n] + 1 - lbound[n];
+	 size = size * delta;
+       }
+     size = size * sizeof(element);
+  */
+
+  or_expr = NULL_TREE;
+
+  /* If there is at least one null loop->to[n], it is a callee allocated
+     array.  */
+  for (n = 0; n < total_dim; n++)
+    if (to[n] == NULL_TREE)
+      {
+	size = NULL_TREE;
+	break;
+      }
+
+  if (size == NULL_TREE)
+    for (s = ss; s; s = s->parent)
+      for (n = 0; n < s->loop->dimen; n++)
+	{
+	  dim = get_scalarizer_dim_for_array_dim (ss, s->dim[n]);
+
+	  /* For a callee allocated array express the loop bounds in terms
+	     of the descriptor fields.  */
+	  tmp = fold_build2_loc (input_location,
+		MINUS_EXPR, gfc_array_index_type,
+		gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]),
+		gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]));
+	  s->loop->to[n] = tmp;
+	}
+  else
+    {
+      for (n = 0; n < total_dim; n++)
+	{
+	  /* Store the stride and bound components in the descriptor.  */
+	  gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
+
+	  gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
+					  gfc_index_zero_node);
+
+	  gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]);
+
+	  tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type,
+				 to[n], gfc_index_one_node);
+
+	  /* Check whether the size for this dimension is negative.  */
+	  cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
+				  tmp, gfc_index_zero_node);
+	  cond = gfc_evaluate_now (cond, pre);
+
+	  if (n == 0)
+	    or_expr = cond;
+	  else
+	    or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+				       boolean_type_node, or_expr, cond);
+
+	  size = fold_build2_loc (input_location, MULT_EXPR,
+				  gfc_array_index_type, size, tmp);
+	  size = gfc_evaluate_now (size, pre);
+	}
+    }
+
+  /* Get the size of the array.  */
+  if (size && !callee_alloc)
+    {
+      tree elemsize;
+      /* If or_expr is true, then the extent in at least one
+	 dimension is zero and the size is set to zero.  */
+      size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
+			      or_expr, gfc_index_zero_node, size);
+
+      nelem = size;
+      if (class_expr == NULL_TREE)
+	elemsize = fold_convert (gfc_array_index_type,
+			TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+      else
+	elemsize = gfc_vtable_size_get (class_expr);
+
+      size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			      size, elemsize);
+    }
+  else
+    {
+      nelem = size;
+      size = NULL_TREE;
+    }
+
+  gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
+				    dynamic, dealloc);
+
+  while (ss->parent)
+    ss = ss->parent;
+
+  if (ss->dimen > ss->loop->temp_dim)
+    ss->loop->temp_dim = ss->dimen;
+
+  return size;
+}
+
+
+/* Return the number of iterations in a loop that starts at START,
+   ends at END, and has step STEP.  */
+
+static tree
+gfc_get_iteration_count (tree start, tree end, tree step)
+{
+  tree tmp;
+  tree type;
+
+  type = TREE_TYPE (step);
+  tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start);
+  tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step);
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp,
+			 build_int_cst (type, 1));
+  tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp,
+			 build_int_cst (type, 0));
+  return fold_convert (gfc_array_index_type, tmp);
+}
+
+
+/* Extend the data in array DESC by EXTRA elements.  */
+
+static void
+gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
+{
+  tree arg0, arg1;
+  tree tmp;
+  tree size;
+  tree ubound;
+
+  if (integer_zerop (extra))
+    return;
+
+  ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
+
+  /* Add EXTRA to the upper bound.  */
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			 ubound, extra);
+  gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
+
+  /* Get the value of the current data pointer.  */
+  arg0 = gfc_conv_descriptor_data_get (desc);
+
+  /* Calculate the new array size.  */
+  size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			 ubound, gfc_index_one_node);
+  arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
+			  fold_convert (size_type_node, tmp),
+			  fold_convert (size_type_node, size));
+
+  /* Call the realloc() function.  */
+  tmp = gfc_call_realloc (pblock, arg0, arg1);
+  gfc_conv_descriptor_data_set (pblock, desc, tmp);
+}
+
+
+/* Return true if the bounds of iterator I can only be determined
+   at run time.  */
+
+static inline bool
+gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
+{
+  return (i->start->expr_type != EXPR_CONSTANT
+	  || i->end->expr_type != EXPR_CONSTANT
+	  || i->step->expr_type != EXPR_CONSTANT);
+}
+
+
+/* Split the size of constructor element EXPR into the sum of two terms,
+   one of which can be determined at compile time and one of which must
+   be calculated at run time.  Set *SIZE to the former and return true
+   if the latter might be nonzero.  */
+
+static bool
+gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
+{
+  if (expr->expr_type == EXPR_ARRAY)
+    return gfc_get_array_constructor_size (size, expr->value.constructor);
+  else if (expr->rank > 0)
+    {
+      /* Calculate everything at run time.  */
+      mpz_set_ui (*size, 0);
+      return true;
+    }
+  else
+    {
+      /* A single element.  */
+      mpz_set_ui (*size, 1);
+      return false;
+    }
+}
+
+
+/* Like gfc_get_array_constructor_element_size, but applied to the whole
+   of array constructor C.  */
+
+static bool
+gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
+{
+  gfc_constructor *c;
+  gfc_iterator *i;
+  mpz_t val;
+  mpz_t len;
+  bool dynamic;
+
+  mpz_set_ui (*size, 0);
+  mpz_init (len);
+  mpz_init (val);
+
+  dynamic = false;
+  for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
+    {
+      i = c->iterator;
+      if (i && gfc_iterator_has_dynamic_bounds (i))
+	dynamic = true;
+      else
+	{
+	  dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
+	  if (i)
+	    {
+	      /* Multiply the static part of the element size by the
+		 number of iterations.  */
+	      mpz_sub (val, i->end->value.integer, i->start->value.integer);
+	      mpz_fdiv_q (val, val, i->step->value.integer);
+	      mpz_add_ui (val, val, 1);
+	      if (mpz_sgn (val) > 0)
+		mpz_mul (len, len, val);
+	      else
+		mpz_set_ui (len, 0);
+	    }
+	  mpz_add (*size, *size, len);
+	}
+    }
+  mpz_clear (len);
+  mpz_clear (val);
+  return dynamic;
+}
+
+
+/* Make sure offset is a variable.  */
+
+static void
+gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
+			 tree * offsetvar)
+{
+  /* We should have already created the offset variable.  We cannot
+     create it here because we may be in an inner scope.  */
+  gcc_assert (*offsetvar != NULL_TREE);
+  gfc_add_modify (pblock, *offsetvar, *poffset);
+  *poffset = *offsetvar;
+  TREE_USED (*offsetvar) = 1;
+}
+
+
+/* Variables needed for bounds-checking.  */
+static bool first_len;
+static tree first_len_val;
+static bool typespec_chararray_ctor;
+
+static void
+gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
+			      tree offset, gfc_se * se, gfc_expr * expr)
+{
+  tree tmp;
+
+  gfc_conv_expr (se, expr);
+
+  /* Store the value.  */
+  tmp = build_fold_indirect_ref_loc (input_location,
+				 gfc_conv_descriptor_data_get (desc));
+  tmp = gfc_build_array_ref (tmp, offset, NULL);
+
+  if (expr->ts.type == BT_CHARACTER)
+    {
+      int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
+      tree esize;
+
+      esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
+      esize = fold_convert (gfc_charlen_type_node, esize);
+      esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+			   gfc_charlen_type_node, esize,
+			   build_int_cst (gfc_charlen_type_node,
+					  gfc_character_kinds[i].bit_size / 8));
+
+      gfc_conv_string_parameter (se);
+      if (POINTER_TYPE_P (TREE_TYPE (tmp)))
+	{
+	  /* The temporary is an array of pointers.  */
+	  se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
+	  gfc_add_modify (&se->pre, tmp, se->expr);
+	}
+      else
+	{
+	  /* The temporary is an array of string values.  */
+	  tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
+	  /* We know the temporary and the value will be the same length,
+	     so can use memcpy.  */
+	  gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
+				 se->string_length, se->expr, expr->ts.kind);
+	}
+      if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
+	{
+	  if (first_len)
+	    {
+	      gfc_add_modify (&se->pre, first_len_val,
+				   se->string_length);
+	      first_len = false;
+	    }
+	  else
+	    {
+	      /* Verify that all constructor elements are of the same
+		 length.  */
+	      tree cond = fold_build2_loc (input_location, NE_EXPR,
+					   boolean_type_node, first_len_val,
+					   se->string_length);
+	      gfc_trans_runtime_check
+		(true, false, cond, &se->pre, &expr->where,
+		 "Different CHARACTER lengths (%ld/%ld) in array constructor",
+		 fold_convert (long_integer_type_node, first_len_val),
+		 fold_convert (long_integer_type_node, se->string_length));
+	    }
+	}
+    }
+  else
+    {
+      /* TODO: Should the frontend already have done this conversion?  */
+      se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
+      gfc_add_modify (&se->pre, tmp, se->expr);
+    }
+
+  gfc_add_block_to_block (pblock, &se->pre);
+  gfc_add_block_to_block (pblock, &se->post);
+}
+
+
+/* Add the contents of an array to the constructor.  DYNAMIC is as for
+   gfc_trans_array_constructor_value.  */
+
+static void
+gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
+				      tree type ATTRIBUTE_UNUSED,
+				      tree desc, gfc_expr * expr,
+				      tree * poffset, tree * offsetvar,
+				      bool dynamic)
+{
+  gfc_se se;
+  gfc_ss *ss;
+  gfc_loopinfo loop;
+  stmtblock_t body;
+  tree tmp;
+  tree size;
+  int n;
+
+  /* We need this to be a variable so we can increment it.  */
+  gfc_put_offset_into_var (pblock, poffset, offsetvar);
+
+  gfc_init_se (&se, NULL);
+
+  /* Walk the array expression.  */
+  ss = gfc_walk_expr (expr);
+  gcc_assert (ss != gfc_ss_terminator);
+
+  /* Initialize the scalarizer.  */
+  gfc_init_loopinfo (&loop);
+  gfc_add_ss_to_loop (&loop, ss);
+
+  /* Initialize the loop.  */
+  gfc_conv_ss_startstride (&loop);
+  gfc_conv_loop_setup (&loop, &expr->where);
+
+  /* Make sure the constructed array has room for the new data.  */
+  if (dynamic)
+    {
+      /* Set SIZE to the total number of elements in the subarray.  */
+      size = gfc_index_one_node;
+      for (n = 0; n < loop.dimen; n++)
+	{
+	  tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
+					 gfc_index_one_node);
+	  size = fold_build2_loc (input_location, MULT_EXPR,
+				  gfc_array_index_type, size, tmp);
+	}
+
+      /* Grow the constructed array by SIZE elements.  */
+      gfc_grow_array (&loop.pre, desc, size);
+    }
+
+  /* Make the loop body.  */
+  gfc_mark_ss_chain_used (ss, 1);
+  gfc_start_scalarized_body (&loop, &body);
+  gfc_copy_loopinfo_to_se (&se, &loop);
+  se.ss = ss;
+
+  gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
+  gcc_assert (se.ss == gfc_ss_terminator);
+
+  /* Increment the offset.  */
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			 *poffset, gfc_index_one_node);
+  gfc_add_modify (&body, *poffset, tmp);
+
+  /* Finish the loop.  */
+  gfc_trans_scalarizing_loops (&loop, &body);
+  gfc_add_block_to_block (&loop.pre, &loop.post);
+  tmp = gfc_finish_block (&loop.pre);
+  gfc_add_expr_to_block (pblock, tmp);
+
+  gfc_cleanup_loop (&loop);
+}
+
+
+/* Assign the values to the elements of an array constructor.  DYNAMIC
+   is true if descriptor DESC only contains enough data for the static
+   size calculated by gfc_get_array_constructor_size.  When true, memory
+   for the dynamic parts must be allocated using realloc.  */
+
+static void
+gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
+				   tree desc, gfc_constructor_base base,
+				   tree * poffset, tree * offsetvar,
+				   bool dynamic)
+{
+  tree tmp;
+  tree start = NULL_TREE;
+  tree end = NULL_TREE;
+  tree step = NULL_TREE;
+  stmtblock_t body;
+  gfc_se se;
+  mpz_t size;
+  gfc_constructor *c;
+
+  tree shadow_loopvar = NULL_TREE;
+  gfc_saved_var saved_loopvar;
+
+  mpz_init (size);
+  for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
+    {
+      /* If this is an iterator or an array, the offset must be a variable.  */
+      if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
+	gfc_put_offset_into_var (pblock, poffset, offsetvar);
+
+      /* Shadowing the iterator avoids changing its value and saves us from
+	 keeping track of it. Further, it makes sure that there's always a
+	 backend-decl for the symbol, even if there wasn't one before,
+	 e.g. in the case of an iterator that appears in a specification
+	 expression in an interface mapping.  */
+      if (c->iterator)
+	{
+	  gfc_symbol *sym;
+	  tree type;
+
+	  /* Evaluate loop bounds before substituting the loop variable
+	     in case they depend on it.  Such a case is invalid, but it is
+	     not more expensive to do the right thing here.
+	     See PR 44354.  */
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_expr_val (&se, c->iterator->start);
+	  gfc_add_block_to_block (pblock, &se.pre);
+	  start = gfc_evaluate_now (se.expr, pblock);
+
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_expr_val (&se, c->iterator->end);
+	  gfc_add_block_to_block (pblock, &se.pre);
+	  end = gfc_evaluate_now (se.expr, pblock);
+
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_expr_val (&se, c->iterator->step);
+	  gfc_add_block_to_block (pblock, &se.pre);
+	  step = gfc_evaluate_now (se.expr, pblock);
+
+	  sym = c->iterator->var->symtree->n.sym;
+	  type = gfc_typenode_for_spec (&sym->ts);
+
+	  shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
+	  gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
+	}
+
+      gfc_start_block (&body);
+
+      if (c->expr->expr_type == EXPR_ARRAY)
+	{
+	  /* Array constructors can be nested.  */
+	  gfc_trans_array_constructor_value (&body, type, desc,
+					     c->expr->value.constructor,
+					     poffset, offsetvar, dynamic);
+	}
+      else if (c->expr->rank > 0)
+	{
+	  gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
+						poffset, offsetvar, dynamic);
+	}
+      else
+	{
+	  /* This code really upsets the gimplifier so don't bother for now.  */
+	  gfc_constructor *p;
+	  HOST_WIDE_INT n;
+	  HOST_WIDE_INT size;
+
+	  p = c;
+	  n = 0;
+	  while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
+	    {
+	      p = gfc_constructor_next (p);
+	      n++;
+	    }
+	  if (n < 4)
+	    {
+	      /* Scalar values.  */
+	      gfc_init_se (&se, NULL);
+	      gfc_trans_array_ctor_element (&body, desc, *poffset,
+					    &se, c->expr);
+
+	      *poffset = fold_build2_loc (input_location, PLUS_EXPR,
+					  gfc_array_index_type,
+					  *poffset, gfc_index_one_node);
+	    }
+	  else
+	    {
+	      /* Collect multiple scalar constants into a constructor.  */
+	      vec<constructor_elt, va_gc> *v = NULL;
+	      tree init;
+	      tree bound;
+	      tree tmptype;
+	      HOST_WIDE_INT idx = 0;
+
+	      p = c;
+              /* Count the number of consecutive scalar constants.  */
+	      while (p && !(p->iterator
+			    || p->expr->expr_type != EXPR_CONSTANT))
+		{
+		  gfc_init_se (&se, NULL);
+		  gfc_conv_constant (&se, p->expr);
+
+		  if (c->expr->ts.type != BT_CHARACTER)
+		    se.expr = fold_convert (type, se.expr);
+		  /* For constant character array constructors we build
+		     an array of pointers.  */
+		  else if (POINTER_TYPE_P (type))
+		    se.expr = gfc_build_addr_expr
+				(gfc_get_pchar_type (p->expr->ts.kind),
+				 se.expr);
+
+                  CONSTRUCTOR_APPEND_ELT (v,
+                                          build_int_cst (gfc_array_index_type,
+                                                         idx++),
+                                          se.expr);
+		  c = p;
+		  p = gfc_constructor_next (p);
+		}
+
+	      bound = size_int (n - 1);
+              /* Create an array type to hold them.  */
+	      tmptype = build_range_type (gfc_array_index_type,
+					  gfc_index_zero_node, bound);
+	      tmptype = build_array_type (type, tmptype);
+
+	      init = build_constructor (tmptype, v);
+	      TREE_CONSTANT (init) = 1;
+	      TREE_STATIC (init) = 1;
+	      /* Create a static variable to hold the data.  */
+	      tmp = gfc_create_var (tmptype, "data");
+	      TREE_STATIC (tmp) = 1;
+	      TREE_CONSTANT (tmp) = 1;
+	      TREE_READONLY (tmp) = 1;
+	      DECL_INITIAL (tmp) = init;
+	      init = tmp;
+
+	      /* Use BUILTIN_MEMCPY to assign the values.  */
+	      tmp = gfc_conv_descriptor_data_get (desc);
+	      tmp = build_fold_indirect_ref_loc (input_location,
+					     tmp);
+	      tmp = gfc_build_array_ref (tmp, *poffset, NULL);
+	      tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+	      init = gfc_build_addr_expr (NULL_TREE, init);
+
+	      size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
+	      bound = build_int_cst (size_type_node, n * size);
+	      tmp = build_call_expr_loc (input_location,
+					 builtin_decl_explicit (BUILT_IN_MEMCPY),
+					 3, tmp, init, bound);
+	      gfc_add_expr_to_block (&body, tmp);
+
+	      *poffset = fold_build2_loc (input_location, PLUS_EXPR,
+				      gfc_array_index_type, *poffset,
+				      build_int_cst (gfc_array_index_type, n));
+	    }
+	  if (!INTEGER_CST_P (*poffset))
+            {
+              gfc_add_modify (&body, *offsetvar, *poffset);
+              *poffset = *offsetvar;
+            }
+	}
+
+      /* The frontend should already have done any expansions
+	 at compile-time.  */
+      if (!c->iterator)
+	{
+	  /* Pass the code as is.  */
+	  tmp = gfc_finish_block (&body);
+	  gfc_add_expr_to_block (pblock, tmp);
+	}
+      else
+	{
+	  /* Build the implied do-loop.  */
+	  stmtblock_t implied_do_block;
+	  tree cond;
+	  tree exit_label;
+	  tree loopbody;
+	  tree tmp2;
+
+	  loopbody = gfc_finish_block (&body);
+
+	  /* Create a new block that holds the implied-do loop. A temporary
+	     loop-variable is used.  */
+	  gfc_start_block(&implied_do_block);
+
+	  /* Initialize the loop.  */
+	  gfc_add_modify (&implied_do_block, shadow_loopvar, start);
+
+	  /* If this array expands dynamically, and the number of iterations
+	     is not constant, we won't have allocated space for the static
+	     part of C->EXPR's size.  Do that now.  */
+	  if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
+	    {
+	      /* Get the number of iterations.  */
+	      tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
+
+	      /* Get the static part of C->EXPR's size.  */
+	      gfc_get_array_constructor_element_size (&size, c->expr);
+	      tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
+
+	      /* Grow the array by TMP * TMP2 elements.  */
+	      tmp = fold_build2_loc (input_location, MULT_EXPR,
+				     gfc_array_index_type, tmp, tmp2);
+	      gfc_grow_array (&implied_do_block, desc, tmp);
+	    }
+
+	  /* Generate the loop body.  */
+	  exit_label = gfc_build_label_decl (NULL_TREE);
+	  gfc_start_block (&body);
+
+	  /* Generate the exit condition.  Depending on the sign of
+	     the step variable we have to generate the correct
+	     comparison.  */
+	  tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+				 step, build_int_cst (TREE_TYPE (step), 0));
+	  cond = fold_build3_loc (input_location, COND_EXPR,
+		      boolean_type_node, tmp,
+		      fold_build2_loc (input_location, GT_EXPR,
+				       boolean_type_node, shadow_loopvar, end),
+		      fold_build2_loc (input_location, LT_EXPR,
+				       boolean_type_node, shadow_loopvar, end));
+	  tmp = build1_v (GOTO_EXPR, exit_label);
+	  TREE_USED (exit_label) = 1;
+	  tmp = build3_v (COND_EXPR, cond, tmp,
+			  build_empty_stmt (input_location));
+	  gfc_add_expr_to_block (&body, tmp);
+
+	  /* The main loop body.  */
+	  gfc_add_expr_to_block (&body, loopbody);
+
+	  /* Increase loop variable by step.  */
+	  tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				 TREE_TYPE (shadow_loopvar), shadow_loopvar,
+				 step);
+	  gfc_add_modify (&body, shadow_loopvar, tmp);
+
+	  /* Finish the loop.  */
+	  tmp = gfc_finish_block (&body);
+	  tmp = build1_v (LOOP_EXPR, tmp);
+	  gfc_add_expr_to_block (&implied_do_block, tmp);
+
+	  /* Add the exit label.  */
+	  tmp = build1_v (LABEL_EXPR, exit_label);
+	  gfc_add_expr_to_block (&implied_do_block, tmp);
+
+	  /* Finish the implied-do loop.  */
+	  tmp = gfc_finish_block(&implied_do_block);
+	  gfc_add_expr_to_block(pblock, tmp);
+
+	  gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
+	}
+    }
+  mpz_clear (size);
+}
+
+
+/* A catch-all to obtain the string length for anything that is not
+   a substring of non-constant length, a constant, array or variable.  */
+
+static void
+get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
+{
+  gfc_se se;
+
+  /* Don't bother if we already know the length is a constant.  */
+  if (*len && INTEGER_CST_P (*len))
+    return;
+
+  if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
+	&& e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+    {
+      /* This is easy.  */
+      gfc_conv_const_charlen (e->ts.u.cl);
+      *len = e->ts.u.cl->backend_decl;
+    }
+  else
+    {
+      /* Otherwise, be brutal even if inefficient.  */
+      gfc_init_se (&se, NULL);
+
+      /* No function call, in case of side effects.  */
+      se.no_function_call = 1;
+      if (e->rank == 0)
+	gfc_conv_expr (&se, e);
+      else
+	gfc_conv_expr_descriptor (&se, e);
+
+      /* Fix the value.  */
+      *len = gfc_evaluate_now (se.string_length, &se.pre);
+
+      gfc_add_block_to_block (block, &se.pre);
+      gfc_add_block_to_block (block, &se.post);
+
+      e->ts.u.cl->backend_decl = *len;
+    }
+}
+
+
+/* Figure out the string length of a variable reference expression.
+   Used by get_array_ctor_strlen.  */
+
+static void
+get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
+{
+  gfc_ref *ref;
+  gfc_typespec *ts;
+  mpz_t char_len;
+
+  /* Don't bother if we already know the length is a constant.  */
+  if (*len && INTEGER_CST_P (*len))
+    return;
+
+  ts = &expr->symtree->n.sym->ts;
+  for (ref = expr->ref; ref; ref = ref->next)
+    {
+      switch (ref->type)
+	{
+	case REF_ARRAY:
+	  /* Array references don't change the string length.  */
+	  break;
+
+	case REF_COMPONENT:
+	  /* Use the length of the component.  */
+	  ts = &ref->u.c.component->ts;
+	  break;
+
+	case REF_SUBSTRING:
+	  if (ref->u.ss.start->expr_type != EXPR_CONSTANT
+	      || ref->u.ss.end->expr_type != EXPR_CONSTANT)
+	    {
+	      /* Note that this might evaluate expr.  */
+	      get_array_ctor_all_strlen (block, expr, len);
+	      return;
+	    }
+	  mpz_init_set_ui (char_len, 1);
+	  mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
+	  mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
+	  *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
+	  *len = convert (gfc_charlen_type_node, *len);
+	  mpz_clear (char_len);
+	  return;
+
+	default:
+	 gcc_unreachable ();
+	}
+    }
+
+  *len = ts->u.cl->backend_decl;
+}
+
+
+/* Figure out the string length of a character array constructor.
+   If len is NULL, don't calculate the length; this happens for recursive calls
+   when a sub-array-constructor is an element but not at the first position,
+   so when we're not interested in the length.
+   Returns TRUE if all elements are character constants.  */
+
+bool
+get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
+{
+  gfc_constructor *c;
+  bool is_const;
+
+  is_const = TRUE;
+
+  if (gfc_constructor_first (base) == NULL)
+    {
+      if (len)
+	*len = build_int_cstu (gfc_charlen_type_node, 0);
+      return is_const;
+    }
+
+  /* Loop over all constructor elements to find out is_const, but in len we
+     want to store the length of the first, not the last, element.  We can
+     of course exit the loop as soon as is_const is found to be false.  */
+  for (c = gfc_constructor_first (base);
+       c && is_const; c = gfc_constructor_next (c))
+    {
+      switch (c->expr->expr_type)
+	{
+	case EXPR_CONSTANT:
+	  if (len && !(*len && INTEGER_CST_P (*len)))
+	    *len = build_int_cstu (gfc_charlen_type_node,
+				   c->expr->value.character.length);
+	  break;
+
+	case EXPR_ARRAY:
+	  if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
+	    is_const = false;
+	  break;
+
+	case EXPR_VARIABLE:
+	  is_const = false;
+	  if (len)
+	    get_array_ctor_var_strlen (block, c->expr, len);
+	  break;
+
+	default:
+	  is_const = false;
+	  if (len)
+	    get_array_ctor_all_strlen (block, c->expr, len);
+	  break;
+	}
+
+      /* After the first iteration, we don't want the length modified.  */
+      len = NULL;
+    }
+
+  return is_const;
+}
+
+/* Check whether the array constructor C consists entirely of constant
+   elements, and if so returns the number of those elements, otherwise
+   return zero.  Note, an empty or NULL array constructor returns zero.  */
+
+unsigned HOST_WIDE_INT
+gfc_constant_array_constructor_p (gfc_constructor_base base)
+{
+  unsigned HOST_WIDE_INT nelem = 0;
+
+  gfc_constructor *c = gfc_constructor_first (base);
+  while (c)
+    {
+      if (c->iterator
+	  || c->expr->rank > 0
+	  || c->expr->expr_type != EXPR_CONSTANT)
+	return 0;
+      c = gfc_constructor_next (c);
+      nelem++;
+    }
+  return nelem;
+}
+
+
+/* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
+   and the tree type of it's elements, TYPE, return a static constant
+   variable that is compile-time initialized.  */
+
+tree
+gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
+{
+  tree tmptype, init, tmp;
+  HOST_WIDE_INT nelem;
+  gfc_constructor *c;
+  gfc_array_spec as;
+  gfc_se se;
+  int i;
+  vec<constructor_elt, va_gc> *v = NULL;
+
+  /* First traverse the constructor list, converting the constants
+     to tree to build an initializer.  */
+  nelem = 0;
+  c = gfc_constructor_first (expr->value.constructor);
+  while (c)
+    {
+      gfc_init_se (&se, NULL);
+      gfc_conv_constant (&se, c->expr);
+      if (c->expr->ts.type != BT_CHARACTER)
+	se.expr = fold_convert (type, se.expr);
+      else if (POINTER_TYPE_P (type))
+	se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
+				       se.expr);
+      CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
+                              se.expr);
+      c = gfc_constructor_next (c);
+      nelem++;
+    }
+
+  /* Next determine the tree type for the array.  We use the gfortran
+     front-end's gfc_get_nodesc_array_type in order to create a suitable
+     GFC_ARRAY_TYPE_P that may be used by the scalarizer.  */
+
+  memset (&as, 0, sizeof (gfc_array_spec));
+
+  as.rank = expr->rank;
+  as.type = AS_EXPLICIT;
+  if (!expr->shape)
+    {
+      as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
+      as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
+				      NULL, nelem - 1);
+    }
+  else
+    for (i = 0; i < expr->rank; i++)
+      {
+	int tmp = (int) mpz_get_si (expr->shape[i]);
+        as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
+        as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
+					NULL, tmp - 1);
+      }
+
+  tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
+
+  /* as is not needed anymore.  */
+  for (i = 0; i < as.rank + as.corank; i++)
+    {
+      gfc_free_expr (as.lower[i]);
+      gfc_free_expr (as.upper[i]);
+    }
+
+  init = build_constructor (tmptype, v);
+
+  TREE_CONSTANT (init) = 1;
+  TREE_STATIC (init) = 1;
+
+  tmp = gfc_create_var (tmptype, "A");
+  TREE_STATIC (tmp) = 1;
+  TREE_CONSTANT (tmp) = 1;
+  TREE_READONLY (tmp) = 1;
+  DECL_INITIAL (tmp) = init;
+
+  return tmp;
+}
+
+
+/* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
+   This mostly initializes the scalarizer state info structure with the
+   appropriate values to directly use the array created by the function
+   gfc_build_constant_array_constructor.  */
+
+static void
+trans_constant_array_constructor (gfc_ss * ss, tree type)
+{
+  gfc_array_info *info;
+  tree tmp;
+  int i;
+
+  tmp = gfc_build_constant_array_constructor (ss->info->expr, type);
+
+  info = &ss->info->data.array;
+
+  info->descriptor = tmp;
+  info->data = gfc_build_addr_expr (NULL_TREE, tmp);
+  info->offset = gfc_index_zero_node;
+
+  for (i = 0; i < ss->dimen; i++)
+    {
+      info->delta[i] = gfc_index_zero_node;
+      info->start[i] = gfc_index_zero_node;
+      info->end[i] = gfc_index_zero_node;
+      info->stride[i] = gfc_index_one_node;
+    }
+}
+
+
+static int
+get_rank (gfc_loopinfo *loop)
+{
+  int rank;
+
+  rank = 0;
+  for (; loop; loop = loop->parent)
+    rank += loop->dimen;
+
+  return rank;
+}
+
+
+/* Helper routine of gfc_trans_array_constructor to determine if the
+   bounds of the loop specified by LOOP are constant and simple enough
+   to use with trans_constant_array_constructor.  Returns the
+   iteration count of the loop if suitable, and NULL_TREE otherwise.  */
+
+static tree
+constant_array_constructor_loop_size (gfc_loopinfo * l)
+{
+  gfc_loopinfo *loop;
+  tree size = gfc_index_one_node;
+  tree tmp;
+  int i, total_dim;
+
+  total_dim = get_rank (l);
+
+  for (loop = l; loop; loop = loop->parent)
+    {
+      for (i = 0; i < loop->dimen; i++)
+	{
+	  /* If the bounds aren't constant, return NULL_TREE.  */
+	  if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
+	    return NULL_TREE;
+	  if (!integer_zerop (loop->from[i]))
+	    {
+	      /* Only allow nonzero "from" in one-dimensional arrays.  */
+	      if (total_dim != 1)
+		return NULL_TREE;
+	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				     gfc_array_index_type,
+				     loop->to[i], loop->from[i]);
+	    }
+	  else
+	    tmp = loop->to[i];
+	  tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type, tmp, gfc_index_one_node);
+	  size = fold_build2_loc (input_location, MULT_EXPR,
+				  gfc_array_index_type, size, tmp);
+	}
+    }
+
+  return size;
+}
+
+
+static tree *
+get_loop_upper_bound_for_array (gfc_ss *array, int array_dim)
+{
+  gfc_ss *ss;
+  int n;
+
+  gcc_assert (array->nested_ss == NULL);
+
+  for (ss = array; ss; ss = ss->parent)
+    for (n = 0; n < ss->loop->dimen; n++)
+      if (array_dim == get_array_ref_dim_for_loop_dim (ss, n))
+	return &(ss->loop->to[n]);
+
+  gcc_unreachable ();
+}
+
+
+static gfc_loopinfo *
+outermost_loop (gfc_loopinfo * loop)
+{
+  while (loop->parent != NULL)
+    loop = loop->parent;
+
+  return loop;
+}
+
+
+/* Array constructors are handled by constructing a temporary, then using that
+   within the scalarization loop.  This is not optimal, but seems by far the
+   simplest method.  */
+
+static void
+trans_array_constructor (gfc_ss * ss, locus * where)
+{
+  gfc_constructor_base c;
+  tree offset;
+  tree offsetvar;
+  tree desc;
+  tree type;
+  tree tmp;
+  tree *loop_ubound0;
+  bool dynamic;
+  bool old_first_len, old_typespec_chararray_ctor;
+  tree old_first_len_val;
+  gfc_loopinfo *loop, *outer_loop;
+  gfc_ss_info *ss_info;
+  gfc_expr *expr;
+  gfc_ss *s;
+
+  /* Save the old values for nested checking.  */
+  old_first_len = first_len;
+  old_first_len_val = first_len_val;
+  old_typespec_chararray_ctor = typespec_chararray_ctor;
+
+  loop = ss->loop;
+  outer_loop = outermost_loop (loop);
+  ss_info = ss->info;
+  expr = ss_info->expr;
+
+  /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
+     typespec was given for the array constructor.  */
+  typespec_chararray_ctor = (expr->ts.u.cl
+			     && expr->ts.u.cl->length_from_typespec);
+
+  if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+      && expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
+    {
+      first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
+      first_len = true;
+    }
+
+  gcc_assert (ss->dimen == ss->loop->dimen);
+
+  c = expr->value.constructor;
+  if (expr->ts.type == BT_CHARACTER)
+    {
+      bool const_string;
+
+      /* get_array_ctor_strlen walks the elements of the constructor, if a
+	 typespec was given, we already know the string length and want the one
+	 specified there.  */
+      if (typespec_chararray_ctor && expr->ts.u.cl->length
+	  && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
+	{
+	  gfc_se length_se;
+
+	  const_string = false;
+	  gfc_init_se (&length_se, NULL);
+	  gfc_conv_expr_type (&length_se, expr->ts.u.cl->length,
+			      gfc_charlen_type_node);
+	  ss_info->string_length = length_se.expr;
+	  gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
+	  gfc_add_block_to_block (&outer_loop->post, &length_se.post);
+	}
+      else
+	const_string = get_array_ctor_strlen (&outer_loop->pre, c,
+					      &ss_info->string_length);
+
+      /* Complex character array constructors should have been taken care of
+	 and not end up here.  */
+      gcc_assert (ss_info->string_length);
+
+      expr->ts.u.cl->backend_decl = ss_info->string_length;
+
+      type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length);
+      if (const_string)
+	type = build_pointer_type (type);
+    }
+  else
+    type = gfc_typenode_for_spec (&expr->ts);
+
+  /* See if the constructor determines the loop bounds.  */
+  dynamic = false;
+
+  loop_ubound0 = get_loop_upper_bound_for_array (ss, 0);
+
+  if (expr->shape && get_rank (loop) > 1 && *loop_ubound0 == NULL_TREE)
+    {
+      /* We have a multidimensional parameter.  */
+      for (s = ss; s; s = s->parent)
+	{
+	  int n;
+	  for (n = 0; n < s->loop->dimen; n++)
+	    {
+	      s->loop->from[n] = gfc_index_zero_node;
+	      s->loop->to[n] = gfc_conv_mpz_to_tree (expr->shape[s->dim[n]],
+						     gfc_index_integer_kind);
+	      s->loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
+						gfc_array_index_type,
+						s->loop->to[n],
+						gfc_index_one_node);
+	    }
+	}
+    }
+
+  if (*loop_ubound0 == NULL_TREE)
+    {
+      mpz_t size;
+
+      /* We should have a 1-dimensional, zero-based loop.  */
+      gcc_assert (loop->parent == NULL && loop->nested == NULL);
+      gcc_assert (loop->dimen == 1);
+      gcc_assert (integer_zerop (loop->from[0]));
+
+      /* Split the constructor size into a static part and a dynamic part.
+	 Allocate the static size up-front and record whether the dynamic
+	 size might be nonzero.  */
+      mpz_init (size);
+      dynamic = gfc_get_array_constructor_size (&size, c);
+      mpz_sub_ui (size, size, 1);
+      loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
+      mpz_clear (size);
+    }
+
+  /* Special case constant array constructors.  */
+  if (!dynamic)
+    {
+      unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
+      if (nelem > 0)
+	{
+	  tree size = constant_array_constructor_loop_size (loop);
+	  if (size && compare_tree_int (size, nelem) == 0)
+	    {
+	      trans_constant_array_constructor (ss, type);
+	      goto finish;
+	    }
+	}
+    }
+
+  gfc_trans_create_temp_array (&outer_loop->pre, &outer_loop->post, ss, type,
+			       NULL_TREE, dynamic, true, false, where);
+
+  desc = ss_info->data.array.descriptor;
+  offset = gfc_index_zero_node;
+  offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
+  TREE_NO_WARNING (offsetvar) = 1;
+  TREE_USED (offsetvar) = 0;
+  gfc_trans_array_constructor_value (&outer_loop->pre, type, desc, c,
+				     &offset, &offsetvar, dynamic);
+
+  /* If the array grows dynamically, the upper bound of the loop variable
+     is determined by the array's final upper bound.  */
+  if (dynamic)
+    {
+      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+			     gfc_array_index_type,
+			     offsetvar, gfc_index_one_node);
+      tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
+      gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp);
+      if (*loop_ubound0 && TREE_CODE (*loop_ubound0) == VAR_DECL)
+	gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp);
+      else
+	*loop_ubound0 = tmp;
+    }
+
+  if (TREE_USED (offsetvar))
+    pushdecl (offsetvar);
+  else
+    gcc_assert (INTEGER_CST_P (offset));
+
+#if 0
+  /* Disable bound checking for now because it's probably broken.  */
+  if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+    {
+      gcc_unreachable ();
+    }
+#endif
+
+finish:
+  /* Restore old values of globals.  */
+  first_len = old_first_len;
+  first_len_val = old_first_len_val;
+  typespec_chararray_ctor = old_typespec_chararray_ctor;
+}
+
+
+/* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
+   called after evaluating all of INFO's vector dimensions.  Go through
+   each such vector dimension and see if we can now fill in any missing
+   loop bounds.  */
+
+static void
+set_vector_loop_bounds (gfc_ss * ss)
+{
+  gfc_loopinfo *loop, *outer_loop;
+  gfc_array_info *info;
+  gfc_se se;
+  tree tmp;
+  tree desc;
+  tree zero;
+  int n;
+  int dim;
+
+  outer_loop = outermost_loop (ss->loop);
+
+  info = &ss->info->data.array;
+
+  for (; ss; ss = ss->parent)
+    {
+      loop = ss->loop;
+
+      for (n = 0; n < loop->dimen; n++)
+	{
+	  dim = ss->dim[n];
+	  if (info->ref->u.ar.dimen_type[dim] != DIMEN_VECTOR
+	      || loop->to[n] != NULL)
+	    continue;
+
+	  /* Loop variable N indexes vector dimension DIM, and we don't
+	     yet know the upper bound of loop variable N.  Set it to the
+	     difference between the vector's upper and lower bounds.  */
+	  gcc_assert (loop->from[n] == gfc_index_zero_node);
+	  gcc_assert (info->subscript[dim]
+		      && info->subscript[dim]->info->type == GFC_SS_VECTOR);
+
+	  gfc_init_se (&se, NULL);
+	  desc = info->subscript[dim]->info->data.array.descriptor;
+	  zero = gfc_rank_cst[0];
+	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+			     gfc_array_index_type,
+			     gfc_conv_descriptor_ubound_get (desc, zero),
+			     gfc_conv_descriptor_lbound_get (desc, zero));
+	  tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
+	  loop->to[n] = tmp;
+	}
+    }
+}
+
+
+/* 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.  */
+
+static void
+gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
+		      locus * where)
+{
+  gfc_loopinfo *nested_loop, *outer_loop;
+  gfc_se se;
+  gfc_ss_info *ss_info;
+  gfc_array_info *info;
+  gfc_expr *expr;
+  int n;
+
+  /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
+     arguments could get evaluated multiple times.  */
+  if (ss->is_alloc_lhs)
+    return;
+
+  outer_loop = outermost_loop (loop);
+
+  /* TODO: This can generate bad code if there are ordering dependencies,
+     e.g., a callee allocated function and an unknown size constructor.  */
+  gcc_assert (ss != NULL);
+
+  for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
+    {
+      gcc_assert (ss);
+
+      /* Cross loop arrays are handled from within the most nested loop.  */
+      if (ss->nested_ss != NULL)
+	continue;
+
+      ss_info = ss->info;
+      expr = ss_info->expr;
+      info = &ss_info->data.array;
+
+      switch (ss_info->type)
+	{
+	case GFC_SS_SCALAR:
+	  /* Scalar expression.  Evaluate this now.  This includes elemental
+	     dimension indices, but not array section bounds.  */
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_expr (&se, expr);
+	  gfc_add_block_to_block (&outer_loop->pre, &se.pre);
+
+	  if (expr->ts.type != BT_CHARACTER)
+	    {
+	      /* Move the evaluation of scalar expressions outside the
+		 scalarization loop, except for WHERE assignments.  */
+	      if (subscript)
+		se.expr = convert(gfc_array_index_type, se.expr);
+	      if (!ss_info->where)
+		se.expr = gfc_evaluate_now (se.expr, &outer_loop->pre);
+	      gfc_add_block_to_block (&outer_loop->pre, &se.post);
+	    }
+	  else
+	    gfc_add_block_to_block (&outer_loop->post, &se.post);
+
+	  ss_info->data.scalar.value = se.expr;
+	  ss_info->string_length = se.string_length;
+	  break;
+
+	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);
+	    }
+	  else
+	    {
+	      /* Otherwise, evaluate the argument outside the loop and pass
+		 a reference to the value.  */
+	      gfc_conv_expr (&se, expr);
+	    }
+
+	  /* Ensure that a pointer to the string is stored.  */
+	  if (expr->ts.type == BT_CHARACTER)
+	    gfc_conv_string_parameter (&se);
+
+	  gfc_add_block_to_block (&outer_loop->pre, &se.pre);
+	  gfc_add_block_to_block (&outer_loop->post, &se.post);
+	  if (gfc_is_class_scalar_expr (expr))
+	    /* This is necessary because the dynamic type will always be
+	       large than the declared type.  In consequence, assigning
+	       the value to a temporary could segfault.
+	       OOP-TODO: see if this is generally correct or is the value
+	       has to be written to an allocated temporary, whose address
+	       is passed via ss_info.  */
+	    ss_info->data.scalar.value = se.expr;
+	  else
+	    ss_info->data.scalar.value = gfc_evaluate_now (se.expr,
+							   &outer_loop->pre);
+
+	  ss_info->string_length = se.string_length;
+	  break;
+
+	case GFC_SS_SECTION:
+	  /* Add the expressions for scalar and vector subscripts.  */
+	  for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
+	    if (info->subscript[n])
+	      gfc_add_loop_ss_code (loop, info->subscript[n], true, where);
+
+	  set_vector_loop_bounds (ss);
+	  break;
+
+	case GFC_SS_VECTOR:
+	  /* Get the vector's descriptor and store it in SS.  */
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_expr_descriptor (&se, expr);
+	  gfc_add_block_to_block (&outer_loop->pre, &se.pre);
+	  gfc_add_block_to_block (&outer_loop->post, &se.post);
+	  info->descriptor = se.expr;
+	  break;
+
+	case GFC_SS_INTRINSIC:
+	  gfc_add_intrinsic_ss_code (loop, ss);
+	  break;
+
+	case GFC_SS_FUNCTION:
+	  /* Array function return value.  We call the function and save its
+	     result in a temporary for use inside the loop.  */
+	  gfc_init_se (&se, NULL);
+	  se.loop = loop;
+	  se.ss = ss;
+	  gfc_conv_expr (&se, expr);
+	  gfc_add_block_to_block (&outer_loop->pre, &se.pre);
+	  gfc_add_block_to_block (&outer_loop->post, &se.post);
+	  ss_info->string_length = se.string_length;
+	  break;
+
+	case GFC_SS_CONSTRUCTOR:
+	  if (expr->ts.type == BT_CHARACTER
+	      && ss_info->string_length == NULL
+	      && expr->ts.u.cl
+	      && expr->ts.u.cl->length)
+	    {
+	      gfc_init_se (&se, NULL);
+	      gfc_conv_expr_type (&se, expr->ts.u.cl->length,
+				  gfc_charlen_type_node);
+	      ss_info->string_length = se.expr;
+	      gfc_add_block_to_block (&outer_loop->pre, &se.pre);
+	      gfc_add_block_to_block (&outer_loop->post, &se.post);
+	    }
+	  trans_array_constructor (ss, where);
+	  break;
+
+        case GFC_SS_TEMP:
+	case GFC_SS_COMPONENT:
+          /* Do nothing.  These are handled elsewhere.  */
+          break;
+
+	default:
+	  gcc_unreachable ();
+	}
+    }
+
+  if (!subscript)
+    for (nested_loop = loop->nested; nested_loop;
+	 nested_loop = nested_loop->next)
+      gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where);
+}
+
+
+/* Translate expressions for the descriptor and data pointer of a SS.  */
+/*GCC ARRAYS*/
+
+static void
+gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
+{
+  gfc_se se;
+  gfc_ss_info *ss_info;
+  gfc_array_info *info;
+  tree tmp;
+
+  ss_info = ss->info;
+  info = &ss_info->data.array;
+
+  /* Get the descriptor for the array to be scalarized.  */
+  gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE);
+  gfc_init_se (&se, NULL);
+  se.descriptor_only = 1;
+  gfc_conv_expr_lhs (&se, ss_info->expr);
+  gfc_add_block_to_block (block, &se.pre);
+  info->descriptor = se.expr;
+  ss_info->string_length = se.string_length;
+
+  if (base)
+    {
+      /* Also the data pointer.  */
+      tmp = gfc_conv_array_data (se.expr);
+      /* If this is a variable or address of a variable we use it directly.
+         Otherwise we must evaluate it now to avoid breaking dependency
+	 analysis by pulling the expressions for elemental array indices
+	 inside the loop.  */
+      if (!(DECL_P (tmp)
+	    || (TREE_CODE (tmp) == ADDR_EXPR
+		&& DECL_P (TREE_OPERAND (tmp, 0)))))
+	tmp = gfc_evaluate_now (tmp, block);
+      info->data = tmp;
+
+      tmp = gfc_conv_array_offset (se.expr);
+      info->offset = gfc_evaluate_now (tmp, block);
+
+      /* Make absolutely sure that the saved_offset is indeed saved
+	 so that the variable is still accessible after the loops
+	 are translated.  */
+      info->saved_offset = info->offset;
+    }
+}
+
+
+/* Initialize a gfc_loopinfo structure.  */
+
+void
+gfc_init_loopinfo (gfc_loopinfo * loop)
+{
+  int n;
+
+  memset (loop, 0, sizeof (gfc_loopinfo));
+  gfc_init_block (&loop->pre);
+  gfc_init_block (&loop->post);
+
+  /* Initially scalarize in order and default to no loop reversal.  */
+  for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
+    {
+      loop->order[n] = n;
+      loop->reverse[n] = GFC_INHIBIT_REVERSE;
+    }
+
+  loop->ss = gfc_ss_terminator;
+}
+
+
+/* Copies the loop variable info to a gfc_se structure. Does not copy the SS
+   chain.  */
+
+void
+gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
+{
+  se->loop = loop;
+}
+
+
+/* Return an expression for the data pointer of an array.  */
+
+tree
+gfc_conv_array_data (tree descriptor)
+{
+  tree type;
+
+  type = TREE_TYPE (descriptor);
+  if (GFC_ARRAY_TYPE_P (type))
+    {
+      if (TREE_CODE (type) == POINTER_TYPE)
+        return descriptor;
+      else
+        {
+          /* Descriptorless arrays.  */
+	  return gfc_build_addr_expr (NULL_TREE, descriptor);
+        }
+    }
+  else
+    return gfc_conv_descriptor_data_get (descriptor);
+}
+
+
+/* Return an expression for the base offset of an array.  */
+
+tree
+gfc_conv_array_offset (tree descriptor)
+{
+  tree type;
+
+  type = TREE_TYPE (descriptor);
+  if (GFC_ARRAY_TYPE_P (type))
+    return GFC_TYPE_ARRAY_OFFSET (type);
+  else
+    return gfc_conv_descriptor_offset_get (descriptor);
+}
+
+
+/* Get an expression for the array stride.  */
+
+tree
+gfc_conv_array_stride (tree descriptor, int dim)
+{
+  tree tmp;
+  tree type;
+
+  type = TREE_TYPE (descriptor);
+
+  /* For descriptorless arrays use the array size.  */
+  tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
+  if (tmp != NULL_TREE)
+    return tmp;
+
+  tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
+  return tmp;
+}
+
+
+/* Like gfc_conv_array_stride, but for the lower bound.  */
+
+tree
+gfc_conv_array_lbound (tree descriptor, int dim)
+{
+  tree tmp;
+  tree type;
+
+  type = TREE_TYPE (descriptor);
+
+  tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
+  if (tmp != NULL_TREE)
+    return tmp;
+
+  tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
+  return tmp;
+}
+
+
+/* Like gfc_conv_array_stride, but for the upper bound.  */
+
+tree
+gfc_conv_array_ubound (tree descriptor, int dim)
+{
+  tree tmp;
+  tree type;
+
+  type = TREE_TYPE (descriptor);
+
+  tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
+  if (tmp != NULL_TREE)
+    return tmp;
+
+  /* This should only ever happen when passing an assumed shape array
+     as an actual parameter.  The value will never be used.  */
+  if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
+    return gfc_index_zero_node;
+
+  tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
+  return tmp;
+}
+
+
+/* Generate code to perform an array index bound check.  */
+
+static tree
+trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n,
+			 locus * where, bool check_upper)
+{
+  tree fault;
+  tree tmp_lo, tmp_up;
+  tree descriptor;
+  char *msg;
+  const char * name = NULL;
+
+  if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
+    return index;
+
+  descriptor = ss->info->data.array.descriptor;
+
+  index = gfc_evaluate_now (index, &se->pre);
+
+  /* We find a name for the error message.  */
+  name = ss->info->expr->symtree->n.sym->name;
+  gcc_assert (name != NULL);
+
+  if (TREE_CODE (descriptor) == VAR_DECL)
+    name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
+
+  /* If upper bound is present, include both bounds in the error message.  */
+  if (check_upper)
+    {
+      tmp_lo = gfc_conv_array_lbound (descriptor, n);
+      tmp_up = gfc_conv_array_ubound (descriptor, n);
+
+      if (name)
+	asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
+		  "outside of expected range (%%ld:%%ld)", n+1, name);
+      else
+	asprintf (&msg, "Index '%%ld' of dimension %d "
+		  "outside of expected range (%%ld:%%ld)", n+1);
+
+      fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+			       index, tmp_lo);
+      gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
+			       fold_convert (long_integer_type_node, index),
+			       fold_convert (long_integer_type_node, tmp_lo),
+			       fold_convert (long_integer_type_node, tmp_up));
+      fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+			       index, tmp_up);
+      gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
+			       fold_convert (long_integer_type_node, index),
+			       fold_convert (long_integer_type_node, tmp_lo),
+			       fold_convert (long_integer_type_node, tmp_up));
+      free (msg);
+    }
+  else
+    {
+      tmp_lo = gfc_conv_array_lbound (descriptor, n);
+
+      if (name)
+	asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
+		  "below lower bound of %%ld", n+1, name);
+      else
+	asprintf (&msg, "Index '%%ld' of dimension %d "
+		  "below lower bound of %%ld", n+1);
+
+      fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+			       index, tmp_lo);
+      gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
+			       fold_convert (long_integer_type_node, index),
+			       fold_convert (long_integer_type_node, tmp_lo));
+      free (msg);
+    }
+
+  return index;
+}
+
+
+/* Return the offset for an index.  Performs bound checking for elemental
+   dimensions.  Single element references are processed separately.
+   DIM is the array dimension, I is the loop dimension.  */
+
+static tree
+conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
+			 gfc_array_ref * ar, tree stride)
+{
+  gfc_array_info *info;
+  tree index;
+  tree desc;
+  tree data;
+
+  info = &ss->info->data.array;
+
+  /* Get the index into the array for this dimension.  */
+  if (ar)
+    {
+      gcc_assert (ar->type != AR_ELEMENT);
+      switch (ar->dimen_type[dim])
+	{
+	case DIMEN_THIS_IMAGE:
+	  gcc_unreachable ();
+	  break;
+	case DIMEN_ELEMENT:
+	  /* Elemental dimension.  */
+	  gcc_assert (info->subscript[dim]
+		      && info->subscript[dim]->info->type == GFC_SS_SCALAR);
+	  /* We've already translated this value outside the loop.  */
+	  index = info->subscript[dim]->info->data.scalar.value;
+
+	  index = trans_array_bound_check (se, ss, index, dim, &ar->where,
+					   ar->as->type != AS_ASSUMED_SIZE
+					   || dim < ar->dimen - 1);
+	  break;
+
+	case DIMEN_VECTOR:
+	  gcc_assert (info && se->loop);
+	  gcc_assert (info->subscript[dim]
+		      && info->subscript[dim]->info->type == GFC_SS_VECTOR);
+	  desc = info->subscript[dim]->info->data.array.descriptor;
+
+	  /* Get a zero-based index into the vector.  */
+	  index = fold_build2_loc (input_location, MINUS_EXPR,
+				   gfc_array_index_type,
+				   se->loop->loopvar[i], se->loop->from[i]);
+
+	  /* Multiply the index by the stride.  */
+	  index = fold_build2_loc (input_location, MULT_EXPR,
+				   gfc_array_index_type,
+				   index, gfc_conv_array_stride (desc, 0));
+
+	  /* Read the vector to get an index into info->descriptor.  */
+	  data = build_fold_indirect_ref_loc (input_location,
+					  gfc_conv_array_data (desc));
+	  index = gfc_build_array_ref (data, index, NULL);
+	  index = gfc_evaluate_now (index, &se->pre);
+	  index = fold_convert (gfc_array_index_type, index);
+
+	  /* Do any bounds checking on the final info->descriptor index.  */
+	  index = trans_array_bound_check (se, ss, index, dim, &ar->where,
+					   ar->as->type != AS_ASSUMED_SIZE
+					   || dim < ar->dimen - 1);
+	  break;
+
+	case DIMEN_RANGE:
+	  /* Scalarized dimension.  */
+	  gcc_assert (info && se->loop);
+
+	  /* Multiply the loop variable by the stride and delta.  */
+	  index = se->loop->loopvar[i];
+	  if (!integer_onep (info->stride[dim]))
+	    index = fold_build2_loc (input_location, MULT_EXPR,
+				     gfc_array_index_type, index,
+				     info->stride[dim]);
+	  if (!integer_zerop (info->delta[dim]))
+	    index = fold_build2_loc (input_location, PLUS_EXPR,
+				     gfc_array_index_type, index,
+				     info->delta[dim]);
+	  break;
+
+	default:
+	  gcc_unreachable ();
+	}
+    }
+  else
+    {
+      /* Temporary array or derived type component.  */
+      gcc_assert (se->loop);
+      index = se->loop->loopvar[se->loop->order[i]];
+
+      /* Pointer functions can have stride[0] different from unity.
+	 Use the stride returned by the function call and stored in
+	 the descriptor for the temporary.  */
+      if (se->ss && se->ss->info->type == GFC_SS_FUNCTION
+	  && se->ss->info->expr
+	  && se->ss->info->expr->symtree
+	  && se->ss->info->expr->symtree->n.sym->result
+	  && se->ss->info->expr->symtree->n.sym->result->attr.pointer)
+	stride = gfc_conv_descriptor_stride_get (info->descriptor,
+						 gfc_rank_cst[dim]);
+
+      if (!integer_zerop (info->delta[dim]))
+	index = fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type, index, info->delta[dim]);
+    }
+
+  /* Multiply by the stride.  */
+  if (!integer_onep (stride))
+    index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			     index, stride);
+
+  return index;
+}
+
+
+/* Build a scalarized array reference using the vptr 'size'.  */
+
+static bool
+build_class_array_ref (gfc_se *se, tree base, tree index)
+{
+  tree type;
+  tree size;
+  tree offset;
+  tree decl;
+  tree tmp;
+  gfc_expr *expr = se->ss->info->expr;
+  gfc_ref *ref;
+  gfc_ref *class_ref;
+  gfc_typespec *ts;
+
+  if (expr == NULL || expr->ts.type != BT_CLASS)
+    return false;
+
+  if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS)
+    ts = &expr->symtree->n.sym->ts;
+  else
+    ts = NULL;
+  class_ref = NULL;
+
+  for (ref = expr->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_COMPONENT
+	    && ref->u.c.component->ts.type == BT_CLASS
+	    && ref->next && ref->next->type == REF_COMPONENT
+	    && strcmp (ref->next->u.c.component->name, "_data") == 0
+	    && ref->next->next
+	    && ref->next->next->type == REF_ARRAY
+	    && ref->next->next->u.ar.type != AR_ELEMENT)
+	{
+	  ts = &ref->u.c.component->ts;
+	  class_ref = ref;
+	  break;
+	}
+    }
+
+  if (ts == NULL)
+    return false;
+
+  if (class_ref == NULL && expr->symtree->n.sym->attr.function
+      && expr->symtree->n.sym == expr->symtree->n.sym->result)
+    {
+      gcc_assert (expr->symtree->n.sym->backend_decl == current_function_decl);
+      decl = gfc_get_fake_result_decl (expr->symtree->n.sym, 0);
+    }
+  else if (class_ref == NULL)
+    decl = expr->symtree->n.sym->backend_decl;
+  else
+    {
+      /* Remove everything after the last class reference, convert the
+	 expression and then recover its tailend once more.  */
+      gfc_se tmpse;
+      ref = class_ref->next;
+      class_ref->next = NULL;
+      gfc_init_se (&tmpse, NULL);
+      gfc_conv_expr (&tmpse, expr);
+      decl = tmpse.expr;
+      class_ref->next = ref;
+    }
+
+  size = gfc_vtable_size_get (decl);
+
+  /* Build the address of the element.  */
+  type = TREE_TYPE (TREE_TYPE (base));
+  size = fold_convert (TREE_TYPE (index), size);
+  offset = fold_build2_loc (input_location, MULT_EXPR,
+			    gfc_array_index_type,
+			    index, size);
+  tmp = gfc_build_addr_expr (pvoid_type_node, base);
+  tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
+  tmp = fold_convert (build_pointer_type (type), tmp);
+
+  /* Return the element in the se expression.  */
+  se->expr = build_fold_indirect_ref_loc (input_location, tmp);
+  return true;
+}
+
+
+/* Build a scalarized reference to an array.  */
+
+static void
+gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
+{
+  gfc_array_info *info;
+  tree decl = NULL_TREE;
+  tree index;
+  tree tmp;
+  gfc_ss *ss;
+  gfc_expr *expr;
+  int n;
+
+  ss = se->ss;
+  expr = ss->info->expr;
+  info = &ss->info->data.array;
+  if (ar)
+    n = se->loop->order[0];
+  else
+    n = 0;
+
+  index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0);
+  /* Add the offset for this dimension to the stored offset for all other
+     dimensions.  */
+  if (!integer_zerop (info->offset))
+    index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			     index, info->offset);
+
+  if (expr && is_subref_array (expr))
+    decl = expr->symtree->n.sym->backend_decl;
+
+  tmp = build_fold_indirect_ref_loc (input_location, info->data);
+
+  /* Use the vptr 'size' field to access a class the element of a class
+     array.  */
+  if (build_class_array_ref (se, tmp, index))
+    return;
+
+  se->expr = gfc_build_array_ref (tmp, index, decl);
+}
+
+
+/* Translate access of temporary array.  */
+
+void
+gfc_conv_tmp_array_ref (gfc_se * se)
+{
+  se->string_length = se->ss->info->string_length;
+  gfc_conv_scalarized_array_ref (se, NULL);
+  gfc_advance_se_ss_chain (se);
+}
+
+/* Add T to the offset pair *OFFSET, *CST_OFFSET.  */
+
+static void
+add_to_offset (tree *cst_offset, tree *offset, tree t)
+{
+  if (TREE_CODE (t) == INTEGER_CST)
+    *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t);
+  else
+    {
+      if (!integer_zerop (*offset))
+	*offset = fold_build2_loc (input_location, PLUS_EXPR,
+				   gfc_array_index_type, *offset, t);
+      else
+	*offset = t;
+    }
+}
+
+
+static tree
+build_array_ref (tree desc, tree offset, tree decl)
+{
+  tree tmp;
+  tree type;
+
+  /* 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)
+    {
+      type = TREE_TYPE (TREE_OPERAND (desc, 0));
+      if (TYPE_CANONICAL (type)
+	  && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type)))
+	type = TYPE_CANONICAL (type);
+    }
+  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))
+    {
+      type = gfc_get_element_type (TREE_TYPE (desc));
+      tmp = TREE_OPERAND (desc, 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);
+      return tmp;
+    }
+
+  tmp = gfc_conv_array_data (desc);
+  tmp = build_fold_indirect_ref_loc (input_location, tmp);
+  tmp = gfc_build_array_ref (tmp, offset, decl);
+  return tmp;
+}
+
+
+/* Build an array reference.  se->expr already holds the array descriptor.
+   This should be either a variable, indirect variable reference or component
+   reference.  For arrays which do not have a descriptor, se->expr will be
+   the data pointer.
+   a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
+
+void
+gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
+		    locus * where)
+{
+  int n;
+  tree offset, cst_offset;
+  tree tmp;
+  tree stride;
+  gfc_se indexse;
+  gfc_se tmpse;
+  gfc_symbol * sym = expr->symtree->n.sym;
+  char *var_name = NULL;
+
+  if (ar->dimen == 0)
+    {
+      gcc_assert (ar->codimen);
+
+      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
+	se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
+      else
+	{
+	  if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
+	      && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
+	    se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
+
+	  /* Use the actual tree type and not the wrapped coarray. */
+	  if (!se->want_pointer)
+	    se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
+				     se->expr);
+	}
+
+      return;
+    }
+
+  /* Handle scalarized references separately.  */
+  if (ar->type != AR_ELEMENT)
+    {
+      gfc_conv_scalarized_array_ref (se, ar);
+      gfc_advance_se_ss_chain (se);
+      return;
+    }
+
+  if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+    {
+      size_t len;
+      gfc_ref *ref;
+
+      len = strlen (sym->name) + 1;
+      for (ref = expr->ref; ref; ref = ref->next)
+	{
+	  if (ref->type == REF_ARRAY && &ref->u.ar == ar)
+	    break;
+	  if (ref->type == REF_COMPONENT)
+	    len += 1 + strlen (ref->u.c.component->name);
+	}
+
+      var_name = XALLOCAVEC (char, len);
+      strcpy (var_name, sym->name);
+
+      for (ref = expr->ref; ref; ref = ref->next)
+	{
+	  if (ref->type == REF_ARRAY && &ref->u.ar == ar)
+	    break;
+	  if (ref->type == REF_COMPONENT)
+	    {
+	      strcat (var_name, "%%");
+	      strcat (var_name, ref->u.c.component->name);
+	    }
+	}
+    }
+
+  cst_offset = offset = gfc_index_zero_node;
+  add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (se->expr));
+
+  /* Calculate the offsets from all the dimensions.  Make sure to associate
+     the final offset so that we form a chain of loop invariant summands.  */
+  for (n = ar->dimen - 1; n >= 0; n--)
+    {
+      /* Calculate the index for this dimension.  */
+      gfc_init_se (&indexse, se);
+      gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
+      gfc_add_block_to_block (&se->pre, &indexse.pre);
+
+      if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+	{
+	  /* Check array bounds.  */
+	  tree cond;
+	  char *msg;
+
+	  /* Evaluate the indexse.expr only once.  */
+	  indexse.expr = save_expr (indexse.expr);
+
+	  /* Lower bound.  */
+	  tmp = gfc_conv_array_lbound (se->expr, n);
+	  if (sym->attr.temporary)
+	    {
+	      gfc_init_se (&tmpse, se);
+	      gfc_conv_expr_type (&tmpse, ar->as->lower[n],
+				  gfc_array_index_type);
+	      gfc_add_block_to_block (&se->pre, &tmpse.pre);
+	      tmp = tmpse.expr;
+	    }
+
+	  cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+				  indexse.expr, tmp);
+	  asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
+		    "below lower bound of %%ld", n+1, var_name);
+	  gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
+				   fold_convert (long_integer_type_node,
+						 indexse.expr),
+				   fold_convert (long_integer_type_node, tmp));
+	  free (msg);
+
+	  /* Upper bound, but not for the last dimension of assumed-size
+	     arrays.  */
+	  if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
+	    {
+	      tmp = gfc_conv_array_ubound (se->expr, n);
+	      if (sym->attr.temporary)
+		{
+		  gfc_init_se (&tmpse, se);
+		  gfc_conv_expr_type (&tmpse, ar->as->upper[n],
+				      gfc_array_index_type);
+		  gfc_add_block_to_block (&se->pre, &tmpse.pre);
+		  tmp = tmpse.expr;
+		}
+
+	      cond = fold_build2_loc (input_location, GT_EXPR,
+				      boolean_type_node, indexse.expr, tmp);
+	      asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
+			"above upper bound of %%ld", n+1, var_name);
+	      gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
+				   fold_convert (long_integer_type_node,
+						 indexse.expr),
+				   fold_convert (long_integer_type_node, tmp));
+	      free (msg);
+	    }
+	}
+
+      /* Multiply the index by the stride.  */
+      stride = gfc_conv_array_stride (se->expr, n);
+      tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			     indexse.expr, stride);
+
+      /* And add it to the total.  */
+      add_to_offset (&cst_offset, &offset, tmp);
+    }
+
+  if (!integer_zerop (cst_offset))
+    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);
+}
+
+
+/* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
+   LOOP_DIM dimension (if any) to array's offset.  */
+
+static void
+add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss,
+		  gfc_array_ref *ar, int array_dim, int loop_dim)
+{
+  gfc_se se;
+  gfc_array_info *info;
+  tree stride, index;
+
+  info = &ss->info->data.array;
+
+  gfc_init_se (&se, NULL);
+  se.loop = loop;
+  se.expr = info->descriptor;
+  stride = gfc_conv_array_stride (info->descriptor, array_dim);
+  index = conv_array_index_offset (&se, ss, array_dim, loop_dim, ar, stride);
+  gfc_add_block_to_block (pblock, &se.pre);
+
+  info->offset = fold_build2_loc (input_location, PLUS_EXPR,
+				  gfc_array_index_type,
+				  info->offset, index);
+  info->offset = gfc_evaluate_now (info->offset, pblock);
+}
+
+
+/* Generate the code to be executed immediately before entering a
+   scalarization loop.  */
+
+static void
+gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
+			 stmtblock_t * pblock)
+{
+  tree stride;
+  gfc_ss_info *ss_info;
+  gfc_array_info *info;
+  gfc_ss_type ss_type;
+  gfc_ss *ss, *pss;
+  gfc_loopinfo *ploop;
+  gfc_array_ref *ar;
+  int i;
+
+  /* This code will be executed before entering the scalarization loop
+     for this dimension.  */
+  for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
+    {
+      ss_info = ss->info;
+
+      if ((ss_info->useflags & flag) == 0)
+	continue;
+
+      ss_type = ss_info->type;
+      if (ss_type != GFC_SS_SECTION
+	  && ss_type != GFC_SS_FUNCTION
+	  && ss_type != GFC_SS_CONSTRUCTOR
+	  && ss_type != GFC_SS_COMPONENT)
+	continue;
+
+      info = &ss_info->data.array;
+
+      gcc_assert (dim < ss->dimen);
+      gcc_assert (ss->dimen == loop->dimen);
+
+      if (info->ref)
+	ar = &info->ref->u.ar;
+      else
+	ar = NULL;
+
+      if (dim == loop->dimen - 1 && loop->parent != NULL)
+	{
+	  /* If we are in the outermost dimension of this loop, the previous
+	     dimension shall be in the parent loop.  */
+	  gcc_assert (ss->parent != NULL);
+
+	  pss = ss->parent;
+	  ploop = loop->parent;
+
+	  /* ss and ss->parent are about the same array.  */
+	  gcc_assert (ss_info == pss->info);
+	}
+      else
+	{
+	  ploop = loop;
+	  pss = ss;
+	}
+
+      if (dim == loop->dimen - 1)
+	i = 0;
+      else
+	i = dim + 1;
+
+      /* For the time being, there is no loop reordering.  */
+      gcc_assert (i == ploop->order[i]);
+      i = ploop->order[i];
+
+      if (dim == loop->dimen - 1 && loop->parent == NULL)
+	{
+	  stride = gfc_conv_array_stride (info->descriptor,
+					  innermost_ss (ss)->dim[i]);
+
+	  /* Calculate the stride of the innermost loop.  Hopefully this will
+	     allow the backend optimizers to do their stuff more effectively.
+	   */
+	  info->stride0 = gfc_evaluate_now (stride, pblock);
+
+	  /* For the outermost loop calculate the offset due to any
+	     elemental dimensions.  It will have been initialized with the
+	     base offset of the array.  */
+	  if (info->ref)
+	    {
+	      for (i = 0; i < ar->dimen; i++)
+		{
+		  if (ar->dimen_type[i] != DIMEN_ELEMENT)
+		    continue;
+
+		  add_array_offset (pblock, loop, ss, ar, i, /* unused */ -1);
+		}
+	    }
+	}
+      else
+	/* Add the offset for the previous loop dimension.  */
+	add_array_offset (pblock, ploop, ss, ar, pss->dim[i], i);
+
+      /* Remember this offset for the second loop.  */
+      if (dim == loop->temp_dim - 1 && loop->parent == NULL)
+        info->saved_offset = info->offset;
+    }
+}
+
+
+/* Start a scalarized expression.  Creates a scope and declares loop
+   variables.  */
+
+void
+gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
+{
+  int dim;
+  int n;
+  int flags;
+
+  gcc_assert (!loop->array_parameter);
+
+  for (dim = loop->dimen - 1; dim >= 0; dim--)
+    {
+      n = loop->order[dim];
+
+      gfc_start_block (&loop->code[n]);
+
+      /* Create the loop variable.  */
+      loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
+
+      if (dim < loop->temp_dim)
+	flags = 3;
+      else
+	flags = 1;
+      /* Calculate values that will be constant within this loop.  */
+      gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
+    }
+  gfc_start_block (pbody);
+}
+
+
+/* Generates the actual loop code for a scalarization loop.  */
+
+void
+gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
+			       stmtblock_t * pbody)
+{
+  stmtblock_t block;
+  tree cond;
+  tree tmp;
+  tree loopbody;
+  tree exit_label;
+  tree stmt;
+  tree init;
+  tree incr;
+
+  if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS))
+      == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
+      && n == loop->dimen - 1)
+    {
+      /* We create an OMP_FOR construct for the outermost scalarized loop.  */
+      init = make_tree_vec (1);
+      cond = make_tree_vec (1);
+      incr = make_tree_vec (1);
+
+      /* Cycle statement is implemented with a goto.  Exit statement must not
+	 be present for this loop.  */
+      exit_label = gfc_build_label_decl (NULL_TREE);
+      TREE_USED (exit_label) = 1;
+
+      /* Label for cycle statements (if needed).  */
+      tmp = build1_v (LABEL_EXPR, exit_label);
+      gfc_add_expr_to_block (pbody, tmp);
+
+      stmt = make_node (OMP_FOR);
+
+      TREE_TYPE (stmt) = void_type_node;
+      OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
+
+      OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
+						 OMP_CLAUSE_SCHEDULE);
+      OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
+	= OMP_CLAUSE_SCHEDULE_STATIC;
+      if (ompws_flags & OMPWS_NOWAIT)
+	OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
+	  = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
+
+      /* Initialize the loopvar.  */
+      TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
+					 loop->from[n]);
+      OMP_FOR_INIT (stmt) = init;
+      /* The exit condition.  */
+      TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
+					   boolean_type_node,
+					   loop->loopvar[n], loop->to[n]);
+      SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
+      OMP_FOR_COND (stmt) = cond;
+      /* Increment the loopvar.  */
+      tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			loop->loopvar[n], gfc_index_one_node);
+      TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
+	  void_type_node, loop->loopvar[n], tmp);
+      OMP_FOR_INCR (stmt) = incr;
+
+      ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
+      gfc_add_expr_to_block (&loop->code[n], stmt);
+    }
+  else
+    {
+      bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
+			     && (loop->temp_ss == NULL);
+
+      loopbody = gfc_finish_block (pbody);
+
+      if (reverse_loop)
+	{
+	  tmp = loop->from[n];
+	  loop->from[n] = loop->to[n];
+	  loop->to[n] = tmp;
+	}
+
+      /* Initialize the loopvar.  */
+      if (loop->loopvar[n] != loop->from[n])
+	gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
+
+      exit_label = gfc_build_label_decl (NULL_TREE);
+
+      /* Generate the loop body.  */
+      gfc_init_block (&block);
+
+      /* The exit condition.  */
+      cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
+			  boolean_type_node, loop->loopvar[n], loop->to[n]);
+      tmp = build1_v (GOTO_EXPR, exit_label);
+      TREE_USED (exit_label) = 1;
+      tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&block, tmp);
+
+      /* The main body.  */
+      gfc_add_expr_to_block (&block, loopbody);
+
+      /* Increment the loopvar.  */
+      tmp = fold_build2_loc (input_location,
+			     reverse_loop ? MINUS_EXPR : PLUS_EXPR,
+			     gfc_array_index_type, loop->loopvar[n],
+			     gfc_index_one_node);
+
+      gfc_add_modify (&block, loop->loopvar[n], tmp);
+
+      /* Build the loop.  */
+      tmp = gfc_finish_block (&block);
+      tmp = build1_v (LOOP_EXPR, tmp);
+      gfc_add_expr_to_block (&loop->code[n], tmp);
+
+      /* Add the exit label.  */
+      tmp = build1_v (LABEL_EXPR, exit_label);
+      gfc_add_expr_to_block (&loop->code[n], tmp);
+    }
+
+}
+
+
+/* Finishes and generates the loops for a scalarized expression.  */
+
+void
+gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
+{
+  int dim;
+  int n;
+  gfc_ss *ss;
+  stmtblock_t *pblock;
+  tree tmp;
+
+  pblock = body;
+  /* Generate the loops.  */
+  for (dim = 0; dim < loop->dimen; dim++)
+    {
+      n = loop->order[dim];
+      gfc_trans_scalarized_loop_end (loop, n, pblock);
+      loop->loopvar[n] = NULL_TREE;
+      pblock = &loop->code[n];
+    }
+
+  tmp = gfc_finish_block (pblock);
+  gfc_add_expr_to_block (&loop->pre, tmp);
+
+  /* Clear all the used flags.  */
+  for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
+    if (ss->parent == NULL)
+      ss->info->useflags = 0;
+}
+
+
+/* Finish the main body of a scalarized expression, and start the secondary
+   copying body.  */
+
+void
+gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
+{
+  int dim;
+  int n;
+  stmtblock_t *pblock;
+  gfc_ss *ss;
+
+  pblock = body;
+  /* We finish as many loops as are used by the temporary.  */
+  for (dim = 0; dim < loop->temp_dim - 1; dim++)
+    {
+      n = loop->order[dim];
+      gfc_trans_scalarized_loop_end (loop, n, pblock);
+      loop->loopvar[n] = NULL_TREE;
+      pblock = &loop->code[n];
+    }
+
+  /* We don't want to finish the outermost loop entirely.  */
+  n = loop->order[loop->temp_dim - 1];
+  gfc_trans_scalarized_loop_end (loop, n, pblock);
+
+  /* Restore the initial offsets.  */
+  for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
+    {
+      gfc_ss_type ss_type;
+      gfc_ss_info *ss_info;
+
+      ss_info = ss->info;
+
+      if ((ss_info->useflags & 2) == 0)
+	continue;
+
+      ss_type = ss_info->type;
+      if (ss_type != GFC_SS_SECTION
+	  && ss_type != GFC_SS_FUNCTION
+	  && ss_type != GFC_SS_CONSTRUCTOR
+	  && ss_type != GFC_SS_COMPONENT)
+	continue;
+
+      ss_info->data.array.offset = ss_info->data.array.saved_offset;
+    }
+
+  /* Restart all the inner loops we just finished.  */
+  for (dim = loop->temp_dim - 2; dim >= 0; dim--)
+    {
+      n = loop->order[dim];
+
+      gfc_start_block (&loop->code[n]);
+
+      loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
+
+      gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
+    }
+
+  /* Start a block for the secondary copying code.  */
+  gfc_start_block (body);
+}
+
+
+/* Precalculate (either lower or upper) bound of an array section.
+     BLOCK: Block in which the (pre)calculation code will go.
+     BOUNDS[DIM]: Where the bound value will be stored once evaluated.
+     VALUES[DIM]: Specified bound (NULL <=> unspecified).
+     DESC: Array descriptor from which the bound will be picked if unspecified
+       (either lower or upper bound according to LBOUND).  */
+
+static void
+evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
+		tree desc, int dim, bool lbound)
+{
+  gfc_se se;
+  gfc_expr * input_val = values[dim];
+  tree *output = &bounds[dim];
+
+
+  if (input_val)
+    {
+      /* Specified section bound.  */
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr_type (&se, input_val, gfc_array_index_type);
+      gfc_add_block_to_block (block, &se.pre);
+      *output = se.expr;
+    }
+  else
+    {
+      /* No specific bound specified so use the bound of the array.  */
+      *output = lbound ? gfc_conv_array_lbound (desc, dim) :
+			 gfc_conv_array_ubound (desc, dim);
+    }
+  *output = gfc_evaluate_now (*output, block);
+}
+
+
+/* Calculate the lower bound of an array section.  */
+
+static void
+gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim)
+{
+  gfc_expr *stride = NULL;
+  tree desc;
+  gfc_se se;
+  gfc_array_info *info;
+  gfc_array_ref *ar;
+
+  gcc_assert (ss->info->type == GFC_SS_SECTION);
+
+  info = &ss->info->data.array;
+  ar = &info->ref->u.ar;
+
+  if (ar->dimen_type[dim] == DIMEN_VECTOR)
+    {
+      /* We use a zero-based index to access the vector.  */
+      info->start[dim] = gfc_index_zero_node;
+      info->end[dim] = NULL;
+      info->stride[dim] = gfc_index_one_node;
+      return;
+    }
+
+  gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE
+	      || ar->dimen_type[dim] == DIMEN_THIS_IMAGE);
+  desc = info->descriptor;
+  stride = ar->stride[dim];
+
+  /* Calculate the start of the range.  For vector subscripts this will
+     be the range of the vector.  */
+  evaluate_bound (block, info->start, ar->start, desc, dim, true);
+
+  /* Similarly calculate the end.  Although this is not used in the
+     scalarizer, it is needed when checking bounds and where the end
+     is an expression with side-effects.  */
+  evaluate_bound (block, info->end, ar->end, desc, dim, false);
+
+  /* Calculate the stride.  */
+  if (stride == NULL)
+    info->stride[dim] = gfc_index_one_node;
+  else
+    {
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr_type (&se, stride, gfc_array_index_type);
+      gfc_add_block_to_block (block, &se.pre);
+      info->stride[dim] = gfc_evaluate_now (se.expr, block);
+    }
+}
+
+
+/* Calculates the range start and stride for a SS chain.  Also gets the
+   descriptor and data pointer.  The range of vector subscripts is the size
+   of the vector.  Array bounds are also checked.  */
+
+void
+gfc_conv_ss_startstride (gfc_loopinfo * loop)
+{
+  int n;
+  tree tmp;
+  gfc_ss *ss;
+  tree desc;
+
+  gfc_loopinfo * const outer_loop = outermost_loop (loop);
+
+  loop->dimen = 0;
+  /* Determine the rank of the loop.  */
+  for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
+    {
+      switch (ss->info->type)
+	{
+	case GFC_SS_SECTION:
+	case GFC_SS_CONSTRUCTOR:
+	case GFC_SS_FUNCTION:
+	case GFC_SS_COMPONENT:
+	  loop->dimen = ss->dimen;
+	  goto done;
+
+	/* As usual, lbound and ubound are exceptions!.  */
+	case GFC_SS_INTRINSIC:
+	  switch (ss->info->expr->value.function.isym->id)
+	    {
+	    case GFC_ISYM_LBOUND:
+	    case GFC_ISYM_UBOUND:
+	    case GFC_ISYM_LCOBOUND:
+	    case GFC_ISYM_UCOBOUND:
+	    case GFC_ISYM_THIS_IMAGE:
+	      loop->dimen = ss->dimen;
+	      goto done;
+
+	    default:
+	      break;
+	    }
+
+	default:
+	  break;
+	}
+    }
+
+  /* We should have determined the rank of the expression by now.  If
+     not, that's bad news.  */
+  gcc_unreachable ();
+
+done:
+  /* Loop over all the SS in the chain.  */
+  for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
+    {
+      gfc_ss_info *ss_info;
+      gfc_array_info *info;
+      gfc_expr *expr;
+
+      ss_info = ss->info;
+      expr = ss_info->expr;
+      info = &ss_info->data.array;
+
+      if (expr && expr->shape && !info->shape)
+	info->shape = expr->shape;
+
+      switch (ss_info->type)
+	{
+	case GFC_SS_SECTION:
+	  /* Get the descriptor for the array.  If it is a cross loops array,
+	     we got the descriptor already in the outermost loop.  */
+	  if (ss->parent == NULL)
+	    gfc_conv_ss_descriptor (&outer_loop->pre, ss,
+				    !loop->array_parameter);
+
+	  for (n = 0; n < ss->dimen; n++)
+	    gfc_conv_section_startstride (&outer_loop->pre, ss, ss->dim[n]);
+	  break;
+
+	case GFC_SS_INTRINSIC:
+	  switch (expr->value.function.isym->id)
+	    {
+	    /* Fall through to supply start and stride.  */
+	    case GFC_ISYM_LBOUND:
+	    case GFC_ISYM_UBOUND:
+	      {
+		gfc_expr *arg;
+
+		/* This is the variant without DIM=...  */
+		gcc_assert (expr->value.function.actual->next->expr == NULL);
+
+		arg = expr->value.function.actual->expr;
+		if (arg->rank == -1)
+		  {
+		    gfc_se se;
+		    tree rank, tmp;
+
+		    /* The rank (hence the return value's shape) is unknown,
+		       we have to retrieve it.  */
+		    gfc_init_se (&se, NULL);
+		    se.descriptor_only = 1;
+		    gfc_conv_expr (&se, arg);
+		    /* This is a bare variable, so there is no preliminary
+		       or cleanup code.  */
+		    gcc_assert (se.pre.head == NULL_TREE
+				&& se.post.head == NULL_TREE);
+		    rank = gfc_conv_descriptor_rank (se.expr);
+		    tmp = fold_build2_loc (input_location, MINUS_EXPR,
+					   gfc_array_index_type,
+					   fold_convert (gfc_array_index_type,
+							 rank),
+					   gfc_index_one_node);
+		    info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre);
+		    info->start[0] = gfc_index_zero_node;
+		    info->stride[0] = gfc_index_one_node;
+		    continue;
+		  }
+		  /* Otherwise fall through GFC_SS_FUNCTION.  */
+	      }
+	    case GFC_ISYM_LCOBOUND:
+	    case GFC_ISYM_UCOBOUND:
+	    case GFC_ISYM_THIS_IMAGE:
+	      break;
+
+	    default:
+	      continue;
+	    }
+
+	case GFC_SS_CONSTRUCTOR:
+	case GFC_SS_FUNCTION:
+	  for (n = 0; n < ss->dimen; n++)
+	    {
+	      int dim = ss->dim[n];
+
+	      info->start[dim]  = gfc_index_zero_node;
+	      info->end[dim]    = gfc_index_zero_node;
+	      info->stride[dim] = gfc_index_one_node;
+	    }
+	  break;
+
+	default:
+	  break;
+	}
+    }
+
+  /* The rest is just runtime bound checking.  */
+  if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+    {
+      stmtblock_t block;
+      tree lbound, ubound;
+      tree end;
+      tree size[GFC_MAX_DIMENSIONS];
+      tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
+      gfc_array_info *info;
+      char *msg;
+      int dim;
+
+      gfc_start_block (&block);
+
+      for (n = 0; n < loop->dimen; n++)
+	size[n] = NULL_TREE;
+
+      for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
+	{
+	  stmtblock_t inner;
+	  gfc_ss_info *ss_info;
+	  gfc_expr *expr;
+	  locus *expr_loc;
+	  const char *expr_name;
+
+	  ss_info = ss->info;
+	  if (ss_info->type != GFC_SS_SECTION)
+	    continue;
+
+	  /* Catch allocatable lhs in f2003.  */
+	  if (gfc_option.flag_realloc_lhs && ss->is_alloc_lhs)
+	    continue;
+
+	  expr = ss_info->expr;
+	  expr_loc = &expr->where;
+	  expr_name = expr->symtree->name;
+
+	  gfc_start_block (&inner);
+
+	  /* TODO: range checking for mapped dimensions.  */
+	  info = &ss_info->data.array;
+
+	  /* This code only checks ranges.  Elemental and vector
+	     dimensions are checked later.  */
+	  for (n = 0; n < loop->dimen; n++)
+	    {
+	      bool check_upper;
+
+	      dim = ss->dim[n];
+	      if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
+		continue;
+
+	      if (dim == info->ref->u.ar.dimen - 1
+		  && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
+		check_upper = false;
+	      else
+		check_upper = true;
+
+	      /* Zero stride is not allowed.  */
+	      tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+				     info->stride[dim], gfc_index_zero_node);
+	      asprintf (&msg, "Zero stride is not allowed, for dimension %d "
+			"of array '%s'", dim + 1, expr_name);
+	      gfc_trans_runtime_check (true, false, tmp, &inner,
+				       expr_loc, msg);
+	      free (msg);
+
+	      desc = info->descriptor;
+
+	      /* This is the run-time equivalent of resolve.c's
+		 check_dimension().  The logical is more readable there
+		 than it is here, with all the trees.  */
+	      lbound = gfc_conv_array_lbound (desc, dim);
+	      end = info->end[dim];
+	      if (check_upper)
+		ubound = gfc_conv_array_ubound (desc, dim);
+	      else
+		ubound = NULL;
+
+	      /* non_zerosized is true when the selected range is not
+		 empty.  */
+	      stride_pos = fold_build2_loc (input_location, GT_EXPR,
+					boolean_type_node, info->stride[dim],
+					gfc_index_zero_node);
+	      tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
+				     info->start[dim], end);
+	      stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+					    boolean_type_node, stride_pos, tmp);
+
+	      stride_neg = fold_build2_loc (input_location, LT_EXPR,
+				     boolean_type_node,
+				     info->stride[dim], gfc_index_zero_node);
+	      tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
+				     info->start[dim], end);
+	      stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+					    boolean_type_node,
+					    stride_neg, tmp);
+	      non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+					       boolean_type_node,
+					       stride_pos, stride_neg);
+
+	      /* Check the start of the range against the lower and upper
+		 bounds of the array, if the range is not empty.
+	         If upper bound is present, include both bounds in the
+		 error message.  */
+	      if (check_upper)
+		{
+		  tmp = fold_build2_loc (input_location, LT_EXPR,
+					 boolean_type_node,
+					 info->start[dim], lbound);
+		  tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+					 boolean_type_node,
+					 non_zerosized, tmp);
+		  tmp2 = fold_build2_loc (input_location, GT_EXPR,
+					  boolean_type_node,
+					  info->start[dim], ubound);
+		  tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+					  boolean_type_node,
+					  non_zerosized, tmp2);
+		  asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
+			    "outside of expected range (%%ld:%%ld)",
+			    dim + 1, expr_name);
+		  gfc_trans_runtime_check (true, false, tmp, &inner,
+					   expr_loc, msg,
+		     fold_convert (long_integer_type_node, info->start[dim]),
+		     fold_convert (long_integer_type_node, lbound),
+		     fold_convert (long_integer_type_node, ubound));
+		  gfc_trans_runtime_check (true, false, tmp2, &inner,
+					   expr_loc, msg,
+		     fold_convert (long_integer_type_node, info->start[dim]),
+		     fold_convert (long_integer_type_node, lbound),
+		     fold_convert (long_integer_type_node, ubound));
+		  free (msg);
+		}
+	      else
+		{
+		  tmp = fold_build2_loc (input_location, LT_EXPR,
+					 boolean_type_node,
+					 info->start[dim], lbound);
+		  tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+					 boolean_type_node, non_zerosized, tmp);
+		  asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
+			    "below lower bound of %%ld",
+			    dim + 1, expr_name);
+		  gfc_trans_runtime_check (true, false, tmp, &inner,
+					   expr_loc, msg,
+		     fold_convert (long_integer_type_node, info->start[dim]),
+		     fold_convert (long_integer_type_node, lbound));
+		  free (msg);
+		}
+
+	      /* Compute the last element of the range, which is not
+		 necessarily "end" (think 0:5:3, which doesn't contain 5)
+		 and check it against both lower and upper bounds.  */
+
+	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				     gfc_array_index_type, end,
+				     info->start[dim]);
+	      tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
+				     gfc_array_index_type, tmp,
+				     info->stride[dim]);
+	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				     gfc_array_index_type, end, tmp);
+	      tmp2 = fold_build2_loc (input_location, LT_EXPR,
+				      boolean_type_node, tmp, lbound);
+	      tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+				      boolean_type_node, non_zerosized, tmp2);
+	      if (check_upper)
+		{
+		  tmp3 = fold_build2_loc (input_location, GT_EXPR,
+					  boolean_type_node, tmp, ubound);
+		  tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+					  boolean_type_node, non_zerosized, tmp3);
+		  asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
+			    "outside of expected range (%%ld:%%ld)",
+			    dim + 1, expr_name);
+		  gfc_trans_runtime_check (true, false, tmp2, &inner,
+					   expr_loc, msg,
+		     fold_convert (long_integer_type_node, tmp),
+		     fold_convert (long_integer_type_node, ubound),
+		     fold_convert (long_integer_type_node, lbound));
+		  gfc_trans_runtime_check (true, false, tmp3, &inner,
+					   expr_loc, msg,
+		     fold_convert (long_integer_type_node, tmp),
+		     fold_convert (long_integer_type_node, ubound),
+		     fold_convert (long_integer_type_node, lbound));
+		  free (msg);
+		}
+	      else
+		{
+		  asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
+			    "below lower bound of %%ld",
+			    dim + 1, expr_name);
+		  gfc_trans_runtime_check (true, false, tmp2, &inner,
+					   expr_loc, msg,
+		     fold_convert (long_integer_type_node, tmp),
+		     fold_convert (long_integer_type_node, lbound));
+		  free (msg);
+		}
+
+	      /* Check the section sizes match.  */
+	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				     gfc_array_index_type, end,
+				     info->start[dim]);
+	      tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
+				     gfc_array_index_type, tmp,
+				     info->stride[dim]);
+	      tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				     gfc_array_index_type,
+				     gfc_index_one_node, tmp);
+	      tmp = fold_build2_loc (input_location, MAX_EXPR,
+				     gfc_array_index_type, tmp,
+				     build_int_cst (gfc_array_index_type, 0));
+	      /* We remember the size of the first section, and check all the
+		 others against this.  */
+	      if (size[n])
+		{
+		  tmp3 = fold_build2_loc (input_location, NE_EXPR,
+					  boolean_type_node, tmp, size[n]);
+		  asprintf (&msg, "Array bound mismatch for dimension %d "
+			    "of array '%s' (%%ld/%%ld)",
+			    dim + 1, expr_name);
+
+		  gfc_trans_runtime_check (true, false, tmp3, &inner,
+					   expr_loc, msg,
+			fold_convert (long_integer_type_node, tmp),
+			fold_convert (long_integer_type_node, size[n]));
+
+		  free (msg);
+		}
+	      else
+		size[n] = gfc_evaluate_now (tmp, &inner);
+	    }
+
+	  tmp = gfc_finish_block (&inner);
+
+	  /* For optional arguments, only check bounds if the argument is
+	     present.  */
+	  if (expr->symtree->n.sym->attr.optional
+	      || expr->symtree->n.sym->attr.not_always_present)
+	    tmp = build3_v (COND_EXPR,
+			    gfc_conv_expr_present (expr->symtree->n.sym),
+			    tmp, build_empty_stmt (input_location));
+
+	  gfc_add_expr_to_block (&block, tmp);
+
+	}
+
+      tmp = gfc_finish_block (&block);
+      gfc_add_expr_to_block (&outer_loop->pre, tmp);
+    }
+
+  for (loop = loop->nested; loop; loop = loop->next)
+    gfc_conv_ss_startstride (loop);
+}
+
+/* Return true if both symbols could refer to the same data object.  Does
+   not take account of aliasing due to equivalence statements.  */
+
+static int
+symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
+		     bool lsym_target, bool rsym_pointer, bool rsym_target)
+{
+  /* Aliasing isn't possible if the symbols have different base types.  */
+  if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
+    return 0;
+
+  /* Pointers can point to other pointers and target objects.  */
+
+  if ((lsym_pointer && (rsym_pointer || rsym_target))
+      || (rsym_pointer && (lsym_pointer || lsym_target)))
+    return 1;
+
+  /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
+     and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
+     checked above.  */
+  if (lsym_target && rsym_target
+      && ((lsym->attr.dummy && !lsym->attr.contiguous
+	   && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
+	  || (rsym->attr.dummy && !rsym->attr.contiguous
+	      && (!rsym->attr.dimension
+		  || rsym->as->type == AS_ASSUMED_SHAPE))))
+    return 1;
+
+  return 0;
+}
+
+
+/* Return true if the two SS could be aliased, i.e. both point to the same data
+   object.  */
+/* TODO: resolve aliases based on frontend expressions.  */
+
+static int
+gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
+{
+  gfc_ref *lref;
+  gfc_ref *rref;
+  gfc_expr *lexpr, *rexpr;
+  gfc_symbol *lsym;
+  gfc_symbol *rsym;
+  bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
+
+  lexpr = lss->info->expr;
+  rexpr = rss->info->expr;
+
+  lsym = lexpr->symtree->n.sym;
+  rsym = rexpr->symtree->n.sym;
+
+  lsym_pointer = lsym->attr.pointer;
+  lsym_target = lsym->attr.target;
+  rsym_pointer = rsym->attr.pointer;
+  rsym_target = rsym->attr.target;
+
+  if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
+			   rsym_pointer, rsym_target))
+    return 1;
+
+  if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
+      && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
+    return 0;
+
+  /* For derived types we must check all the component types.  We can ignore
+     array references as these will have the same base type as the previous
+     component ref.  */
+  for (lref = lexpr->ref; lref != lss->info->data.array.ref; lref = lref->next)
+    {
+      if (lref->type != REF_COMPONENT)
+	continue;
+
+      lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
+      lsym_target  = lsym_target  || lref->u.c.sym->attr.target;
+
+      if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
+			       rsym_pointer, rsym_target))
+	return 1;
+
+      if ((lsym_pointer && (rsym_pointer || rsym_target))
+	  || (rsym_pointer && (lsym_pointer || lsym_target)))
+	{
+	  if (gfc_compare_types (&lref->u.c.component->ts,
+				 &rsym->ts))
+	    return 1;
+	}
+
+      for (rref = rexpr->ref; rref != rss->info->data.array.ref;
+	   rref = rref->next)
+	{
+	  if (rref->type != REF_COMPONENT)
+	    continue;
+
+	  rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
+	  rsym_target  = lsym_target  || rref->u.c.sym->attr.target;
+
+	  if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
+				   lsym_pointer, lsym_target,
+				   rsym_pointer, rsym_target))
+	    return 1;
+
+	  if ((lsym_pointer && (rsym_pointer || rsym_target))
+	      || (rsym_pointer && (lsym_pointer || lsym_target)))
+	    {
+	      if (gfc_compare_types (&lref->u.c.component->ts,
+				     &rref->u.c.sym->ts))
+		return 1;
+	      if (gfc_compare_types (&lref->u.c.sym->ts,
+				     &rref->u.c.component->ts))
+		return 1;
+	      if (gfc_compare_types (&lref->u.c.component->ts,
+				     &rref->u.c.component->ts))
+		return 1;
+	    }
+	}
+    }
+
+  lsym_pointer = lsym->attr.pointer;
+  lsym_target = lsym->attr.target;
+  lsym_pointer = lsym->attr.pointer;
+  lsym_target = lsym->attr.target;
+
+  for (rref = rexpr->ref; rref != rss->info->data.array.ref; rref = rref->next)
+    {
+      if (rref->type != REF_COMPONENT)
+	break;
+
+      rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
+      rsym_target  = lsym_target  || rref->u.c.sym->attr.target;
+
+      if (symbols_could_alias (rref->u.c.sym, lsym,
+			       lsym_pointer, lsym_target,
+			       rsym_pointer, rsym_target))
+	return 1;
+
+      if ((lsym_pointer && (rsym_pointer || rsym_target))
+	  || (rsym_pointer && (lsym_pointer || lsym_target)))
+	{
+	  if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
+	    return 1;
+	}
+    }
+
+  return 0;
+}
+
+
+/* Resolve array data dependencies.  Creates a temporary if required.  */
+/* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
+   dependency.c.  */
+
+void
+gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
+			       gfc_ss * rss)
+{
+  gfc_ss *ss;
+  gfc_ref *lref;
+  gfc_ref *rref;
+  gfc_expr *dest_expr;
+  gfc_expr *ss_expr;
+  int nDepend = 0;
+  int i, j;
+
+  loop->temp_ss = NULL;
+  dest_expr = dest->info->expr;
+
+  for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
+    {
+      ss_expr = ss->info->expr;
+
+      if (ss->info->type != GFC_SS_SECTION)
+	{
+	  if (gfc_option.flag_realloc_lhs
+	      && dest_expr != ss_expr
+	      && gfc_is_reallocatable_lhs (dest_expr)
+	      && ss_expr->rank)
+	    nDepend = gfc_check_dependency (dest_expr, ss_expr, true);
+
+	  continue;
+	}
+
+      if (dest_expr->symtree->n.sym != ss_expr->symtree->n.sym)
+	{
+	  if (gfc_could_be_alias (dest, ss)
+	      || gfc_are_equivalenced_arrays (dest_expr, ss_expr))
+	    {
+	      nDepend = 1;
+	      break;
+	    }
+	}
+      else
+	{
+	  lref = dest_expr->ref;
+	  rref = ss_expr->ref;
+
+	  nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
+
+	  if (nDepend == 1)
+	    break;
+
+	  for (i = 0; i < dest->dimen; i++)
+	    for (j = 0; j < ss->dimen; j++)
+	      if (i != j
+		  && dest->dim[i] == ss->dim[j])
+		{
+		  /* If we don't access array elements in the same order,
+		     there is a dependency.  */
+		  nDepend = 1;
+		  goto temporary;
+		}
+#if 0
+	  /* TODO : loop shifting.  */
+	  if (nDepend == 1)
+	    {
+	      /* Mark the dimensions for LOOP SHIFTING */
+	      for (n = 0; n < loop->dimen; n++)
+	        {
+	          int dim = dest->data.info.dim[n];
+
+		  if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
+		    depends[n] = 2;
+		  else if (! gfc_is_same_range (&lref->u.ar,
+						&rref->u.ar, dim, 0))
+		    depends[n] = 1;
+	         }
+
+	      /* Put all the dimensions with dependencies in the
+		 innermost loops.  */
+	      dim = 0;
+	      for (n = 0; n < loop->dimen; n++)
+		{
+		  gcc_assert (loop->order[n] == n);
+		  if (depends[n])
+		  loop->order[dim++] = n;
+		}
+	      for (n = 0; n < loop->dimen; n++)
+	        {
+		  if (! depends[n])
+		  loop->order[dim++] = n;
+		}
+
+	      gcc_assert (dim == loop->dimen);
+	      break;
+	    }
+#endif
+	}
+    }
+
+temporary:
+
+  if (nDepend == 1)
+    {
+      tree base_type = gfc_typenode_for_spec (&dest_expr->ts);
+      if (GFC_ARRAY_TYPE_P (base_type)
+	  || GFC_DESCRIPTOR_TYPE_P (base_type))
+	base_type = gfc_get_element_type (base_type);
+      loop->temp_ss = gfc_get_temp_ss (base_type, dest->info->string_length,
+				       loop->dimen);
+      gfc_add_ss_to_loop (loop, loop->temp_ss);
+    }
+  else
+    loop->temp_ss = NULL;
+}
+
+
+/* Browse through each array's information from the scalarizer and set the loop
+   bounds according to the "best" one (per dimension), i.e. the one which
+   provides the most information (constant bounds, shape, etc.).  */
+
+static void
+set_loop_bounds (gfc_loopinfo *loop)
+{
+  int n, dim, spec_dim;
+  gfc_array_info *info;
+  gfc_array_info *specinfo;
+  gfc_ss *ss;
+  tree tmp;
+  gfc_ss **loopspec;
+  bool dynamic[GFC_MAX_DIMENSIONS];
+  mpz_t *cshape;
+  mpz_t i;
+  bool nonoptional_arr;
+
+  gfc_loopinfo * const outer_loop = outermost_loop (loop);
+
+  loopspec = loop->specloop;
+
+  mpz_init (i);
+  for (n = 0; n < loop->dimen; n++)
+    {
+      loopspec[n] = NULL;
+      dynamic[n] = false;
+
+      /* If there are both optional and nonoptional array arguments, scalarize
+	 over the nonoptional; otherwise, it does not matter as then all
+	 (optional) arrays have to be present per F2008, 125.2.12p3(6).  */
+
+      nonoptional_arr = false;
+
+      for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
+	if (ss->info->type != GFC_SS_SCALAR && ss->info->type != GFC_SS_TEMP
+	    && ss->info->type != GFC_SS_REFERENCE && !ss->info->can_be_null_ref)
+	  {
+	    nonoptional_arr = true;
+	    break;
+	  }
+
+      /* We use one SS term, and use that to determine the bounds of the
+	 loop for this dimension.  We try to pick the simplest term.  */
+      for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
+	{
+	  gfc_ss_type ss_type;
+
+	  ss_type = ss->info->type;
+	  if (ss_type == GFC_SS_SCALAR
+	      || ss_type == GFC_SS_TEMP
+	      || ss_type == GFC_SS_REFERENCE
+	      || (ss->info->can_be_null_ref && nonoptional_arr))
+	    continue;
+
+	  info = &ss->info->data.array;
+	  dim = ss->dim[n];
+
+	  if (loopspec[n] != NULL)
+	    {
+	      specinfo = &loopspec[n]->info->data.array;
+	      spec_dim = loopspec[n]->dim[n];
+	    }
+	  else
+	    {
+	      /* Silence uninitialized warnings.  */
+	      specinfo = NULL;
+	      spec_dim = 0;
+	    }
+
+	  if (info->shape)
+	    {
+	      gcc_assert (info->shape[dim]);
+	      /* The frontend has worked out the size for us.  */
+	      if (!loopspec[n]
+		  || !specinfo->shape
+		  || !integer_zerop (specinfo->start[spec_dim]))
+		/* Prefer zero-based descriptors if possible.  */
+		loopspec[n] = ss;
+	      continue;
+	    }
+
+	  if (ss_type == GFC_SS_CONSTRUCTOR)
+	    {
+	      gfc_constructor_base base;
+	      /* An unknown size constructor will always be rank one.
+		 Higher rank constructors will either have known shape,
+		 or still be wrapped in a call to reshape.  */
+	      gcc_assert (loop->dimen == 1);
+
+	      /* Always prefer to use the constructor bounds if the size
+		 can be determined at compile time.  Prefer not to otherwise,
+		 since the general case involves realloc, and it's better to
+		 avoid that overhead if possible.  */
+	      base = ss->info->expr->value.constructor;
+	      dynamic[n] = gfc_get_array_constructor_size (&i, base);
+	      if (!dynamic[n] || !loopspec[n])
+		loopspec[n] = ss;
+	      continue;
+	    }
+
+	  /* Avoid using an allocatable lhs in an assignment, since
+	     there might be a reallocation coming.  */
+	  if (loopspec[n] && ss->is_alloc_lhs)
+	    continue;
+
+	  if (!loopspec[n])
+	    loopspec[n] = ss;
+	  /* Criteria for choosing a loop specifier (most important first):
+	     doesn't need realloc
+	     stride of one
+	     known stride
+	     known lower bound
+	     known upper bound
+	   */
+	  else if (loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n])
+	    loopspec[n] = ss;
+	  else if (integer_onep (info->stride[dim])
+		   && !integer_onep (specinfo->stride[spec_dim]))
+	    loopspec[n] = ss;
+	  else if (INTEGER_CST_P (info->stride[dim])
+		   && !INTEGER_CST_P (specinfo->stride[spec_dim]))
+	    loopspec[n] = ss;
+	  else if (INTEGER_CST_P (info->start[dim])
+		   && !INTEGER_CST_P (specinfo->start[spec_dim])
+		   && integer_onep (info->stride[dim])
+		      == integer_onep (specinfo->stride[spec_dim])
+		   && INTEGER_CST_P (info->stride[dim])
+		      == INTEGER_CST_P (specinfo->stride[spec_dim]))
+	    loopspec[n] = ss;
+	  /* We don't work out the upper bound.
+	     else if (INTEGER_CST_P (info->finish[n])
+	     && ! INTEGER_CST_P (specinfo->finish[n]))
+	     loopspec[n] = ss; */
+	}
+
+      /* We should have found the scalarization loop specifier.  If not,
+	 that's bad news.  */
+      gcc_assert (loopspec[n]);
+
+      info = &loopspec[n]->info->data.array;
+      dim = loopspec[n]->dim[n];
+
+      /* Set the extents of this range.  */
+      cshape = info->shape;
+      if (cshape && INTEGER_CST_P (info->start[dim])
+	  && INTEGER_CST_P (info->stride[dim]))
+	{
+	  loop->from[n] = info->start[dim];
+	  mpz_set (i, cshape[get_array_ref_dim_for_loop_dim (loopspec[n], n)]);
+	  mpz_sub_ui (i, i, 1);
+	  /* To = from + (size - 1) * stride.  */
+	  tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
+	  if (!integer_onep (info->stride[dim]))
+	    tmp = fold_build2_loc (input_location, MULT_EXPR,
+				   gfc_array_index_type, tmp,
+				   info->stride[dim]);
+	  loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
+					 gfc_array_index_type,
+					 loop->from[n], tmp);
+	}
+      else
+	{
+	  loop->from[n] = info->start[dim];
+	  switch (loopspec[n]->info->type)
+	    {
+	    case GFC_SS_CONSTRUCTOR:
+	      /* The upper bound is calculated when we expand the
+		 constructor.  */
+	      gcc_assert (loop->to[n] == NULL_TREE);
+	      break;
+
+	    case GFC_SS_SECTION:
+	      /* Use the end expression if it exists and is not constant,
+		 so that it is only evaluated once.  */
+	      loop->to[n] = info->end[dim];
+	      break;
+
+	    case GFC_SS_FUNCTION:
+	      /* The loop bound will be set when we generate the call.  */
+	      gcc_assert (loop->to[n] == NULL_TREE);
+	      break;
+
+	    case GFC_SS_INTRINSIC:
+	      {
+		gfc_expr *expr = loopspec[n]->info->expr;
+
+		/* The {l,u}bound of an assumed rank.  */
+		gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND
+			     || expr->value.function.isym->id == GFC_ISYM_UBOUND)
+			     && expr->value.function.actual->next->expr == NULL
+			     && expr->value.function.actual->expr->rank == -1);
+
+		loop->to[n] = info->end[dim];
+		break;
+	      }
+
+	    default:
+	      gcc_unreachable ();
+	    }
+	}
+
+      /* Transform everything so we have a simple incrementing variable.  */
+      if (integer_onep (info->stride[dim]))
+	info->delta[dim] = gfc_index_zero_node;
+      else
+	{
+	  /* Set the delta for this section.  */
+	  info->delta[dim] = gfc_evaluate_now (loop->from[n], &outer_loop->pre);
+	  /* Number of iterations is (end - start + step) / step.
+	     with start = 0, this simplifies to
+	     last = end / step;
+	     for (i = 0; i<=last; i++){...};  */
+	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				 gfc_array_index_type, loop->to[n],
+				 loop->from[n]);
+	  tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
+				 gfc_array_index_type, tmp, info->stride[dim]);
+	  tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
+				 tmp, build_int_cst (gfc_array_index_type, -1));
+	  loop->to[n] = gfc_evaluate_now (tmp, &outer_loop->pre);
+	  /* Make the loop variable start at 0.  */
+	  loop->from[n] = gfc_index_zero_node;
+	}
+    }
+  mpz_clear (i);
+
+  for (loop = loop->nested; loop; loop = loop->next)
+    set_loop_bounds (loop);
+}
+
+
+/* Initialize the scalarization loop.  Creates the loop variables.  Determines
+   the range of the loop variables.  Creates a temporary if required.
+   Also generates code for scalar expressions which have been
+   moved outside the loop.  */
+
+void
+gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
+{
+  gfc_ss *tmp_ss;
+  tree tmp;
+
+  set_loop_bounds (loop);
+
+  /* Add all the scalar code that can be taken out of the loops.
+     This may include calculating the loop bounds, so do it before
+     allocating the temporary.  */
+  gfc_add_loop_ss_code (loop, loop->ss, false, where);
+
+  tmp_ss = loop->temp_ss;
+  /* If we want a temporary then create it.  */
+  if (tmp_ss != NULL)
+    {
+      gfc_ss_info *tmp_ss_info;
+
+      tmp_ss_info = tmp_ss->info;
+      gcc_assert (tmp_ss_info->type == GFC_SS_TEMP);
+      gcc_assert (loop->parent == NULL);
+
+      /* Make absolutely sure that this is a complete type.  */
+      if (tmp_ss_info->string_length)
+	tmp_ss_info->data.temp.type
+		= gfc_get_character_type_len_for_eltype
+			(TREE_TYPE (tmp_ss_info->data.temp.type),
+			 tmp_ss_info->string_length);
+
+      tmp = tmp_ss_info->data.temp.type;
+      memset (&tmp_ss_info->data.array, 0, sizeof (gfc_array_info));
+      tmp_ss_info->type = GFC_SS_SECTION;
+
+      gcc_assert (tmp_ss->dimen != 0);
+
+      gfc_trans_create_temp_array (&loop->pre, &loop->post, tmp_ss, tmp,
+				   NULL_TREE, false, true, false, where);
+    }
+
+  /* For array parameters we don't have loop variables, so don't calculate the
+     translations.  */
+  if (!loop->array_parameter)
+    gfc_set_delta (loop);
+}
+
+
+/* Calculates how to transform from loop variables to array indices for each
+   array: once loop bounds are chosen, sets the difference (DELTA field) between
+   loop bounds and array reference bounds, for each array info.  */
+
+void
+gfc_set_delta (gfc_loopinfo *loop)
+{
+  gfc_ss *ss, **loopspec;
+  gfc_array_info *info;
+  tree tmp;
+  int n, dim;
+
+  gfc_loopinfo * const outer_loop = outermost_loop (loop);
+
+  loopspec = loop->specloop;
+
+  /* Calculate the translation from loop variables to array indices.  */
+  for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
+    {
+      gfc_ss_type ss_type;
+
+      ss_type = ss->info->type;
+      if (ss_type != GFC_SS_SECTION
+	  && ss_type != GFC_SS_COMPONENT
+	  && ss_type != GFC_SS_CONSTRUCTOR)
+	continue;
+
+      info = &ss->info->data.array;
+
+      for (n = 0; n < ss->dimen; n++)
+	{
+	  /* If we are specifying the range the delta is already set.  */
+	  if (loopspec[n] != ss)
+	    {
+	      dim = ss->dim[n];
+
+	      /* Calculate the offset relative to the loop variable.
+		 First multiply by the stride.  */
+	      tmp = loop->from[n];
+	      if (!integer_onep (info->stride[dim]))
+		tmp = fold_build2_loc (input_location, MULT_EXPR,
+				       gfc_array_index_type,
+				       tmp, info->stride[dim]);
+
+	      /* Then subtract this from our starting value.  */
+	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				     gfc_array_index_type,
+				     info->start[dim], tmp);
+
+	      info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre);
+	    }
+	}
+    }
+
+  for (loop = loop->nested; loop; loop = loop->next)
+    gfc_set_delta (loop);
+}
+
+
+/* Calculate the size of a given array dimension from the bounds.  This
+   is simply (ubound - lbound + 1) if this expression is positive
+   or 0 if it is negative (pick either one if it is zero).  Optionally
+   (if or_expr is present) OR the (expression != 0) condition to it.  */
+
+tree
+gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
+{
+  tree res;
+  tree cond;
+
+  /* Calculate (ubound - lbound + 1).  */
+  res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			 ubound, lbound);
+  res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
+			 gfc_index_one_node);
+
+  /* Check whether the size for this dimension is negative.  */
+  cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, res,
+			  gfc_index_zero_node);
+  res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
+			 gfc_index_zero_node, res);
+
+  /* Build OR expression.  */
+  if (or_expr)
+    *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+				boolean_type_node, *or_expr, cond);
+
+  return res;
+}
+
+
+/* For an array descriptor, get the total number of elements.  This is just
+   the product of the extents along from_dim to to_dim.  */
+
+static tree
+gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
+{
+  tree res;
+  int dim;
+
+  res = gfc_index_one_node;
+
+  for (dim = from_dim; dim < to_dim; ++dim)
+    {
+      tree lbound;
+      tree ubound;
+      tree extent;
+
+      lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
+      ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
+
+      extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+      res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			     res, extent);
+    }
+
+  return res;
+}
+
+
+/* Full size of an array.  */
+
+tree
+gfc_conv_descriptor_size (tree desc, int rank)
+{
+  return gfc_conv_descriptor_size_1 (desc, 0, rank);
+}
+
+
+/* Size of a coarray for all dimensions but the last.  */
+
+tree
+gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
+{
+  return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
+}
+
+
+/* Fills in an array descriptor, and returns the size of the array.
+   The size will be a simple_val, ie a variable or a constant.  Also
+   calculates the offset of the base.  The pointer argument overflow,
+   which should be of integer type, will increase in value if overflow
+   occurs during the size calculation.  Returns the size of the array.
+   {
+    stride = 1;
+    offset = 0;
+    for (n = 0; n < rank; n++)
+      {
+	a.lbound[n] = specified_lower_bound;
+	offset = offset + a.lbond[n] * stride;
+	size = 1 - lbound;
+	a.ubound[n] = specified_upper_bound;
+	a.stride[n] = stride;
+	size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
+	overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
+	stride = stride * size;
+      }
+    for (n = rank; n < rank+corank; n++)
+      (Set lcobound/ucobound as above.)
+    element_size = sizeof (array element);
+    if (!rank)
+      return element_size
+    stride = (size_t) stride;
+    overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
+    stride = stride * element_size;
+    return (stride);
+   }  */
+/*GCC ARRAYS*/
+
+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,
+		     gfc_typespec *ts)
+{
+  tree type;
+  tree tmp;
+  tree size;
+  tree offset;
+  tree stride;
+  tree element_size;
+  tree or_expr;
+  tree thencase;
+  tree elsecase;
+  tree cond;
+  tree var;
+  stmtblock_t thenblock;
+  stmtblock_t elseblock;
+  gfc_expr *ubound;
+  gfc_se se;
+  int n;
+
+  type = TREE_TYPE (descriptor);
+
+  stride = gfc_index_one_node;
+  offset = gfc_index_zero_node;
+
+  /* Set the dtype.  */
+  tmp = gfc_conv_descriptor_dtype (descriptor);
+  gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
+
+  or_expr = boolean_false_node;
+
+  for (n = 0; n < rank; n++)
+    {
+      tree conv_lbound;
+      tree conv_ubound;
+
+      /* We have 3 possibilities for determining the size of the array:
+	 lower == NULL    => lbound = 1, ubound = upper[n]
+	 upper[n] = NULL  => lbound = 1, ubound = lower[n]
+	 upper[n] != NULL => lbound = lower[n], ubound = upper[n]  */
+      ubound = upper[n];
+
+      /* Set lower bound.  */
+      gfc_init_se (&se, NULL);
+      if (lower == NULL)
+	se.expr = gfc_index_one_node;
+      else
+	{
+	  gcc_assert (lower[n]);
+	  if (ubound)
+	    {
+	      gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
+	      gfc_add_block_to_block (pblock, &se.pre);
+	    }
+	  else
+	    {
+	      se.expr = gfc_index_one_node;
+	      ubound = lower[n];
+	    }
+	}
+      gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
+				      gfc_rank_cst[n], se.expr);
+      conv_lbound = se.expr;
+
+      /* Work out the offset for this component.  */
+      tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			     se.expr, stride);
+      offset = fold_build2_loc (input_location, MINUS_EXPR,
+				gfc_array_index_type, offset, tmp);
+
+      /* Set upper bound.  */
+      gfc_init_se (&se, NULL);
+      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;
+
+      /* Store the stride.  */
+      gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
+				      gfc_rank_cst[n], stride);
+
+      /* Calculate size and check whether extent is negative.  */
+      size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
+      size = gfc_evaluate_now (size, pblock);
+
+      /* Check whether multiplying the stride by the number of
+	 elements in this dimension would overflow. We must also check
+	 whether the current dimension has zero size in order to avoid
+	 division by zero.
+      */
+      tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+			     gfc_array_index_type,
+			     fold_convert (gfc_array_index_type,
+					   TYPE_MAX_VALUE (gfc_array_index_type)),
+					   size);
+      cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
+					    boolean_type_node, tmp, stride),
+			   PRED_FORTRAN_OVERFLOW);
+      tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
+			     integer_one_node, integer_zero_node);
+      cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
+					    boolean_type_node, size,
+					    gfc_index_zero_node),
+			   PRED_FORTRAN_SIZE_ZERO);
+      tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
+			     integer_zero_node, tmp);
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
+			     *overflow, tmp);
+      *overflow = gfc_evaluate_now (tmp, pblock);
+
+      /* Multiply the stride by the number of elements in this dimension.  */
+      stride = fold_build2_loc (input_location, MULT_EXPR,
+				gfc_array_index_type, stride, size);
+      stride = gfc_evaluate_now (stride, pblock);
+    }
+
+  for (n = rank; n < rank + corank; n++)
+    {
+      ubound = upper[n];
+
+      /* Set lower bound.  */
+      gfc_init_se (&se, NULL);
+      if (lower == NULL || lower[n] == NULL)
+	{
+	  gcc_assert (n == rank + corank - 1);
+	  se.expr = gfc_index_one_node;
+	}
+      else
+	{
+	  if (ubound || n == rank + corank - 1)
+	    {
+	      gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
+	      gfc_add_block_to_block (pblock, &se.pre);
+	    }
+	  else
+	    {
+	      se.expr = gfc_index_one_node;
+	      ubound = lower[n];
+	    }
+	}
+      gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
+				      gfc_rank_cst[n], se.expr);
+
+      if (n < rank + corank - 1)
+	{
+	  gfc_init_se (&se, NULL);
+	  gcc_assert (ubound);
+	  gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
+	  gfc_add_block_to_block (pblock, &se.pre);
+	  gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
+					  gfc_rank_cst[n], se.expr);
+	}
+    }
+
+  /* The stride is the number of elements in the array, so multiply by the
+     size of an element to get the total size.  Obviously, if there is a
+     SOURCE expression (expr3) we must use its element size.  */
+  if (expr3_elem_size != NULL_TREE)
+    tmp = expr3_elem_size;
+  else if (expr3 != NULL)
+    {
+      if (expr3->ts.type == BT_CLASS)
+	{
+	  gfc_se se_sz;
+	  gfc_expr *sz = gfc_copy_expr (expr3);
+	  gfc_add_vptr_component (sz);
+	  gfc_add_size_component (sz);
+	  gfc_init_se (&se_sz, NULL);
+	  gfc_conv_expr (&se_sz, sz);
+	  gfc_free_expr (sz);
+	  tmp = se_sz.expr;
+	}
+      else
+	{
+	  tmp = gfc_typenode_for_spec (&expr3->ts);
+	  tmp = TYPE_SIZE_UNIT (tmp);
+	}
+    }
+  else if (ts->type != BT_UNKNOWN && ts->type != BT_CHARACTER)
+    /* FIXME: Properly handle characters.  See PR 57456.  */
+    tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (ts));
+  else
+    tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
+
+  /* Convert to size_t.  */
+  element_size = fold_convert (size_type_node, tmp);
+
+  if (rank == 0)
+    return element_size;
+
+  *nelems = gfc_evaluate_now (stride, pblock);
+  stride = fold_convert (size_type_node, stride);
+
+  /* First check for overflow. Since an array of type character can
+     have zero element_size, we must check for that before
+     dividing.  */
+  tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+			 size_type_node,
+			 TYPE_MAX_VALUE (size_type_node), element_size);
+  cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
+					boolean_type_node, tmp, stride),
+		       PRED_FORTRAN_OVERFLOW);
+  tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
+			 integer_one_node, integer_zero_node);
+  cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
+					boolean_type_node, element_size,
+					build_int_cst (size_type_node, 0)),
+		       PRED_FORTRAN_SIZE_ZERO);
+  tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
+			 integer_zero_node, tmp);
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
+			 *overflow, tmp);
+  *overflow = gfc_evaluate_now (tmp, pblock);
+
+  size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
+			  stride, element_size);
+
+  if (poffset != NULL)
+    {
+      offset = gfc_evaluate_now (offset, pblock);
+      *poffset = offset;
+    }
+
+  if (integer_zerop (or_expr))
+    return size;
+  if (integer_onep (or_expr))
+    return build_int_cst (size_type_node, 0);
+
+  var = gfc_create_var (TREE_TYPE (size), "size");
+  gfc_start_block (&thenblock);
+  gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
+  thencase = gfc_finish_block (&thenblock);
+
+  gfc_start_block (&elseblock);
+  gfc_add_modify (&elseblock, var, size);
+  elsecase = gfc_finish_block (&elseblock);
+
+  tmp = gfc_evaluate_now (or_expr, pblock);
+  tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
+  gfc_add_expr_to_block (pblock, tmp);
+
+  return var;
+}
+
+
+/* Initializes the descriptor and generates a call to _gfor_allocate.  Does
+   the work for an ALLOCATE statement.  */
+/*GCC ARRAYS*/
+
+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, gfc_typespec *ts)
+{
+  tree tmp;
+  tree pointer;
+  tree offset = NULL_TREE;
+  tree token = NULL_TREE;
+  tree size;
+  tree msg;
+  tree error = NULL_TREE;
+  tree overflow; /* Boolean storing whether size calculation overflows.  */
+  tree var_overflow = NULL_TREE;
+  tree cond;
+  tree set_descriptor;
+  stmtblock_t set_descriptor_block;
+  stmtblock_t elseblock;
+  gfc_expr **lower;
+  gfc_expr **upper;
+  gfc_ref *ref, *prev_ref = NULL;
+  bool allocatable, coarray, dimension;
+
+  ref = expr->ref;
+
+  /* Find the last reference in the chain.  */
+  while (ref && ref->next != NULL)
+    {
+      gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
+		  || (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;
+
+  if (!prev_ref)
+    {
+      allocatable = expr->symtree->n.sym->attr.allocatable;
+      coarray = expr->symtree->n.sym->attr.codimension;
+      dimension = expr->symtree->n.sym->attr.dimension;
+    }
+  else
+    {
+      allocatable = prev_ref->u.c.component->attr.allocatable;
+      coarray = prev_ref->u.c.component->attr.codimension;
+      dimension = prev_ref->u.c.component->attr.dimension;
+    }
+
+  if (!dimension)
+    gcc_assert (coarray);
+
+  /* Figure out the size of the array.  */
+  switch (ref->u.ar.type)
+    {
+    case AR_ELEMENT:
+      if (!coarray)
+	{
+	  lower = NULL;
+	  upper = ref->u.ar.start;
+	  break;
+	}
+      /* Fall through.  */
+
+    case AR_SECTION:
+      lower = ref->u.ar.start;
+      upper = ref->u.ar.end;
+      break;
+
+    case AR_FULL:
+      gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
+
+      lower = ref->u.ar.as->lower;
+      upper = ref->u.ar.as->upper;
+      break;
+
+    default:
+      gcc_unreachable ();
+      break;
+    }
+
+  overflow = integer_zero_node;
+
+  gfc_init_block (&set_descriptor_block);
+  size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
+			      ref->u.ar.as->corank, &offset, lower, upper,
+			      &se->pre, &set_descriptor_block, &overflow,
+			      expr3_elem_size, nelems, expr3, ts);
+
+  if (dimension)
+    {
+      var_overflow = gfc_create_var (integer_type_node, "overflow");
+      gfc_add_modify (&se->pre, var_overflow, overflow);
+
+      if (status == NULL_TREE)
+	{
+	  /* Generate the block of code handling overflow.  */
+	  msg = gfc_build_addr_expr (pchar_type_node,
+		    gfc_build_localized_cstring_const
+  			("Integer overflow when calculating the amount of "
+  			 "memory to allocate"));
+	  error = build_call_expr_loc (input_location,
+				       gfor_fndecl_runtime_error, 1, msg);
+	}
+      else
+	{
+	  tree status_type = TREE_TYPE (status);
+	  stmtblock_t set_status_block;
+
+	  gfc_start_block (&set_status_block);
+	  gfc_add_modify (&set_status_block, status,
+			  build_int_cst (status_type, LIBERROR_ALLOCATION));
+	  error = gfc_finish_block (&set_status_block);
+	}
+    }
+
+  gfc_start_block (&elseblock);
+
+  /* Allocate memory to store the data.  */
+  if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
+    se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
+
+  pointer = gfc_conv_descriptor_data_get (se->expr);
+  STRIP_NOPS (pointer);
+
+  if (coarray && gfc_option.coarray == GFC_FCOARRAY_LIB)
+    token = gfc_build_addr_expr (NULL_TREE,
+				 gfc_conv_descriptor_token (se->expr));
+
+  /* The allocatable variant takes the old pointer as first argument.  */
+  if (allocatable)
+    gfc_allocate_allocatable (&elseblock, pointer, size, token,
+			      status, errmsg, errlen, label_finish, expr);
+  else
+    gfc_allocate_using_malloc (&elseblock, pointer, size, status);
+
+  if (dimension)
+    {
+      cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
+			   boolean_type_node, var_overflow, integer_zero_node),
+			   PRED_FORTRAN_OVERFLOW);
+      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+			     error, gfc_finish_block (&elseblock));
+    }
+  else
+    tmp = gfc_finish_block (&elseblock);
+
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  /* Update the array descriptors. */
+  if (dimension)
+    gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
+
+  set_descriptor = gfc_finish_block (&set_descriptor_block);
+  if (status != NULL_TREE)
+    {
+      cond = fold_build2_loc (input_location, EQ_EXPR,
+			  boolean_type_node, status,
+			  build_int_cst (TREE_TYPE (status), 0));
+      gfc_add_expr_to_block (&se->pre,
+		 fold_build3_loc (input_location, COND_EXPR, void_type_node,
+				  gfc_likely (cond, PRED_FORTRAN_FAIL_ALLOC),
+				  set_descriptor,
+				  build_empty_stmt (input_location)));
+    }
+  else
+      gfc_add_expr_to_block (&se->pre, set_descriptor);
+
+  if ((expr->ts.type == BT_DERIVED)
+	&& expr->ts.u.derived->attr.alloc_comp)
+    {
+      tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
+				    ref->u.ar.as->rank);
+      gfc_add_expr_to_block (&se->pre, tmp);
+    }
+
+  return true;
+}
+
+
+/* Deallocate an array variable.  Also used when an allocated variable goes
+   out of scope.  */
+/*GCC ARRAYS*/
+
+tree
+gfc_array_deallocate (tree descriptor, tree pstat, tree errmsg, tree errlen,
+		      tree label_finish, gfc_expr* expr)
+{
+  tree var;
+  tree tmp;
+  stmtblock_t block;
+  bool coarray = gfc_is_coarray (expr);
+
+  gfc_start_block (&block);
+
+  /* Get a pointer to the data.  */
+  var = gfc_conv_descriptor_data_get (descriptor);
+  STRIP_NOPS (var);
+
+  /* Parameter is the address of the data component.  */
+  tmp = gfc_deallocate_with_status (coarray ? descriptor : var, pstat, errmsg,
+				    errlen, label_finish, false, expr, coarray);
+  gfc_add_expr_to_block (&block, tmp);
+
+  /* Zero the data pointer; only for coarrays an error can occur and then
+     the allocation status may not be changed.  */
+  tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+			 var, build_int_cst (TREE_TYPE (var), 0));
+  if (pstat != NULL_TREE && coarray && gfc_option.coarray == GFC_FCOARRAY_LIB)
+    {
+      tree cond;
+      tree stat = build_fold_indirect_ref_loc (input_location, pstat);
+
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+			      stat, build_int_cst (TREE_TYPE (stat), 0));
+      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+			     cond, tmp, build_empty_stmt (input_location));
+    }
+
+  gfc_add_expr_to_block (&block, tmp);
+
+  return gfc_finish_block (&block);
+}
+
+
+/* Create an array constructor from an initialization expression.
+   We assume the frontend already did any expansions and conversions.  */
+
+tree
+gfc_conv_array_initializer (tree type, gfc_expr * expr)
+{
+  gfc_constructor *c;
+  tree tmp;
+  gfc_se se;
+  HOST_WIDE_INT hi;
+  unsigned HOST_WIDE_INT lo;
+  tree index, range;
+  vec<constructor_elt, va_gc> *v = NULL;
+
+  if (expr->expr_type == EXPR_VARIABLE
+      && expr->symtree->n.sym->attr.flavor == FL_PARAMETER
+      && expr->symtree->n.sym->value)
+    expr = expr->symtree->n.sym->value;
+
+  switch (expr->expr_type)
+    {
+    case EXPR_CONSTANT:
+    case EXPR_STRUCTURE:
+      /* A single scalar or derived type value.  Create an array with all
+         elements equal to that value.  */
+      gfc_init_se (&se, NULL);
+
+      if (expr->expr_type == EXPR_CONSTANT)
+	gfc_conv_constant (&se, expr);
+      else
+	gfc_conv_structure (&se, expr, 1);
+
+      tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
+      gcc_assert (tmp && INTEGER_CST_P (tmp));
+      hi = TREE_INT_CST_HIGH (tmp);
+      lo = TREE_INT_CST_LOW (tmp);
+      lo++;
+      if (lo == 0)
+	hi++;
+      /* This will probably eat buckets of memory for large arrays.  */
+      while (hi != 0 || lo != 0)
+        {
+	  CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
+          if (lo == 0)
+            hi--;
+          lo--;
+        }
+      break;
+
+    case EXPR_ARRAY:
+      /* Create a vector of all the elements.  */
+      for (c = gfc_constructor_first (expr->value.constructor);
+	   c; c = gfc_constructor_next (c))
+        {
+          if (c->iterator)
+            {
+              /* Problems occur when we get something like
+                 integer :: a(lots) = (/(i, i=1, lots)/)  */
+              gfc_fatal_error ("The number of elements in the array constructor "
+			       "at %L requires an increase of the allowed %d "
+			       "upper limit.   See -fmax-array-constructor "
+			       "option", &expr->where,
+			       gfc_option.flag_max_array_constructor);
+	      return NULL_TREE;
+	    }
+          if (mpz_cmp_si (c->offset, 0) != 0)
+            index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
+          else
+            index = NULL_TREE;
+
+	  if (mpz_cmp_si (c->repeat, 1) > 0)
+	    {
+	      tree tmp1, tmp2;
+	      mpz_t maxval;
+
+	      mpz_init (maxval);
+	      mpz_add (maxval, c->offset, c->repeat);
+	      mpz_sub_ui (maxval, maxval, 1);
+	      tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
+	      if (mpz_cmp_si (c->offset, 0) != 0)
+		{
+		  mpz_add_ui (maxval, c->offset, 1);
+		  tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
+		}
+	      else
+		tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
+
+	      range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2);
+	      mpz_clear (maxval);
+	    }
+	  else
+	    range = NULL;
+
+          gfc_init_se (&se, NULL);
+	  switch (c->expr->expr_type)
+	    {
+	    case EXPR_CONSTANT:
+	      gfc_conv_constant (&se, c->expr);
+	      break;
+
+	    case EXPR_STRUCTURE:
+              gfc_conv_structure (&se, c->expr, 1);
+	      break;
+
+	    default:
+	      /* Catch those occasional beasts that do not simplify
+		 for one reason or another, assuming that if they are
+		 standard defying the frontend will catch them.  */
+	      gfc_conv_expr (&se, c->expr);
+	      break;
+	    }
+
+	  if (range == NULL_TREE)
+	    CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
+	  else
+	    {
+	      if (index != NULL_TREE)
+		CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
+	      CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
+	    }
+        }
+      break;
+
+    case EXPR_NULL:
+      return gfc_build_null_descriptor (type);
+
+    default:
+      gcc_unreachable ();
+    }
+
+  /* Create a constructor from the list of elements.  */
+  tmp = build_constructor (type, v);
+  TREE_CONSTANT (tmp) = 1;
+  return tmp;
+}
+
+
+/* Generate code to evaluate non-constant coarray cobounds.  */
+
+void
+gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
+			  const gfc_symbol *sym)
+{
+  int dim;
+  tree ubound;
+  tree lbound;
+  gfc_se se;
+  gfc_array_spec *as;
+
+  as = sym->as;
+
+  for (dim = as->rank; dim < as->rank + as->corank; dim++)
+    {
+      /* Evaluate non-constant array bound expressions.  */
+      lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
+      if (as->lower[dim] && !INTEGER_CST_P (lbound))
+        {
+          gfc_init_se (&se, NULL);
+          gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
+          gfc_add_block_to_block (pblock, &se.pre);
+          gfc_add_modify (pblock, lbound, se.expr);
+        }
+      ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
+      if (as->upper[dim] && !INTEGER_CST_P (ubound))
+        {
+          gfc_init_se (&se, NULL);
+          gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
+          gfc_add_block_to_block (pblock, &se.pre);
+          gfc_add_modify (pblock, ubound, se.expr);
+        }
+    }
+}
+
+
+/* Generate code to evaluate non-constant array bounds.  Sets *poffset and
+   returns the size (in elements) of the array.  */
+
+static tree
+gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
+                        stmtblock_t * pblock)
+{
+  gfc_array_spec *as;
+  tree size;
+  tree stride;
+  tree offset;
+  tree ubound;
+  tree lbound;
+  tree tmp;
+  gfc_se se;
+
+  int dim;
+
+  as = sym->as;
+
+  size = gfc_index_one_node;
+  offset = gfc_index_zero_node;
+  for (dim = 0; dim < as->rank; dim++)
+    {
+      /* Evaluate non-constant array bound expressions.  */
+      lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
+      if (as->lower[dim] && !INTEGER_CST_P (lbound))
+        {
+          gfc_init_se (&se, NULL);
+          gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
+          gfc_add_block_to_block (pblock, &se.pre);
+          gfc_add_modify (pblock, lbound, se.expr);
+        }
+      ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
+      if (as->upper[dim] && !INTEGER_CST_P (ubound))
+        {
+          gfc_init_se (&se, NULL);
+          gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
+          gfc_add_block_to_block (pblock, &se.pre);
+          gfc_add_modify (pblock, ubound, se.expr);
+        }
+      /* The offset of this dimension.  offset = offset - lbound * stride.  */
+      tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			     lbound, size);
+      offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+				offset, tmp);
+
+      /* The size of this dimension, and the stride of the next.  */
+      if (dim + 1 < as->rank)
+        stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
+      else
+	stride = GFC_TYPE_ARRAY_SIZE (type);
+
+      if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
+        {
+          /* Calculate stride = size * (ubound + 1 - lbound).  */
+          tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				 gfc_array_index_type,
+				 gfc_index_one_node, lbound);
+          tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type, ubound, tmp);
+          tmp = fold_build2_loc (input_location, MULT_EXPR,
+				 gfc_array_index_type, size, tmp);
+          if (stride)
+            gfc_add_modify (pblock, stride, tmp);
+          else
+            stride = gfc_evaluate_now (tmp, pblock);
+
+	  /* Make sure that negative size arrays are translated
+	     to being zero size.  */
+	  tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
+				 stride, gfc_index_zero_node);
+	  tmp = fold_build3_loc (input_location, COND_EXPR,
+				 gfc_array_index_type, tmp,
+				 stride, gfc_index_zero_node);
+	  gfc_add_modify (pblock, stride, tmp);
+        }
+
+      size = stride;
+    }
+
+  gfc_trans_array_cobounds (type, pblock, sym);
+  gfc_trans_vla_type_sizes (sym, pblock);
+
+  *poffset = offset;
+  return size;
+}
+
+
+/* Generate code to initialize/allocate an array variable.  */
+
+void
+gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
+				 gfc_wrapped_block * block)
+{
+  stmtblock_t init;
+  tree type;
+  tree tmp = NULL_TREE;
+  tree size;
+  tree offset;
+  tree space;
+  tree inittree;
+  bool onstack;
+
+  gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
+
+  /* Do nothing for USEd variables.  */
+  if (sym->attr.use_assoc)
+    return;
+
+  type = TREE_TYPE (decl);
+  gcc_assert (GFC_ARRAY_TYPE_P (type));
+  onstack = TREE_CODE (type) != POINTER_TYPE;
+
+  gfc_init_block (&init);
+
+  /* Evaluate character string length.  */
+  if (sym->ts.type == BT_CHARACTER
+      && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
+    {
+      gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
+
+      gfc_trans_vla_type_sizes (sym, &init);
+
+      /* Emit a DECL_EXPR for this variable, which will cause the
+	 gimplifier to allocate storage, and all that good stuff.  */
+      tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
+      gfc_add_expr_to_block (&init, tmp);
+    }
+
+  if (onstack)
+    {
+      gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
+      return;
+    }
+
+  type = TREE_TYPE (type);
+
+  gcc_assert (!sym->attr.use_assoc);
+  gcc_assert (!TREE_STATIC (decl));
+  gcc_assert (!sym->module);
+
+  if (sym->ts.type == BT_CHARACTER
+      && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
+    gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
+
+  size = gfc_trans_array_bounds (type, sym, &offset, &init);
+
+  /* Don't actually allocate space for Cray Pointees.  */
+  if (sym->attr.cray_pointee)
+    {
+      if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
+	gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
+
+      gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
+      return;
+    }
+
+  if (gfc_option.flag_stack_arrays)
+    {
+      gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
+      space = build_decl (sym->declared_at.lb->location,
+			  VAR_DECL, create_tmp_var_name ("A"),
+			  TREE_TYPE (TREE_TYPE (decl)));
+      gfc_trans_vla_type_sizes (sym, &init);
+    }
+  else
+    {
+      /* The size is the number of elements in the array, so multiply by the
+	 size of an element to get the total size.  */
+      tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
+      size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			      size, fold_convert (gfc_array_index_type, tmp));
+
+      /* Allocate memory to hold the data.  */
+      tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
+      gfc_add_modify (&init, decl, tmp);
+
+      /* Free the temporary.  */
+      tmp = gfc_call_free (convert (pvoid_type_node, decl));
+      space = NULL_TREE;
+    }
+
+  /* Set offset of the array.  */
+  if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
+    gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
+
+  /* Automatic arrays should not have initializers.  */
+  gcc_assert (!sym->value);
+
+  inittree = gfc_finish_block (&init);
+
+  if (space)
+    {
+      tree addr;
+      pushdecl (space);
+
+      /* Don't create new scope, emit the DECL_EXPR in exactly the scope
+         where also space is located.  */
+      gfc_init_block (&init);
+      tmp = fold_build1_loc (input_location, DECL_EXPR,
+			     TREE_TYPE (space), space);
+      gfc_add_expr_to_block (&init, tmp);
+      addr = fold_build1_loc (sym->declared_at.lb->location,
+			      ADDR_EXPR, TREE_TYPE (decl), space);
+      gfc_add_modify (&init, decl, addr);
+      gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
+      tmp = NULL_TREE;
+    }
+  gfc_add_init_cleanup (block, inittree, tmp);
+}
+
+
+/* Generate entry and exit code for g77 calling convention arrays.  */
+
+void
+gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
+{
+  tree parm;
+  tree type;
+  locus loc;
+  tree offset;
+  tree tmp;
+  tree stmt;
+  stmtblock_t init;
+
+  gfc_save_backend_locus (&loc);
+  gfc_set_backend_locus (&sym->declared_at);
+
+  /* Descriptor type.  */
+  parm = sym->backend_decl;
+  type = TREE_TYPE (parm);
+  gcc_assert (GFC_ARRAY_TYPE_P (type));
+
+  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);
+
+  /* Evaluate the bounds of the array.  */
+  gfc_trans_array_bounds (type, sym, &offset, &init);
+
+  /* Set the offset.  */
+  if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
+    gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
+
+  /* Set the pointer itself if we aren't using the parameter directly.  */
+  if (TREE_CODE (parm) != PARM_DECL)
+    {
+      tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
+      gfc_add_modify (&init, parm, tmp);
+    }
+  stmt = gfc_finish_block (&init);
+
+  gfc_restore_backend_locus (&loc);
+
+  /* Add the initialization code to the start of the function.  */
+
+  if (sym->attr.optional || sym->attr.not_always_present)
+    {
+      tmp = gfc_conv_expr_present (sym);
+      stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
+    }
+
+  gfc_add_init_cleanup (block, stmt, NULL_TREE);
+}
+
+
+/* Modify the descriptor of an array parameter so that it has the
+   correct lower bound.  Also move the upper bound accordingly.
+   If the array is not packed, it will be copied into a temporary.
+   For each dimension we set the new lower and upper bounds.  Then we copy the
+   stride and calculate the offset for this dimension.  We also work out
+   what the stride of a packed array would be, and see it the two match.
+   If the array need repacking, we set the stride to the values we just
+   calculated, recalculate the offset and copy the array data.
+   Code is also added to copy the data back at the end of the function.
+   */
+
+void
+gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
+			    gfc_wrapped_block * block)
+{
+  tree size;
+  tree type;
+  tree offset;
+  locus loc;
+  stmtblock_t init;
+  tree stmtInit, stmtCleanup;
+  tree lbound;
+  tree ubound;
+  tree dubound;
+  tree dlbound;
+  tree dumdesc;
+  tree tmp;
+  tree stride, stride2;
+  tree stmt_packed;
+  tree stmt_unpacked;
+  tree partial;
+  gfc_se se;
+  int n;
+  int checkparm;
+  int no_repack;
+  bool optional_arg;
+
+  /* Do nothing for pointer and allocatable arrays.  */
+  if (sym->attr.pointer || sym->attr.allocatable)
+    return;
+
+  if (sym->attr.dummy && gfc_is_nodesc_array (sym))
+    {
+      gfc_trans_g77_array (sym, block);
+      return;
+    }
+
+  gfc_save_backend_locus (&loc);
+  gfc_set_backend_locus (&sym->declared_at);
+
+  /* Descriptor type.  */
+  type = TREE_TYPE (tmpdesc);
+  gcc_assert (GFC_ARRAY_TYPE_P (type));
+  dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
+  dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
+  gfc_start_block (&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
+	       && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
+
+  no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
+		|| GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
+
+  if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
+    {
+      /* For non-constant shape arrays we only check if the first dimension
+	 is contiguous.  Repacking higher dimensions wouldn't gain us
+	 anything as we still don't know the array stride.  */
+      partial = gfc_create_var (boolean_type_node, "partial");
+      TREE_USED (partial) = 1;
+      tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
+      tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
+			     gfc_index_one_node);
+      gfc_add_modify (&init, partial, tmp);
+    }
+  else
+    partial = NULL_TREE;
+
+  /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
+     here, however I think it does the right thing.  */
+  if (no_repack)
+    {
+      /* Set the first stride.  */
+      stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
+      stride = gfc_evaluate_now (stride, &init);
+
+      tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+			     stride, gfc_index_zero_node);
+      tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
+			     tmp, gfc_index_one_node, stride);
+      stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
+      gfc_add_modify (&init, stride, tmp);
+
+      /* Allow the user to disable array repacking.  */
+      stmt_unpacked = NULL_TREE;
+    }
+  else
+    {
+      gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
+      /* A library call to repack the array if necessary.  */
+      tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
+      stmt_unpacked = build_call_expr_loc (input_location,
+				       gfor_fndecl_in_pack, 1, tmp);
+
+      stride = gfc_index_one_node;
+
+      if (gfc_option.warn_array_temp)
+	gfc_warning ("Creating array temporary at %L", &loc);
+    }
+
+  /* This is for the case where the array data is used directly without
+     calling the repack function.  */
+  if (no_repack || partial != NULL_TREE)
+    stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
+  else
+    stmt_packed = NULL_TREE;
+
+  /* Assign the data pointer.  */
+  if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
+    {
+      /* Don't repack unknown shape arrays when the first stride is 1.  */
+      tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
+			     partial, stmt_packed, stmt_unpacked);
+    }
+  else
+    tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
+  gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
+
+  offset = gfc_index_zero_node;
+  size = gfc_index_one_node;
+
+  /* Evaluate the bounds of the array.  */
+  for (n = 0; n < sym->as->rank; n++)
+    {
+      if (checkparm || !sym->as->upper[n])
+	{
+	  /* Get the bounds of the actual parameter.  */
+	  dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
+	  dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
+	}
+      else
+	{
+	  dubound = NULL_TREE;
+	  dlbound = NULL_TREE;
+	}
+
+      lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
+      if (!INTEGER_CST_P (lbound))
+	{
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_expr_type (&se, sym->as->lower[n],
+			      gfc_array_index_type);
+	  gfc_add_block_to_block (&init, &se.pre);
+	  gfc_add_modify (&init, lbound, se.expr);
+	}
+
+      ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
+      /* Set the desired upper bound.  */
+      if (sym->as->upper[n])
+	{
+	  /* We know what we want the upper bound to be.  */
+	  if (!INTEGER_CST_P (ubound))
+	    {
+	      gfc_init_se (&se, NULL);
+	      gfc_conv_expr_type (&se, sym->as->upper[n],
+				  gfc_array_index_type);
+	      gfc_add_block_to_block (&init, &se.pre);
+	      gfc_add_modify (&init, ubound, se.expr);
+	    }
+
+	  /* Check the sizes match.  */
+	  if (checkparm)
+	    {
+	      /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)).  */
+	      char * msg;
+	      tree temp;
+
+	      temp = fold_build2_loc (input_location, MINUS_EXPR,
+				      gfc_array_index_type, ubound, lbound);
+	      temp = fold_build2_loc (input_location, PLUS_EXPR,
+				      gfc_array_index_type,
+				      gfc_index_one_node, temp);
+	      stride2 = fold_build2_loc (input_location, MINUS_EXPR,
+					 gfc_array_index_type, dubound,
+					 dlbound);
+	      stride2 = fold_build2_loc (input_location, PLUS_EXPR,
+					 gfc_array_index_type,
+					 gfc_index_one_node, stride2);
+	      tmp = fold_build2_loc (input_location, NE_EXPR,
+				     gfc_array_index_type, temp, stride2);
+	      asprintf (&msg, "Dimension %d of array '%s' has extent "
+			"%%ld instead of %%ld", n+1, sym->name);
+
+	      gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
+			fold_convert (long_integer_type_node, temp),
+			fold_convert (long_integer_type_node, stride2));
+
+	      free (msg);
+	    }
+	}
+      else
+	{
+	  /* For assumed shape arrays move the upper bound by the same amount
+	     as the lower bound.  */
+	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				 gfc_array_index_type, dubound, dlbound);
+	  tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type, tmp, lbound);
+	  gfc_add_modify (&init, ubound, tmp);
+	}
+      /* The offset of this dimension.  offset = offset - lbound * stride.  */
+      tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			     lbound, stride);
+      offset = fold_build2_loc (input_location, MINUS_EXPR,
+				gfc_array_index_type, offset, tmp);
+
+      /* The size of this dimension, and the stride of the next.  */
+      if (n + 1 < sym->as->rank)
+	{
+	  stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
+
+	  if (no_repack || partial != NULL_TREE)
+	    stmt_unpacked =
+	      gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
+
+	  /* Figure out the stride if not a known constant.  */
+	  if (!INTEGER_CST_P (stride))
+	    {
+	      if (no_repack)
+		stmt_packed = NULL_TREE;
+	      else
+		{
+		  /* Calculate stride = size * (ubound + 1 - lbound).  */
+		  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+					 gfc_array_index_type,
+					 gfc_index_one_node, lbound);
+		  tmp = fold_build2_loc (input_location, PLUS_EXPR,
+					 gfc_array_index_type, ubound, tmp);
+		  size = fold_build2_loc (input_location, MULT_EXPR,
+					  gfc_array_index_type, size, tmp);
+		  stmt_packed = size;
+		}
+
+	      /* Assign the stride.  */
+	      if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
+		tmp = fold_build3_loc (input_location, COND_EXPR,
+				       gfc_array_index_type, partial,
+				       stmt_unpacked, stmt_packed);
+	      else
+		tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
+	      gfc_add_modify (&init, stride, tmp);
+	    }
+	}
+      else
+	{
+	  stride = GFC_TYPE_ARRAY_SIZE (type);
+
+	  if (stride && !INTEGER_CST_P (stride))
+	    {
+	      /* Calculate size = stride * (ubound + 1 - lbound).  */
+	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				     gfc_array_index_type,
+				     gfc_index_one_node, lbound);
+	      tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				     gfc_array_index_type,
+				     ubound, tmp);
+	      tmp = fold_build2_loc (input_location, MULT_EXPR,
+				     gfc_array_index_type,
+				     GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
+	      gfc_add_modify (&init, stride, tmp);
+	    }
+	}
+    }
+
+  gfc_trans_array_cobounds (type, &init, sym);
+
+  /* Set the offset.  */
+  if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
+    gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
+
+  gfc_trans_vla_type_sizes (sym, &init);
+
+  stmtInit = gfc_finish_block (&init);
+
+  /* Only do the entry/initialization code if the arg is present.  */
+  dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
+  optional_arg = (sym->attr.optional
+		  || (sym->ns->proc_name->attr.entry_master
+		      && sym->attr.dummy));
+  if (optional_arg)
+    {
+      tmp = gfc_conv_expr_present (sym);
+      stmtInit = build3_v (COND_EXPR, tmp, stmtInit,
+			   build_empty_stmt (input_location));
+    }
+
+  /* Cleanup code.  */
+  if (no_repack)
+    stmtCleanup = NULL_TREE;
+  else
+    {
+      stmtblock_t cleanup;
+      gfc_start_block (&cleanup);
+
+      if (sym->attr.intent != INTENT_IN)
+	{
+	  /* Copy the data back.  */
+	  tmp = build_call_expr_loc (input_location,
+				 gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
+	  gfc_add_expr_to_block (&cleanup, tmp);
+	}
+
+      /* Free the temporary.  */
+      tmp = gfc_call_free (tmpdesc);
+      gfc_add_expr_to_block (&cleanup, tmp);
+
+      stmtCleanup = gfc_finish_block (&cleanup);
+
+      /* Only do the cleanup if the array was repacked.  */
+      tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
+      tmp = gfc_conv_descriptor_data_get (tmp);
+      tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			     tmp, tmpdesc);
+      stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
+			      build_empty_stmt (input_location));
+
+      if (optional_arg)
+	{
+	  tmp = gfc_conv_expr_present (sym);
+	  stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
+				  build_empty_stmt (input_location));
+	}
+    }
+
+  /* We don't need to free any memory allocated by internal_pack as it will
+     be freed at the end of the function by pop_context.  */
+  gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
+
+  gfc_restore_backend_locus (&loc);
+}
+
+
+/* Calculate the overall offset, including subreferences.  */
+static void
+gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
+			bool subref, gfc_expr *expr)
+{
+  tree tmp;
+  tree field;
+  tree stride;
+  tree index;
+  gfc_ref *ref;
+  gfc_se start;
+  int n;
+
+  /* If offset is NULL and this is not a subreferenced array, there is
+     nothing to do.  */
+  if (offset == NULL_TREE)
+    {
+      if (subref)
+	offset = gfc_index_zero_node;
+      else
+	return;
+    }
+
+  tmp = build_array_ref (desc, offset, NULL);
+
+  /* Offset the data pointer for pointer assignments from arrays with
+     subreferences; e.g. my_integer => my_type(:)%integer_component.  */
+  if (subref)
+    {
+      /* Go past the array reference.  */
+      for (ref = expr->ref; ref; ref = ref->next)
+	if (ref->type == REF_ARRAY &&
+	      ref->u.ar.type != AR_ELEMENT)
+	  {
+	    ref = ref->next;
+	    break;
+	  }
+
+      /* Calculate the offset for each subsequent subreference.  */
+      for (; ref; ref = ref->next)
+	{
+	  switch (ref->type)
+	    {
+	    case REF_COMPONENT:
+	      field = ref->u.c.component->backend_decl;
+	      gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
+	      tmp = fold_build3_loc (input_location, COMPONENT_REF,
+				     TREE_TYPE (field),
+				     tmp, field, NULL_TREE);
+	      break;
+
+	    case REF_SUBSTRING:
+	      gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
+	      gfc_init_se (&start, NULL);
+	      gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
+	      gfc_add_block_to_block (block, &start.pre);
+	      tmp = gfc_build_array_ref (tmp, start.expr, NULL);
+	      break;
+
+	    case REF_ARRAY:
+	      gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
+			    && ref->u.ar.type == AR_ELEMENT);
+
+	      /* TODO - Add bounds checking.  */
+	      stride = gfc_index_one_node;
+	      index = gfc_index_zero_node;
+	      for (n = 0; n < ref->u.ar.dimen; n++)
+		{
+		  tree itmp;
+		  tree jtmp;
+
+		  /* Update the index.  */
+		  gfc_init_se (&start, NULL);
+		  gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
+		  itmp = gfc_evaluate_now (start.expr, block);
+		  gfc_init_se (&start, NULL);
+		  gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
+		  jtmp = gfc_evaluate_now (start.expr, block);
+		  itmp = fold_build2_loc (input_location, MINUS_EXPR,
+					  gfc_array_index_type, itmp, jtmp);
+		  itmp = fold_build2_loc (input_location, MULT_EXPR,
+					  gfc_array_index_type, itmp, stride);
+		  index = fold_build2_loc (input_location, PLUS_EXPR,
+					  gfc_array_index_type, itmp, index);
+		  index = gfc_evaluate_now (index, block);
+
+		  /* Update the stride.  */
+		  gfc_init_se (&start, NULL);
+		  gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
+		  itmp =  fold_build2_loc (input_location, MINUS_EXPR,
+					   gfc_array_index_type, start.expr,
+					   jtmp);
+		  itmp =  fold_build2_loc (input_location, PLUS_EXPR,
+					   gfc_array_index_type,
+					   gfc_index_one_node, itmp);
+		  stride =  fold_build2_loc (input_location, MULT_EXPR,
+					     gfc_array_index_type, stride, itmp);
+		  stride = gfc_evaluate_now (stride, block);
+		}
+
+	      /* Apply the index to obtain the array element.  */
+	      tmp = gfc_build_array_ref (tmp, index, NULL);
+	      break;
+
+	    default:
+	      gcc_unreachable ();
+	      break;
+	    }
+	}
+    }
+
+  /* Set the target data pointer.  */
+  offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
+  gfc_conv_descriptor_data_set (block, parm, offset);
+}
+
+
+/* gfc_conv_expr_descriptor needs the string length an expression
+   so that the size of the temporary can be obtained.  This is done
+   by adding up the string lengths of all the elements in the
+   expression.  Function with non-constant expressions have their
+   string lengths mapped onto the actual arguments using the
+   interface mapping machinery in trans-expr.c.  */
+static void
+get_array_charlen (gfc_expr *expr, gfc_se *se)
+{
+  gfc_interface_mapping mapping;
+  gfc_formal_arglist *formal;
+  gfc_actual_arglist *arg;
+  gfc_se tse;
+
+  if (expr->ts.u.cl->length
+	&& gfc_is_constant_expr (expr->ts.u.cl->length))
+    {
+      if (!expr->ts.u.cl->backend_decl)
+	gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
+      return;
+    }
+
+  switch (expr->expr_type)
+    {
+    case EXPR_OP:
+      get_array_charlen (expr->value.op.op1, se);
+
+      /* For parentheses the expression ts.u.cl is identical.  */
+      if (expr->value.op.op == INTRINSIC_PARENTHESES)
+	return;
+
+     expr->ts.u.cl->backend_decl =
+		gfc_create_var (gfc_charlen_type_node, "sln");
+
+      if (expr->value.op.op2)
+	{
+	  get_array_charlen (expr->value.op.op2, se);
+
+	  gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
+
+	  /* Add the string lengths and assign them to the expression
+	     string length backend declaration.  */
+	  gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
+			  fold_build2_loc (input_location, PLUS_EXPR,
+				gfc_charlen_type_node,
+				expr->value.op.op1->ts.u.cl->backend_decl,
+				expr->value.op.op2->ts.u.cl->backend_decl));
+	}
+      else
+	gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
+			expr->value.op.op1->ts.u.cl->backend_decl);
+      break;
+
+    case EXPR_FUNCTION:
+      if (expr->value.function.esym == NULL
+	    || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+	{
+	  gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
+	  break;
+	}
+
+      /* Map expressions involving the dummy arguments onto the actual
+	 argument expressions.  */
+      gfc_init_interface_mapping (&mapping);
+      formal = gfc_sym_get_dummy_args (expr->symtree->n.sym);
+      arg = expr->value.function.actual;
+
+      /* Set se = NULL in the calls to the interface mapping, to suppress any
+	 backend stuff.  */
+      for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
+	{
+	  if (!arg->expr)
+	    continue;
+	  if (formal->sym)
+	  gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
+	}
+
+      gfc_init_se (&tse, NULL);
+
+      /* Build the expression for the character length and convert it.  */
+      gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
+
+      gfc_add_block_to_block (&se->pre, &tse.pre);
+      gfc_add_block_to_block (&se->post, &tse.post);
+      tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
+      tse.expr = fold_build2_loc (input_location, MAX_EXPR,
+				  gfc_charlen_type_node, tse.expr,
+				  build_int_cst (gfc_charlen_type_node, 0));
+      expr->ts.u.cl->backend_decl = tse.expr;
+      gfc_free_interface_mapping (&mapping);
+      break;
+
+    default:
+      gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
+      break;
+    }
+}
+
+
+/* Helper function to check dimensions.  */
+static bool
+transposed_dims (gfc_ss *ss)
+{
+  int n;
+
+  for (n = 0; n < ss->dimen; n++)
+    if (ss->dim[n] != n)
+      return true;
+  return false;
+}
+
+
+/* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
+   AR_FULL, suitable for the scalarizer.  */
+
+static gfc_ss *
+walk_coarray (gfc_expr *e)
+{
+  gfc_ss *ss;
+
+  gcc_assert (gfc_get_corank (e) > 0);
+
+  ss = gfc_walk_expr (e);
+
+  /* Fix scalar coarray.  */
+  if (ss == gfc_ss_terminator)
+    {
+      gfc_ref *ref;
+
+      ref = e->ref;
+      while (ref)
+	{
+	  if (ref->type == REF_ARRAY
+	      && ref->u.ar.codimen > 0)
+	    break;
+
+	  ref = ref->next;
+	}
+
+      gcc_assert (ref != NULL);
+      if (ref->u.ar.type == AR_ELEMENT)
+	ref->u.ar.type = AR_SECTION;
+      ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref));
+    }
+
+  return ss;
+}
+
+
+/* Convert an array for passing as an actual argument.  Expressions and
+   vector subscripts are evaluated and stored in a temporary, which is then
+   passed.  For whole arrays the descriptor is passed.  For array sections
+   a modified copy of the descriptor is passed, but using the original data.
+
+   This function is also used for array pointer assignments, and there
+   are three cases:
+
+     - se->want_pointer && !se->direct_byref
+	 EXPR is an actual argument.  On exit, se->expr contains a
+	 pointer to the array descriptor.
+
+     - !se->want_pointer && !se->direct_byref
+	 EXPR is an actual argument to an intrinsic function or the
+	 left-hand side of a pointer assignment.  On exit, se->expr
+	 contains the descriptor for EXPR.
+
+     - !se->want_pointer && se->direct_byref
+	 EXPR is the right-hand side of a pointer assignment and
+	 se->expr is the descriptor for the previously-evaluated
+	 left-hand side.  The function creates an assignment from
+	 EXPR to se->expr.
+
+
+   The se->force_tmp flag disables the non-copying descriptor optimization
+   that is used for transpose. It may be used in cases where there is an
+   alias between the transpose argument and another argument in the same
+   function call.  */
+
+void
+gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
+{
+  gfc_ss *ss;
+  gfc_ss_type ss_type;
+  gfc_ss_info *ss_info;
+  gfc_loopinfo loop;
+  gfc_array_info *info;
+  int need_tmp;
+  int n;
+  tree tmp;
+  tree desc;
+  stmtblock_t block;
+  tree start;
+  tree offset;
+  int full;
+  bool subref_array_target = false;
+  gfc_expr *arg, *ss_expr;
+
+  if (se->want_coarray)
+    ss = walk_coarray (expr);
+  else
+    ss = gfc_walk_expr (expr);
+
+  gcc_assert (ss != NULL);
+  gcc_assert (ss != gfc_ss_terminator);
+
+  ss_info = ss->info;
+  ss_type = ss_info->type;
+  ss_expr = ss_info->expr;
+
+  /* Special case: TRANSPOSE which needs no temporary.  */
+  while (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym
+      && NULL != (arg = gfc_get_noncopying_intrinsic_argument (expr)))
+    {
+      /* This is a call to transpose which has already been handled by the
+	 scalarizer, so that we just need to get its argument's descriptor.  */
+      gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
+      expr = expr->value.function.actual->expr;
+    }
+
+  /* Special case things we know we can pass easily.  */
+  switch (expr->expr_type)
+    {
+    case EXPR_VARIABLE:
+      /* If we have a linear array section, we can pass it directly.
+	 Otherwise we need to copy it into a temporary.  */
+
+      gcc_assert (ss_type == GFC_SS_SECTION);
+      gcc_assert (ss_expr == expr);
+      info = &ss_info->data.array;
+
+      /* Get the descriptor for the array.  */
+      gfc_conv_ss_descriptor (&se->pre, ss, 0);
+      desc = info->descriptor;
+
+      subref_array_target = se->direct_byref && is_subref_array (expr);
+      need_tmp = gfc_ref_needs_temporary_p (expr->ref)
+			&& !subref_array_target;
+
+      if (se->force_tmp)
+	need_tmp = 1;
+
+      if (need_tmp)
+	full = 0;
+      else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
+	{
+	  /* Create a new descriptor if the array doesn't have one.  */
+	  full = 0;
+	}
+      else if (info->ref->u.ar.type == AR_FULL || se->descriptor_only)
+	full = 1;
+      else if (se->direct_byref)
+	full = 0;
+      else
+	full = gfc_full_array_ref_p (info->ref, NULL);
+
+      if (full && !transposed_dims (ss))
+	{
+	  if (se->direct_byref && !se->byref_noassign)
+	    {
+	      /* Copy the descriptor for pointer assignments.  */
+	      gfc_add_modify (&se->pre, se->expr, desc);
+
+	      /* Add any offsets from subreferences.  */
+	      gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
+				      subref_array_target, expr);
+	    }
+	  else if (se->want_pointer)
+	    {
+	      /* We pass full arrays directly.  This means that pointers and
+		 allocatable arrays should also work.  */
+	      se->expr = gfc_build_addr_expr (NULL_TREE, desc);
+	    }
+	  else
+	    {
+	      se->expr = desc;
+	    }
+
+	  if (expr->ts.type == BT_CHARACTER)
+	    se->string_length = gfc_get_expr_charlen (expr);
+
+	  gfc_free_ss_chain (ss);
+	  return;
+	}
+      break;
+
+    case EXPR_FUNCTION:
+      /* A transformational function return value will be a temporary
+	 array descriptor.  We still need to go through the scalarizer
+	 to create the descriptor.  Elemental functions are handled as
+	 arbitrary expressions, i.e. copy to a temporary.  */
+
+      if (se->direct_byref)
+	{
+	  gcc_assert (ss_type == GFC_SS_FUNCTION && ss_expr == expr);
+
+	  /* For pointer assignments pass the descriptor directly.  */
+	  if (se->ss == NULL)
+	    se->ss = ss;
+	  else
+	    gcc_assert (se->ss == ss);
+	  se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
+	  gfc_conv_expr (se, expr);
+	  gfc_free_ss_chain (ss);
+	  return;
+	}
+
+      if (ss_expr != expr || ss_type != GFC_SS_FUNCTION)
+	{
+	  if (ss_expr != expr)
+	    /* Elemental function.  */
+	    gcc_assert ((expr->value.function.esym != NULL
+			 && expr->value.function.esym->attr.elemental)
+			|| (expr->value.function.isym != NULL
+			    && expr->value.function.isym->elemental)
+			|| gfc_inline_intrinsic_function_p (expr));
+	  else
+	    gcc_assert (ss_type == GFC_SS_INTRINSIC);
+
+	  need_tmp = 1;
+	  if (expr->ts.type == BT_CHARACTER
+		&& expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
+	    get_array_charlen (expr, se);
+
+	  info = NULL;
+	}
+      else
+	{
+	  /* Transformational function.  */
+	  info = &ss_info->data.array;
+	  need_tmp = 0;
+	}
+      break;
+
+    case EXPR_ARRAY:
+      /* Constant array constructors don't need a temporary.  */
+      if (ss_type == GFC_SS_CONSTRUCTOR
+	  && expr->ts.type != BT_CHARACTER
+	  && gfc_constant_array_constructor_p (expr->value.constructor))
+	{
+	  need_tmp = 0;
+	  info = &ss_info->data.array;
+	}
+      else
+	{
+	  need_tmp = 1;
+	  info = NULL;
+	}
+      break;
+
+    default:
+      /* Something complicated.  Copy it into a temporary.  */
+      need_tmp = 1;
+      info = NULL;
+      break;
+    }
+
+  /* If we are creating a temporary, we don't need to bother about aliases
+     anymore.  */
+  if (need_tmp)
+    se->force_tmp = 0;
+
+  gfc_init_loopinfo (&loop);
+
+  /* Associate the SS with the loop.  */
+  gfc_add_ss_to_loop (&loop, ss);
+
+  /* Tell the scalarizer not to bother creating loop variables, etc.  */
+  if (!need_tmp)
+    loop.array_parameter = 1;
+  else
+    /* The right-hand side of a pointer assignment mustn't use a temporary.  */
+    gcc_assert (!se->direct_byref);
+
+  /* Setup the scalarizing loops and bounds.  */
+  gfc_conv_ss_startstride (&loop);
+
+  if (need_tmp)
+    {
+      if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
+	get_array_charlen (expr, se);
+
+      /* Tell the scalarizer to make a temporary.  */
+      loop.temp_ss = gfc_get_temp_ss (gfc_typenode_for_spec (&expr->ts),
+				      ((expr->ts.type == BT_CHARACTER)
+				       ? expr->ts.u.cl->backend_decl
+				       : NULL),
+				      loop.dimen);
+
+      se->string_length = loop.temp_ss->info->string_length;
+      gcc_assert (loop.temp_ss->dimen == loop.dimen);
+      gfc_add_ss_to_loop (&loop, loop.temp_ss);
+    }
+
+  gfc_conv_loop_setup (&loop, & expr->where);
+
+  if (need_tmp)
+    {
+      /* Copy into a temporary and pass that.  We don't need to copy the data
+         back because expressions and vector subscripts must be INTENT_IN.  */
+      /* TODO: Optimize passing function return values.  */
+      gfc_se lse;
+      gfc_se rse;
+
+      /* Start the copying loops.  */
+      gfc_mark_ss_chain_used (loop.temp_ss, 1);
+      gfc_mark_ss_chain_used (ss, 1);
+      gfc_start_scalarized_body (&loop, &block);
+
+      /* Copy each data element.  */
+      gfc_init_se (&lse, NULL);
+      gfc_copy_loopinfo_to_se (&lse, &loop);
+      gfc_init_se (&rse, NULL);
+      gfc_copy_loopinfo_to_se (&rse, &loop);
+
+      lse.ss = loop.temp_ss;
+      rse.ss = ss;
+
+      gfc_conv_scalarized_array_ref (&lse, NULL);
+      if (expr->ts.type == BT_CHARACTER)
+	{
+	  gfc_conv_expr (&rse, expr);
+	  if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
+	    rse.expr = build_fold_indirect_ref_loc (input_location,
+						rse.expr);
+	}
+      else
+        gfc_conv_expr_val (&rse, expr);
+
+      gfc_add_block_to_block (&block, &rse.pre);
+      gfc_add_block_to_block (&block, &lse.pre);
+
+      lse.string_length = rse.string_length;
+      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
+				     expr->expr_type == EXPR_VARIABLE
+				     || expr->expr_type == EXPR_ARRAY, true);
+      gfc_add_expr_to_block (&block, tmp);
+
+      /* Finish the copying loops.  */
+      gfc_trans_scalarizing_loops (&loop, &block);
+
+      desc = loop.temp_ss->info->data.array.descriptor;
+    }
+  else if (expr->expr_type == EXPR_FUNCTION && !transposed_dims (ss))
+    {
+      desc = info->descriptor;
+      se->string_length = ss_info->string_length;
+    }
+  else
+    {
+      /* We pass sections without copying to a temporary.  Make a new
+	 descriptor and point it at the section we want.  The loop variable
+	 limits will be the limits of the section.
+	 A function may decide to repack the array to speed up access, but
+	 we're not bothered about that here.  */
+      int dim, ndim, codim;
+      tree parm;
+      tree parmtype;
+      tree stride;
+      tree from;
+      tree to;
+      tree base;
+
+      ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
+
+      if (se->want_coarray)
+	{
+	  gfc_array_ref *ar = &info->ref->u.ar;
+
+	  codim = gfc_get_corank (expr);
+	  for (n = 0; n < codim - 1; n++)
+	    {
+	      /* Make sure we are not lost somehow.  */
+	      gcc_assert (ar->dimen_type[n + ndim] == DIMEN_THIS_IMAGE);
+
+	      /* Make sure the call to gfc_conv_section_startstride won't
+		 generate unnecessary code to calculate stride.  */
+	      gcc_assert (ar->stride[n + ndim] == NULL);
+
+	      gfc_conv_section_startstride (&loop.pre, ss, n + ndim);
+	      loop.from[n + loop.dimen] = info->start[n + ndim];
+	      loop.to[n + loop.dimen]   = info->end[n + ndim];
+	    }
+
+	  gcc_assert (n == codim - 1);
+	  evaluate_bound (&loop.pre, info->start, ar->start,
+			  info->descriptor, n + ndim, true);
+	  loop.from[n + loop.dimen] = info->start[n + ndim];
+	}
+      else
+	codim = 0;
+
+      /* Set the string_length for a character array.  */
+      if (expr->ts.type == BT_CHARACTER)
+	se->string_length =  gfc_get_expr_charlen (expr);
+
+      desc = info->descriptor;
+      if (se->direct_byref && !se->byref_noassign)
+	{
+	  /* For pointer assignments we fill in the destination.  */
+	  parm = se->expr;
+	  parmtype = TREE_TYPE (parm);
+	}
+      else
+	{
+	  /* Otherwise make a new one.  */
+	  parmtype = gfc_get_element_type (TREE_TYPE (desc));
+	  parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim,
+						loop.from, loop.to, 0,
+						GFC_ARRAY_UNKNOWN, false);
+	  parm = gfc_create_var (parmtype, "parm");
+	}
+
+      offset = gfc_index_zero_node;
+
+      /* The following can be somewhat confusing.  We have two
+         descriptors, a new one and the original array.
+         {parm, parmtype, dim} refer to the new one.
+         {desc, type, n, loop} refer to the original, which maybe
+         a descriptorless array.
+         The bounds of the scalarization are the bounds of the section.
+         We don't have to worry about numeric overflows when calculating
+         the offsets because all elements are within the array data.  */
+
+      /* Set the dtype.  */
+      tmp = gfc_conv_descriptor_dtype (parm);
+      gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
+
+      /* Set offset for assignments to pointer only to zero if it is not
+         the full array.  */
+      if (se->direct_byref
+	  && info->ref && info->ref->u.ar.type != AR_FULL)
+	base = gfc_index_zero_node;
+      else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
+	base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
+      else
+	base = NULL_TREE;
+
+      for (n = 0; n < ndim; n++)
+	{
+	  stride = gfc_conv_array_stride (desc, n);
+
+	  /* Work out the offset.  */
+	  if (info->ref
+	      && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
+	    {
+	      gcc_assert (info->subscript[n]
+			  && info->subscript[n]->info->type == GFC_SS_SCALAR);
+	      start = info->subscript[n]->info->data.scalar.value;
+	    }
+	  else
+	    {
+	      /* Evaluate and remember the start of the section.  */
+	      start = info->start[n];
+	      stride = gfc_evaluate_now (stride, &loop.pre);
+	    }
+
+	  tmp = gfc_conv_array_lbound (desc, n);
+	  tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
+				 start, tmp);
+	  tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
+				 tmp, stride);
+	  offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
+				    offset, tmp);
+
+	  if (info->ref
+	      && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
+	    {
+	      /* For elemental dimensions, we only need the offset.  */
+	      continue;
+	    }
+
+	  /* Vector subscripts need copying and are handled elsewhere.  */
+	  if (info->ref)
+	    gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
+
+	  /* look for the corresponding scalarizer dimension: dim.  */
+	  for (dim = 0; dim < ndim; dim++)
+	    if (ss->dim[dim] == n)
+	      break;
+
+	  /* loop exited early: the DIM being looked for has been found.  */
+	  gcc_assert (dim < ndim);
+
+	  /* Set the new lower bound.  */
+	  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;
+	    }
+	  gfc_conv_descriptor_lbound_set (&loop.pre, parm,
+					  gfc_rank_cst[dim], from);
+
+	  /* Set the new upper bound.  */
+	  gfc_conv_descriptor_ubound_set (&loop.pre, parm,
+					  gfc_rank_cst[dim], to);
+
+	  /* Multiply the stride by the section stride to get the
+	     total stride.  */
+	  stride = fold_build2_loc (input_location, MULT_EXPR,
+				    gfc_array_index_type,
+				    stride, info->stride[n]);
+
+	  if (se->direct_byref
+	      && info->ref
+	      && info->ref->u.ar.type != AR_FULL)
+	    {
+	      base = fold_build2_loc (input_location, MINUS_EXPR,
+				      TREE_TYPE (base), base, stride);
+	    }
+	  else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
+	    {
+	      tmp = gfc_conv_array_lbound (desc, n);
+	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				     TREE_TYPE (base), tmp, loop.from[dim]);
+	      tmp = fold_build2_loc (input_location, MULT_EXPR,
+				     TREE_TYPE (base), tmp,
+				     gfc_conv_array_stride (desc, n));
+	      base = fold_build2_loc (input_location, PLUS_EXPR,
+				     TREE_TYPE (base), tmp, base);
+	    }
+
+	  /* Store the new stride.  */
+	  gfc_conv_descriptor_stride_set (&loop.pre, parm,
+					  gfc_rank_cst[dim], stride);
+	}
+
+      for (n = loop.dimen; n < loop.dimen + codim; n++)
+	{
+	  from = loop.from[n];
+	  to = loop.to[n];
+	  gfc_conv_descriptor_lbound_set (&loop.pre, parm,
+					  gfc_rank_cst[n], from);
+	  if (n < loop.dimen + codim - 1)
+	    gfc_conv_descriptor_ubound_set (&loop.pre, parm,
+					    gfc_rank_cst[n], to);
+	}
+
+      if (se->data_not_needed)
+	gfc_conv_descriptor_data_set (&loop.pre, parm,
+				      gfc_index_zero_node);
+      else
+	/* Point the data pointer at the 1st element in the section.  */
+	gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
+				subref_array_target, expr);
+
+      if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
+	  && !se->data_not_needed)
+	{
+	  /* Set the offset.  */
+	  gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
+	}
+      else
+	{
+	  /* Only the callee knows what the correct offset it, so just set
+	     it to zero here.  */
+	  gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
+	}
+      desc = parm;
+    }
+
+  if (!se->direct_byref || se->byref_noassign)
+    {
+      /* Get a pointer to the new descriptor.  */
+      if (se->want_pointer)
+	se->expr = gfc_build_addr_expr (NULL_TREE, desc);
+      else
+	se->expr = desc;
+    }
+
+  gfc_add_block_to_block (&se->pre, &loop.pre);
+  gfc_add_block_to_block (&se->post, &loop.post);
+
+  /* Cleanup the scalarizer.  */
+  gfc_cleanup_loop (&loop);
+}
+
+/* Helper function for gfc_conv_array_parameter if array size needs to be
+   computed.  */
+
+static void
+array_parameter_size (tree desc, gfc_expr *expr, tree *size)
+{
+  tree elem;
+  if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
+    *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
+  else if (expr->rank > 1)
+    *size = build_call_expr_loc (input_location,
+			     gfor_fndecl_size0, 1,
+			     gfc_build_addr_expr (NULL, desc));
+  else
+    {
+      tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
+      tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
+
+      *size = fold_build2_loc (input_location, MINUS_EXPR,
+			       gfc_array_index_type, ubound, lbound);
+      *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			       *size, gfc_index_one_node);
+      *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
+			       *size, gfc_index_zero_node);
+    }
+  elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
+  *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			   *size, fold_convert (gfc_array_index_type, elem));
+}
+
+/* Convert an array for passing as an actual parameter.  */
+/* TODO: Optimize passing g77 arrays.  */
+
+void
+gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
+			  const gfc_symbol *fsym, const char *proc_name,
+			  tree *size)
+{
+  tree ptr;
+  tree desc;
+  tree tmp = NULL_TREE;
+  tree stmt;
+  tree parent = DECL_CONTEXT (current_function_decl);
+  bool full_array_var;
+  bool this_array_result;
+  bool contiguous;
+  bool no_pack;
+  bool array_constructor;
+  bool good_allocatable;
+  bool ultimate_ptr_comp;
+  bool ultimate_alloc_comp;
+  gfc_symbol *sym;
+  stmtblock_t block;
+  gfc_ref *ref;
+
+  ultimate_ptr_comp = false;
+  ultimate_alloc_comp = false;
+
+  for (ref = expr->ref; ref; ref = ref->next)
+    {
+      if (ref->next == NULL)
+        break;
+
+      if (ref->type == REF_COMPONENT)
+	{
+	  ultimate_ptr_comp = ref->u.c.component->attr.pointer;
+	  ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
+	}
+    }
+
+  full_array_var = false;
+  contiguous = false;
+
+  if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
+    full_array_var = gfc_full_array_ref_p (ref, &contiguous);
+
+  sym = full_array_var ? expr->symtree->n.sym : NULL;
+
+  /* The symbol should have an array specification.  */
+  gcc_assert (!sym || sym->as || ref->u.ar.as);
+
+  if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
+    {
+      get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
+      expr->ts.u.cl->backend_decl = tmp;
+      se->string_length = tmp;
+    }
+
+  /* Is this the result of the enclosing procedure?  */
+  this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
+  if (this_array_result
+	&& (sym->backend_decl != current_function_decl)
+	&& (sym->backend_decl != parent))
+    this_array_result = false;
+
+  /* Passing address of the array if it is not pointer or assumed-shape.  */
+  if (full_array_var && g77 && !this_array_result
+      && sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
+    {
+      tmp = gfc_get_symbol_decl (sym);
+
+      if (sym->ts.type == BT_CHARACTER)
+	se->string_length = sym->ts.u.cl->backend_decl;
+
+      if (!sym->attr.pointer
+	  && sym->as
+	  && sym->as->type != AS_ASSUMED_SHAPE
+	  && sym->as->type != AS_DEFERRED
+	  && sym->as->type != AS_ASSUMED_RANK
+	  && !sym->attr.allocatable)
+        {
+	  /* Some variables are declared directly, others are declared as
+	     pointers and allocated on the heap.  */
+          if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
+            se->expr = tmp;
+          else
+	    se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
+	  if (size)
+	    array_parameter_size (tmp, expr, size);
+	  return;
+        }
+
+      if (sym->attr.allocatable)
+        {
+	  if (sym->attr.dummy || sym->attr.result)
+	    {
+	      gfc_conv_expr_descriptor (se, expr);
+	      tmp = se->expr;
+	    }
+	  if (size)
+	    array_parameter_size (tmp, expr, size);
+	  se->expr = gfc_conv_array_data (tmp);
+          return;
+        }
+    }
+
+  /* A convenient reduction in scope.  */
+  contiguous = g77 && !this_array_result && contiguous;
+
+  /* There is no need to pack and unpack the array, if it is contiguous
+     and not a deferred- or assumed-shape array, or if it is simply
+     contiguous.  */
+  no_pack = ((sym && sym->as
+		  && !sym->attr.pointer
+		  && sym->as->type != AS_DEFERRED
+		  && sym->as->type != AS_ASSUMED_RANK
+		  && sym->as->type != AS_ASSUMED_SHAPE)
+		      ||
+	     (ref && ref->u.ar.as
+		  && ref->u.ar.as->type != AS_DEFERRED
+		  && ref->u.ar.as->type != AS_ASSUMED_RANK
+		  && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
+		      ||
+	     gfc_is_simply_contiguous (expr, false));
+
+  no_pack = contiguous && no_pack;
+
+  /* Array constructors are always contiguous and do not need packing.  */
+  array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
+
+  /* Same is true of contiguous sections from allocatable variables.  */
+  good_allocatable = contiguous
+		       && expr->symtree
+		       && expr->symtree->n.sym->attr.allocatable;
+
+  /* Or ultimate allocatable components.  */
+  ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
+
+  if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
+    {
+      gfc_conv_expr_descriptor (se, expr);
+      if (expr->ts.type == BT_CHARACTER)
+	se->string_length = expr->ts.u.cl->backend_decl;
+      if (size)
+	array_parameter_size (se->expr, expr, size);
+      se->expr = gfc_conv_array_data (se->expr);
+      return;
+    }
+
+  if (this_array_result)
+    {
+      /* Result of the enclosing function.  */
+      gfc_conv_expr_descriptor (se, expr);
+      if (size)
+	array_parameter_size (se->expr, expr, size);
+      se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
+
+      if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
+	      && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
+	se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
+								 se->expr));
+
+      return;
+    }
+  else
+    {
+      /* Every other type of array.  */
+      se->want_pointer = 1;
+      gfc_conv_expr_descriptor (se, expr);
+      if (size)
+	array_parameter_size (build_fold_indirect_ref_loc (input_location,
+						       se->expr),
+				  expr, size);
+    }
+
+  /* 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 = 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);
+    }
+
+  if (g77 || (fsym && fsym->attr.contiguous
+	      && !gfc_is_simply_contiguous (expr, false)))
+    {
+      tree origptr = NULL_TREE;
+
+      desc = se->expr;
+
+      /* For contiguous arrays, save the original value of the descriptor.  */
+      if (!g77)
+	{
+	  origptr = gfc_create_var (pvoid_type_node, "origptr");
+	  tmp = build_fold_indirect_ref_loc (input_location, desc);
+	  tmp = gfc_conv_array_data (tmp);
+	  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+				 TREE_TYPE (origptr), origptr,
+				 fold_convert (TREE_TYPE (origptr), tmp));
+	  gfc_add_expr_to_block (&se->pre, tmp);
+	}
+
+      /* Repack the array.  */
+      if (gfc_option.warn_array_temp)
+	{
+	  if (fsym)
+	    gfc_warning ("Creating array temporary at %L for argument '%s'",
+			 &expr->where, fsym->name);
+	  else
+	    gfc_warning ("Creating array temporary at %L", &expr->where);
+	}
+
+      ptr = build_call_expr_loc (input_location,
+			     gfor_fndecl_in_pack, 1, desc);
+
+      if (fsym && fsym->attr.optional && sym && sym->attr.optional)
+	{
+	  tmp = gfc_conv_expr_present (sym);
+	  ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
+			tmp, fold_convert (TREE_TYPE (se->expr), ptr),
+			fold_convert (TREE_TYPE (se->expr), null_pointer_node));
+	}
+
+      ptr = gfc_evaluate_now (ptr, &se->pre);
+
+      /* Use the packed data for the actual argument, except for contiguous arrays,
+	 where the descriptor's data component is set.  */
+      if (g77)
+	se->expr = ptr;
+      else
+	{
+	  tmp = build_fold_indirect_ref_loc (input_location, desc);
+
+	  gfc_ss * ss = gfc_walk_expr (expr);
+	  if (!transposed_dims (ss))
+	    gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
+	  else
+	    {
+	      tree old_field, new_field;
+
+	      /* The original descriptor has transposed dims so we can't reuse
+		 it directly; we have to create a new one.  */
+	      tree old_desc = tmp;
+	      tree new_desc = gfc_create_var (TREE_TYPE (old_desc), "arg_desc");
+
+	      old_field = gfc_conv_descriptor_dtype (old_desc);
+	      new_field = gfc_conv_descriptor_dtype (new_desc);
+	      gfc_add_modify (&se->pre, new_field, old_field);
+
+	      old_field = gfc_conv_descriptor_offset (old_desc);
+	      new_field = gfc_conv_descriptor_offset (new_desc);
+	      gfc_add_modify (&se->pre, new_field, old_field);
+
+	      for (int i = 0; i < expr->rank; i++)
+		{
+		  old_field = gfc_conv_descriptor_dimension (old_desc,
+			gfc_rank_cst[get_array_ref_dim_for_loop_dim (ss, i)]);
+		  new_field = gfc_conv_descriptor_dimension (new_desc,
+			gfc_rank_cst[i]);
+		  gfc_add_modify (&se->pre, new_field, old_field);
+		}
+
+	      if (gfc_option.coarray == GFC_FCOARRAY_LIB
+		  && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc))
+		  && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc))
+		     == GFC_ARRAY_ALLOCATABLE)
+		{
+		  old_field = gfc_conv_descriptor_token (old_desc);
+		  new_field = gfc_conv_descriptor_token (new_desc);
+		  gfc_add_modify (&se->pre, new_field, old_field);
+		}
+
+	      gfc_conv_descriptor_data_set (&se->pre, new_desc, ptr);
+	      se->expr = gfc_build_addr_expr (NULL_TREE, new_desc);
+	    }
+	  gfc_free_ss (ss);
+	}
+
+      if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
+	{
+	  char * msg;
+
+	  if (fsym && proc_name)
+	    asprintf (&msg, "An array temporary was created for argument "
+		      "'%s' of procedure '%s'", fsym->name, proc_name);
+	  else
+	    asprintf (&msg, "An array temporary was created");
+
+	  tmp = build_fold_indirect_ref_loc (input_location,
+					 desc);
+	  tmp = gfc_conv_array_data (tmp);
+	  tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+				 fold_convert (TREE_TYPE (tmp), ptr), tmp);
+
+	  if (fsym && fsym->attr.optional && sym && sym->attr.optional)
+	    tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+				   boolean_type_node,
+				   gfc_conv_expr_present (sym), tmp);
+
+	  gfc_trans_runtime_check (false, true, tmp, &se->pre,
+				   &expr->where, msg);
+	  free (msg);
+	}
+
+      gfc_start_block (&block);
+
+      /* Copy the data back.  */
+      if (fsym == NULL || fsym->attr.intent != INTENT_IN)
+	{
+	  tmp = build_call_expr_loc (input_location,
+				 gfor_fndecl_in_unpack, 2, desc, ptr);
+	  gfc_add_expr_to_block (&block, tmp);
+	}
+
+      /* Free the temporary.  */
+      tmp = gfc_call_free (convert (pvoid_type_node, ptr));
+      gfc_add_expr_to_block (&block, tmp);
+
+      stmt = gfc_finish_block (&block);
+
+      gfc_init_block (&block);
+      /* Only if it was repacked.  This code needs to be executed before the
+         loop cleanup code.  */
+      tmp = build_fold_indirect_ref_loc (input_location,
+				     desc);
+      tmp = gfc_conv_array_data (tmp);
+      tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			     fold_convert (TREE_TYPE (tmp), ptr), tmp);
+
+      if (fsym && fsym->attr.optional && sym && sym->attr.optional)
+	tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+			       boolean_type_node,
+			       gfc_conv_expr_present (sym), tmp);
+
+      tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
+
+      gfc_add_expr_to_block (&block, tmp);
+      gfc_add_block_to_block (&block, &se->post);
+
+      gfc_init_block (&se->post);
+
+      /* Reset the descriptor pointer.  */
+      if (!g77)
+        {
+          tmp = build_fold_indirect_ref_loc (input_location, desc);
+          gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
+        }
+
+      gfc_add_block_to_block (&se->post, &block);
+    }
+}
+
+
+/* Generate code to deallocate an array, if it is allocated.  */
+
+tree
+gfc_trans_dealloc_allocated (tree descriptor, bool coarray, gfc_expr *expr)
+{
+  tree tmp;
+  tree var;
+  stmtblock_t block;
+
+  gfc_start_block (&block);
+
+  var = gfc_conv_descriptor_data_get (descriptor);
+  STRIP_NOPS (var);
+
+  /* Call array_deallocate with an int * present in the second argument.
+     Although it is ignored here, it's presence ensures that arrays that
+     are already deallocated are ignored.  */
+  tmp = gfc_deallocate_with_status (coarray ? descriptor : var, NULL_TREE,
+				    NULL_TREE, NULL_TREE, NULL_TREE, true,
+				    expr, coarray);
+  gfc_add_expr_to_block (&block, tmp);
+
+  /* Zero the data pointer.  */
+  tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+			 var, build_int_cst (TREE_TYPE (var), 0));
+  gfc_add_expr_to_block (&block, tmp);
+
+  return gfc_finish_block (&block);
+}
+
+
+/* This helper function calculates the size in words of a full array.  */
+
+static tree
+get_full_array_size (stmtblock_t *block, tree decl, int rank)
+{
+  tree idx;
+  tree nelems;
+  tree tmp;
+  idx = gfc_rank_cst[rank - 1];
+  nelems = gfc_conv_descriptor_ubound_get (decl, idx);
+  tmp = gfc_conv_descriptor_lbound_get (decl, idx);
+  tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			 nelems, tmp);
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			 tmp, gfc_index_one_node);
+  tmp = gfc_evaluate_now (tmp, block);
+
+  nelems = gfc_conv_descriptor_stride_get (decl, idx);
+  tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			 nelems, tmp);
+  return gfc_evaluate_now (tmp, block);
+}
+
+
+/* Allocate dest to the same size as src, and copy src -> dest.
+   If no_malloc is set, only the copy is done.  */
+
+static tree
+duplicate_allocatable (tree dest, tree src, tree type, int rank,
+		       bool no_malloc, tree str_sz)
+{
+  tree tmp;
+  tree size;
+  tree nelems;
+  tree null_cond;
+  tree null_data;
+  stmtblock_t block;
+
+  /* If the source is null, set the destination to null.  Then,
+     allocate memory to the destination.  */
+  gfc_init_block (&block);
+
+  if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
+    {
+      tmp = null_pointer_node;
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, dest, tmp);
+      gfc_add_expr_to_block (&block, tmp);
+      null_data = gfc_finish_block (&block);
+
+      gfc_init_block (&block);
+      if (str_sz != NULL_TREE)
+	size = str_sz;
+      else
+	size = TYPE_SIZE_UNIT (TREE_TYPE (type));
+
+      if (!no_malloc)
+	{
+	  tmp = gfc_call_malloc (&block, type, size);
+	  tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+				 dest, fold_convert (type, tmp));
+	  gfc_add_expr_to_block (&block, tmp);
+	}
+
+      tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
+      tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
+				 fold_convert (size_type_node, size));
+    }
+  else
+    {
+      gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
+      null_data = gfc_finish_block (&block);
+
+      gfc_init_block (&block);
+      if (rank)
+	nelems = get_full_array_size (&block, src, rank);
+      else
+	nelems = gfc_index_one_node;
+
+      if (str_sz != NULL_TREE)
+	tmp = fold_convert (gfc_array_index_type, str_sz);
+      else
+	tmp = fold_convert (gfc_array_index_type,
+			    TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+      size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			      nelems, tmp);
+      if (!no_malloc)
+	{
+	  tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
+	  tmp = gfc_call_malloc (&block, tmp, size);
+	  gfc_conv_descriptor_data_set (&block, dest, tmp);
+	}
+
+      /* We know the temporary and the value will be the same length,
+	 so can use memcpy.  */
+      tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
+      tmp = build_call_expr_loc (input_location,
+			tmp, 3, gfc_conv_descriptor_data_get (dest),
+			gfc_conv_descriptor_data_get (src),
+			fold_convert (size_type_node, size));
+    }
+
+  gfc_add_expr_to_block (&block, tmp);
+  tmp = gfc_finish_block (&block);
+
+  /* Null the destination if the source is null; otherwise do
+     the allocate and copy.  */
+  if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
+    null_cond = src;
+  else
+    null_cond = gfc_conv_descriptor_data_get (src);
+
+  null_cond = convert (pvoid_type_node, null_cond);
+  null_cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			       null_cond, null_pointer_node);
+  return build3_v (COND_EXPR, null_cond, tmp, null_data);
+}
+
+
+/* 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)
+{
+  return duplicate_allocatable (dest, src, type, rank, false, NULL_TREE);
+}
+
+
+/* Copy data src -> dest.  */
+
+tree
+gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
+{
+  return duplicate_allocatable (dest, src, type, rank, true, NULL_TREE);
+}
+
+
+/* Recursively traverse an object of derived type, generating code to
+   deallocate, nullify or copy allocatable components.  This is the work horse
+   function for the functions named in this enum.  */
+
+enum {DEALLOCATE_ALLOC_COMP = 1, DEALLOCATE_ALLOC_COMP_NO_CAF,
+      NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP,
+      COPY_ALLOC_COMP_CAF};
+
+static tree
+structure_alloc_comps (gfc_symbol * der_type, tree decl,
+		       tree dest, int rank, int purpose)
+{
+  gfc_component *c;
+  gfc_loopinfo loop;
+  stmtblock_t fnblock;
+  stmtblock_t loopbody;
+  stmtblock_t tmpblock;
+  tree decl_type;
+  tree tmp;
+  tree comp;
+  tree dcmp;
+  tree nelems;
+  tree index;
+  tree var;
+  tree cdecl;
+  tree ctype;
+  tree vref, dref;
+  tree null_cond = NULL_TREE;
+  bool called_dealloc_with_status;
+
+  gfc_init_block (&fnblock);
+
+  decl_type = TREE_TYPE (decl);
+
+  if ((POINTER_TYPE_P (decl_type) && rank != 0)
+	|| (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
+    decl = build_fold_indirect_ref_loc (input_location, decl);
+
+  /* Just in case in gets dereferenced.  */
+  decl_type = TREE_TYPE (decl);
+
+  /* If this an array of derived types with allocatable components
+     build a loop and recursively call this function.  */
+  if (TREE_CODE (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);
+
+      /* Get the number of elements - 1 and set the counter.  */
+      if (GFC_DESCRIPTOR_TYPE_P (decl_type))
+	{
+	  /* Use the descriptor for an allocatable array.  Since this
+	     is a full array reference, we only need the descriptor
+	     information from dimension = rank.  */
+	  tmp = get_full_array_size (&fnblock, decl, rank);
+	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				 gfc_array_index_type, tmp,
+				 gfc_index_one_node);
+
+	  null_cond = gfc_conv_descriptor_data_get (decl);
+	  null_cond = fold_build2_loc (input_location, NE_EXPR,
+				       boolean_type_node, null_cond,
+				       build_int_cst (TREE_TYPE (null_cond), 0));
+	}
+      else
+	{
+	  /*  Otherwise use the TYPE_DOMAIN information.  */
+	  tmp =  array_type_nelts (decl_type);
+	  tmp = fold_convert (gfc_array_index_type, tmp);
+	}
+
+      /* Remember that this is, in fact, the no. of elements - 1.  */
+      nelems = gfc_evaluate_now (tmp, &fnblock);
+      index = gfc_create_var (gfc_array_index_type, "S");
+
+      /* Build the body of the loop.  */
+      gfc_init_block (&loopbody);
+
+      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)
+        {
+	  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,
+				       COPY_ALLOC_COMP);
+	}
+      else
+        tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
+
+      gfc_add_expr_to_block (&loopbody, tmp);
+
+      /* Build the loop and return.  */
+      gfc_init_loopinfo (&loop);
+      loop.dimen = 1;
+      loop.from[0] = gfc_index_zero_node;
+      loop.loopvar[0] = index;
+      loop.to[0] = nelems;
+      gfc_trans_scalarizing_loops (&loop, &loopbody);
+      gfc_add_block_to_block (&fnblock, &loop.pre);
+
+      tmp = gfc_finish_block (&fnblock);
+      if (null_cond != NULL_TREE)
+	tmp = build3_v (COND_EXPR, null_cond, tmp,
+			build_empty_stmt (input_location));
+
+      return tmp;
+    }
+
+  /* Otherwise, act on the components or recursively call self to
+     act on a chain of components.  */
+  for (c = der_type->components; c; c = c->next)
+    {
+      bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
+				  || c->ts.type == BT_CLASS)
+				    && c->ts.u.derived->attr.alloc_comp;
+      cdecl = c->backend_decl;
+      ctype = TREE_TYPE (cdecl);
+
+      switch (purpose)
+	{
+	case DEALLOCATE_ALLOC_COMP:
+	case DEALLOCATE_ALLOC_COMP_NO_CAF:
+
+	  /* gfc_deallocate_scalar_with_status calls gfc_deallocate_alloc_comp
+	     (i.e. this function) so generate all the calls and suppress the
+	     recursion from here, if necessary.  */
+	  called_dealloc_with_status = false;
+	  gfc_init_block (&tmpblock);
+
+	  if ((c->ts.type == BT_DERIVED && !c->attr.pointer)
+	      || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer))
+	    {
+	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+				      decl, cdecl, NULL_TREE);
+
+	      /* The finalizer frees allocatable components.  */
+	      called_dealloc_with_status
+		= gfc_add_comp_finalizer_call (&tmpblock, comp, c,
+					       purpose == DEALLOCATE_ALLOC_COMP);
+	    }
+	  else
+	    comp = NULL_TREE;
+
+	  if (c->attr.allocatable && !c->attr.proc_pointer
+	      && (c->attr.dimension
+		  || (c->attr.codimension
+		      && purpose != DEALLOCATE_ALLOC_COMP_NO_CAF)))
+	    {
+	      if (comp == NULL_TREE)
+		comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+					decl, cdecl, NULL_TREE);
+	      tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension, NULL);
+	      gfc_add_expr_to_block (&tmpblock, tmp);
+	    }
+	  else if (c->attr.allocatable && !c->attr.codimension)
+	    {
+	      /* Allocatable scalar components.  */
+	      if (comp == NULL_TREE)
+		comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+					decl, cdecl, NULL_TREE);
+
+	      tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
+						       c->ts);
+	      gfc_add_expr_to_block (&tmpblock, tmp);
+	      called_dealloc_with_status = true;
+
+	      tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+				     void_type_node, comp,
+				     build_int_cst (TREE_TYPE (comp), 0));
+	      gfc_add_expr_to_block (&tmpblock, tmp);
+	    }
+	  else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable
+		   && (!CLASS_DATA (c)->attr.codimension
+		       || purpose != DEALLOCATE_ALLOC_COMP_NO_CAF))
+	    {
+	      /* Allocatable CLASS components.  */
+
+	      /* Add reference to '_data' component.  */
+	      tmp = CLASS_DATA (c)->backend_decl;
+	      comp = fold_build3_loc (input_location, COMPONENT_REF,
+				      TREE_TYPE (tmp), comp, tmp, NULL_TREE);
+
+	      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
+	        tmp = gfc_trans_dealloc_allocated (comp,
+					CLASS_DATA (c)->attr.codimension, NULL);
+	      else
+		{
+		  tmp = gfc_deallocate_scalar_with_status (comp, NULL_TREE, true, NULL,
+							   CLASS_DATA (c)->ts);
+		  gfc_add_expr_to_block (&tmpblock, tmp);
+		  called_dealloc_with_status = true;
+
+		  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+					 void_type_node, comp,
+					 build_int_cst (TREE_TYPE (comp), 0));
+		}
+	      gfc_add_expr_to_block (&tmpblock, tmp);
+	    }
+
+	  if (cmp_has_alloc_comps
+		&& !c->attr.pointer
+		&& !called_dealloc_with_status)
+	    {
+	      /* Do not deallocate the components of ultimate pointer
+		 components or iteratively call self if call has been made
+		 to gfc_trans_dealloc_allocated  */
+	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+				      decl, cdecl, NULL_TREE);
+	      rank = c->as ? c->as->rank : 0;
+	      tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
+					   rank, purpose);
+	      gfc_add_expr_to_block (&fnblock, tmp);
+	    }
+
+	  /* Now add the deallocation of this component.  */
+	  gfc_add_block_to_block (&fnblock, &tmpblock);
+	  break;
+
+	case NULLIFY_ALLOC_COMP:
+	  if (c->attr.pointer)
+	    continue;
+	  else if (c->attr.allocatable
+		   && (c->attr.dimension|| c->attr.codimension))
+	    {
+	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+				      decl, cdecl, NULL_TREE);
+	      gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
+	    }
+	  else if (c->attr.allocatable)
+	    {
+	      /* Allocatable scalar components.  */
+	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+				      decl, cdecl, NULL_TREE);
+	      tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+				     void_type_node, comp,
+				     build_int_cst (TREE_TYPE (comp), 0));
+	      gfc_add_expr_to_block (&fnblock, tmp);
+	      if (gfc_deferred_strlen (c, &comp))
+		{
+		  comp = fold_build3_loc (input_location, COMPONENT_REF,
+					  TREE_TYPE (comp),
+					  decl, comp, NULL_TREE);
+		  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+					 TREE_TYPE (comp), comp,
+					 build_int_cst (TREE_TYPE (comp), 0));
+		  gfc_add_expr_to_block (&fnblock, tmp);
+		}
+	    }
+	  else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
+	    {
+	      /* Allocatable CLASS components.  */
+	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+				      decl, cdecl, NULL_TREE);
+	      /* Add reference to '_data' component.  */
+	      tmp = CLASS_DATA (c)->backend_decl;
+	      comp = fold_build3_loc (input_location, COMPONENT_REF,
+				      TREE_TYPE (tmp), comp, tmp, NULL_TREE);
+	      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
+		gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
+	      else
+		{
+		  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+					 void_type_node, comp,
+					 build_int_cst (TREE_TYPE (comp), 0));
+		  gfc_add_expr_to_block (&fnblock, tmp);
+		}
+	    }
+          else if (cmp_has_alloc_comps)
+	    {
+	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+				      decl, cdecl, NULL_TREE);
+	      rank = c->as ? c->as->rank : 0;
+	      tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
+					   rank, purpose);
+	      gfc_add_expr_to_block (&fnblock, tmp);
+	    }
+	  break;
+
+	case COPY_ALLOC_COMP_CAF:
+	  if (!c->attr.codimension
+	      && (c->ts.type != BT_CLASS || CLASS_DATA (c)->attr.coarray_comp)
+	      && (c->ts.type != BT_DERIVED
+		  || !c->ts.u.derived->attr.coarray_comp))
+	    continue;
+
+	  comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
+				  cdecl, NULL_TREE);
+	  dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
+				  cdecl, NULL_TREE);
+
+	  if (c->attr.codimension)
+	    {
+	      if (c->ts.type == BT_CLASS)
+		{
+		  comp = gfc_class_data_get (comp);
+		  dcmp = gfc_class_data_get (dcmp);
+		}
+	      gfc_conv_descriptor_data_set (&fnblock, dcmp,
+					   gfc_conv_descriptor_data_get (comp));
+	    }
+	  else
+	    {
+	      tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
+					   rank, purpose);
+	      gfc_add_expr_to_block (&fnblock, tmp);
+
+	    }
+	  break;
+
+	case COPY_ALLOC_COMP:
+	  if (c->attr.pointer)
+	    continue;
+
+	  /* We need source and destination components.  */
+	  comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
+				  cdecl, NULL_TREE);
+	  dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
+				  cdecl, NULL_TREE);
+	  dcmp = fold_convert (TREE_TYPE (comp), dcmp);
+
+	  if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
+	    {
+	      tree ftn_tree;
+	      tree size;
+	      tree dst_data;
+	      tree src_data;
+	      tree null_data;
+
+	      dst_data = gfc_class_data_get (dcmp);
+	      src_data = gfc_class_data_get (comp);
+	      size = fold_convert (size_type_node, gfc_vtable_size_get (comp));
+
+	      if (CLASS_DATA (c)->attr.dimension)
+		{
+		  nelems = gfc_conv_descriptor_size (src_data,
+						     CLASS_DATA (c)->as->rank);
+		  size = fold_build2_loc (input_location, MULT_EXPR,
+					  size_type_node, size,
+					  fold_convert (size_type_node,
+							nelems));
+		}
+	      else
+		nelems = build_int_cst (size_type_node, 1);
+
+	      if (CLASS_DATA (c)->attr.dimension
+		  || CLASS_DATA (c)->attr.codimension)
+		{
+		  src_data = gfc_conv_descriptor_data_get (src_data);
+		  dst_data = gfc_conv_descriptor_data_get (dst_data);
+		}
+
+	      gfc_init_block (&tmpblock);
+
+	      /* Coarray component have to have the same allocation status and
+		 shape/type-parameter/effective-type on the LHS and RHS of an
+		 intrinsic assignment. Hence, we did not deallocated them - and
+		 do not allocate them here.  */
+	      if (!CLASS_DATA (c)->attr.codimension)
+		{
+		  ftn_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
+		  tmp = build_call_expr_loc (input_location, ftn_tree, 1, size);
+		  gfc_add_modify (&tmpblock, dst_data,
+				  fold_convert (TREE_TYPE (dst_data), tmp));
+		}
+
+	      tmp = gfc_copy_class_to_class (comp, dcmp, nelems);
+	      gfc_add_expr_to_block (&tmpblock, tmp);
+	      tmp = gfc_finish_block (&tmpblock);
+
+	      gfc_init_block (&tmpblock);
+	      gfc_add_modify (&tmpblock, dst_data,
+			      fold_convert (TREE_TYPE (dst_data),
+					    null_pointer_node));
+	      null_data = gfc_finish_block (&tmpblock);
+
+	      null_cond = fold_build2_loc (input_location, NE_EXPR,
+					   boolean_type_node, src_data,
+				           null_pointer_node);
+
+	      gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond,
+							 tmp, null_data));
+	      continue;
+	    }
+
+	  if (gfc_deferred_strlen (c, &tmp))
+	    {
+	      tree len, size;
+	      len = tmp;
+	      tmp = fold_build3_loc (input_location, COMPONENT_REF,
+				     TREE_TYPE (len),
+				     decl, len, NULL_TREE);
+	      len = fold_build3_loc (input_location, COMPONENT_REF,
+				     TREE_TYPE (len),
+				     dest, len, NULL_TREE);
+	      tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+				     TREE_TYPE (len), len, tmp);
+	      gfc_add_expr_to_block (&fnblock, tmp);
+	      size = size_of_string_in_bytes (c->ts.kind, len);
+	      tmp = duplicate_allocatable (dcmp, comp, ctype, rank,
+					   false, size);
+	      gfc_add_expr_to_block (&fnblock, tmp);
+	    }
+	  else if (c->attr.allocatable && !c->attr.proc_pointer
+		   && !cmp_has_alloc_comps)
+	    {
+	      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);
+	      gfc_add_expr_to_block (&fnblock, tmp);
+	    }
+
+          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:
+	  gcc_unreachable ();
+	  break;
+	}
+    }
+
+  return gfc_finish_block (&fnblock);
+}
+
+/* Recursively traverse an object of derived type, generating code to
+   nullify allocatable components.  */
+
+tree
+gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
+{
+  return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
+				NULLIFY_ALLOC_COMP);
+}
+
+
+/* Recursively traverse an object of derived type, generating code to
+   deallocate allocatable components.  */
+
+tree
+gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
+{
+  return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
+				DEALLOCATE_ALLOC_COMP);
+}
+
+
+/* Recursively traverse an object of derived type, generating code to
+   deallocate allocatable components.  But do not deallocate coarrays.
+   To be used for intrinsic assignment, which may not change the allocation
+   status of coarrays.  */
+
+tree
+gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank)
+{
+  return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
+				DEALLOCATE_ALLOC_COMP_NO_CAF);
+}
+
+
+tree
+gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest)
+{
+  return structure_alloc_comps (der_type, decl, dest, 0, COPY_ALLOC_COMP_CAF);
+}
+
+
+/* Recursively traverse an object of derived type, generating code to
+   copy it and its allocatable components.  */
+
+tree
+gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
+{
+  return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
+}
+
+
+/* Recursively traverse an object of derived type, generating code to
+   copy only its allocatable components.  */
+
+tree
+gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
+{
+  return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP);
+}
+
+
+/* Returns the value of LBOUND for an expression.  This could be broken out
+   from gfc_conv_intrinsic_bound but this seemed to be simpler.  This is
+   called by gfc_alloc_allocatable_for_assignment.  */
+static tree
+get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
+{
+  tree lbound;
+  tree ubound;
+  tree stride;
+  tree cond, cond1, cond3, cond4;
+  tree tmp;
+  gfc_ref *ref;
+
+  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+    {
+      tmp = gfc_rank_cst[dim];
+      lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
+      ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
+      stride = gfc_conv_descriptor_stride_get (desc, tmp);
+      cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
+			       ubound, lbound);
+      cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
+			       stride, gfc_index_zero_node);
+      cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+			       boolean_type_node, cond3, cond1);
+      cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+			       stride, gfc_index_zero_node);
+      if (assumed_size)
+	cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+				tmp, build_int_cst (gfc_array_index_type,
+						    expr->rank - 1));
+      else
+	cond = boolean_false_node;
+
+      cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+			       boolean_type_node, cond3, cond4);
+      cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+			      boolean_type_node, cond, cond1);
+
+      return fold_build3_loc (input_location, COND_EXPR,
+			      gfc_array_index_type, cond,
+			      lbound, gfc_index_one_node);
+    }
+
+  if (expr->expr_type == EXPR_FUNCTION)
+    {
+      /* A conversion function, so use the argument.  */
+      gcc_assert (expr->value.function.isym
+		  && expr->value.function.isym->conversion);
+      expr = expr->value.function.actual->expr;
+    }
+
+  if (expr->expr_type == EXPR_VARIABLE)
+    {
+      tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
+      for (ref = expr->ref; ref; ref = ref->next)
+	{
+	  if (ref->type == REF_COMPONENT
+		&& ref->u.c.component->as
+		&& ref->next
+		&& ref->next->u.ar.type == AR_FULL)
+	    tmp = TREE_TYPE (ref->u.c.component->backend_decl);
+	}
+      return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
+    }
+
+  return gfc_index_one_node;
+}
+
+
+/* Returns true if an expression represents an lhs that can be reallocated
+   on assignment.  */
+
+bool
+gfc_is_reallocatable_lhs (gfc_expr *expr)
+{
+  gfc_ref * ref;
+
+  if (!expr->ref)
+    return false;
+
+  /* An allocatable variable.  */
+  if (expr->symtree->n.sym->attr.allocatable
+	&& expr->ref
+	&& expr->ref->type == REF_ARRAY
+	&& expr->ref->u.ar.type == AR_FULL)
+    return true;
+
+  /* All that can be left are allocatable components.  */
+  if ((expr->symtree->n.sym->ts.type != BT_DERIVED
+       && expr->symtree->n.sym->ts.type != BT_CLASS)
+	|| !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
+    return false;
+
+  /* Find a component ref followed by an array reference.  */
+  for (ref = expr->ref; ref; ref = ref->next)
+    if (ref->next
+	  && ref->type == REF_COMPONENT
+	  && ref->next->type == REF_ARRAY
+	  && !ref->next->next)
+      break;
+
+  if (!ref)
+    return false;
+
+  /* Return true if valid reallocatable lhs.  */
+  if (ref->u.c.component->attr.allocatable
+	&& ref->next->u.ar.type == AR_FULL)
+    return true;
+
+  return false;
+}
+
+
+/* Allocate the lhs of an assignment to an allocatable array, otherwise
+   reallocate it.  */
+
+tree
+gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
+				      gfc_expr *expr1,
+				      gfc_expr *expr2)
+{
+  stmtblock_t realloc_block;
+  stmtblock_t alloc_block;
+  stmtblock_t fblock;
+  gfc_ss *rss;
+  gfc_ss *lss;
+  gfc_array_info *linfo;
+  tree realloc_expr;
+  tree alloc_expr;
+  tree size1;
+  tree size2;
+  tree array1;
+  tree cond_null;
+  tree cond;
+  tree tmp;
+  tree tmp2;
+  tree lbound;
+  tree ubound;
+  tree desc;
+  tree old_desc;
+  tree desc2;
+  tree offset;
+  tree jump_label1;
+  tree jump_label2;
+  tree neq_size;
+  tree lbd;
+  int n;
+  int dim;
+  gfc_array_spec * as;
+
+  /* x = f(...) with x allocatable.  In this case, expr1 is the rhs.
+     Find the lhs expression in the loop chain and set expr1 and
+     expr2 accordingly.  */
+  if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
+    {
+      expr2 = expr1;
+      /* Find the ss for the lhs.  */
+      lss = loop->ss;
+      for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
+	if (lss->info->expr && lss->info->expr->expr_type == EXPR_VARIABLE)
+	  break;
+      if (lss == gfc_ss_terminator)
+	return NULL_TREE;
+      expr1 = lss->info->expr;
+    }
+
+  /* Bail out if this is not a valid allocate on assignment.  */
+  if (!gfc_is_reallocatable_lhs (expr1)
+	|| (expr2 && !expr2->rank))
+    return NULL_TREE;
+
+  /* Find the ss for the lhs.  */
+  lss = loop->ss;
+  for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
+    if (lss->info->expr == expr1)
+      break;
+
+  if (lss == gfc_ss_terminator)
+    return NULL_TREE;
+
+  linfo = &lss->info->data.array;
+
+  /* Find an ss for the rhs. For operator expressions, we see the
+     ss's for the operands. Any one of these will do.  */
+  rss = loop->ss;
+  for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
+    if (rss->info->expr != expr1 && rss != loop->temp_ss)
+      break;
+
+  if (expr2 && rss == gfc_ss_terminator)
+    return NULL_TREE;
+
+  gfc_start_block (&fblock);
+
+  /* Since the lhs is allocatable, this must be a descriptor type.
+     Get the data and array size.  */
+  desc = linfo->descriptor;
+  gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
+  array1 = gfc_conv_descriptor_data_get (desc);
+
+  /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
+     deallocated if expr is an array of different shape or any of the
+     corresponding length type parameter values of variable and expr
+     differ."  This assures F95 compatibility.  */
+  jump_label1 = gfc_build_label_decl (NULL_TREE);
+  jump_label2 = gfc_build_label_decl (NULL_TREE);
+
+  /* Allocate if data is NULL.  */
+  cond_null = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+			 array1, build_int_cst (TREE_TYPE (array1), 0));
+  tmp = build3_v (COND_EXPR, cond_null,
+		  build1_v (GOTO_EXPR, jump_label1),
+		  build_empty_stmt (input_location));
+  gfc_add_expr_to_block (&fblock, tmp);
+
+  /* Get arrayspec if expr is a full array.  */
+  if (expr2 && expr2->expr_type == EXPR_FUNCTION
+	&& expr2->value.function.isym
+	&& expr2->value.function.isym->conversion)
+    {
+      /* For conversion functions, take the arg.  */
+      gfc_expr *arg = expr2->value.function.actual->expr;
+      as = gfc_get_full_arrayspec_from_expr (arg);
+    }
+  else if (expr2)
+    as = gfc_get_full_arrayspec_from_expr (expr2);
+  else
+    as = NULL;
+
+  /* If the lhs shape is not the same as the rhs jump to setting the
+     bounds and doing the reallocation.......  */
+  for (n = 0; n < expr1->rank; n++)
+    {
+      /* Check the shape.  */
+      lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
+      ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
+      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+			     gfc_array_index_type,
+			     loop->to[n], loop->from[n]);
+      tmp = fold_build2_loc (input_location, PLUS_EXPR,
+			     gfc_array_index_type,
+			     tmp, lbound);
+      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+			     gfc_array_index_type,
+			     tmp, ubound);
+      cond = fold_build2_loc (input_location, NE_EXPR,
+			      boolean_type_node,
+			      tmp, gfc_index_zero_node);
+      tmp = build3_v (COND_EXPR, cond,
+		      build1_v (GOTO_EXPR, jump_label1),
+		      build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&fblock, tmp);
+    }
+
+  /* ....else jump past the (re)alloc code.  */
+  tmp = build1_v (GOTO_EXPR, jump_label2);
+  gfc_add_expr_to_block (&fblock, tmp);
+
+  /* Add the label to start automatic (re)allocation.  */
+  tmp = build1_v (LABEL_EXPR, jump_label1);
+  gfc_add_expr_to_block (&fblock, tmp);
+
+  /* If the lhs has not been allocated, its bounds will not have been
+     initialized and so its size is set to zero.  */
+  size1 = gfc_create_var (gfc_array_index_type, NULL);
+  gfc_init_block (&alloc_block);
+  gfc_add_modify (&alloc_block, size1, gfc_index_zero_node);
+  gfc_init_block (&realloc_block);
+  gfc_add_modify (&realloc_block, size1,
+		  gfc_conv_descriptor_size (desc, expr1->rank));
+  tmp = build3_v (COND_EXPR, cond_null,
+		  gfc_finish_block (&alloc_block),
+		  gfc_finish_block (&realloc_block));
+  gfc_add_expr_to_block (&fblock, tmp);
+
+  /* Get the rhs size and fix it.  */
+  if (expr2)
+    desc2 = rss->info->data.array.descriptor;
+  else
+    desc2 = NULL_TREE;
+
+  size2 = gfc_index_one_node;
+  for (n = 0; n < expr2->rank; n++)
+    {
+      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+			     gfc_array_index_type,
+			     loop->to[n], loop->from[n]);
+      tmp = fold_build2_loc (input_location, PLUS_EXPR,
+			     gfc_array_index_type,
+			     tmp, gfc_index_one_node);
+      size2 = fold_build2_loc (input_location, MULT_EXPR,
+			       gfc_array_index_type,
+			       tmp, size2);
+    }
+  size2 = gfc_evaluate_now (size2, &fblock);
+
+  cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			  size1, size2);
+  neq_size = gfc_evaluate_now (cond, &fblock);
+
+  /* Deallocation of allocatable components will have to occur on
+     reallocation.  Fix the old descriptor now.  */
+  if ((expr1->ts.type == BT_DERIVED)
+	&& expr1->ts.u.derived->attr.alloc_comp)
+    old_desc = gfc_evaluate_now (desc, &fblock);
+  else
+    old_desc = NULL_TREE;
+
+  /* Now modify the lhs descriptor and the associated scalarizer
+     variables. F2003 7.4.1.3: "If variable is or becomes an
+     unallocated allocatable variable, then it is allocated with each
+     deferred type parameter equal to the corresponding type parameters
+     of expr , with the shape of expr , and with each lower bound equal
+     to the corresponding element of LBOUND(expr)."
+     Reuse size1 to keep a dimension-by-dimension track of the
+     stride of the new array.  */
+  size1 = gfc_index_one_node;
+  offset = gfc_index_zero_node;
+
+  for (n = 0; n < expr2->rank; n++)
+    {
+      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+			     gfc_array_index_type,
+			     loop->to[n], loop->from[n]);
+      tmp = fold_build2_loc (input_location, PLUS_EXPR,
+			     gfc_array_index_type,
+			     tmp, gfc_index_one_node);
+
+      lbound = gfc_index_one_node;
+      ubound = tmp;
+
+      if (as)
+	{
+	  lbd = get_std_lbound (expr2, desc2, n,
+				as->type == AS_ASSUMED_SIZE);
+	  ubound = fold_build2_loc (input_location,
+				    MINUS_EXPR,
+				    gfc_array_index_type,
+				    ubound, lbound);
+	  ubound = fold_build2_loc (input_location,
+				    PLUS_EXPR,
+				    gfc_array_index_type,
+				    ubound, lbd);
+	  lbound = lbd;
+	}
+
+      gfc_conv_descriptor_lbound_set (&fblock, desc,
+				      gfc_rank_cst[n],
+				      lbound);
+      gfc_conv_descriptor_ubound_set (&fblock, desc,
+				      gfc_rank_cst[n],
+				      ubound);
+      gfc_conv_descriptor_stride_set (&fblock, desc,
+				      gfc_rank_cst[n],
+				      size1);
+      lbound = gfc_conv_descriptor_lbound_get (desc,
+					       gfc_rank_cst[n]);
+      tmp2 = fold_build2_loc (input_location, MULT_EXPR,
+			      gfc_array_index_type,
+			      lbound, size1);
+      offset = fold_build2_loc (input_location, MINUS_EXPR,
+				gfc_array_index_type,
+				offset, tmp2);
+      size1 = fold_build2_loc (input_location, MULT_EXPR,
+			       gfc_array_index_type,
+			       tmp, size1);
+    }
+
+  /* Set the lhs descriptor and scalarizer offsets.  For rank > 1,
+     the array offset is saved and the info.offset is used for a
+     running offset.  Use the saved_offset instead.  */
+  tmp = gfc_conv_descriptor_offset (desc);
+  gfc_add_modify (&fblock, tmp, offset);
+  if (linfo->saved_offset
+      && TREE_CODE (linfo->saved_offset) == VAR_DECL)
+    gfc_add_modify (&fblock, linfo->saved_offset, tmp);
+
+  /* Now set the deltas for the lhs.  */
+  for (n = 0; n < expr1->rank; n++)
+    {
+      tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
+      dim = lss->dim[n];
+      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+			     gfc_array_index_type, tmp,
+			     loop->from[dim]);
+      if (linfo->delta[dim]
+	  && TREE_CODE (linfo->delta[dim]) == VAR_DECL)
+	gfc_add_modify (&fblock, linfo->delta[dim], tmp);
+    }
+
+  /* Get the new lhs size in bytes.  */
+  if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+    {
+      if (expr2->ts.deferred)
+	{
+	  if (TREE_CODE (expr2->ts.u.cl->backend_decl) == VAR_DECL)
+	    tmp = expr2->ts.u.cl->backend_decl;
+	  else
+	    tmp = rss->info->string_length;
+	}
+      else
+	{
+	  tmp = expr2->ts.u.cl->backend_decl;
+	  tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
+	}
+
+      if (expr1->ts.u.cl->backend_decl
+	  && TREE_CODE (expr1->ts.u.cl->backend_decl) == VAR_DECL)
+	gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
+      else
+	gfc_add_modify (&fblock, lss->info->string_length, tmp);
+    }
+  else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
+    {
+      tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
+      tmp = fold_build2_loc (input_location, MULT_EXPR,
+			     gfc_array_index_type, tmp,
+			     expr1->ts.u.cl->backend_decl);
+    }
+  else
+    tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
+  tmp = fold_convert (gfc_array_index_type, tmp);
+  size2 = fold_build2_loc (input_location, MULT_EXPR,
+			   gfc_array_index_type,
+			   tmp, size2);
+  size2 = fold_convert (size_type_node, size2);
+  size2 = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
+			   size2, size_one_node);
+  size2 = gfc_evaluate_now (size2, &fblock);
+
+  /* Realloc expression.  Note that the scalarizer uses desc.data
+     in the array reference - (*desc.data)[<element>]. */
+  gfc_init_block (&realloc_block);
+
+  if ((expr1->ts.type == BT_DERIVED)
+	&& expr1->ts.u.derived->attr.alloc_comp)
+    {
+      tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, old_desc,
+					      expr1->rank);
+      gfc_add_expr_to_block (&realloc_block, tmp);
+    }
+
+  tmp = build_call_expr_loc (input_location,
+			     builtin_decl_explicit (BUILT_IN_REALLOC), 2,
+			     fold_convert (pvoid_type_node, array1),
+			     size2);
+  gfc_conv_descriptor_data_set (&realloc_block,
+				desc, tmp);
+
+  if ((expr1->ts.type == BT_DERIVED)
+	&& expr1->ts.u.derived->attr.alloc_comp)
+    {
+      tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
+				    expr1->rank);
+      gfc_add_expr_to_block (&realloc_block, tmp);
+    }
+
+  realloc_expr = gfc_finish_block (&realloc_block);
+
+  /* Only reallocate if sizes are different.  */
+  tmp = build3_v (COND_EXPR, neq_size, realloc_expr,
+		  build_empty_stmt (input_location));
+  realloc_expr = tmp;
+
+
+  /* Malloc expression.  */
+  gfc_init_block (&alloc_block);
+  tmp = build_call_expr_loc (input_location,
+			     builtin_decl_explicit (BUILT_IN_MALLOC),
+			     1, size2);
+  gfc_conv_descriptor_data_set (&alloc_block,
+				desc, tmp);
+  tmp = gfc_conv_descriptor_dtype (desc);
+  gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+  if ((expr1->ts.type == BT_DERIVED)
+	&& expr1->ts.u.derived->attr.alloc_comp)
+    {
+      tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
+				    expr1->rank);
+      gfc_add_expr_to_block (&alloc_block, tmp);
+    }
+  alloc_expr = gfc_finish_block (&alloc_block);
+
+  /* Malloc if not allocated; realloc otherwise.  */
+  tmp = build_int_cst (TREE_TYPE (array1), 0);
+  cond = fold_build2_loc (input_location, EQ_EXPR,
+			  boolean_type_node,
+			  array1, tmp);
+  tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr);
+  gfc_add_expr_to_block (&fblock, tmp);
+
+  /* Make sure that the scalarizer data pointer is updated.  */
+  if (linfo->data
+      && TREE_CODE (linfo->data) == VAR_DECL)
+    {
+      tmp = gfc_conv_descriptor_data_get (desc);
+      gfc_add_modify (&fblock, linfo->data, tmp);
+    }
+
+  /* Add the exit label.  */
+  tmp = build1_v (LABEL_EXPR, jump_label2);
+  gfc_add_expr_to_block (&fblock, tmp);
+
+  return gfc_finish_block (&fblock);
+}
+
+
+/* NULLIFY an allocatable/pointer array on function entry, free it on exit.
+   Do likewise, recursively if necessary, with the allocatable components of
+   derived types.  */
+
+void
+gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
+{
+  tree type;
+  tree tmp;
+  tree descriptor;
+  stmtblock_t init;
+  stmtblock_t cleanup;
+  locus loc;
+  int rank;
+  bool sym_has_alloc_comp, has_finalizer;
+
+  sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
+			|| sym->ts.type == BT_CLASS)
+			  && sym->ts.u.derived->attr.alloc_comp;
+  has_finalizer = sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED
+		   ? gfc_is_finalizable (sym->ts.u.derived, NULL) : false;
+
+  /* Make sure the frontend gets these right.  */
+  gcc_assert (sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp
+	      || has_finalizer);
+
+  gfc_save_backend_locus (&loc);
+  gfc_set_backend_locus (&sym->declared_at);
+  gfc_init_block (&init);
+
+  gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
+		|| TREE_CODE (sym->backend_decl) == PARM_DECL);
+
+  if (sym->ts.type == BT_CHARACTER
+      && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
+    {
+      gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
+      gfc_trans_vla_type_sizes (sym, &init);
+    }
+
+  /* Dummy, use associated and result variables don't need anything special.  */
+  if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
+    {
+      gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
+      gfc_restore_backend_locus (&loc);
+      return;
+    }
+
+  descriptor = sym->backend_decl;
+
+  /* Although static, derived types with default initializers and
+     allocatable components must not be nulled wholesale; instead they
+     are treated component by component.  */
+  if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer)
+    {
+      /* SAVEd variables are not freed on exit.  */
+      gfc_trans_static_array_pointer (sym);
+
+      gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
+      gfc_restore_backend_locus (&loc);
+      return;
+    }
+
+  /* Get the descriptor type.  */
+  type = TREE_TYPE (sym->backend_decl);
+
+  if ((sym_has_alloc_comp || (has_finalizer && sym->ts.type != BT_CLASS))
+      && !(sym->attr.pointer || sym->attr.allocatable))
+    {
+      if (!sym->attr.save
+	  && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
+	{
+	  if (sym->value == NULL
+	      || !gfc_has_default_initializer (sym->ts.u.derived))
+	    {
+	      rank = sym->as ? sym->as->rank : 0;
+	      tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
+					    descriptor, rank);
+	      gfc_add_expr_to_block (&init, tmp);
+	    }
+	  else
+	    gfc_init_default_dt (sym, &init, false);
+	}
+    }
+  else if (!GFC_DESCRIPTOR_TYPE_P (type))
+    {
+      /* If the backend_decl is not a descriptor, we must have a pointer
+	 to one.  */
+      descriptor = build_fold_indirect_ref_loc (input_location,
+						sym->backend_decl);
+      type = TREE_TYPE (descriptor);
+    }
+
+  /* NULLIFY the data pointer.  */
+  if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
+    gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
+
+  gfc_restore_backend_locus (&loc);
+  gfc_init_block (&cleanup);
+
+  /* Allocatable arrays need to be freed when they go out of scope.
+     The allocatable components of pointers must not be touched.  */
+  if (!sym->attr.allocatable && has_finalizer && sym->ts.type != BT_CLASS
+      && !sym->attr.pointer && !sym->attr.artificial && !sym->attr.save
+      && !sym->ns->proc_name->attr.is_main_program)
+    {
+      gfc_expr *e;
+      sym->attr.referenced = 1;
+      e = gfc_lval_expr_from_sym (sym);
+      gfc_add_finalizer_call (&cleanup, e);
+      gfc_free_expr (e);
+    }
+  else if ((!sym->attr.allocatable || !has_finalizer)
+      && sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
+      && !sym->attr.pointer && !sym->attr.save
+      && !sym->ns->proc_name->attr.is_main_program)
+    {
+      int rank;
+      rank = sym->as ? sym->as->rank : 0;
+      tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
+      gfc_add_expr_to_block (&cleanup, tmp);
+    }
+
+  if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
+      && !sym->attr.save && !sym->attr.result
+      && !sym->ns->proc_name->attr.is_main_program)
+    {
+      gfc_expr *e;
+      e = has_finalizer ? gfc_lval_expr_from_sym (sym) : NULL;
+      tmp = gfc_trans_dealloc_allocated (sym->backend_decl,
+					 sym->attr.codimension, e);
+      if (e)
+	gfc_free_expr (e);
+      gfc_add_expr_to_block (&cleanup, tmp);
+    }
+
+  gfc_add_init_cleanup (block, gfc_finish_block (&init),
+			gfc_finish_block (&cleanup));
+}
+
+/************ Expression Walking Functions ******************/
+
+/* Walk a variable reference.
+
+   Possible extension - multiple component subscripts.
+    x(:,:) = foo%a(:)%b(:)
+   Transforms to
+    forall (i=..., j=...)
+      x(i,j) = foo%a(j)%b(i)
+    end forall
+   This adds a fair amount of complexity because you need to deal with more
+   than one ref.  Maybe handle in a similar manner to vector subscripts.
+   Maybe not worth the effort.  */
+
+
+static gfc_ss *
+gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
+{
+  gfc_ref *ref;
+
+  for (ref = expr->ref; ref; ref = ref->next)
+    if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
+      break;
+
+  return gfc_walk_array_ref (ss, expr, ref);
+}
+
+
+gfc_ss *
+gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref)
+{
+  gfc_array_ref *ar;
+  gfc_ss *newss;
+  int n;
+
+  for (; ref; ref = ref->next)
+    {
+      if (ref->type == REF_SUBSTRING)
+	{
+	  ss = gfc_get_scalar_ss (ss, ref->u.ss.start);
+	  ss = gfc_get_scalar_ss (ss, ref->u.ss.end);
+	}
+
+      /* We're only interested in array sections from now on.  */
+      if (ref->type != REF_ARRAY)
+	continue;
+
+      ar = &ref->u.ar;
+
+      switch (ar->type)
+	{
+	case AR_ELEMENT:
+	  for (n = ar->dimen - 1; n >= 0; n--)
+	    ss = gfc_get_scalar_ss (ss, ar->start[n]);
+	  break;
+
+	case AR_FULL:
+	  newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
+	  newss->info->data.array.ref = ref;
+
+	  /* Make sure array is the same as array(:,:), this way
+	     we don't need to special case all the time.  */
+	  ar->dimen = ar->as->rank;
+	  for (n = 0; n < ar->dimen; n++)
+	    {
+	      ar->dimen_type[n] = DIMEN_RANGE;
+
+	      gcc_assert (ar->start[n] == NULL);
+	      gcc_assert (ar->end[n] == NULL);
+	      gcc_assert (ar->stride[n] == NULL);
+	    }
+	  ss = newss;
+	  break;
+
+	case AR_SECTION:
+	  newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION);
+	  newss->info->data.array.ref = ref;
+
+	  /* We add SS chains for all the subscripts in the section.  */
+	  for (n = 0; n < ar->dimen; n++)
+	    {
+	      gfc_ss *indexss;
+
+	      switch (ar->dimen_type[n])
+		{
+		case DIMEN_ELEMENT:
+		  /* Add SS for elemental (scalar) subscripts.  */
+		  gcc_assert (ar->start[n]);
+		  indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]);
+		  indexss->loop_chain = gfc_ss_terminator;
+		  newss->info->data.array.subscript[n] = indexss;
+		  break;
+
+		case DIMEN_RANGE:
+                  /* We don't add anything for sections, just remember this
+                     dimension for later.  */
+		  newss->dim[newss->dimen] = n;
+		  newss->dimen++;
+		  break;
+
+		case DIMEN_VECTOR:
+		  /* Create a GFC_SS_VECTOR index in which we can store
+		     the vector's descriptor.  */
+		  indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n],
+					      1, GFC_SS_VECTOR);
+		  indexss->loop_chain = gfc_ss_terminator;
+		  newss->info->data.array.subscript[n] = indexss;
+		  newss->dim[newss->dimen] = n;
+		  newss->dimen++;
+		  break;
+
+		default:
+		  /* We should know what sort of section it is by now.  */
+		  gcc_unreachable ();
+		}
+	    }
+	  /* We should have at least one non-elemental dimension,
+	     unless we are creating a descriptor for a (scalar) coarray.  */
+	  gcc_assert (newss->dimen > 0
+		      || newss->info->data.array.ref->u.ar.as->corank > 0);
+	  ss = newss;
+	  break;
+
+	default:
+	  /* We should know what sort of section it is by now.  */
+	  gcc_unreachable ();
+	}
+
+    }
+  return ss;
+}
+
+
+/* Walk an expression operator. If only one operand of a binary expression is
+   scalar, we must also add the scalar term to the SS chain.  */
+
+static gfc_ss *
+gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
+{
+  gfc_ss *head;
+  gfc_ss *head2;
+
+  head = gfc_walk_subexpr (ss, expr->value.op.op1);
+  if (expr->value.op.op2 == NULL)
+    head2 = head;
+  else
+    head2 = gfc_walk_subexpr (head, expr->value.op.op2);
+
+  /* All operands are scalar.  Pass back and let the caller deal with it.  */
+  if (head2 == ss)
+    return head2;
+
+  /* All operands require scalarization.  */
+  if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
+    return head2;
+
+  /* One of the operands needs scalarization, the other is scalar.
+     Create a gfc_ss for the scalar expression.  */
+  if (head == ss)
+    {
+      /* First operand is scalar.  We build the chain in reverse order, so
+         add the scalar SS after the second operand.  */
+      head = head2;
+      while (head && head->next != ss)
+	head = head->next;
+      /* Check we haven't somehow broken the chain.  */
+      gcc_assert (head);
+      head->next = gfc_get_scalar_ss (ss, expr->value.op.op1);
+    }
+  else				/* head2 == head */
+    {
+      gcc_assert (head2 == head);
+      /* Second operand is scalar.  */
+      head2 = gfc_get_scalar_ss (head2, expr->value.op.op2);
+    }
+
+  return head2;
+}
+
+
+/* Reverse a SS chain.  */
+
+gfc_ss *
+gfc_reverse_ss (gfc_ss * ss)
+{
+  gfc_ss *next;
+  gfc_ss *head;
+
+  gcc_assert (ss != NULL);
+
+  head = gfc_ss_terminator;
+  while (ss != gfc_ss_terminator)
+    {
+      next = ss->next;
+      /* Check we didn't somehow break the chain.  */
+      gcc_assert (next != NULL);
+      ss->next = head;
+      head = ss;
+      ss = next;
+    }
+
+  return (head);
+}
+
+
+/* Given an expression referring to a procedure, return the symbol of its
+   interface.  We can't get the procedure symbol directly as we have to handle
+   the case of (deferred) type-bound procedures.  */
+
+gfc_symbol *
+gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref)
+{
+  gfc_symbol *sym;
+  gfc_ref *ref;
+
+  if (procedure_ref == NULL)
+    return NULL;
+
+  /* Normal procedure case.  */
+  sym = procedure_ref->symtree->n.sym;
+
+  /* Typebound procedure case.  */
+  for (ref = procedure_ref->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_COMPONENT
+	  && ref->u.c.component->attr.proc_pointer)
+	sym = ref->u.c.component->ts.interface;
+      else
+	sym = NULL;
+    }
+
+  return sym;
+}
+
+
+/* Walk the arguments of an elemental function.
+   PROC_EXPR is used to check whether an argument is permitted to be absent.  If
+   it is NULL, we don't do the check and the argument is assumed to be present.
+*/
+
+gfc_ss *
+gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
+				  gfc_symbol *proc_ifc, gfc_ss_type type)
+{
+  gfc_formal_arglist *dummy_arg;
+  int scalar;
+  gfc_ss *head;
+  gfc_ss *tail;
+  gfc_ss *newss;
+
+  head = gfc_ss_terminator;
+  tail = NULL;
+
+  if (proc_ifc)
+    dummy_arg = gfc_sym_get_dummy_args (proc_ifc);
+  else
+    dummy_arg = NULL;
+
+  scalar = 1;
+  for (; arg; arg = arg->next)
+    {
+      if (!arg->expr || arg->expr->expr_type == EXPR_NULL)
+	continue;
+
+      newss = gfc_walk_subexpr (head, arg->expr);
+      if (newss == head)
+	{
+	  /* Scalar argument.  */
+	  gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE);
+	  newss = gfc_get_scalar_ss (head, arg->expr);
+	  newss->info->type = type;
+
+	}
+      else
+	scalar = 0;
+
+      if (dummy_arg != NULL
+	  && dummy_arg->sym->attr.optional
+	  && arg->expr->expr_type == EXPR_VARIABLE
+	  && (gfc_expr_attr (arg->expr).optional
+	      || gfc_expr_attr (arg->expr).allocatable
+	      || gfc_expr_attr (arg->expr).pointer))
+	newss->info->can_be_null_ref = true;
+
+      head = newss;
+      if (!tail)
+        {
+          tail = head;
+          while (tail->next != gfc_ss_terminator)
+            tail = tail->next;
+        }
+
+      if (dummy_arg != NULL)
+	dummy_arg = dummy_arg->next;
+    }
+
+  if (scalar)
+    {
+      /* If all the arguments are scalar we don't need the argument SS.  */
+      gfc_free_ss_chain (head);
+      /* Pass it back.  */
+      return ss;
+    }
+
+  /* Add it onto the existing chain.  */
+  tail->next = ss;
+  return head;
+}
+
+
+/* Walk a function call.  Scalar functions are passed back, and taken out of
+   scalarization loops.  For elemental functions we walk their arguments.
+   The result of functions returning arrays is stored in a temporary outside
+   the loop, so that the function is only called once.  Hence we do not need
+   to walk their arguments.  */
+
+static gfc_ss *
+gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
+{
+  gfc_intrinsic_sym *isym;
+  gfc_symbol *sym;
+  gfc_component *comp = NULL;
+
+  isym = expr->value.function.isym;
+
+  /* Handle intrinsic functions separately.  */
+  if (isym)
+    return gfc_walk_intrinsic_function (ss, expr, isym);
+
+  sym = expr->value.function.esym;
+  if (!sym)
+    sym = expr->symtree->n.sym;
+
+  /* A function that returns arrays.  */
+  comp = gfc_get_proc_ptr_comp (expr);
+  if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
+      || (comp && comp->attr.dimension))
+    return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
+
+  /* Walk the parameters of an elemental function.  For now we always pass
+     by reference.  */
+  if (sym->attr.elemental || (comp && comp->attr.elemental))
+    return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
+					     gfc_get_proc_ifc_for_expr (expr),
+					     GFC_SS_REFERENCE);
+
+  /* Scalar functions are OK as these are evaluated outside the scalarization
+     loop.  Pass back and let the caller deal with it.  */
+  return ss;
+}
+
+
+/* An array temporary is constructed for array constructors.  */
+
+static gfc_ss *
+gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
+{
+  return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_CONSTRUCTOR);
+}
+
+
+/* Walk an expression.  Add walked expressions to the head of the SS chain.
+   A wholly scalar expression will not be added.  */
+
+gfc_ss *
+gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
+{
+  gfc_ss *head;
+
+  switch (expr->expr_type)
+    {
+    case EXPR_VARIABLE:
+      head = gfc_walk_variable_expr (ss, expr);
+      return head;
+
+    case EXPR_OP:
+      head = gfc_walk_op_expr (ss, expr);
+      return head;
+
+    case EXPR_FUNCTION:
+      head = gfc_walk_function_expr (ss, expr);
+      return head;
+
+    case EXPR_CONSTANT:
+    case EXPR_NULL:
+    case EXPR_STRUCTURE:
+      /* Pass back and let the caller deal with it.  */
+      break;
+
+    case EXPR_ARRAY:
+      head = gfc_walk_array_constructor (ss, expr);
+      return head;
+
+    case EXPR_SUBSTRING:
+      /* Pass back and let the caller deal with it.  */
+      break;
+
+    default:
+      internal_error ("bad expression type during walk (%d)",
+		      expr->expr_type);
+    }
+  return ss;
+}
+
+
+/* Entry point for expression walking.
+   A return value equal to the passed chain means this is
+   a scalar expression.  It is up to the caller to take whatever action is
+   necessary to translate these.  */
+
+gfc_ss *
+gfc_walk_expr (gfc_expr * expr)
+{
+  gfc_ss *res;
+
+  res = gfc_walk_subexpr (gfc_ss_terminator, expr);
+  return gfc_reverse_ss (res);
+}
diff --git a/gcc-4.9/gcc/fortran/trans-array.h b/gcc-4.9/gcc/fortran/trans-array.h
new file mode 100644
index 000000000..c4c09c1c5
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/trans-array.h
@@ -0,0 +1,188 @@
+/* Header for array handling functions
+   Copyright (C) 2002-2014 Free Software Foundation, Inc.
+   Contributed by Paul Brook
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+/* Generate code to free an array.  */
+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 *, gfc_typespec *);
+
+/* 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 *,
+					  gfc_se *, gfc_array_spec *);
+
+/* Generate code to create a temporary array.  */
+tree gfc_trans_create_temp_array (stmtblock_t *, stmtblock_t *, gfc_ss *,
+				  tree, tree, bool, bool, bool, locus *);
+
+/* Generate function entry code for allocation of compiler allocated array
+   variables.  */
+void gfc_trans_auto_array_allocation (tree, gfc_symbol *, gfc_wrapped_block *);
+/* Generate entry and exit code for dummy array parameters.  */
+void gfc_trans_dummy_array_bias (gfc_symbol *, tree, gfc_wrapped_block *);
+/* Generate entry and exit code for g77 calling convention arrays.  */
+void gfc_trans_g77_array (gfc_symbol *, gfc_wrapped_block *);
+/* Generate code to deallocate an array, if it is allocated.  */
+tree gfc_trans_dealloc_allocated (tree, bool, gfc_expr *);
+
+tree gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank);
+
+tree gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank);
+
+tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int);
+
+tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int);
+tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol *, tree, int);
+tree gfc_reassign_alloc_comp_caf (gfc_symbol *, tree, tree);
+
+tree gfc_copy_alloc_comp (gfc_symbol *, tree, tree, int);
+
+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.  */
+void gfc_trans_static_array_pointer (gfc_symbol *);
+
+/* Get the procedure interface for a function call.  */
+gfc_symbol *gfc_get_proc_ifc_for_expr (gfc_expr *);
+/* Generate scalarization information for an expression.  */
+gfc_ss *gfc_walk_expr (gfc_expr *);
+/* Workhorse for gfc_walk_expr.  */
+gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
+/* Workhorse for gfc_walk_variable_expr.  */
+gfc_ss *gfc_walk_array_ref (gfc_ss *, gfc_expr *, gfc_ref * ref);
+/* Walk the arguments of an elemental function.  */
+gfc_ss *gfc_walk_elemental_function_args (gfc_ss *, gfc_actual_arglist *,
+					  gfc_symbol *, gfc_ss_type);
+/* Walk an intrinsic function.  */
+gfc_ss *gfc_walk_intrinsic_function (gfc_ss *, gfc_expr *,
+				     gfc_intrinsic_sym *);
+/* Reverse the order of an SS chain.  */
+gfc_ss *gfc_reverse_ss (gfc_ss *);
+
+/* Free the SS associated with a loop.  */
+void gfc_cleanup_loop (gfc_loopinfo *);
+/* Associate a SS chain with a loop.  */
+void gfc_add_ss_to_loop (gfc_loopinfo *, gfc_ss *);
+/* Mark a SS chain as used in this loop.  */
+void gfc_mark_ss_chain_used (gfc_ss *, unsigned);
+/* Free a gfc_ss chain.  */
+void gfc_free_ss_chain (gfc_ss *);
+/* Free a single gfc_ss element.  */
+void gfc_free_ss (gfc_ss *);
+/* Allocate a new array type ss.  */
+gfc_ss *gfc_get_array_ss (gfc_ss *, gfc_expr *, int, gfc_ss_type);
+/* Allocate a new temporary type ss.  */
+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 *);
+
+/* Calculates the lower bound and stride of array sections.  */
+void gfc_conv_ss_startstride (gfc_loopinfo *);
+
+void gfc_init_loopinfo (gfc_loopinfo *);
+void gfc_copy_loopinfo_to_se (gfc_se *, gfc_loopinfo *);
+
+/* Marks the start of a scalarized expression, and declares loop variables.  */
+void gfc_start_scalarized_body (gfc_loopinfo *, stmtblock_t *);
+/* Generates one actual loop for a scalarized expression.  */
+void  gfc_trans_scalarized_loop_end (gfc_loopinfo *, int, stmtblock_t *);
+/* Generates the actual loops for a scalarized expression.  */
+void gfc_trans_scalarizing_loops (gfc_loopinfo *, stmtblock_t *);
+/* Mark the end of the main loop body and the start of the copying loop.  */
+void gfc_trans_scalarized_loop_boundary (gfc_loopinfo *, stmtblock_t *);
+/* Initialize the scalarization loop parameters.  */
+void gfc_conv_loop_setup (gfc_loopinfo *, locus *);
+/* Set each array's delta.  */
+void gfc_set_delta (gfc_loopinfo *);
+/* Resolve array assignment dependencies.  */
+void gfc_conv_resolve_dependencies (gfc_loopinfo *, gfc_ss *, gfc_ss *);
+/* Build a null array descriptor constructor.  */
+tree gfc_build_null_descriptor (tree);
+
+/* Get a single array element.  */
+void gfc_conv_array_ref (gfc_se *, gfc_array_ref *, gfc_expr *, locus *);
+/* Translate a reference to a temporary array.  */
+void gfc_conv_tmp_array_ref (gfc_se * se);
+/* Translate a reference to an array temporary.  */
+void gfc_conv_tmp_ref (gfc_se *);
+
+/* Evaluate an array expression.  */
+void gfc_conv_expr_descriptor (gfc_se *, gfc_expr *);
+/* Convert an array for passing as an actual function parameter.  */
+void gfc_conv_array_parameter (gfc_se *, gfc_expr *, bool,
+			       const gfc_symbol *, const char *, tree *);
+/* Evaluate and transpose a matrix expression.  */
+void gfc_conv_array_transpose (gfc_se *, gfc_expr *);
+
+/* These work with both descriptors and descriptorless arrays.  */
+tree gfc_conv_array_data (tree);
+tree gfc_conv_array_offset (tree);
+/* Return either an INT_CST or an expression for that part of the descriptor.  */
+tree gfc_conv_array_stride (tree, int);
+tree gfc_conv_array_lbound (tree, int);
+tree gfc_conv_array_ubound (tree, int);
+
+/* Set cobounds of an array.  */
+void gfc_trans_array_cobounds (tree, stmtblock_t *, const gfc_symbol *);
+
+/* Build expressions for accessing components of an array descriptor.  */
+tree gfc_conv_descriptor_data_get (tree);
+tree gfc_conv_descriptor_data_addr (tree);
+tree gfc_conv_descriptor_offset_get (tree);
+tree gfc_conv_descriptor_dtype (tree);
+tree gfc_conv_descriptor_rank (tree);
+tree gfc_get_descriptor_dimension (tree);
+tree gfc_conv_descriptor_stride_get (tree, tree);
+tree gfc_conv_descriptor_lbound_get (tree, tree);
+tree gfc_conv_descriptor_ubound_get (tree, tree);
+tree gfc_conv_descriptor_token (tree);
+
+void gfc_conv_descriptor_data_set (stmtblock_t *, tree, tree);
+void gfc_conv_descriptor_offset_set (stmtblock_t *, tree, tree);
+void gfc_conv_descriptor_stride_set (stmtblock_t *, tree, tree, tree);
+void gfc_conv_descriptor_lbound_set (stmtblock_t *, tree, tree, tree);
+void gfc_conv_descriptor_ubound_set (stmtblock_t *, tree, tree, tree);
+
+/* Shift lower bound of descriptor, updating ubound and offset.  */
+void gfc_conv_shift_descriptor_lbound (stmtblock_t*, tree, int, tree);
+
+/* Add pre-loop scalarization code for intrinsic functions which require
+   special handling.  */
+void gfc_add_intrinsic_ss_code (gfc_loopinfo *, gfc_ss *);
+
+/* Functions for constant array constructor processing.  */
+unsigned HOST_WIDE_INT gfc_constant_array_constructor_p (gfc_constructor_base);
+tree gfc_build_constant_array_constructor (gfc_expr *, tree);
+
+/* Copy a string from src to dest.  */
+void gfc_trans_string_copy (stmtblock_t *, tree, tree, int, tree, tree, int);
+
+/* Calculate extent / size of an array.  */
+tree gfc_conv_array_extent_dim (tree, tree, tree*);
+tree gfc_conv_descriptor_size (tree, int);
+tree gfc_conv_descriptor_cosize (tree, int, int);
diff --git a/gcc-4.9/gcc/fortran/trans-common.c b/gcc-4.9/gcc/fortran/trans-common.c
new file mode 100644
index 000000000..19eaddae2
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/trans-common.c
@@ -0,0 +1,1271 @@
+/* Common block and equivalence list handling
+   Copyright (C) 2000-2014 Free Software Foundation, Inc.
+   Contributed by Canqun Yang <canqun@nudt.edu.cn>
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */     
+
+/* The core algorithm is based on Andy Vaught's g95 tree.  Also the
+   way to build UNION_TYPE is borrowed from Richard Henderson.
+ 
+   Transform common blocks.  An integral part of this is processing
+   equivalence variables.  Equivalenced variables that are not in a
+   common block end up in a private block of their own.
+
+   Each common block or local equivalence list is declared as a union.
+   Variables within the block are represented as a field within the
+   block with the proper offset. 
+ 
+   So if two variables are equivalenced, they just point to a common
+   area in memory.
+ 
+   Mathematically, laying out an equivalence block is equivalent to
+   solving a linear system of equations.  The matrix is usually a
+   sparse matrix in which each row contains all zero elements except
+   for a +1 and a -1, a sort of a generalized Vandermonde matrix.  The
+   matrix is usually block diagonal.  The system can be
+   overdetermined, underdetermined or have a unique solution.  If the
+   system is inconsistent, the program is not standard conforming.
+   The solution vector is integral, since all of the pivots are +1 or -1.
+ 
+   How we lay out an equivalence block is a little less complicated.
+   In an equivalence list with n elements, there are n-1 conditions to
+   be satisfied.  The conditions partition the variables into what we
+   will call segments.  If A and B are equivalenced then A and B are
+   in the same segment.  If B and C are equivalenced as well, then A,
+   B and C are in a segment and so on.  Each segment is a block of
+   memory that has one or more variables equivalenced in some way.  A
+   common block is made up of a series of segments that are joined one
+   after the other.  In the linear system, a segment is a block
+   diagonal.
+ 
+   To lay out a segment we first start with some variable and
+   determine its length.  The first variable is assumed to start at
+   offset one and extends to however long it is.  We then traverse the
+   list of equivalences to find an unused condition that involves at
+   least one of the variables currently in the segment.
+ 
+   Each equivalence condition amounts to the condition B+b=C+c where B
+   and C are the offsets of the B and C variables, and b and c are
+   constants which are nonzero for array elements, substrings or
+   structure components.  So for
+ 
+     EQUIVALENCE(B(2), C(3))
+   we have
+     B + 2*size of B's elements = C + 3*size of C's elements.
+ 
+   If B and C are known we check to see if the condition already
+   holds.  If B is known we can solve for C.  Since we know the length
+   of C, we can see if the minimum and maximum extents of the segment
+   are affected.  Eventually, we make a full pass through the
+   equivalence list without finding any new conditions and the segment
+   is fully specified.
+ 
+   At this point, the segment is added to the current common block.
+   Since we know the minimum extent of the segment, everything in the
+   segment is translated to its position in the common block.  The
+   usual case here is that there are no equivalence statements and the
+   common block is series of segments with one variable each, which is
+   a diagonal matrix in the matrix formulation.
+ 
+   Each segment is described by a chain of segment_info structures.  Each
+   segment_info structure describes the extents of a single variable within
+   the segment.  This list is maintained in the order the elements are
+   positioned within the segment.  If two elements have the same starting
+   offset the smaller will come first.  If they also have the same size their
+   ordering is undefined. 
+   
+   Once all common blocks have been created, the list of equivalences
+   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 "coretypes.h"
+#include "tm.h"
+#include "tree.h"
+#include "stringpool.h"
+#include "stor-layout.h"
+#include "varasm.h"
+#include "gfortran.h"
+#include "trans.h"
+#include "trans-types.h"
+#include "trans-const.h"
+#include "target-memory.h"
+
+
+/* Holds a single variable in an equivalence set.  */
+typedef struct segment_info
+{
+  gfc_symbol *sym;
+  HOST_WIDE_INT offset;
+  HOST_WIDE_INT length;
+  /* This will contain the field type until the field is created.  */
+  tree field;
+  struct segment_info *next;
+} segment_info;
+
+static segment_info * current_segment;
+
+/* Store decl of all common blocks in this translation unit; the first
+   tree is the identifier.  */
+static std::map<tree, tree> gfc_map_of_all_commons;
+
+
+/* Make a segment_info based on a symbol.  */
+
+static segment_info *
+get_segment_info (gfc_symbol * sym, HOST_WIDE_INT offset)
+{
+  segment_info *s;
+
+  /* Make sure we've got the character length.  */
+  if (sym->ts.type == BT_CHARACTER)
+    gfc_conv_const_charlen (sym->ts.u.cl);
+
+  /* Create the segment_info and fill it in.  */
+  s = XCNEW (segment_info);
+  s->sym = sym;
+  /* We will use this type when building the segment aggregate type.  */
+  s->field = gfc_sym_type (sym);
+  s->length = int_size_in_bytes (s->field);
+  s->offset = offset;
+
+  return s;
+}
+
+
+/* Add a copy of a segment list to the namespace.  This is specifically for
+   equivalence segments, so that dependency checking can be done on
+   equivalence group members.  */
+
+static void
+copy_equiv_list_to_ns (segment_info *c)
+{
+  segment_info *f;
+  gfc_equiv_info *s;
+  gfc_equiv_list *l;
+
+  l = XCNEW (gfc_equiv_list);
+
+  l->next = c->sym->ns->equiv_lists;
+  c->sym->ns->equiv_lists = l;
+
+  for (f = c; f; f = f->next)
+    {
+      s = XCNEW (gfc_equiv_info);
+      s->next = l->equiv;
+      l->equiv = s;
+      s->sym = f->sym;
+      s->offset = f->offset;
+      s->length = f->length;
+    }
+}
+
+
+/* Add combine segment V and segment LIST.  */
+
+static segment_info *
+add_segments (segment_info *list, segment_info *v)
+{
+  segment_info *s;
+  segment_info *p;
+  segment_info *next;
+
+  p = NULL;
+  s = list;
+
+  while (v)
+    {
+      /* Find the location of the new element.  */
+      while (s)
+	{
+	  if (v->offset < s->offset)
+	    break;
+	  if (v->offset == s->offset
+	      && v->length <= s->length)
+	    break;
+
+	  p = s;
+	  s = s->next;
+	}
+
+      /* Insert the new element in between p and s.  */
+      next = v->next;
+      v->next = s;
+      if (p == NULL)
+	list = v;
+      else
+	p->next = v;
+
+      p = v;
+      v = next;
+    }
+
+  return list;
+}
+
+
+/* Construct mangled common block name from symbol name.  */
+
+/* We need the bind(c) flag to tell us how/if we should mangle the symbol
+   name.  There are few calls to this function, so few places that this
+   would need to be added.  At the moment, there is only one call, in
+   build_common_decl().  We can't attempt to look up the common block
+   because we may be building it for the first time and therefore, it won't
+   be in the common_root.  We also need the binding label, if it's bind(c).
+   Therefore, send in the pointer to the common block, so whatever info we
+   have so far can be used.  All of the necessary info should be available
+   in the gfc_common_head by now, so it should be accurate to test the
+   isBindC flag and use the binding label given if it is bind(c).
+
+   We may NOT know yet if it's bind(c) or not, but we can try at least.
+   Will have to figure out what to do later if it's labeled bind(c)
+   after this is called.  */
+
+static tree
+gfc_sym_mangled_common_id (gfc_common_head *com)
+{
+  int has_underscore;
+  char mangled_name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+
+  /* Get the name out of the common block pointer.  */
+  strcpy (name, com->name);
+
+  /* If we're suppose to do a bind(c).  */
+  if (com->is_bind_c == 1 && com->binding_label)
+    return get_identifier (com->binding_label);
+
+  if (strcmp (name, BLANK_COMMON_NAME) == 0)
+    return get_identifier (name);
+
+  if (gfc_option.flag_underscoring)
+    {
+      has_underscore = strchr (name, '_') != 0;
+      if (gfc_option.flag_second_underscore && has_underscore)
+        snprintf (mangled_name, sizeof mangled_name, "%s__", name);
+      else
+        snprintf (mangled_name, sizeof mangled_name, "%s_", name);
+
+      return get_identifier (mangled_name);
+    }
+  else
+    return get_identifier (name);
+}
+
+
+/* Build a field declaration for a common variable or a local equivalence
+   object.  */
+
+static void
+build_field (segment_info *h, tree union_type, record_layout_info rli)
+{
+  tree field;
+  tree name;
+  HOST_WIDE_INT offset = h->offset;
+  unsigned HOST_WIDE_INT desired_align, known_align;
+
+  name = get_identifier (h->sym->name);
+  field = build_decl (h->sym->declared_at.lb->location,
+		      FIELD_DECL, name, h->field);
+  known_align = (offset & -offset) * BITS_PER_UNIT;
+  if (known_align == 0 || known_align > BIGGEST_ALIGNMENT)
+    known_align = BIGGEST_ALIGNMENT;
+
+  desired_align = update_alignment_for_field (rli, field, known_align);
+  if (desired_align > known_align)
+    DECL_PACKED (field) = 1;
+
+  DECL_FIELD_CONTEXT (field) = union_type;
+  DECL_FIELD_OFFSET (field) = size_int (offset);
+  DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node;
+  SET_DECL_OFFSET_ALIGN (field, known_align);
+
+  rli->offset = size_binop (MAX_EXPR, rli->offset,
+                            size_binop (PLUS_EXPR,
+                                        DECL_FIELD_OFFSET (field),
+                                        DECL_SIZE_UNIT (field)));
+  /* If this field is assigned to a label, we create another two variables.
+     One will hold the address of target label or format label. The other will
+     hold the length of format label string.  */
+  if (h->sym->attr.assign)
+    {
+      tree len;
+      tree addr;
+
+      gfc_allocate_lang_decl (field);
+      GFC_DECL_ASSIGN (field) = 1;
+      len = gfc_create_var_np (gfc_charlen_type_node,h->sym->name);
+      addr = gfc_create_var_np (pvoid_type_node, h->sym->name);
+      TREE_STATIC (len) = 1;
+      TREE_STATIC (addr) = 1;
+      DECL_INITIAL (len) = build_int_cst (gfc_charlen_type_node, -2);
+      gfc_set_decl_location (len, &h->sym->declared_at);
+      gfc_set_decl_location (addr, &h->sym->declared_at);
+      GFC_DECL_STRING_LEN (field) = pushdecl_top_level (len);
+      GFC_DECL_ASSIGN_ADDR (field) = pushdecl_top_level (addr);
+    }
+
+  /* If this field is volatile, mark it.  */
+  if (h->sym->attr.volatile_)
+    {
+      tree new_type;
+      TREE_THIS_VOLATILE (field) = 1;
+      TREE_SIDE_EFFECTS (field) = 1;
+      new_type = build_qualified_type (TREE_TYPE (field), TYPE_QUAL_VOLATILE);
+      TREE_TYPE (field) = new_type;
+    }
+
+  h->field = field;
+}
+
+
+/* Get storage for local equivalence.  */
+
+static tree
+build_equiv_decl (tree union_type, bool is_init, bool is_saved)
+{
+  tree decl;
+  char name[15];
+  static int serial = 0;
+
+  if (is_init)
+    {
+      decl = gfc_create_var (union_type, "equiv");
+      TREE_STATIC (decl) = 1;
+      GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
+      return decl;
+    }
+
+  snprintf (name, sizeof (name), "equiv.%d", serial++);
+  decl = build_decl (input_location,
+		     VAR_DECL, get_identifier (name), union_type);
+  DECL_ARTIFICIAL (decl) = 1;
+  DECL_IGNORED_P (decl) = 1;
+
+  if (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
+      || is_saved)
+    TREE_STATIC (decl) = 1;
+
+  TREE_ADDRESSABLE (decl) = 1;
+  TREE_USED (decl) = 1;
+  GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
+
+  /* The source location has been lost, and doesn't really matter.
+     We need to set it to something though.  */
+  gfc_set_decl_location (decl, &gfc_current_locus);
+
+  gfc_add_decl_to_function (decl);
+
+  return decl;
+}
+
+
+/* Get storage for common block.  */
+
+static tree
+build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
+{
+  tree decl, identifier;
+
+  identifier = gfc_sym_mangled_common_id (com);
+  decl = gfc_map_of_all_commons.count(identifier)
+	 ? gfc_map_of_all_commons[identifier] : NULL_TREE;
+
+  /* Update the size of this common block as needed.  */
+  if (decl != NULL_TREE)
+    {
+      tree size = TYPE_SIZE_UNIT (union_type);
+
+      /* Named common blocks of the same name shall be of the same size
+	 in all scoping units of a program in which they appear, but
+	 blank common blocks may be of different sizes.  */
+      if (!tree_int_cst_equal (DECL_SIZE_UNIT (decl), size)
+	  && strcmp (com->name, BLANK_COMMON_NAME))
+	gfc_warning ("Named COMMON block '%s' at %L shall be of the "
+		     "same size as elsewhere (%lu vs %lu bytes)", com->name,
+		     &com->where,
+		     (unsigned long) TREE_INT_CST_LOW (size),
+		     (unsigned long) TREE_INT_CST_LOW (DECL_SIZE_UNIT (decl)));
+
+      if (tree_int_cst_lt (DECL_SIZE_UNIT (decl), size))
+	{
+	  DECL_SIZE (decl) = TYPE_SIZE (union_type);
+	  DECL_SIZE_UNIT (decl) = size;
+	  DECL_MODE (decl) = TYPE_MODE (union_type);
+	  TREE_TYPE (decl) = union_type;
+	  layout_decl (decl, 0);
+	}
+     }
+
+  /* If this common block has been declared in a previous program unit,
+     and either it is already initialized or there is no new initialization
+     for it, just return.  */
+  if ((decl != NULL_TREE) && (!is_init || DECL_INITIAL (decl)))
+    return decl;
+
+  /* If there is no backend_decl for the common block, build it.  */
+  if (decl == NULL_TREE)
+    {
+      if (com->is_bind_c == 1 && com->binding_label)
+	decl = build_decl (input_location, VAR_DECL, identifier, union_type);
+      else
+	{
+	  decl = build_decl (input_location, VAR_DECL, get_identifier (com->name),
+			     union_type);
+	  gfc_set_decl_assembler_name (decl, identifier);
+	}
+
+      TREE_PUBLIC (decl) = 1;
+      TREE_STATIC (decl) = 1;
+      DECL_IGNORED_P (decl) = 1;
+      if (!com->is_bind_c)
+	DECL_ALIGN (decl) = BIGGEST_ALIGNMENT;
+      else
+        {
+	  /* Do not set the alignment for bind(c) common blocks to
+	     BIGGEST_ALIGNMENT because that won't match what C does.  Also,
+	     for common blocks with one element, the alignment must be
+	     that of the field within the common block in order to match
+	     what C will do.  */
+	  tree field = NULL_TREE;
+	  field = TYPE_FIELDS (TREE_TYPE (decl));
+	  if (DECL_CHAIN (field) == NULL_TREE)
+	    DECL_ALIGN (decl) = TYPE_ALIGN (TREE_TYPE (field));
+	}
+      DECL_USER_ALIGN (decl) = 0;
+      GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
+
+      gfc_set_decl_location (decl, &com->where);
+
+      if (com->threadprivate)
+	DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
+
+      /* Place the back end declaration for this common block in
+         GLOBAL_BINDING_LEVEL.  */
+      gfc_map_of_all_commons[identifier] = pushdecl_top_level (decl);
+    }
+
+  /* Has no initial values.  */
+  if (!is_init)
+    {
+      DECL_INITIAL (decl) = NULL_TREE;
+      DECL_COMMON (decl) = 1;
+      DECL_DEFER_OUTPUT (decl) = 1;
+    }
+  else
+    {
+      DECL_INITIAL (decl) = error_mark_node;
+      DECL_COMMON (decl) = 0;
+      DECL_DEFER_OUTPUT (decl) = 0;
+    }
+  return decl;
+}
+
+
+/* Return a field that is the size of the union, if an equivalence has
+   overlapping initializers.  Merge the initializers into a single
+   initializer for this new field, then free the old ones.  */ 
+
+static tree
+get_init_field (segment_info *head, tree union_type, tree *field_init,
+		record_layout_info rli)
+{
+  segment_info *s;
+  HOST_WIDE_INT length = 0;
+  HOST_WIDE_INT offset = 0;
+  unsigned HOST_WIDE_INT known_align, desired_align;
+  bool overlap = false;
+  tree tmp, field;
+  tree init;
+  unsigned char *data, *chk;
+  vec<constructor_elt, va_gc> *v = NULL;
+
+  tree type = unsigned_char_type_node;
+  int i;
+
+  /* Obtain the size of the union and check if there are any overlapping
+     initializers.  */
+  for (s = head; s; s = s->next)
+    {
+      HOST_WIDE_INT slen = s->offset + s->length;
+      if (s->sym->value)
+	{
+	  if (s->offset < offset)
+            overlap = true;
+	  offset = slen;
+	}
+      length = length < slen ? slen : length;
+    }
+
+  if (!overlap)
+    return NULL_TREE;
+
+  /* Now absorb all the initializer data into a single vector,
+     whilst checking for overlapping, unequal values.  */
+  data = XCNEWVEC (unsigned char, (size_t)length);
+  chk = XCNEWVEC (unsigned char, (size_t)length);
+
+  /* TODO - change this when default initialization is implemented.  */
+  memset (data, '\0', (size_t)length);
+  memset (chk, '\0', (size_t)length);
+  for (s = head; s; s = s->next)
+    if (s->sym->value)
+      gfc_merge_initializers (s->sym->ts, s->sym->value,
+			      &data[s->offset],
+			      &chk[s->offset],
+			     (size_t)s->length);
+  
+  for (i = 0; i < length; i++)
+    CONSTRUCTOR_APPEND_ELT (v, NULL, build_int_cst (type, data[i]));
+
+  free (data);
+  free (chk);
+
+  /* Build a char[length] array to hold the initializers.  Much of what
+     follows is borrowed from build_field, above.  */
+
+  tmp = build_int_cst (gfc_array_index_type, length - 1);
+  tmp = build_range_type (gfc_array_index_type,
+			  gfc_index_zero_node, tmp);
+  tmp = build_array_type (type, tmp);
+  field = build_decl (gfc_current_locus.lb->location,
+		      FIELD_DECL, NULL_TREE, tmp);
+
+  known_align = BIGGEST_ALIGNMENT;
+
+  desired_align = update_alignment_for_field (rli, field, known_align);
+  if (desired_align > known_align)
+    DECL_PACKED (field) = 1;
+
+  DECL_FIELD_CONTEXT (field) = union_type;
+  DECL_FIELD_OFFSET (field) = size_int (0);
+  DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node;
+  SET_DECL_OFFSET_ALIGN (field, known_align);
+
+  rli->offset = size_binop (MAX_EXPR, rli->offset,
+                            size_binop (PLUS_EXPR,
+                                        DECL_FIELD_OFFSET (field),
+                                        DECL_SIZE_UNIT (field)));
+
+  init = build_constructor (TREE_TYPE (field), v);
+  TREE_CONSTANT (init) = 1;
+
+  *field_init = init;
+
+  for (s = head; s; s = s->next)
+    {
+      if (s->sym->value == NULL)
+	continue;
+
+      gfc_free_expr (s->sym->value);
+      s->sym->value = NULL;
+    }
+
+  return field;
+}
+
+
+/* Declare memory for the common block or local equivalence, and create
+   backend declarations for all of the elements.  */
+
+static void
+create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
+{
+  segment_info *s, *next_s;
+  tree union_type;
+  tree *field_link;
+  tree field;
+  tree field_init = NULL_TREE;
+  record_layout_info rli;
+  tree decl;
+  bool is_init = false;
+  bool is_saved = false;
+
+  /* Declare the variables inside the common block.
+     If the current common block contains any equivalence object, then
+     make a UNION_TYPE node, otherwise RECORD_TYPE. This will let the
+     alias analyzer work well when there is no address overlapping for
+     common variables in the current common block.  */
+  if (saw_equiv)
+    union_type = make_node (UNION_TYPE);
+  else
+    union_type = make_node (RECORD_TYPE);
+
+  rli = start_record_layout (union_type);
+  field_link = &TYPE_FIELDS (union_type);
+
+  /* Check for overlapping initializers and replace them with a single,
+     artificial field that contains all the data.  */
+  if (saw_equiv)
+    field = get_init_field (head, union_type, &field_init, rli);
+  else
+    field = NULL_TREE;
+
+  if (field != NULL_TREE)
+    {
+      is_init = true;
+      *field_link = field;
+      field_link = &DECL_CHAIN (field);
+    }
+
+  for (s = head; s; s = s->next)
+    {
+      build_field (s, union_type, rli);
+
+      /* Link the field into the type.  */
+      *field_link = s->field;
+      field_link = &DECL_CHAIN (s->field);
+
+      /* Has initial value.  */
+      if (s->sym->value)
+        is_init = true;
+
+      /* Has SAVE attribute.  */
+      if (s->sym->attr.save)
+        is_saved = true;
+    }
+
+  finish_record_layout (rli, true);
+
+  if (com)
+    decl = build_common_decl (com, union_type, is_init);
+  else
+    decl = build_equiv_decl (union_type, is_init, is_saved);
+
+  if (is_init)
+    {
+      tree ctor, tmp;
+      vec<constructor_elt, va_gc> *v = NULL;
+
+      if (field != NULL_TREE && field_init != NULL_TREE)
+	CONSTRUCTOR_APPEND_ELT (v, field, field_init);
+      else
+	for (s = head; s; s = s->next)
+	  {
+	    if (s->sym->value)
+	      {
+		/* Add the initializer for this field.  */
+		tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts,
+					    TREE_TYPE (s->field),
+					    s->sym->attr.dimension,
+					    s->sym->attr.pointer
+					    || s->sym->attr.allocatable, false);
+
+		CONSTRUCTOR_APPEND_ELT (v, s->field, tmp);
+	      }
+	  }
+
+      gcc_assert (!v->is_empty ());
+      ctor = build_constructor (union_type, v);
+      TREE_CONSTANT (ctor) = 1;
+      TREE_STATIC (ctor) = 1;
+      DECL_INITIAL (decl) = ctor;
+
+#ifdef ENABLE_CHECKING
+      {
+	tree field, value;
+	unsigned HOST_WIDE_INT idx;
+	FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor), idx, field, value)
+	  gcc_assert (TREE_CODE (field) == FIELD_DECL);
+      }
+#endif
+    }
+
+  /* Build component reference for each variable.  */
+  for (s = head; s; s = next_s)
+    {
+      tree var_decl;
+
+      var_decl = build_decl (s->sym->declared_at.lb->location,
+			     VAR_DECL, DECL_NAME (s->field),
+			     TREE_TYPE (s->field));
+      TREE_STATIC (var_decl) = TREE_STATIC (decl);
+      /* Mark the variable as used in order to avoid warnings about
+	 unused variables.  */
+      TREE_USED (var_decl) = 1;
+      if (s->sym->attr.use_assoc)
+	DECL_IGNORED_P (var_decl) = 1;
+      if (s->sym->attr.target)
+	TREE_ADDRESSABLE (var_decl) = 1;
+      /* Fake variables are not visible from other translation units. */
+      TREE_PUBLIC (var_decl) = 0;
+
+      /* To preserve identifier names in COMMON, chain to procedure
+         scope unless at top level in a module definition.  */
+      if (com
+          && s->sym->ns->proc_name
+          && s->sym->ns->proc_name->attr.flavor == FL_MODULE)
+	var_decl = pushdecl_top_level (var_decl);
+      else
+	gfc_add_decl_to_function (var_decl);
+
+      SET_DECL_VALUE_EXPR (var_decl,
+			   fold_build3_loc (input_location, COMPONENT_REF,
+					    TREE_TYPE (s->field),
+					    decl, s->field, NULL_TREE));
+      DECL_HAS_VALUE_EXPR_P (var_decl) = 1;
+      GFC_DECL_COMMON_OR_EQUIV (var_decl) = 1;
+
+      if (s->sym->attr.assign)
+	{
+	  gfc_allocate_lang_decl (var_decl);
+	  GFC_DECL_ASSIGN (var_decl) = 1;
+	  GFC_DECL_STRING_LEN (var_decl) = GFC_DECL_STRING_LEN (s->field);
+	  GFC_DECL_ASSIGN_ADDR (var_decl) = GFC_DECL_ASSIGN_ADDR (s->field);
+	}
+
+      s->sym->backend_decl = var_decl;
+
+      next_s = s->next;
+      free (s);
+    }
+}
+
+
+/* Given a symbol, find it in the current segment list. Returns NULL if
+   not found.  */
+
+static segment_info *
+find_segment_info (gfc_symbol *symbol)
+{
+  segment_info *n;
+
+  for (n = current_segment; n; n = n->next)
+    {
+      if (n->sym == symbol)
+	return n;
+    }
+
+  return NULL;
+}
+
+
+/* Given an expression node, make sure it is a constant integer and return
+   the mpz_t value.  */
+
+static mpz_t *
+get_mpz (gfc_expr *e)
+{
+
+  if (e->expr_type != EXPR_CONSTANT)
+    gfc_internal_error ("get_mpz(): Not an integer constant");
+
+  return &e->value.integer;
+}
+
+
+/* Given an array specification and an array reference, figure out the
+   array element number (zero based). Bounds and elements are guaranteed
+   to be constants.  If something goes wrong we generate an error and
+   return zero.  */
+ 
+static HOST_WIDE_INT
+element_number (gfc_array_ref *ar)
+{
+  mpz_t multiplier, offset, extent, n;
+  gfc_array_spec *as;
+  HOST_WIDE_INT i, rank;
+
+  as = ar->as;
+  rank = as->rank;
+  mpz_init_set_ui (multiplier, 1);
+  mpz_init_set_ui (offset, 0);
+  mpz_init (extent);
+  mpz_init (n);
+
+  for (i = 0; i < rank; i++)
+    { 
+      if (ar->dimen_type[i] != DIMEN_ELEMENT)
+        gfc_internal_error ("element_number(): Bad dimension type");
+
+      mpz_sub (n, *get_mpz (ar->start[i]), *get_mpz (as->lower[i]));
+ 
+      mpz_mul (n, n, multiplier);
+      mpz_add (offset, offset, n);
+ 
+      mpz_sub (extent, *get_mpz (as->upper[i]), *get_mpz (as->lower[i]));
+      mpz_add_ui (extent, extent, 1);
+ 
+      if (mpz_sgn (extent) < 0)
+        mpz_set_ui (extent, 0);
+ 
+      mpz_mul (multiplier, multiplier, extent);
+    } 
+ 
+  i = mpz_get_ui (offset);
+ 
+  mpz_clear (multiplier);
+  mpz_clear (offset);
+  mpz_clear (extent);
+  mpz_clear (n);
+ 
+  return i;
+}
+
+
+/* Given a single element of an equivalence list, figure out the offset
+   from the base symbol.  For simple variables or full arrays, this is
+   simply zero.  For an array element we have to calculate the array
+   element number and multiply by the element size. For a substring we
+   have to calculate the further reference.  */
+
+static HOST_WIDE_INT
+calculate_offset (gfc_expr *e)
+{
+  HOST_WIDE_INT n, element_size, offset;
+  gfc_typespec *element_type;
+  gfc_ref *reference;
+
+  offset = 0;
+  element_type = &e->symtree->n.sym->ts;
+
+  for (reference = e->ref; reference; reference = reference->next)
+    switch (reference->type)
+      {
+      case REF_ARRAY:
+        switch (reference->u.ar.type)
+          {
+          case AR_FULL:
+	    break;
+
+          case AR_ELEMENT:
+	    n = element_number (&reference->u.ar);
+	    if (element_type->type == BT_CHARACTER)
+	      gfc_conv_const_charlen (element_type->u.cl);
+	    element_size =
+              int_size_in_bytes (gfc_typenode_for_spec (element_type));
+	    offset += n * element_size;
+	    break;
+
+          default:
+	    gfc_error ("Bad array reference at %L", &e->where);
+          }
+        break;
+      case REF_SUBSTRING:
+        if (reference->u.ss.start != NULL)
+	  offset += mpz_get_ui (*get_mpz (reference->u.ss.start)) - 1;
+        break;
+      default:
+        gfc_error ("Illegal reference type at %L as EQUIVALENCE object",
+                   &e->where);
+    }
+  return offset;
+}
+
+
+/* Add a new segment_info structure to the current segment.  eq1 is already
+   in the list, eq2 is not.  */
+
+static void
+new_condition (segment_info *v, gfc_equiv *eq1, gfc_equiv *eq2)
+{
+  HOST_WIDE_INT offset1, offset2;
+  segment_info *a;
+
+  offset1 = calculate_offset (eq1->expr);
+  offset2 = calculate_offset (eq2->expr);
+
+  a = get_segment_info (eq2->expr->symtree->n.sym,
+			v->offset + offset1 - offset2);
+ 
+  current_segment = add_segments (current_segment, a);
+}
+
+
+/* Given two equivalence structures that are both already in the list, make
+   sure that this new condition is not violated, generating an error if it
+   is.  */
+
+static void
+confirm_condition (segment_info *s1, gfc_equiv *eq1, segment_info *s2,
+                   gfc_equiv *eq2)
+{
+  HOST_WIDE_INT offset1, offset2;
+
+  offset1 = calculate_offset (eq1->expr);
+  offset2 = calculate_offset (eq2->expr);
+
+  if (s1->offset + offset1 != s2->offset + offset2)
+    gfc_error ("Inconsistent equivalence rules involving '%s' at %L and "
+	       "'%s' at %L", s1->sym->name, &s1->sym->declared_at,
+	       s2->sym->name, &s2->sym->declared_at);
+}
+
+
+/* Process a new equivalence condition. eq1 is know to be in segment f.
+   If eq2 is also present then confirm that the condition holds.
+   Otherwise add a new variable to the segment list.  */
+
+static void
+add_condition (segment_info *f, gfc_equiv *eq1, gfc_equiv *eq2)
+{
+  segment_info *n;
+
+  n = find_segment_info (eq2->expr->symtree->n.sym);
+
+  if (n == NULL)
+    new_condition (f, eq1, eq2);
+  else
+    confirm_condition (f, eq1, n, eq2);
+}
+
+
+/* Given a segment element, search through the equivalence lists for unused
+   conditions that involve the symbol.  Add these rules to the segment.  */
+
+static bool
+find_equivalence (segment_info *n)
+{
+  gfc_equiv *e1, *e2, *eq;
+  bool found;
+
+  found = FALSE;
+
+  for (e1 = n->sym->ns->equiv; e1; e1 = e1->next)
+    {
+      eq = NULL;
+
+      /* Search the equivalence list, including the root (first) element
+         for the symbol that owns the segment.  */
+      for (e2 = e1; e2; e2 = e2->eq)
+	{
+	  if (!e2->used && e2->expr->symtree->n.sym == n->sym)
+	    {
+	      eq = e2;
+	      break;
+	    }
+	}
+
+      /* Go to the next root element.  */
+      if (eq == NULL)
+	continue;
+
+      eq->used = 1;
+
+      /* Now traverse the equivalence list matching the offsets.  */
+      for (e2 = e1; e2; e2 = e2->eq)
+	{
+	  if (!e2->used && e2 != eq)
+	    {
+	      add_condition (n, eq, e2);
+	      e2->used = 1;
+	      found = TRUE;
+	    }
+	}
+    }
+  return found;
+}
+
+
+/* Add all symbols equivalenced within a segment.  We need to scan the
+   segment list multiple times to include indirect equivalences.  Since
+   a new segment_info can inserted at the beginning of the segment list,
+   depending on its offset, we have to force a final pass through the
+   loop by demanding that completion sees a pass with no matches; i.e.,
+   all symbols with equiv_built set and no new equivalences found.  */
+
+static void
+add_equivalences (bool *saw_equiv)
+{
+  segment_info *f;
+  bool seen_one, more;
+
+  seen_one = false;
+  more = TRUE;
+  while (more)
+    {
+      more = FALSE;
+      for (f = current_segment; f; f = f->next)
+	{
+	  if (!f->sym->equiv_built)
+	    {
+	      f->sym->equiv_built = 1;
+	      seen_one = find_equivalence (f);
+	      if (seen_one)
+		{
+		  *saw_equiv = true;
+		  more = true;
+		}
+	    }
+	}
+    }
+
+  /* Add a copy of this segment list to the namespace.  */
+  copy_equiv_list_to_ns (current_segment);
+}
+
+
+/* Returns the offset necessary to properly align the current equivalence.
+   Sets *palign to the required alignment.  */
+
+static HOST_WIDE_INT
+align_segment (unsigned HOST_WIDE_INT *palign)
+{
+  segment_info *s;
+  unsigned HOST_WIDE_INT offset;
+  unsigned HOST_WIDE_INT max_align;
+  unsigned HOST_WIDE_INT this_align;
+  unsigned HOST_WIDE_INT this_offset;
+
+  max_align = 1;
+  offset = 0;
+  for (s = current_segment; s; s = s->next)
+    {
+      this_align = TYPE_ALIGN_UNIT (s->field);
+      if (s->offset & (this_align - 1))
+	{
+	  /* Field is misaligned.  */
+	  this_offset = this_align - ((s->offset + offset) & (this_align - 1));
+	  if (this_offset & (max_align - 1))
+	    {
+	      /* Aligning this field would misalign a previous field.  */
+	      gfc_error ("The equivalence set for variable '%s' "
+			 "declared at %L violates alignment requirements",
+			 s->sym->name, &s->sym->declared_at);
+	    }
+	  offset += this_offset;
+	}
+      max_align = this_align;
+    }
+  if (palign)
+    *palign = max_align;
+  return offset;
+}
+
+
+/* Adjust segment offsets by the given amount.  */
+
+static void
+apply_segment_offset (segment_info *s, HOST_WIDE_INT offset)
+{
+  for (; s; s = s->next)
+    s->offset += offset;
+}
+
+
+/* Lay out a symbol in a common block.  If the symbol has already been seen
+   then check the location is consistent.  Otherwise create segments
+   for that symbol and all the symbols equivalenced with it.  */
+
+/* Translate a single common block.  */
+
+static void
+translate_common (gfc_common_head *common, gfc_symbol *var_list)
+{
+  gfc_symbol *sym;
+  segment_info *s;
+  segment_info *common_segment;
+  HOST_WIDE_INT offset;
+  HOST_WIDE_INT current_offset;
+  unsigned HOST_WIDE_INT align;
+  bool saw_equiv;
+
+  common_segment = NULL;
+  offset = 0;
+  current_offset = 0;
+  align = 1;
+  saw_equiv = false;
+
+  /* Add symbols to the segment.  */
+  for (sym = var_list; sym; sym = sym->common_next)
+    {
+      current_segment = common_segment;
+      s = find_segment_info (sym);
+
+      /* Symbol has already been added via an equivalence.  Multiple
+	 use associations of the same common block result in equiv_built
+	 being set but no information about the symbol in the segment.  */
+      if (s && sym->equiv_built)
+	{
+	  /* Ensure the current location is properly aligned.  */
+	  align = TYPE_ALIGN_UNIT (s->field);
+	  current_offset = (current_offset + align - 1) &~ (align - 1);
+
+	  /* Verify that it ended up where we expect it.  */
+	  if (s->offset != current_offset)
+	    {
+	      gfc_error ("Equivalence for '%s' does not match ordering of "
+			 "COMMON '%s' at %L", sym->name,
+			 common->name, &common->where);
+	    }
+	}
+      else
+	{
+	  /* A symbol we haven't seen before.  */
+	  s = current_segment = get_segment_info (sym, current_offset);
+
+	  /* Add all objects directly or indirectly equivalenced with this
+	     symbol.  */
+	  add_equivalences (&saw_equiv);
+
+	  if (current_segment->offset < 0)
+	    gfc_error ("The equivalence set for '%s' cause an invalid "
+		       "extension to COMMON '%s' at %L", sym->name,
+		       common->name, &common->where);
+
+	  if (gfc_option.flag_align_commons)
+	    offset = align_segment (&align);
+
+	  if (offset)
+	    {
+	      /* The required offset conflicts with previous alignment
+		 requirements.  Insert padding immediately before this
+		 segment.  */
+	      if (gfc_option.warn_align_commons)
+		{
+		  if (strcmp (common->name, BLANK_COMMON_NAME))
+		    gfc_warning ("Padding of %d bytes required before '%s' in "
+				 "COMMON '%s' at %L; reorder elements or use "
+				 "-fno-align-commons", (int)offset,
+				 s->sym->name, common->name, &common->where);
+		  else
+		    gfc_warning ("Padding of %d bytes required before '%s' in "
+				 "COMMON at %L; reorder elements or use "
+				 "-fno-align-commons", (int)offset,
+				 s->sym->name, &common->where);
+		}
+	    }
+
+	  /* Apply the offset to the new segments.  */
+	  apply_segment_offset (current_segment, offset);
+	  current_offset += offset;
+
+	  /* Add the new segments to the common block.  */
+	  common_segment = add_segments (common_segment, current_segment);
+	}
+
+      /* The offset of the next common variable.  */
+      current_offset += s->length;
+    }
+
+  if (common_segment == NULL)
+    {
+      gfc_error ("COMMON '%s' at %L does not exist",
+		 common->name, &common->where);
+      return;
+    }
+
+  if (common_segment->offset != 0 && gfc_option.warn_align_commons)
+    {
+      if (strcmp (common->name, BLANK_COMMON_NAME))
+	gfc_warning ("COMMON '%s' at %L requires %d bytes of padding; "
+		     "reorder elements or use -fno-align-commons",
+		     common->name, &common->where, (int)common_segment->offset);
+      else
+	gfc_warning ("COMMON at %L requires %d bytes of padding; "
+		     "reorder elements or use -fno-align-commons",
+		     &common->where, (int)common_segment->offset);
+    }
+
+  create_common (common, common_segment, saw_equiv);
+}
+
+
+/* Create a new block for each merged equivalence list.  */
+
+static void
+finish_equivalences (gfc_namespace *ns)
+{
+  gfc_equiv *z, *y;
+  gfc_symbol *sym;
+  gfc_common_head * c;
+  HOST_WIDE_INT offset;
+  unsigned HOST_WIDE_INT align;
+  bool dummy;
+
+  for (z = ns->equiv; z; z = z->next)
+    for (y = z->eq; y; y = y->eq)
+      {
+        if (y->used) 
+	  continue;
+        sym = z->expr->symtree->n.sym;
+        current_segment = get_segment_info (sym, 0);
+
+        /* All objects directly or indirectly equivalenced with this
+	   symbol.  */
+        add_equivalences (&dummy);
+
+	/* Align the block.  */
+	offset = align_segment (&align);
+
+	/* Ensure all offsets are positive.  */
+	offset -= current_segment->offset & ~(align - 1);
+
+	apply_segment_offset (current_segment, offset);
+
+	/* Create the decl.  If this is a module equivalence, it has a
+	   unique name, pointed to by z->module.  This is written to a
+	   gfc_common_header to push create_common into using
+	   build_common_decl, so that the equivalence appears as an
+	   external symbol.  Otherwise, a local declaration is built using
+	   build_equiv_decl.  */
+	if (z->module)
+	  {
+	    c = gfc_get_common_head ();
+	    /* We've lost the real location, so use the location of the
+	       enclosing procedure.  */
+	    c->where = ns->proc_name->declared_at;
+	    strcpy (c->name, z->module);
+	  }
+	else
+	  c = NULL;
+
+        create_common (c, current_segment, true);
+        break;
+      }
+}
+
+
+/* Work function for translating a named common block.  */
+
+static void
+named_common (gfc_symtree *st)
+{
+  translate_common (st->n.common, st->n.common->head);
+}
+
+
+/* Translate the common blocks in a namespace. Unlike other variables,
+   these have to be created before code, because the backend_decl depends
+   on the rest of the common block.  */
+
+void
+gfc_trans_common (gfc_namespace *ns)
+{
+  gfc_common_head *c;
+
+  /* Translate the blank common block.  */
+  if (ns->blank_common.head != NULL)
+    {
+      c = gfc_get_common_head ();
+      c->where = ns->blank_common.head->common_head->where;
+      strcpy (c->name, BLANK_COMMON_NAME);
+      translate_common (c, ns->blank_common.head);
+    }
+
+  /* Translate all named common blocks.  */
+  gfc_traverse_symtree (ns->common_root, named_common);
+
+  /* Translate local equivalence.  */
+  finish_equivalences (ns);
+
+  /* Commit the newly created symbols for common blocks and module
+     equivalences.  */
+  gfc_commit_symbols ();
+}
diff --git a/gcc-4.9/gcc/fortran/trans-const.c b/gcc-4.9/gcc/fortran/trans-const.c
new file mode 100644
index 000000000..a2c3e31b6
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/trans-const.c
@@ -0,0 +1,408 @@
+/* Translation of constants
+   Copyright (C) 2002-2014 Free Software Foundation, Inc.
+   Contributed by Paul Brook
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+/* trans-const.c -- convert constant values */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "tree.h"
+#include "stor-layout.h"
+#include "realmpfr.h"
+#include "diagnostic-core.h"	/* For fatal_error.  */
+#include "double-int.h"
+#include "gfortran.h"
+#include "trans.h"
+#include "trans-const.h"
+#include "trans-types.h"
+#include "target-memory.h"
+
+tree gfc_rank_cst[GFC_MAX_DIMENSIONS + 1];
+
+/* Build a constant with given type from an int_cst.  */
+
+tree
+gfc_build_const (tree type, tree intval)
+{
+  tree val;
+  tree zero;
+
+  switch (TREE_CODE (type))
+    {
+    case INTEGER_TYPE:
+      val = convert (type, intval);
+      break;
+
+    case REAL_TYPE:
+      val = build_real_from_int_cst (type, intval);
+      break;
+
+    case COMPLEX_TYPE:
+      val = build_real_from_int_cst (TREE_TYPE (type), intval);
+      zero = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
+      val = build_complex (type, val, zero);
+      break;
+
+    default:
+      gcc_unreachable ();
+    }
+  return val;
+}
+
+/* Build a string constant with C char type.  */
+
+tree
+gfc_build_string_const (int length, const char *s)
+{
+  tree str;
+  tree len;
+
+  str = build_string (length, s);
+  len = size_int (length);
+  TREE_TYPE (str) =
+    build_array_type (gfc_character1_type_node,
+		      build_range_type (gfc_charlen_type_node,
+					size_one_node, len));
+  return str;
+}
+
+
+/* Build a string constant with a type given by its kind; take care of
+   non-default character kinds.  */
+
+tree
+gfc_build_wide_string_const (int kind, int length, const gfc_char_t *string)
+{
+  int i;
+  tree str, len;
+  size_t size;
+  char *s;
+
+  i = gfc_validate_kind (BT_CHARACTER, kind, false);
+  size = length * gfc_character_kinds[i].bit_size / 8;
+
+  s = XCNEWVAR (char, size);
+  gfc_encode_character (kind, length, string, (unsigned char *) s, size);
+
+  str = build_string (size, s);
+  free (s);
+
+  len = size_int (length);
+  TREE_TYPE (str) =
+    build_array_type (gfc_get_char_type (kind),
+		      build_range_type (gfc_charlen_type_node,
+					size_one_node, len));
+  return str;
+}
+
+
+/* Build a Fortran character constant from a zero-terminated string.
+   There a two version of this function, one that translates the string
+   and one that doesn't.  */
+tree
+gfc_build_cstring_const (const char *string)
+{
+  return gfc_build_string_const (strlen (string) + 1, string);
+}
+
+tree
+gfc_build_localized_cstring_const (const char *msgid)
+{
+  const char *localized = _(msgid);
+  return gfc_build_string_const (strlen (localized) + 1, localized);
+}
+
+
+/* Return a string constant with the given length.  Used for static
+   initializers.  The constant will be padded or truncated to match 
+   length.  */
+
+tree
+gfc_conv_string_init (tree length, gfc_expr * expr)
+{
+  gfc_char_t *s;
+  HOST_WIDE_INT len;
+  int slen;
+  tree str;
+  bool free_s = false;
+
+  gcc_assert (expr->expr_type == EXPR_CONSTANT);
+  gcc_assert (expr->ts.type == BT_CHARACTER);
+  gcc_assert (INTEGER_CST_P (length));
+  gcc_assert (TREE_INT_CST_HIGH (length) == 0);
+
+  len = TREE_INT_CST_LOW (length);
+  slen = expr->value.character.length;
+
+  if (len > slen)
+    {
+      s = gfc_get_wide_string (len);
+      memcpy (s, expr->value.character.string, slen * sizeof (gfc_char_t));
+      gfc_wide_memset (&s[slen], ' ', len - slen);
+      free_s = true;
+    }
+  else
+    s = expr->value.character.string;
+
+  str = gfc_build_wide_string_const (expr->ts.kind, len, s);
+
+  if (free_s)
+    free (s);
+
+  return str;
+}
+
+
+/* Create a tree node for the string length if it is constant.  */
+
+void
+gfc_conv_const_charlen (gfc_charlen * cl)
+{
+  if (!cl || cl->backend_decl)
+    return;
+
+  if (cl->length && cl->length->expr_type == EXPR_CONSTANT)
+    {
+      cl->backend_decl = gfc_conv_mpz_to_tree (cl->length->value.integer,
+					       cl->length->ts.kind);
+      cl->backend_decl = fold_convert (gfc_charlen_type_node,
+					cl->backend_decl);
+    }
+}
+
+void
+gfc_init_constants (void)
+{
+  int n;
+
+  for (n = 0; n <= GFC_MAX_DIMENSIONS; n++)
+    gfc_rank_cst[n] = build_int_cst (gfc_array_index_type, n);
+}
+
+/* Converts a GMP integer into a backend tree node.  */
+
+tree
+gfc_conv_mpz_to_tree (mpz_t i, int kind)
+{
+  double_int val = mpz_get_double_int (gfc_get_int_type (kind), i, true);
+  return double_int_to_tree (gfc_get_int_type (kind), val);
+}
+
+/* Converts a backend tree into a GMP integer.  */
+
+void
+gfc_conv_tree_to_mpz (mpz_t i, tree source)
+{
+  double_int val = tree_to_double_int (source);
+  mpz_set_double_int (i, val, TYPE_UNSIGNED (TREE_TYPE (source)));
+}
+
+/* Converts a real constant into backend form.  */
+
+tree
+gfc_conv_mpfr_to_tree (mpfr_t f, int kind, int is_snan)
+{
+  tree type;
+  int n;
+  REAL_VALUE_TYPE real;
+
+  n = gfc_validate_kind (BT_REAL, kind, false);
+  gcc_assert (gfc_real_kinds[n].radix == 2);
+
+  type = gfc_get_real_type (kind);
+  if (mpfr_nan_p (f) && is_snan)
+     real_from_string (&real, "SNaN");
+  else
+    real_from_mpfr (&real, f, type, GFC_RND_MODE);
+
+  return build_real (type, real);
+}
+
+/* Returns a real constant that is +Infinity if the target
+   supports infinities for this floating-point mode, and
+   +HUGE_VAL otherwise (the largest representable number).  */
+
+tree
+gfc_build_inf_or_huge (tree type, int kind)
+{
+  if (HONOR_INFINITIES (TYPE_MODE (type)))
+    {
+      REAL_VALUE_TYPE real;
+      real_inf (&real);
+      return build_real (type, real);
+    }
+  else
+    {
+      int k = gfc_validate_kind (BT_REAL, kind, false);
+      return gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge, kind, 0);
+    }
+}
+
+/* Converts a backend tree into a real constant.  */
+
+void
+gfc_conv_tree_to_mpfr (mpfr_ptr f, tree source)
+{
+  mpfr_from_real (f, TREE_REAL_CST_PTR (source), GFC_RND_MODE);
+}
+
+/* Translate any literal constant to a tree.  Constants never have
+   pre or post chains.  Character literal constants are special
+   special because they have a value and a length, so they cannot be
+   returned as a single tree.  It is up to the caller to set the
+   length somewhere if necessary.
+
+   Returns the translated constant, or aborts if it gets a type it
+   can't handle.  */
+
+tree
+gfc_conv_constant_to_tree (gfc_expr * expr)
+{
+  tree res;
+
+  gcc_assert (expr->expr_type == EXPR_CONSTANT);
+
+  /* If it is has a prescribed memory representation, we build a string
+     constant and VIEW_CONVERT to its type.  */
+ 
+  switch (expr->ts.type)
+    {
+    case BT_INTEGER:
+      if (expr->representation.string)
+	return fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
+			 gfc_get_int_type (expr->ts.kind),
+			 gfc_build_string_const (expr->representation.length,
+						 expr->representation.string));
+      else
+	return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
+
+    case BT_REAL:
+      if (expr->representation.string)
+	return fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
+			 gfc_get_real_type (expr->ts.kind),
+			 gfc_build_string_const (expr->representation.length,
+						 expr->representation.string));
+      else
+	return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind, expr->is_snan);
+
+    case BT_LOGICAL:
+      if (expr->representation.string)
+	{
+	  tree tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
+			gfc_get_int_type (expr->ts.kind),
+			gfc_build_string_const (expr->representation.length,
+						expr->representation.string));
+	  if (!integer_zerop (tmp) && !integer_onep (tmp))
+	    gfc_warning ("Assigning value other than 0 or 1 to LOGICAL"
+			 " has undefined result at %L", &expr->where);
+	  return fold_convert (gfc_get_logical_type (expr->ts.kind), tmp);
+	}
+      else
+	return build_int_cst (gfc_get_logical_type (expr->ts.kind),
+			      expr->value.logical);
+
+    case BT_COMPLEX:
+      if (expr->representation.string)
+	return fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
+			 gfc_get_complex_type (expr->ts.kind),
+			 gfc_build_string_const (expr->representation.length,
+						 expr->representation.string));
+      else
+	{
+	  tree real = gfc_conv_mpfr_to_tree (mpc_realref (expr->value.complex),
+					  expr->ts.kind, expr->is_snan);
+	  tree imag = gfc_conv_mpfr_to_tree (mpc_imagref (expr->value.complex),
+					  expr->ts.kind, expr->is_snan);
+
+	  return build_complex (gfc_typenode_for_spec (&expr->ts),
+				real, imag);
+	}
+
+    case BT_CHARACTER:
+      res = gfc_build_wide_string_const (expr->ts.kind,
+					 expr->value.character.length,
+					 expr->value.character.string);
+      return res;
+
+    case BT_HOLLERITH:
+      return gfc_build_string_const (expr->representation.length,
+				     expr->representation.string);
+
+    default:
+      fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s",
+		   gfc_typename (&expr->ts));
+    }
+}
+
+
+/* Like gfc_conv_constant_to_tree, but for a simplified expression.
+   We can handle character literal constants here as well.  */
+
+void
+gfc_conv_constant (gfc_se * se, gfc_expr * expr)
+{
+  gfc_ss *ss;
+
+  /* We may be receiving an expression for C_NULL_PTR or C_NULL_FUNPTR.  If
+     so, the expr_type will not yet be an EXPR_CONSTANT.  We need to make
+     it so here.  */
+  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
+      && expr->ts.u.derived->attr.is_iso_c)
+    {
+      if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR 
+          || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
+        {
+          /* Create a new EXPR_CONSTANT expression for our local uses.  */
+          expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
+        }
+    }
+
+  if (expr->expr_type != EXPR_CONSTANT)
+    {
+      gfc_expr *e = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
+      gfc_error ("non-constant initialization expression at %L", &expr->where);
+      se->expr = gfc_conv_constant_to_tree (e);
+      return;
+    }
+
+  ss = se->ss;
+  if (ss != NULL)
+    {
+      gfc_ss_info *ss_info;
+
+      ss_info = ss->info;
+      gcc_assert (ss != gfc_ss_terminator);
+      gcc_assert (ss_info->type == GFC_SS_SCALAR);
+      gcc_assert (ss_info->expr == expr);
+
+      se->expr = ss_info->data.scalar.value;
+      se->string_length = ss_info->string_length;
+      gfc_advance_se_ss_chain (se);
+      return;
+    }
+
+  /* Translate the constant and put it in the simplifier structure.  */
+  se->expr = gfc_conv_constant_to_tree (expr);
+
+  /* If this is a CHARACTER string, set its length in the simplifier
+     structure, too.  */
+  if (expr->ts.type == BT_CHARACTER)
+    se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
+}
diff --git a/gcc-4.9/gcc/fortran/trans-const.h b/gcc-4.9/gcc/fortran/trans-const.h
new file mode 100644
index 000000000..42ffe6952
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/trans-const.h
@@ -0,0 +1,63 @@
+/* Header for code constant translation functions
+   Copyright (C) 2002-2014 Free Software Foundation, Inc.
+   Contributed by Paul Brook
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+/* Converts between INT_CST and GMP integer representations.  */
+tree gfc_conv_mpz_to_tree (mpz_t, int);
+void gfc_conv_tree_to_mpz (mpz_t, tree);
+
+/* Converts between REAL_CST and MPFR floating-point representations.  */
+tree gfc_conv_mpfr_to_tree (mpfr_t, int, int);
+void gfc_conv_tree_to_mpfr (mpfr_ptr, tree);
+
+/* Build a tree containing a real infinity (or HUGE if infinities are
+   not supported for the given type.  */
+tree gfc_build_inf_or_huge (tree, int);
+
+/* Build a tree for a constant.  Must be an EXPR_CONSTANT gfc_expr.
+   For CHARACTER literal constants, the caller still has to set the
+   string length as a separate operation.  */
+tree gfc_conv_constant_to_tree (gfc_expr *);
+
+/* Like gfc_conv_noncharacter_constant, but works on simplified expression
+   structures.  Also sets the length of CHARACTER strings in the gfc_se.  */
+void gfc_conv_constant (gfc_se *, gfc_expr *);
+
+tree gfc_build_string_const (int, const char *);
+tree gfc_build_wide_string_const (int, int, const gfc_char_t *);
+tree gfc_build_cstring_const (const char *);
+tree gfc_build_localized_cstring_const (const char *);
+
+/* Translate a string constant for a static initializer.  */
+tree gfc_conv_string_init (tree, gfc_expr *);
+
+/* Create a tree node for the string length if it is constant.  */
+void gfc_conv_const_charlen (gfc_charlen *);
+
+/* Initialize the nodes for constants.  */
+void gfc_init_constants (void);
+
+/* Build a constant with given type from an int_cst.  */
+tree gfc_build_const (tree, tree);
+
+/* Integer constants 0..GFC_MAX_DIMENSIONS.  */
+extern GTY(()) tree gfc_rank_cst[GFC_MAX_DIMENSIONS + 1];
+
+#define gfc_index_zero_node gfc_rank_cst[0]
+#define gfc_index_one_node gfc_rank_cst[1]
diff --git a/gcc-4.9/gcc/fortran/trans-decl.c b/gcc-4.9/gcc/fortran/trans-decl.c
new file mode 100644
index 000000000..cf7b661d8
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/trans-decl.c
@@ -0,0 +1,5884 @@
+/* Backend function setup
+   Copyright (C) 2002-2014 Free Software Foundation, Inc.
+   Contributed by Paul Brook
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+/* trans-decl.c -- Handling of backend function and variable decls, etc */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "tm.h"
+#include "tree.h"
+#include "stringpool.h"
+#include "stor-layout.h"
+#include "varasm.h"
+#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 "function.h"
+#include "flags.h"
+#include "cgraph.h"
+#include "debug.h"
+#include "gfortran.h"
+#include "pointer-set.h"
+#include "constructor.h"
+#include "trans.h"
+#include "trans-types.h"
+#include "trans-array.h"
+#include "trans-const.h"
+/* Only for gfc_trans_code.  Shouldn't need to include this.  */
+#include "trans-stmt.h"
+
+#define MAX_LABEL_VALUE 99999
+
+
+/* Holds the result of the function if no result variable specified.  */
+
+static GTY(()) tree current_fake_result_decl;
+static GTY(()) tree parent_fake_result_decl;
+
+
+/* Holds the variable DECLs for the current function.  */
+
+static GTY(()) tree saved_function_decls;
+static GTY(()) tree saved_parent_function_decls;
+
+static struct pointer_set_t *nonlocal_dummy_decl_pset;
+static GTY(()) tree nonlocal_dummy_decls;
+
+/* Holds the variable DECLs that are locals.  */
+
+static GTY(()) tree saved_local_decls;
+
+/* The namespace of the module we're currently generating.  Only used while
+   outputting decls for module variables.  Do not rely on this being set.  */
+
+static gfc_namespace *module_namespace;
+
+/* The currently processed procedure symbol.  */
+static gfc_symbol* current_procedure_symbol = NULL;
+
+
+/* With -fcoarray=lib: For generating the registering call
+   of static coarrays.  */
+static bool has_coarray_vars;
+static stmtblock_t caf_init_block;
+
+
+/* List of static constructor functions.  */
+
+tree gfc_static_ctors;
+
+
+/* Function declarations for builtin library functions.  */
+
+tree gfor_fndecl_pause_numeric;
+tree gfor_fndecl_pause_string;
+tree gfor_fndecl_stop_numeric;
+tree gfor_fndecl_stop_numeric_f08;
+tree gfor_fndecl_stop_string;
+tree gfor_fndecl_error_stop_numeric;
+tree gfor_fndecl_error_stop_string;
+tree gfor_fndecl_runtime_error;
+tree gfor_fndecl_runtime_error_at;
+tree gfor_fndecl_runtime_warning_at;
+tree gfor_fndecl_os_error;
+tree gfor_fndecl_generate_error;
+tree gfor_fndecl_set_args;
+tree gfor_fndecl_set_fpe;
+tree gfor_fndecl_set_options;
+tree gfor_fndecl_set_convert;
+tree gfor_fndecl_set_record_marker;
+tree gfor_fndecl_set_max_subrecord_length;
+tree gfor_fndecl_ctime;
+tree gfor_fndecl_fdate;
+tree gfor_fndecl_ttynam;
+tree gfor_fndecl_in_pack;
+tree gfor_fndecl_in_unpack;
+tree gfor_fndecl_associated;
+
+
+/* Coarray run-time library function decls.  */
+tree gfor_fndecl_caf_init;
+tree gfor_fndecl_caf_finalize;
+tree gfor_fndecl_caf_register;
+tree gfor_fndecl_caf_deregister;
+tree gfor_fndecl_caf_critical;
+tree gfor_fndecl_caf_end_critical;
+tree gfor_fndecl_caf_sync_all;
+tree gfor_fndecl_caf_sync_images;
+tree gfor_fndecl_caf_error_stop;
+tree gfor_fndecl_caf_error_stop_str;
+
+/* Coarray global variables for num_images/this_image.  */
+
+tree gfort_gvar_caf_num_images;
+tree gfort_gvar_caf_this_image;
+
+
+/* Math functions.  Many other math functions are handled in
+   trans-intrinsic.c.  */
+
+gfc_powdecl_list gfor_fndecl_math_powi[4][3];
+tree gfor_fndecl_math_ishftc4;
+tree gfor_fndecl_math_ishftc8;
+tree gfor_fndecl_math_ishftc16;
+
+
+/* String functions.  */
+
+tree gfor_fndecl_compare_string;
+tree gfor_fndecl_concat_string;
+tree gfor_fndecl_string_len_trim;
+tree gfor_fndecl_string_index;
+tree gfor_fndecl_string_scan;
+tree gfor_fndecl_string_verify;
+tree gfor_fndecl_string_trim;
+tree gfor_fndecl_string_minmax;
+tree gfor_fndecl_adjustl;
+tree gfor_fndecl_adjustr;
+tree gfor_fndecl_select_string;
+tree gfor_fndecl_compare_string_char4;
+tree gfor_fndecl_concat_string_char4;
+tree gfor_fndecl_string_len_trim_char4;
+tree gfor_fndecl_string_index_char4;
+tree gfor_fndecl_string_scan_char4;
+tree gfor_fndecl_string_verify_char4;
+tree gfor_fndecl_string_trim_char4;
+tree gfor_fndecl_string_minmax_char4;
+tree gfor_fndecl_adjustl_char4;
+tree gfor_fndecl_adjustr_char4;
+tree gfor_fndecl_select_string_char4;
+
+
+/* Conversion between character kinds.  */
+tree gfor_fndecl_convert_char1_to_char4;
+tree gfor_fndecl_convert_char4_to_char1;
+
+
+/* Other misc. runtime library functions.  */
+tree gfor_fndecl_size0;
+tree gfor_fndecl_size1;
+tree gfor_fndecl_iargc;
+
+/* Intrinsic functions implemented in Fortran.  */
+tree gfor_fndecl_sc_kind;
+tree gfor_fndecl_si_kind;
+tree gfor_fndecl_sr_kind;
+
+/* BLAS gemm functions.  */
+tree gfor_fndecl_sgemm;
+tree gfor_fndecl_dgemm;
+tree gfor_fndecl_cgemm;
+tree gfor_fndecl_zgemm;
+
+
+static void
+gfc_add_decl_to_parent_function (tree decl)
+{
+  gcc_assert (decl);
+  DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
+  DECL_NONLOCAL (decl) = 1;
+  DECL_CHAIN (decl) = saved_parent_function_decls;
+  saved_parent_function_decls = decl;
+}
+
+void
+gfc_add_decl_to_function (tree decl)
+{
+  gcc_assert (decl);
+  TREE_USED (decl) = 1;
+  DECL_CONTEXT (decl) = current_function_decl;
+  DECL_CHAIN (decl) = saved_function_decls;
+  saved_function_decls = decl;
+}
+
+static void
+add_decl_as_local (tree decl)
+{
+  gcc_assert (decl);
+  TREE_USED (decl) = 1;
+  DECL_CONTEXT (decl) = current_function_decl;
+  DECL_CHAIN (decl) = saved_local_decls;
+  saved_local_decls = decl;
+}
+
+
+/* Build a  backend label declaration.  Set TREE_USED for named labels.
+   The context of the label is always the current_function_decl.  All
+   labels are marked artificial.  */
+
+tree
+gfc_build_label_decl (tree label_id)
+{
+  /* 2^32 temporaries should be enough.  */
+  static unsigned int tmp_num = 1;
+  tree label_decl;
+  char *label_name;
+
+  if (label_id == NULL_TREE)
+    {
+      /* Build an internal label name.  */
+      ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
+      label_id = get_identifier (label_name);
+    }
+  else
+    label_name = NULL;
+
+  /* Build the LABEL_DECL node. Labels have no type.  */
+  label_decl = build_decl (input_location,
+			   LABEL_DECL, label_id, void_type_node);
+  DECL_CONTEXT (label_decl) = current_function_decl;
+  DECL_MODE (label_decl) = VOIDmode;
+
+  /* We always define the label as used, even if the original source
+     file never references the label.  We don't want all kinds of
+     spurious warnings for old-style Fortran code with too many
+     labels.  */
+  TREE_USED (label_decl) = 1;
+
+  DECL_ARTIFICIAL (label_decl) = 1;
+  return label_decl;
+}
+
+
+/* Set the backend source location of a decl.  */
+
+void
+gfc_set_decl_location (tree decl, locus * loc)
+{
+  DECL_SOURCE_LOCATION (decl) = loc->lb->location;
+}
+
+
+/* Return the backend label declaration for a given label structure,
+   or create it if it doesn't exist yet.  */
+
+tree
+gfc_get_label_decl (gfc_st_label * lp)
+{
+  if (lp->backend_decl)
+    return lp->backend_decl;
+  else
+    {
+      char label_name[GFC_MAX_SYMBOL_LEN + 1];
+      tree label_decl;
+
+      /* Validate the label declaration from the front end.  */
+      gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
+
+      /* Build a mangled name for the label.  */
+      sprintf (label_name, "__label_%.6d", lp->value);
+
+      /* Build the LABEL_DECL node.  */
+      label_decl = gfc_build_label_decl (get_identifier (label_name));
+
+      /* Tell the debugger where the label came from.  */
+      if (lp->value <= MAX_LABEL_VALUE)	/* An internal label.  */
+	gfc_set_decl_location (label_decl, &lp->where);
+      else
+	DECL_ARTIFICIAL (label_decl) = 1;
+
+      /* Store the label in the label list and return the LABEL_DECL.  */
+      lp->backend_decl = label_decl;
+      return label_decl;
+    }
+}
+
+
+/* Convert a gfc_symbol to an identifier of the same name.  */
+
+static tree
+gfc_sym_identifier (gfc_symbol * sym)
+{
+  if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
+    return (get_identifier ("MAIN__"));
+  else
+    return (get_identifier (sym->name));
+}
+
+
+/* Construct mangled name from symbol name.  */
+
+static tree
+gfc_sym_mangled_identifier (gfc_symbol * sym)
+{
+  char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
+
+  /* Prevent the mangling of identifiers that have an assigned
+     binding label (mainly those that are bind(c)).  */
+  if (sym->attr.is_bind_c == 1 && sym->binding_label)
+    return get_identifier (sym->binding_label);
+
+  if (sym->module == NULL)
+    return gfc_sym_identifier (sym);
+  else
+    {
+      snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
+      return get_identifier (name);
+    }
+}
+
+
+/* Construct mangled function name from symbol name.  */
+
+static tree
+gfc_sym_mangled_function_id (gfc_symbol * sym)
+{
+  int has_underscore;
+  char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
+
+  /* It may be possible to simply use the binding label if it's
+     provided, and remove the other checks.  Then we could use it
+     for other things if we wished.  */
+  if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) &&
+      sym->binding_label)
+    /* use the binding label rather than the mangled name */
+    return get_identifier (sym->binding_label);
+
+  if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
+      || (sym->module != NULL && (sym->attr.external
+	    || sym->attr.if_source == IFSRC_IFBODY)))
+    {
+      /* Main program is mangled into MAIN__.  */
+      if (sym->attr.is_main_program)
+	return get_identifier ("MAIN__");
+
+      /* Intrinsic procedures are never mangled.  */
+      if (sym->attr.proc == PROC_INTRINSIC)
+	return get_identifier (sym->name);
+
+      if (gfc_option.flag_underscoring)
+	{
+	  has_underscore = strchr (sym->name, '_') != 0;
+	  if (gfc_option.flag_second_underscore && has_underscore)
+	    snprintf (name, sizeof name, "%s__", sym->name);
+	  else
+	    snprintf (name, sizeof name, "%s_", sym->name);
+	  return get_identifier (name);
+	}
+      else
+	return get_identifier (sym->name);
+    }
+  else
+    {
+      snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
+      return get_identifier (name);
+    }
+}
+
+
+void
+gfc_set_decl_assembler_name (tree decl, tree name)
+{
+  tree target_mangled = targetm.mangle_decl_assembler_name (decl, name);
+  SET_DECL_ASSEMBLER_NAME (decl, target_mangled);
+}
+
+
+/* Returns true if a variable of specified size should go on the stack.  */
+
+int
+gfc_can_put_var_on_stack (tree size)
+{
+  unsigned HOST_WIDE_INT low;
+
+  if (!INTEGER_CST_P (size))
+    return 0;
+
+  if (gfc_option.flag_max_stack_var_size < 0)
+    return 1;
+
+  if (TREE_INT_CST_HIGH (size) != 0)
+    return 0;
+
+  low = TREE_INT_CST_LOW (size);
+  if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
+    return 0;
+
+/* TODO: Set a per-function stack size limit.  */
+
+  return 1;
+}
+
+
+/* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
+   an expression involving its corresponding pointer.  There are
+   2 cases; one for variable size arrays, and one for everything else,
+   because variable-sized arrays require one fewer level of
+   indirection.  */
+
+static void
+gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
+{
+  tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
+  tree value;
+
+  /* Parameters need to be dereferenced.  */
+  if (sym->cp_pointer->attr.dummy)
+    ptr_decl = build_fold_indirect_ref_loc (input_location,
+					ptr_decl);
+
+  /* Check to see if we're dealing with a variable-sized array.  */
+  if (sym->attr.dimension
+      && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
+    {
+      /* These decls will be dereferenced later, so we don't dereference
+	 them here.  */
+      value = convert (TREE_TYPE (decl), ptr_decl);
+    }
+  else
+    {
+      ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
+			  ptr_decl);
+      value = build_fold_indirect_ref_loc (input_location,
+				       ptr_decl);
+    }
+
+  SET_DECL_VALUE_EXPR (decl, value);
+  DECL_HAS_VALUE_EXPR_P (decl) = 1;
+  GFC_DECL_CRAY_POINTEE (decl) = 1;
+}
+
+
+/* Finish processing of a declaration without an initial value.  */
+
+static void
+gfc_finish_decl (tree decl)
+{
+  gcc_assert (TREE_CODE (decl) == PARM_DECL
+	      || DECL_INITIAL (decl) == NULL_TREE);
+
+  if (TREE_CODE (decl) != VAR_DECL)
+    return;
+
+  if (DECL_SIZE (decl) == NULL_TREE
+      && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
+    layout_decl (decl, 0);
+
+  /* A few consistency checks.  */
+  /* A static variable with an incomplete type is an error if it is
+     initialized. Also if it is not file scope. Otherwise, let it
+     through, but if it is not `extern' then it may cause an error
+     message later.  */
+  /* An automatic variable with an incomplete type is an error.  */
+
+  /* We should know the storage size.  */
+  gcc_assert (DECL_SIZE (decl) != NULL_TREE
+	      || (TREE_STATIC (decl)
+		  ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
+		  : DECL_EXTERNAL (decl)));
+
+  /* The storage size should be constant.  */
+  gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl))
+	      || !DECL_SIZE (decl)
+	      || TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST);
+}
+
+
+/* Apply symbol attributes to a variable, and add it to the function scope.  */
+
+static void
+gfc_finish_var_decl (tree decl, gfc_symbol * sym)
+{
+  tree new_type;
+  /* TREE_ADDRESSABLE means the address of this variable is actually needed.
+     This is the equivalent of the TARGET variables.
+     We also need to set this if the variable is passed by reference in a
+     CALL statement.  */
+
+  /* Set DECL_VALUE_EXPR for Cray Pointees.  */
+  if (sym->attr.cray_pointee)
+    gfc_finish_cray_pointee (decl, sym);
+
+  if (sym->attr.target)
+    TREE_ADDRESSABLE (decl) = 1;
+  /* If it wasn't used we wouldn't be getting it.  */
+  TREE_USED (decl) = 1;
+
+  if (sym->attr.flavor == FL_PARAMETER
+      && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
+    TREE_READONLY (decl) = 1;
+
+  /* Chain this decl to the pending declarations.  Don't do pushdecl()
+     because this would add them to the current scope rather than the
+     function scope.  */
+  if (current_function_decl != NULL_TREE)
+    {
+      if (sym->ns->proc_name->backend_decl == current_function_decl
+	  || sym->result == sym)
+	gfc_add_decl_to_function (decl);
+      else if (sym->ns->proc_name->attr.flavor == FL_LABEL)
+	/* This is a BLOCK construct.  */
+	add_decl_as_local (decl);
+      else
+	gfc_add_decl_to_parent_function (decl);
+    }
+
+  if (sym->attr.cray_pointee)
+    return;
+
+  if(sym->attr.is_bind_c == 1 && sym->binding_label)
+    {
+      /* We need to put variables that are bind(c) into the common
+	 segment of the object file, because this is what C would do.
+	 gfortran would typically put them in either the BSS or
+	 initialized data segments, and only mark them as common if
+	 they were part of common blocks.  However, if they are not put
+	 into common space, then C cannot initialize global Fortran
+	 variables that it interoperates with and the draft says that
+	 either Fortran or C should be able to initialize it (but not
+	 both, of course.) (J3/04-007, section 15.3).  */
+      TREE_PUBLIC(decl) = 1;
+      DECL_COMMON(decl) = 1;
+    }
+
+  /* If a variable is USE associated, it's always external.  */
+  if (sym->attr.use_assoc)
+    {
+      DECL_EXTERNAL (decl) = 1;
+      TREE_PUBLIC (decl) = 1;
+    }
+  else if (sym->module && !sym->attr.result && !sym->attr.dummy)
+    {
+      /* TODO: Don't set sym->module for result or dummy variables.  */
+      gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
+
+      if (sym->attr.access != ACCESS_PRIVATE || sym->attr.public_used)
+	TREE_PUBLIC (decl) = 1;
+      TREE_STATIC (decl) = 1;
+    }
+
+  /* Derived types are a bit peculiar because of the possibility of
+     a default initializer; this must be applied each time the variable
+     comes into scope it therefore need not be static.  These variables
+     are SAVE_NONE but have an initializer.  Otherwise explicitly
+     initialized variables are SAVE_IMPLICIT and explicitly saved are
+     SAVE_EXPLICIT.  */
+  if (!sym->attr.use_assoc
+	&& (sym->attr.save != SAVE_NONE || sym->attr.data
+	    || (sym->value && sym->ns->proc_name->attr.is_main_program)
+	    || (gfc_option.coarray == GFC_FCOARRAY_LIB
+		&& sym->attr.codimension && !sym->attr.allocatable)))
+    TREE_STATIC (decl) = 1;
+
+  if (sym->attr.volatile_)
+    {
+      TREE_THIS_VOLATILE (decl) = 1;
+      TREE_SIDE_EFFECTS (decl) = 1;
+      new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
+      TREE_TYPE (decl) = new_type;
+    }
+
+  /* Keep variables larger than max-stack-var-size off stack.  */
+  if (!sym->ns->proc_name->attr.recursive
+      && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
+      && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
+	 /* Put variable length auto array pointers always into stack.  */
+      && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
+	  || sym->attr.dimension == 0
+	  || sym->as->type != AS_EXPLICIT
+	  || sym->attr.pointer
+	  || sym->attr.allocatable)
+      && !DECL_ARTIFICIAL (decl))
+    TREE_STATIC (decl) = 1;
+
+  /* Handle threadprivate variables.  */
+  if (sym->attr.threadprivate
+      && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
+    DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
+}
+
+
+/* Allocate the lang-specific part of a decl.  */
+
+void
+gfc_allocate_lang_decl (tree decl)
+{
+  DECL_LANG_SPECIFIC (decl) = ggc_alloc_cleared_lang_decl(sizeof
+							  (struct lang_decl));
+}
+
+/* Remember a symbol to generate initialization/cleanup code at function
+   entry/exit.  */
+
+static void
+gfc_defer_symbol_init (gfc_symbol * sym)
+{
+  gfc_symbol *p;
+  gfc_symbol *last;
+  gfc_symbol *head;
+
+  /* Don't add a symbol twice.  */
+  if (sym->tlink)
+    return;
+
+  last = head = sym->ns->proc_name;
+  p = last->tlink;
+
+  /* Make sure that setup code for dummy variables which are used in the
+     setup of other variables is generated first.  */
+  if (sym->attr.dummy)
+    {
+      /* Find the first dummy arg seen after us, or the first non-dummy arg.
+         This is a circular list, so don't go past the head.  */
+      while (p != head
+             && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
+        {
+          last = p;
+          p = p->tlink;
+        }
+    }
+  /* Insert in between last and p.  */
+  last->tlink = sym;
+  sym->tlink = p;
+}
+
+
+/* Used in gfc_get_symbol_decl and gfc_get_derived_type to obtain the
+   backend_decl for a module symbol, if it all ready exists.  If the
+   module gsymbol does not exist, it is created.  If the symbol does
+   not exist, it is added to the gsymbol namespace.  Returns true if
+   an existing backend_decl is found.  */
+
+bool
+gfc_get_module_backend_decl (gfc_symbol *sym)
+{
+  gfc_gsymbol *gsym;
+  gfc_symbol *s;
+  gfc_symtree *st;
+
+  gsym =  gfc_find_gsymbol (gfc_gsym_root, sym->module);
+
+  if (!gsym || (gsym->ns && gsym->type == GSYM_MODULE))
+    {
+      st = NULL;
+      s = NULL;
+
+      if (gsym)
+	gfc_find_symbol (sym->name, gsym->ns, 0, &s);
+
+      if (!s)
+	{
+	  if (!gsym)
+	    {
+	      gsym = gfc_get_gsymbol (sym->module);
+	      gsym->type = GSYM_MODULE;
+	      gsym->ns = gfc_get_namespace (NULL, 0);
+	    }
+
+	  st = gfc_new_symtree (&gsym->ns->sym_root, sym->name);
+	  st->n.sym = sym;
+	  sym->refs++;
+	}
+      else if (sym->attr.flavor == FL_DERIVED)
+	{
+	  if (s && s->attr.flavor == FL_PROCEDURE)
+	    {
+	      gfc_interface *intr;
+	      gcc_assert (s->attr.generic);
+	      for (intr = s->generic; intr; intr = intr->next)
+		if (intr->sym->attr.flavor == FL_DERIVED)
+		  {
+		    s = intr->sym;
+		    break;
+		  }
+    	    }
+
+	  if (!s->backend_decl)
+	    s->backend_decl = gfc_get_derived_type (s);
+	  gfc_copy_dt_decls_ifequal (s, sym, true);
+	  return true;
+	}
+      else if (s->backend_decl)
+	{
+	  if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
+	    gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived,
+				       true);
+	  else if (sym->ts.type == BT_CHARACTER)
+	    sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
+	  sym->backend_decl = s->backend_decl;
+	  return true;
+	}
+    }
+  return false;
+}
+
+
+/* Create an array index type variable with function scope.  */
+
+static tree
+create_index_var (const char * pfx, int nest)
+{
+  tree decl;
+
+  decl = gfc_create_var_np (gfc_array_index_type, pfx);
+  if (nest)
+    gfc_add_decl_to_parent_function (decl);
+  else
+    gfc_add_decl_to_function (decl);
+  return decl;
+}
+
+
+/* Create variables to hold all the non-constant bits of info for a
+   descriptorless array.  Remember these in the lang-specific part of the
+   type.  */
+
+static void
+gfc_build_qualified_array (tree decl, gfc_symbol * sym)
+{
+  tree type;
+  int dim;
+  int nest;
+  gfc_namespace* procns;
+
+  type = TREE_TYPE (decl);
+
+  /* We just use the descriptor, if there is one.  */
+  if (GFC_DESCRIPTOR_TYPE_P (type))
+    return;
+
+  gcc_assert (GFC_ARRAY_TYPE_P (type));
+  procns = gfc_find_proc_namespace (sym->ns);
+  nest = (procns->proc_name->backend_decl != current_function_decl)
+	 && !sym->attr.contained;
+
+  if (sym->attr.codimension && gfc_option.coarray == GFC_FCOARRAY_LIB
+      && sym->as->type != AS_ASSUMED_SHAPE
+      && GFC_TYPE_ARRAY_CAF_TOKEN (type) == NULL_TREE)
+    {
+      tree token;
+
+      token = gfc_create_var_np (build_qualified_type (pvoid_type_node,
+						       TYPE_QUAL_RESTRICT),
+				 "caf_token");
+      GFC_TYPE_ARRAY_CAF_TOKEN (type) = token;
+      DECL_ARTIFICIAL (token) = 1;
+      TREE_STATIC (token) = 1;
+      gfc_add_decl_to_function (token);
+    }
+
+  for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
+    {
+      if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
+	{
+	  GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
+	  TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
+	}
+      /* 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))
+	{
+	  GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
+	  TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
+	}
+
+      if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
+	{
+	  GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
+	  TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;
+	}
+    }
+  for (dim = GFC_TYPE_ARRAY_RANK (type);
+       dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type); dim++)
+    {
+      if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
+	{
+	  GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
+	  TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
+	}
+      /* Don't try to use the unknown ubound for the last coarray dimension.  */
+      if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
+          && dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type) - 1)
+	{
+	  GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
+	  TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
+	}
+    }
+  if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
+    {
+      GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
+							"offset");
+      TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type)) = 1;
+
+      if (nest)
+	gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
+      else
+	gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
+    }
+
+  if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
+      && sym->as->type != AS_ASSUMED_SIZE)
+    {
+      GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
+      TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1;
+    }
+
+  if (POINTER_TYPE_P (type))
+    {
+      gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
+      gcc_assert (TYPE_LANG_SPECIFIC (type)
+		  == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
+      type = TREE_TYPE (type);
+    }
+
+  if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
+    {
+      tree size, range;
+
+      size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			      GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
+      range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
+				size);
+      TYPE_DOMAIN (type) = range;
+      layout_type (type);
+    }
+
+  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)
+    {
+      tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));
+
+      for (dim = 0; dim < sym->as->rank - 1; dim++)
+	{
+	  gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
+	  gtype = TREE_TYPE (gtype);
+	}
+      gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
+      if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype)) == NULL)
+	TYPE_NAME (type) = NULL_TREE;
+    }
+
+  if (TYPE_NAME (type) == NULL_TREE)
+    {
+      tree gtype = TREE_TYPE (type), rtype, type_decl;
+
+      for (dim = sym->as->rank - 1; dim >= 0; dim--)
+	{
+	  tree lbound, ubound;
+	  lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
+	  ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
+	  rtype = build_range_type (gfc_array_index_type, lbound, ubound);
+	  gtype = build_array_type (gtype, rtype);
+	  /* Ensure the bound variables aren't optimized out at -O0.
+	     For -O1 and above they often will be optimized out, but
+	     can be tracked by VTA.  Also set DECL_NAMELESS, so that
+	     the artificial lbound.N or ubound.N DECL_NAME doesn't
+	     end up in debug info.  */
+	  if (lbound && TREE_CODE (lbound) == VAR_DECL
+	      && DECL_ARTIFICIAL (lbound) && DECL_IGNORED_P (lbound))
+	    {
+	      if (DECL_NAME (lbound)
+		  && strstr (IDENTIFIER_POINTER (DECL_NAME (lbound)),
+			     "lbound") != 0)
+		DECL_NAMELESS (lbound) = 1;
+	      DECL_IGNORED_P (lbound) = 0;
+	    }
+	  if (ubound && TREE_CODE (ubound) == VAR_DECL
+	      && DECL_ARTIFICIAL (ubound) && DECL_IGNORED_P (ubound))
+	    {
+	      if (DECL_NAME (ubound)
+		  && strstr (IDENTIFIER_POINTER (DECL_NAME (ubound)),
+			     "ubound") != 0)
+		DECL_NAMELESS (ubound) = 1;
+	      DECL_IGNORED_P (ubound) = 0;
+	    }
+	}
+      TYPE_NAME (type) = type_decl = build_decl (input_location,
+						 TYPE_DECL, NULL, gtype);
+      DECL_ORIGINAL_TYPE (type_decl) = gtype;
+    }
+}
+
+
+/* For some dummy arguments we don't use the actual argument directly.
+   Instead we create a local decl and use that.  This allows us to perform
+   initialization, and construct full type information.  */
+
+static tree
+gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
+{
+  tree decl;
+  tree type;
+  gfc_array_spec *as;
+  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))
+    return dummy;
+
+  /* Add to list of variables if not a fake result variable.  */
+  if (sym->attr.result || sym->attr.dummy)
+    gfc_defer_symbol_init (sym);
+
+  type = TREE_TYPE (dummy);
+  gcc_assert (TREE_CODE (dummy) == PARM_DECL
+	  && POINTER_TYPE_P (type));
+
+  /* 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)))
+    {
+      /* 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
+	 are not repacked.  */
+      if (!gfc_option.flag_repack_arrays || sym->attr.target)
+	{
+	  if (as->type == AS_ASSUMED_SIZE)
+	    packed = PACKED_FULL;
+	}
+      else
+	{
+	  if (as->type == AS_EXPLICIT)
+	    {
+	      packed = PACKED_FULL;
+	      for (n = 0; n < as->rank; n++)
+		{
+		  if (!(as->upper[n]
+			&& as->lower[n]
+			&& as->upper[n]->expr_type == EXPR_CONSTANT
+			&& as->lower[n]->expr_type == EXPR_CONSTANT))
+		    {
+		      packed = PACKED_PARTIAL;
+		      break;
+		    }
+		}
+	    }
+	  else
+	    packed = PACKED_PARTIAL;
+	}
+
+      type = gfc_typenode_for_spec (&sym->ts);
+      type = gfc_get_nodesc_array_type (type, sym->as, packed,
+					!sym->attr.target);
+    }
+  else
+    {
+      /* We now have an expression for the element size, so create a fully
+	 qualified type.  Reset sym->backend decl or this will just return the
+	 old type.  */
+      DECL_ARTIFICIAL (sym->backend_decl) = 1;
+      sym->backend_decl = NULL_TREE;
+      type = gfc_sym_type (sym);
+      packed = PACKED_FULL;
+    }
+
+  ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
+  decl = build_decl (input_location,
+		     VAR_DECL, get_identifier (name), type);
+
+  DECL_ARTIFICIAL (decl) = 1;
+  DECL_NAMELESS (decl) = 1;
+  TREE_PUBLIC (decl) = 0;
+  TREE_STATIC (decl) = 0;
+  DECL_EXTERNAL (decl) = 0;
+
+  /* Avoid uninitialized warnings for optional dummy arguments.  */
+  if (sym->attr.optional)
+    TREE_NO_WARNING (decl) = 1;
+
+  /* We should never get deferred shape arrays here.  We used to because of
+     frontend bugs.  */
+  gcc_assert (sym->as->type != AS_DEFERRED);
+
+  if (packed == PACKED_PARTIAL)
+    GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
+  else if (packed == PACKED_FULL)
+    GFC_DECL_PACKED_ARRAY (decl) = 1;
+
+  gfc_build_qualified_array (decl, sym);
+
+  if (DECL_LANG_SPECIFIC (dummy))
+    DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
+  else
+    gfc_allocate_lang_decl (decl);
+
+  GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
+
+  if (sym->ns->proc_name->backend_decl == current_function_decl
+      || sym->attr.contained)
+    gfc_add_decl_to_function (decl);
+  else
+    gfc_add_decl_to_parent_function (decl);
+
+  return decl;
+}
+
+/* For symbol SYM with GFC_DECL_SAVED_DESCRIPTOR used in contained
+   function add a VAR_DECL to the current function with DECL_VALUE_EXPR
+   pointing to the artificial variable for debug info purposes.  */
+
+static void
+gfc_nonlocal_dummy_array_decl (gfc_symbol *sym)
+{
+  tree decl, dummy;
+
+  if (! nonlocal_dummy_decl_pset)
+    nonlocal_dummy_decl_pset = pointer_set_create ();
+
+  if (pointer_set_insert (nonlocal_dummy_decl_pset, sym->backend_decl))
+    return;
+
+  dummy = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
+  decl = build_decl (input_location, VAR_DECL, DECL_NAME (dummy),
+		     TREE_TYPE (sym->backend_decl));
+  DECL_ARTIFICIAL (decl) = 0;
+  TREE_USED (decl) = 1;
+  TREE_PUBLIC (decl) = 0;
+  TREE_STATIC (decl) = 0;
+  DECL_EXTERNAL (decl) = 0;
+  if (DECL_BY_REFERENCE (dummy))
+    DECL_BY_REFERENCE (decl) = 1;
+  DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl);
+  SET_DECL_VALUE_EXPR (decl, sym->backend_decl);
+  DECL_HAS_VALUE_EXPR_P (decl) = 1;
+  DECL_CONTEXT (decl) = DECL_CONTEXT (sym->backend_decl);
+  DECL_CHAIN (decl) = nonlocal_dummy_decls;
+  nonlocal_dummy_decls = decl;
+}
+
+/* Return a constant or a variable to use as a string length.  Does not
+   add the decl to the current scope.  */
+
+static tree
+gfc_create_string_length (gfc_symbol * sym)
+{
+  gcc_assert (sym->ts.u.cl);
+  gfc_conv_const_charlen (sym->ts.u.cl);
+
+  if (sym->ts.u.cl->backend_decl == NULL_TREE)
+    {
+      tree length;
+      const char *name;
+
+      /* The string length variable shall be in static memory if it is either
+	 explicitly SAVED, a module variable or with -fno-automatic. Only
+	 relevant is "len=:" - otherwise, it is either a constant length or
+	 it is an automatic variable.  */
+      bool static_length = sym->attr.save
+			   || sym->ns->proc_name->attr.flavor == FL_MODULE
+			   || (gfc_option.flag_max_stack_var_size == 0
+			       && sym->ts.deferred && !sym->attr.dummy
+			       && !sym->attr.result && !sym->attr.function);
+
+      /* Also prefix the mangled name. We need to call GFC_PREFIX for static
+	 variables as some systems do not support the "." in the assembler name.
+	 For nonstatic variables, the "." does not appear in assembler.  */
+      if (static_length)
+	{
+	  if (sym->module)
+	    name = gfc_get_string (GFC_PREFIX ("%s_MOD_%s"), sym->module,
+				   sym->name);
+	  else
+	    name = gfc_get_string (GFC_PREFIX ("%s"), sym->name);
+	}
+      else if (sym->module)
+	name = gfc_get_string (".__%s_MOD_%s", sym->module, sym->name);
+      else
+	name = gfc_get_string (".%s", sym->name);
+
+      length = build_decl (input_location,
+			   VAR_DECL, get_identifier (name),
+			   gfc_charlen_type_node);
+      DECL_ARTIFICIAL (length) = 1;
+      TREE_USED (length) = 1;
+      if (sym->ns->proc_name->tlink != NULL)
+	gfc_defer_symbol_init (sym);
+
+      sym->ts.u.cl->backend_decl = length;
+
+      if (static_length)
+	TREE_STATIC (length) = 1;
+
+      if (sym->ns->proc_name->attr.flavor == FL_MODULE
+	  && (sym->attr.access != ACCESS_PRIVATE || sym->attr.public_used))
+	TREE_PUBLIC (length) = 1;
+    }
+
+  gcc_assert (sym->ts.u.cl->backend_decl != NULL_TREE);
+  return sym->ts.u.cl->backend_decl;
+}
+
+/* If a variable is assigned a label, we add another two auxiliary
+   variables.  */
+
+static void
+gfc_add_assign_aux_vars (gfc_symbol * sym)
+{
+  tree addr;
+  tree length;
+  tree decl;
+
+  gcc_assert (sym->backend_decl);
+
+  decl = sym->backend_decl;
+  gfc_allocate_lang_decl (decl);
+  GFC_DECL_ASSIGN (decl) = 1;
+  length = build_decl (input_location,
+		       VAR_DECL, create_tmp_var_name (sym->name),
+		       gfc_charlen_type_node);
+  addr = build_decl (input_location,
+		     VAR_DECL, create_tmp_var_name (sym->name),
+		     pvoid_type_node);
+  gfc_finish_var_decl (length, sym);
+  gfc_finish_var_decl (addr, sym);
+  /*  STRING_LENGTH is also used as flag. Less than -1 means that
+      ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
+      target label's address. Otherwise, value is the length of a format string
+      and ASSIGN_ADDR is its address.  */
+  if (TREE_STATIC (length))
+    DECL_INITIAL (length) = build_int_cst (gfc_charlen_type_node, -2);
+  else
+    gfc_defer_symbol_init (sym);
+
+  GFC_DECL_STRING_LEN (decl) = length;
+  GFC_DECL_ASSIGN_ADDR (decl) = addr;
+}
+
+
+static tree
+add_attributes_to_decl (symbol_attribute sym_attr, tree list)
+{
+  unsigned id;
+  tree attr;
+
+  for (id = 0; id < EXT_ATTR_NUM; id++)
+    if (sym_attr.ext_attr & (1 << id))
+      {
+	attr = build_tree_list (
+		 get_identifier (ext_attr_list[id].middle_end_name),
+				 NULL_TREE);
+	list = chainon (list, attr);
+      }
+
+  return list;
+}
+
+
+static void build_function_decl (gfc_symbol * sym, bool global);
+
+
+/* Return the decl for a gfc_symbol, create it if it doesn't already
+   exist.  */
+
+tree
+gfc_get_symbol_decl (gfc_symbol * sym)
+{
+  tree decl;
+  tree length = NULL_TREE;
+  tree attributes;
+  int byref;
+  bool intrinsic_array_parameter = false;
+  bool fun_or_res;
+
+  gcc_assert (sym->attr.referenced
+	      || sym->attr.flavor == FL_PROCEDURE
+	      || sym->attr.use_assoc
+	      || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY
+	      || (sym->module && sym->attr.if_source != IFSRC_DECL
+		  && sym->backend_decl));
+
+  if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)
+    byref = gfc_return_by_reference (sym->ns->proc_name);
+  else
+    byref = 0;
+
+  /* Make sure that the vtab for the declared type is completed.  */
+  if (sym->ts.type == BT_CLASS)
+    {
+      gfc_component *c = CLASS_DATA (sym);
+      if (!c->ts.u.derived->backend_decl)
+	{
+	  gfc_find_derived_vtab (c->ts.u.derived);
+	  gfc_get_derived_type (sym->ts.u.derived);
+	}
+    }
+
+  /* All deferred character length procedures need to retain the backend
+     decl, which is a pointer to the character length in the caller's
+     namespace and to declare a local character length.  */
+  if (!byref && sym->attr.function
+	&& sym->ts.type == BT_CHARACTER
+	&& sym->ts.deferred
+	&& sym->ts.u.cl->passed_length == NULL
+	&& sym->ts.u.cl->backend_decl
+	&& TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL)
+    {
+      sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
+      sym->ts.u.cl->backend_decl = NULL_TREE;
+      length = gfc_create_string_length (sym);
+    }
+
+  fun_or_res = byref && (sym->attr.result
+			 || (sym->attr.function && sym->ts.deferred));
+  if ((sym->attr.dummy && ! sym->attr.function) || fun_or_res)
+    {
+      /* Return via extra parameter.  */
+      if (sym->attr.result && byref
+	  && !sym->backend_decl)
+	{
+	  sym->backend_decl =
+	    DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
+	  /* For entry master function skip over the __entry
+	     argument.  */
+	  if (sym->ns->proc_name->attr.entry_master)
+	    sym->backend_decl = DECL_CHAIN (sym->backend_decl);
+	}
+
+      /* Dummy variables should already have been created.  */
+      gcc_assert (sym->backend_decl);
+
+      /* Create a character length variable.  */
+      if (sym->ts.type == BT_CHARACTER)
+	{
+	  /* For a deferred dummy, make a new string length variable.  */
+	  if (sym->ts.deferred
+		&&
+	     (sym->ts.u.cl->passed_length == sym->ts.u.cl->backend_decl))
+	    sym->ts.u.cl->backend_decl = NULL_TREE;
+
+	  if (sym->ts.deferred && fun_or_res
+		&& sym->ts.u.cl->passed_length == NULL
+		&& sym->ts.u.cl->backend_decl)
+	    {
+	      sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
+	      sym->ts.u.cl->backend_decl = NULL_TREE;
+	    }
+
+	  if (sym->ts.u.cl->backend_decl == NULL_TREE)
+	    length = gfc_create_string_length (sym);
+	  else
+	    length = sym->ts.u.cl->backend_decl;
+	  if (TREE_CODE (length) == VAR_DECL
+	      && DECL_FILE_SCOPE_P (length))
+	    {
+	      /* Add the string length to the same context as the symbol.  */
+	      if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
+	        gfc_add_decl_to_function (length);
+	      else
+		gfc_add_decl_to_parent_function (length);
+
+	      gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
+			    DECL_CONTEXT (length));
+
+	      gfc_defer_symbol_init (sym);
+	    }
+	}
+
+      /* Use a copy of the descriptor for dummy arrays.  */
+      if ((sym->attr.dimension || sym->attr.codimension)
+         && !TREE_USED (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
+	  && DECL_LANG_SPECIFIC (sym->backend_decl)
+	  && GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)
+	  && DECL_CONTEXT (sym->backend_decl) != current_function_decl)
+	gfc_nonlocal_dummy_array_decl (sym);
+
+      if (sym->ts.type == BT_CLASS && sym->backend_decl)
+	GFC_DECL_CLASS(sym->backend_decl) = 1;
+
+      if (sym->ts.type == BT_CLASS && sym->backend_decl)
+	GFC_DECL_CLASS(sym->backend_decl) = 1;
+     return sym->backend_decl;
+    }
+
+  if (sym->backend_decl)
+    return sym->backend_decl;
+
+  /* Special case for array-valued named constants from intrinsic
+     procedures; those are inlined.  */
+  if (sym->attr.use_assoc && sym->from_intmod
+      && sym->attr.flavor == FL_PARAMETER)
+    intrinsic_array_parameter = true;
+
+  /* If use associated compilation, use the module
+     declaration.  */
+  if ((sym->attr.flavor == FL_VARIABLE
+       || sym->attr.flavor == FL_PARAMETER)
+      && sym->attr.use_assoc
+      && !intrinsic_array_parameter
+      && sym->module
+      && gfc_get_module_backend_decl (sym))
+    {
+      if (sym->ts.type == BT_CLASS && sym->backend_decl)
+	GFC_DECL_CLASS(sym->backend_decl) = 1;
+      return sym->backend_decl;
+    }
+
+  if (sym->attr.flavor == FL_PROCEDURE)
+    {
+      /* Catch functions. Only used for actual parameters,
+	 procedure pointers and procptr initialization targets.  */
+      if (sym->attr.use_assoc || sym->attr.intrinsic
+	  || sym->attr.if_source != IFSRC_DECL)
+	{
+	  decl = gfc_get_extern_function_decl (sym);
+	  gfc_set_decl_location (decl, &sym->declared_at);
+	}
+      else
+	{
+	  if (!sym->backend_decl)
+	    build_function_decl (sym, false);
+	  decl = sym->backend_decl;
+	}
+      return decl;
+    }
+
+  if (sym->attr.intrinsic)
+    internal_error ("intrinsic variable which isn't a procedure");
+
+  /* Create string length decl first so that they can be used in the
+     type declaration.  */
+  if (sym->ts.type == BT_CHARACTER)
+    length = gfc_create_string_length (sym);
+
+  /* Create the decl for the variable.  */
+  decl = build_decl (sym->declared_at.lb->location,
+		     VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
+
+  /* Add attributes to variables.  Functions are handled elsewhere.  */
+  attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
+  decl_attributes (&decl, attributes, 0);
+
+  /* Symbols from modules should have their assembler names mangled.
+     This is done here rather than in gfc_finish_var_decl because it
+     is different for string length variables.  */
+  if (sym->module)
+    {
+      gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
+      if (sym->attr.use_assoc && !intrinsic_array_parameter)
+	DECL_IGNORED_P (decl) = 1;
+    }
+
+  if (sym->attr.select_type_temporary)
+    {
+      DECL_ARTIFICIAL (decl) = 1;
+      DECL_IGNORED_P (decl) = 1;
+    }
+
+  if (sym->attr.dimension || sym->attr.codimension)
+    {
+      /* Create variables to hold the non-constant bits of array info.  */
+      gfc_build_qualified_array (decl, sym);
+
+      if (sym->attr.contiguous
+	  || ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer))
+	GFC_DECL_PACKED_ARRAY (decl) = 1;
+    }
+
+  /* Remember this variable for allocation/cleanup.  */
+  if (sym->attr.dimension || sym->attr.allocatable || sym->attr.codimension
+      || (sym->ts.type == BT_CLASS &&
+	  (CLASS_DATA (sym)->attr.dimension
+	   || CLASS_DATA (sym)->attr.allocatable))
+      || (sym->ts.type == BT_DERIVED
+	  && (sym->ts.u.derived->attr.alloc_comp
+	      || (!sym->attr.pointer && !sym->attr.artificial && !sym->attr.save
+		  && !sym->ns->proc_name->attr.is_main_program
+		  && gfc_is_finalizable (sym->ts.u.derived, NULL))))
+      /* This applies a derived type default initializer.  */
+      || (sym->ts.type == BT_DERIVED
+	  && sym->attr.save == SAVE_NONE
+	  && !sym->attr.data
+	  && !sym->attr.allocatable
+	  && (sym->value && !sym->ns->proc_name->attr.is_main_program)
+	  && !(sym->attr.use_assoc && !intrinsic_array_parameter)))
+    gfc_defer_symbol_init (sym);
+
+  gfc_finish_var_decl (decl, sym);
+
+  if (sym->ts.type == BT_CHARACTER)
+    {
+      /* Character variables need special handling.  */
+      gfc_allocate_lang_decl (decl);
+
+      if (TREE_CODE (length) != INTEGER_CST)
+	{
+	  gfc_finish_var_decl (length, sym);
+	  gcc_assert (!sym->value);
+	}
+    }
+  else if (sym->attr.subref_array_pointer)
+    {
+      /* We need the span for these beasts.  */
+      gfc_allocate_lang_decl (decl);
+    }
+
+  if (sym->attr.subref_array_pointer)
+    {
+      tree span;
+      GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
+      span = build_decl (input_location,
+			 VAR_DECL, create_tmp_var_name ("span"),
+			 gfc_array_index_type);
+      gfc_finish_var_decl (span, sym);
+      TREE_STATIC (span) = TREE_STATIC (decl);
+      DECL_ARTIFICIAL (span) = 1;
+
+      GFC_DECL_SPAN (decl) = span;
+      GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
+    }
+
+  if (sym->ts.type == BT_CLASS)
+	GFC_DECL_CLASS(decl) = 1;
+
+  sym->backend_decl = decl;
+
+  if (sym->attr.assign)
+    gfc_add_assign_aux_vars (sym);
+
+  if (intrinsic_array_parameter)
+    {
+      TREE_STATIC (decl) = 1;
+      DECL_EXTERNAL (decl) = 0;
+    }
+
+  if (TREE_STATIC (decl)
+      && !(sym->attr.use_assoc && !intrinsic_array_parameter)
+      && (sym->attr.save || sym->ns->proc_name->attr.is_main_program
+	  || gfc_option.flag_max_stack_var_size == 0
+	  || sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE)
+      && (gfc_option.coarray != GFC_FCOARRAY_LIB
+	  || !sym->attr.codimension || sym->attr.allocatable))
+    {
+      /* Add static initializer. For procedures, it is only needed if
+	 SAVE is specified otherwise they need to be reinitialized
+	 every time the procedure is entered. The TREE_STATIC is
+	 in this case due to -fmax-stack-var-size=.  */
+
+      DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
+				    TREE_TYPE (decl), sym->attr.dimension
+				    || (sym->attr.codimension
+					&& sym->attr.allocatable),
+				    sym->attr.pointer || sym->attr.allocatable
+				    || sym->ts.type == BT_CLASS,
+				    sym->attr.proc_pointer);
+    }
+
+  if (!TREE_STATIC (decl)
+      && POINTER_TYPE_P (TREE_TYPE (decl))
+      && !sym->attr.pointer
+      && !sym->attr.allocatable
+      && !sym->attr.proc_pointer
+      && !sym->attr.select_type_temporary)
+    DECL_BY_REFERENCE (decl) = 1;
+
+  if (sym->attr.vtab
+      || (sym->name[0] == '_' && strncmp ("__def_init", sym->name, 10) == 0))
+    TREE_READONLY (decl) = 1;
+
+  return decl;
+}
+
+
+/* Substitute a temporary variable in place of the real one.  */
+
+void
+gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
+{
+  save->attr = sym->attr;
+  save->decl = sym->backend_decl;
+
+  gfc_clear_attr (&sym->attr);
+  sym->attr.referenced = 1;
+  sym->attr.flavor = FL_VARIABLE;
+
+  sym->backend_decl = decl;
+}
+
+
+/* Restore the original variable.  */
+
+void
+gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
+{
+  sym->attr = save->attr;
+  sym->backend_decl = save->decl;
+}
+
+
+/* Declare a procedure pointer.  */
+
+static tree
+get_proc_pointer_decl (gfc_symbol *sym)
+{
+  tree decl;
+  tree attributes;
+
+  decl = sym->backend_decl;
+  if (decl)
+    return decl;
+
+  decl = build_decl (input_location,
+		     VAR_DECL, get_identifier (sym->name),
+		     build_pointer_type (gfc_get_function_type (sym)));
+
+  if (sym->module)
+    {
+      /* Apply name mangling.  */
+      gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
+      if (sym->attr.use_assoc)
+	DECL_IGNORED_P (decl) = 1;
+    }
+
+  if ((sym->ns->proc_name
+      && sym->ns->proc_name->backend_decl == current_function_decl)
+      || sym->attr.contained)
+    gfc_add_decl_to_function (decl);
+  else if (sym->ns->proc_name->attr.flavor != FL_MODULE)
+    gfc_add_decl_to_parent_function (decl);
+
+  sym->backend_decl = decl;
+
+  /* If a variable is USE associated, it's always external.  */
+  if (sym->attr.use_assoc)
+    {
+      DECL_EXTERNAL (decl) = 1;
+      TREE_PUBLIC (decl) = 1;
+    }
+  else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)
+    {
+      /* This is the declaration of a module variable.  */
+      TREE_PUBLIC (decl) = 1;
+      TREE_STATIC (decl) = 1;
+    }
+
+  if (!sym->attr.use_assoc
+	&& (sym->attr.save != SAVE_NONE || sym->attr.data
+	      || (sym->value && sym->ns->proc_name->attr.is_main_program)))
+    TREE_STATIC (decl) = 1;
+
+  if (TREE_STATIC (decl) && sym->value)
+    {
+      /* Add static initializer.  */
+      DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
+						  TREE_TYPE (decl),
+						  sym->attr.dimension,
+						  false, true);
+    }
+
+  /* Handle threadprivate procedure pointers.  */
+  if (sym->attr.threadprivate
+      && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
+    DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
+
+  attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
+  decl_attributes (&decl, attributes, 0);
+
+  return decl;
+}
+
+
+/* Get a basic decl for an external function.  */
+
+tree
+gfc_get_extern_function_decl (gfc_symbol * sym)
+{
+  tree type;
+  tree fndecl;
+  tree attributes;
+  gfc_expr e;
+  gfc_intrinsic_sym *isym;
+  gfc_expr argexpr;
+  char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'.  */
+  tree name;
+  tree mangled_name;
+  gfc_gsymbol *gsym;
+
+  if (sym->backend_decl)
+    return sym->backend_decl;
+
+  /* We should never be creating external decls for alternate entry points.
+     The procedure may be an alternate entry point, but we don't want/need
+     to know that.  */
+  gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
+
+  if (sym->attr.proc_pointer)
+    return get_proc_pointer_decl (sym);
+
+  /* See if this is an external procedure from the same file.  If so,
+     return the backend_decl.  */
+  gsym =  gfc_find_gsymbol (gfc_gsym_root, sym->binding_label
+					   ? sym->binding_label : sym->name);
+
+  if (gsym && !gsym->defined)
+    gsym = NULL;
+
+  /* This can happen because of C binding.  */
+  if (gsym && gsym->ns && gsym->ns->proc_name
+      && gsym->ns->proc_name->attr.flavor == FL_MODULE)
+    goto module_sym;
+
+  if ((!sym->attr.use_assoc || sym->attr.if_source != IFSRC_DECL)
+      && !sym->backend_decl
+      && gsym && gsym->ns
+      && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
+      && (gsym->ns->proc_name->backend_decl || !sym->attr.intrinsic))
+    {
+      if (!gsym->ns->proc_name->backend_decl)
+	{
+	  /* By construction, the external function cannot be
+	     a contained procedure.  */
+	  locus old_loc;
+
+	  gfc_save_backend_locus (&old_loc);
+	  push_cfun (NULL);
+
+	  gfc_create_function_decl (gsym->ns, true);
+
+	  pop_cfun ();
+	  gfc_restore_backend_locus (&old_loc);
+	}
+
+      /* If the namespace has entries, the proc_name is the
+	 entry master.  Find the entry and use its backend_decl.
+	 otherwise, use the proc_name backend_decl.  */
+      if (gsym->ns->entries)
+	{
+	  gfc_entry_list *entry = gsym->ns->entries;
+
+	  for (; entry; entry = entry->next)
+	    {
+	      if (strcmp (gsym->name, entry->sym->name) == 0)
+		{
+	          sym->backend_decl = entry->sym->backend_decl;
+		  break;
+		}
+	    }
+	}
+      else
+	sym->backend_decl = gsym->ns->proc_name->backend_decl;
+
+      if (sym->backend_decl)
+	{
+	  /* Avoid problems of double deallocation of the backend declaration
+	     later in gfc_trans_use_stmts; cf. PR 45087.  */
+	  if (sym->attr.if_source != IFSRC_DECL && sym->attr.use_assoc)
+	    sym->attr.use_assoc = 0;
+
+	  return sym->backend_decl;
+	}
+    }
+
+  /* See if this is a module procedure from the same file.  If so,
+     return the backend_decl.  */
+  if (sym->module)
+    gsym =  gfc_find_gsymbol (gfc_gsym_root, sym->module);
+
+module_sym:
+  if (gsym && gsym->ns
+      && (gsym->type == GSYM_MODULE
+	  || (gsym->ns->proc_name && gsym->ns->proc_name->attr.flavor == FL_MODULE)))
+    {
+      gfc_symbol *s;
+
+      s = NULL;
+      if (gsym->type == GSYM_MODULE)
+	gfc_find_symbol (sym->name, gsym->ns, 0, &s);
+      else
+	gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &s);
+
+      if (s && s->backend_decl)
+	{
+	  if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
+	    gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived,
+				       true);
+	  else if (sym->ts.type == BT_CHARACTER)
+	    sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
+	  sym->backend_decl = s->backend_decl;
+	  return sym->backend_decl;
+	}
+    }
+
+  if (sym->attr.intrinsic)
+    {
+      /* Call the resolution function to get the actual name.  This is
+         a nasty hack which relies on the resolution functions only looking
+	 at the first argument.  We pass NULL for the second argument
+	 otherwise things like AINT get confused.  */
+      isym = gfc_find_function (sym->name);
+      gcc_assert (isym->resolve.f0 != NULL);
+
+      memset (&e, 0, sizeof (e));
+      e.expr_type = EXPR_FUNCTION;
+
+      memset (&argexpr, 0, sizeof (argexpr));
+      gcc_assert (isym->formal);
+      argexpr.ts = isym->formal->ts;
+
+      if (isym->formal->next == NULL)
+	isym->resolve.f1 (&e, &argexpr);
+      else
+	{
+	  if (isym->formal->next->next == NULL)
+	    isym->resolve.f2 (&e, &argexpr, NULL);
+	  else
+	    {
+	      if (isym->formal->next->next->next == NULL)
+		isym->resolve.f3 (&e, &argexpr, NULL, NULL);
+	      else
+		{
+		  /* All specific intrinsics take less than 5 arguments.  */
+		  gcc_assert (isym->formal->next->next->next->next == NULL);
+		  isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
+		}
+	    }
+	}
+
+      if (gfc_option.flag_f2c
+	  && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
+	      || e.ts.type == BT_COMPLEX))
+	{
+	  /* Specific which needs a different implementation if f2c
+	     calling conventions are used.  */
+	  sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
+	}
+      else
+	sprintf (s, "_gfortran_specific%s", e.value.function.name);
+
+      name = get_identifier (s);
+      mangled_name = name;
+    }
+  else
+    {
+      name = gfc_sym_identifier (sym);
+      mangled_name = gfc_sym_mangled_function_id (sym);
+    }
+
+  type = gfc_get_function_type (sym);
+  fndecl = build_decl (input_location,
+		       FUNCTION_DECL, name, type);
+
+  /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
+     TREE_PUBLIC specifies whether a function is globally addressable (i.e.
+     the opposite of declaring a function as static in C).  */
+  DECL_EXTERNAL (fndecl) = 1;
+  TREE_PUBLIC (fndecl) = 1;
+
+  attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
+  decl_attributes (&fndecl, attributes, 0);
+
+  gfc_set_decl_assembler_name (fndecl, mangled_name);
+
+  /* Set the context of this decl.  */
+  if (0 && sym->ns && sym->ns->proc_name)
+    {
+      /* TODO: Add external decls to the appropriate scope.  */
+      DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
+    }
+  else
+    {
+      /* Global declaration, e.g. intrinsic subroutine.  */
+      DECL_CONTEXT (fndecl) = NULL_TREE;
+    }
+
+  /* Set attributes for PURE functions. A call to PURE function in the
+     Fortran 95 sense is both pure and without side effects in the C
+     sense.  */
+  if (sym->attr.pure || sym->attr.implicit_pure)
+    {
+      if (sym->attr.function && !gfc_return_by_reference (sym))
+	DECL_PURE_P (fndecl) = 1;
+      /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
+	 parameters and don't use alternate returns (is this
+	 allowed?). In that case, calls to them are meaningless, and
+	 can be optimized away. See also in build_function_decl().  */
+      TREE_SIDE_EFFECTS (fndecl) = 0;
+    }
+
+  /* Mark non-returning functions.  */
+  if (sym->attr.noreturn)
+      TREE_THIS_VOLATILE(fndecl) = 1;
+
+  sym->backend_decl = fndecl;
+
+  if (DECL_CONTEXT (fndecl) == NULL_TREE)
+    pushdecl_top_level (fndecl);
+
+  return fndecl;
+}
+
+
+/* Create a declaration for a procedure.  For external functions (in the C
+   sense) use gfc_get_extern_function_decl.  HAS_ENTRIES is true if this is
+   a master function with alternate entry points.  */
+
+static void
+build_function_decl (gfc_symbol * sym, bool global)
+{
+  tree fndecl, type, attributes;
+  symbol_attribute attr;
+  tree result_decl;
+  gfc_formal_arglist *f;
+
+  gcc_assert (!sym->attr.external);
+
+  if (sym->backend_decl)
+    return;
+
+  /* Set the line and filename.  sym->declared_at seems to point to the
+     last statement for subroutines, but it'll do for now.  */
+  gfc_set_backend_locus (&sym->declared_at);
+
+  /* Allow only one nesting level.  Allow public declarations.  */
+  gcc_assert (current_function_decl == NULL_TREE
+	      || DECL_FILE_SCOPE_P (current_function_decl)
+	      || (TREE_CODE (DECL_CONTEXT (current_function_decl))
+		  == NAMESPACE_DECL));
+
+  type = gfc_get_function_type (sym);
+  fndecl = build_decl (input_location,
+		       FUNCTION_DECL, gfc_sym_identifier (sym), type);
+
+  attr = sym->attr;
+
+  /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
+     TREE_PUBLIC specifies whether a function is globally addressable (i.e.
+     the opposite of declaring a function as static in C).  */
+  DECL_EXTERNAL (fndecl) = 0;
+
+  if (sym->attr.access == ACCESS_UNKNOWN && sym->module
+      && (sym->ns->default_access == ACCESS_PRIVATE
+	  || (sym->ns->default_access == ACCESS_UNKNOWN
+	      && gfc_option.flag_module_private)))
+    sym->attr.access = ACCESS_PRIVATE;
+
+  if (!current_function_decl
+      && !sym->attr.entry_master && !sym->attr.is_main_program
+      && (sym->attr.access != ACCESS_PRIVATE || sym->binding_label
+	  || sym->attr.public_used))
+    TREE_PUBLIC (fndecl) = 1;
+
+  if (sym->attr.referenced || sym->attr.entry_master)
+    TREE_USED (fndecl) = 1;
+
+  attributes = add_attributes_to_decl (attr, NULL_TREE);
+  decl_attributes (&fndecl, attributes, 0);
+
+  /* Figure out the return type of the declared function, and build a
+     RESULT_DECL for it.  If this is a subroutine with alternate
+     returns, build a RESULT_DECL for it.  */
+  result_decl = NULL_TREE;
+  /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)).  */
+  if (attr.function)
+    {
+      if (gfc_return_by_reference (sym))
+	type = void_type_node;
+      else
+	{
+	  if (sym->result != sym)
+	    result_decl = gfc_sym_identifier (sym->result);
+
+	  type = TREE_TYPE (TREE_TYPE (fndecl));
+	}
+    }
+  else
+    {
+      /* Look for alternate return placeholders.  */
+      int has_alternate_returns = 0;
+      for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
+	{
+	  if (f->sym == NULL)
+	    {
+	      has_alternate_returns = 1;
+	      break;
+	    }
+	}
+
+      if (has_alternate_returns)
+	type = integer_type_node;
+      else
+	type = void_type_node;
+    }
+
+  result_decl = build_decl (input_location,
+			    RESULT_DECL, result_decl, type);
+  DECL_ARTIFICIAL (result_decl) = 1;
+  DECL_IGNORED_P (result_decl) = 1;
+  DECL_CONTEXT (result_decl) = fndecl;
+  DECL_RESULT (fndecl) = result_decl;
+
+  /* Don't call layout_decl for a RESULT_DECL.
+     layout_decl (result_decl, 0);  */
+
+  /* TREE_STATIC means the function body is defined here.  */
+  TREE_STATIC (fndecl) = 1;
+
+  /* Set attributes for PURE functions. A call to a PURE function in the
+     Fortran 95 sense is both pure and without side effects in the C
+     sense.  */
+  if (attr.pure || attr.implicit_pure)
+    {
+      /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
+	 including an alternate return. In that case it can also be
+	 marked as PURE. See also in gfc_get_extern_function_decl().  */
+      if (attr.function && !gfc_return_by_reference (sym))
+	DECL_PURE_P (fndecl) = 1;
+      TREE_SIDE_EFFECTS (fndecl) = 0;
+    }
+
+
+  /* Layout the function declaration and put it in the binding level
+     of the current function.  */
+
+  if (global)
+    pushdecl_top_level (fndecl);
+  else
+    pushdecl (fndecl);
+
+  /* Perform name mangling if this is a top level or module procedure.  */
+  if (current_function_decl == NULL_TREE)
+    gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym));
+
+  sym->backend_decl = fndecl;
+}
+
+
+/* Create the DECL_ARGUMENTS for a procedure.  */
+
+static void
+create_function_arglist (gfc_symbol * sym)
+{
+  tree fndecl;
+  gfc_formal_arglist *f;
+  tree typelist, hidden_typelist;
+  tree arglist, hidden_arglist;
+  tree type;
+  tree parm;
+
+  fndecl = sym->backend_decl;
+
+  /* Build formal argument list. Make sure that their TREE_CONTEXT is
+     the new FUNCTION_DECL node.  */
+  arglist = NULL_TREE;
+  hidden_arglist = NULL_TREE;
+  typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
+
+  if (sym->attr.entry_master)
+    {
+      type = TREE_VALUE (typelist);
+      parm = build_decl (input_location,
+			 PARM_DECL, get_identifier ("__entry"), type);
+
+      DECL_CONTEXT (parm) = fndecl;
+      DECL_ARG_TYPE (parm) = type;
+      TREE_READONLY (parm) = 1;
+      gfc_finish_decl (parm);
+      DECL_ARTIFICIAL (parm) = 1;
+
+      arglist = chainon (arglist, parm);
+      typelist = TREE_CHAIN (typelist);
+    }
+
+  if (gfc_return_by_reference (sym))
+    {
+      tree type = TREE_VALUE (typelist), length = NULL;
+
+      if (sym->ts.type == BT_CHARACTER)
+	{
+	  /* Length of character result.  */
+	  tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
+
+	  length = build_decl (input_location,
+			       PARM_DECL,
+			       get_identifier (".__result"),
+			       len_type);
+	  if (!sym->ts.u.cl->length)
+	    {
+	      sym->ts.u.cl->backend_decl = length;
+	      TREE_USED (length) = 1;
+	    }
+	  gcc_assert (TREE_CODE (length) == PARM_DECL);
+	  DECL_CONTEXT (length) = fndecl;
+	  DECL_ARG_TYPE (length) = len_type;
+	  TREE_READONLY (length) = 1;
+	  DECL_ARTIFICIAL (length) = 1;
+	  gfc_finish_decl (length);
+	  if (sym->ts.u.cl->backend_decl == NULL
+	      || sym->ts.u.cl->backend_decl == length)
+	    {
+	      gfc_symbol *arg;
+	      tree backend_decl;
+
+	      if (sym->ts.u.cl->backend_decl == NULL)
+		{
+		  tree len = build_decl (input_location,
+					 VAR_DECL,
+					 get_identifier ("..__result"),
+					 gfc_charlen_type_node);
+		  DECL_ARTIFICIAL (len) = 1;
+		  TREE_USED (len) = 1;
+		  sym->ts.u.cl->backend_decl = len;
+		}
+
+	      /* Make sure PARM_DECL type doesn't point to incomplete type.  */
+	      arg = sym->result ? sym->result : sym;
+	      backend_decl = arg->backend_decl;
+	      /* Temporary clear it, so that gfc_sym_type creates complete
+		 type.  */
+	      arg->backend_decl = NULL;
+	      type = gfc_sym_type (arg);
+	      arg->backend_decl = backend_decl;
+	      type = build_reference_type (type);
+	    }
+	}
+
+      parm = build_decl (input_location,
+			 PARM_DECL, get_identifier ("__result"), type);
+
+      DECL_CONTEXT (parm) = fndecl;
+      DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
+      TREE_READONLY (parm) = 1;
+      DECL_ARTIFICIAL (parm) = 1;
+      gfc_finish_decl (parm);
+
+      arglist = chainon (arglist, parm);
+      typelist = TREE_CHAIN (typelist);
+
+      if (sym->ts.type == BT_CHARACTER)
+	{
+	  gfc_allocate_lang_decl (parm);
+	  arglist = chainon (arglist, length);
+	  typelist = TREE_CHAIN (typelist);
+	}
+    }
+
+  hidden_typelist = typelist;
+  for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
+    if (f->sym != NULL)	/* Ignore alternate returns.  */
+      hidden_typelist = TREE_CHAIN (hidden_typelist);
+
+  for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
+    {
+      char name[GFC_MAX_SYMBOL_LEN + 2];
+
+      /* Ignore alternate returns.  */
+      if (f->sym == NULL)
+	continue;
+
+      type = TREE_VALUE (typelist);
+
+      if (f->sym->ts.type == BT_CHARACTER
+	  && (!sym->attr.is_bind_c || sym->attr.entry_master))
+	{
+	  tree len_type = TREE_VALUE (hidden_typelist);
+	  tree length = NULL_TREE;
+	  if (!f->sym->ts.deferred)
+	    gcc_assert (len_type == gfc_charlen_type_node);
+	  else
+	    gcc_assert (POINTER_TYPE_P (len_type));
+
+	  strcpy (&name[1], f->sym->name);
+	  name[0] = '_';
+	  length = build_decl (input_location,
+			       PARM_DECL, get_identifier (name), len_type);
+
+	  hidden_arglist = chainon (hidden_arglist, length);
+	  DECL_CONTEXT (length) = fndecl;
+	  DECL_ARTIFICIAL (length) = 1;
+	  DECL_ARG_TYPE (length) = len_type;
+	  TREE_READONLY (length) = 1;
+	  gfc_finish_decl (length);
+
+	  /* Remember the passed value.  */
+          if (!f->sym->ts.u.cl ||  f->sym->ts.u.cl->passed_length)
+            {
+	      /* This can happen if the same type is used for multiple
+		 arguments. We need to copy cl as otherwise
+		 cl->passed_length gets overwritten.  */
+	      f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl);
+            }
+	  f->sym->ts.u.cl->passed_length = length;
+
+	  /* Use the passed value for assumed length variables.  */
+	  if (!f->sym->ts.u.cl->length)
+	    {
+	      TREE_USED (length) = 1;
+	      gcc_assert (!f->sym->ts.u.cl->backend_decl);
+	      f->sym->ts.u.cl->backend_decl = length;
+	    }
+
+	  hidden_typelist = TREE_CHAIN (hidden_typelist);
+
+	  if (f->sym->ts.u.cl->backend_decl == NULL
+	      || f->sym->ts.u.cl->backend_decl == length)
+	    {
+	      if (f->sym->ts.u.cl->backend_decl == NULL)
+		gfc_create_string_length (f->sym);
+
+	      /* Make sure PARM_DECL type doesn't point to incomplete type.  */
+	      if (f->sym->attr.flavor == FL_PROCEDURE)
+		type = build_pointer_type (gfc_get_function_type (f->sym));
+	      else
+		type = gfc_sym_type (f->sym);
+	    }
+	}
+      /* For noncharacter scalar intrinsic types, VALUE passes the value,
+	 hence, the optional status cannot be transferred via a NULL pointer.
+	 Thus, we will use a hidden argument in that case.  */
+      else if (f->sym->attr.optional && f->sym->attr.value
+	       && !f->sym->attr.dimension && f->sym->ts.type != BT_CLASS
+	       && f->sym->ts.type != BT_DERIVED)
+	{
+          tree tmp;
+          strcpy (&name[1], f->sym->name);
+          name[0] = '_';
+          tmp = build_decl (input_location,
+			    PARM_DECL, get_identifier (name),
+			    boolean_type_node);
+
+          hidden_arglist = chainon (hidden_arglist, tmp);
+          DECL_CONTEXT (tmp) = fndecl;
+          DECL_ARTIFICIAL (tmp) = 1;
+          DECL_ARG_TYPE (tmp) = boolean_type_node;
+          TREE_READONLY (tmp) = 1;
+          gfc_finish_decl (tmp);
+	}
+
+      /* For non-constant length array arguments, make sure they use
+	 a different type node from TYPE_ARG_TYPES type.  */
+      if (f->sym->attr.dimension
+	  && type == TREE_VALUE (typelist)
+	  && TREE_CODE (type) == POINTER_TYPE
+	  && GFC_ARRAY_TYPE_P (type)
+	  && f->sym->as->type != AS_ASSUMED_SIZE
+	  && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
+	{
+	  if (f->sym->attr.flavor == FL_PROCEDURE)
+	    type = build_pointer_type (gfc_get_function_type (f->sym));
+	  else
+	    type = gfc_sym_type (f->sym);
+	}
+
+      if (f->sym->attr.proc_pointer)
+        type = build_pointer_type (type);
+
+      if (f->sym->attr.volatile_)
+	type = build_qualified_type (type, TYPE_QUAL_VOLATILE);
+
+      /* Build the argument declaration.  */
+      parm = build_decl (input_location,
+			 PARM_DECL, gfc_sym_identifier (f->sym), type);
+
+      if (f->sym->attr.volatile_)
+	{
+	  TREE_THIS_VOLATILE (parm) = 1;
+	  TREE_SIDE_EFFECTS (parm) = 1;
+	}
+
+      /* Fill in arg stuff.  */
+      DECL_CONTEXT (parm) = fndecl;
+      DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
+      /* All implementation args are read-only.  */
+      TREE_READONLY (parm) = 1;
+      if (POINTER_TYPE_P (type)
+	  && (!f->sym->attr.proc_pointer
+	      && f->sym->attr.flavor != FL_PROCEDURE))
+	DECL_BY_REFERENCE (parm) = 1;
+
+      gfc_finish_decl (parm);
+
+      f->sym->backend_decl = parm;
+
+      /* Coarrays which are descriptorless or assumed-shape pass with
+	 -fcoarray=lib the token and the offset as hidden arguments.  */
+      if (f->sym->attr.codimension
+	  && gfc_option.coarray == GFC_FCOARRAY_LIB
+	  && !f->sym->attr.allocatable)
+	{
+	  tree caf_type;
+	  tree token;
+	  tree offset;
+
+	  gcc_assert (f->sym->backend_decl != NULL_TREE
+		      && !sym->attr.is_bind_c);
+	  caf_type = TREE_TYPE (f->sym->backend_decl);
+
+	  token = build_decl (input_location, PARM_DECL,
+			      create_tmp_var_name ("caf_token"),
+			      build_qualified_type (pvoid_type_node,
+						    TYPE_QUAL_RESTRICT));
+	  if (f->sym->as->type == AS_ASSUMED_SHAPE)
+	    {
+	      gcc_assert (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL
+			  || GFC_DECL_TOKEN (f->sym->backend_decl) == NULL_TREE);
+	      if (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL)
+		gfc_allocate_lang_decl (f->sym->backend_decl);
+	      GFC_DECL_TOKEN (f->sym->backend_decl) = token;
+	    }
+          else
+	    {
+	      gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) == NULL_TREE);
+	      GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) = token;
+	    }
+
+	  DECL_CONTEXT (token) = fndecl;
+	  DECL_ARTIFICIAL (token) = 1;
+	  DECL_ARG_TYPE (token) = TREE_VALUE (typelist);
+	  TREE_READONLY (token) = 1;
+	  hidden_arglist = chainon (hidden_arglist, token);
+	  gfc_finish_decl (token);
+
+	  offset = build_decl (input_location, PARM_DECL,
+			       create_tmp_var_name ("caf_offset"),
+			       gfc_array_index_type);
+
+	  if (f->sym->as->type == AS_ASSUMED_SHAPE)
+	    {
+	      gcc_assert (GFC_DECL_CAF_OFFSET (f->sym->backend_decl)
+					       == NULL_TREE);
+	      GFC_DECL_CAF_OFFSET (f->sym->backend_decl) = offset;
+	    }
+	  else
+	    {
+	      gcc_assert (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) == NULL_TREE);
+	      GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) = offset;
+	    }
+	  DECL_CONTEXT (offset) = fndecl;
+	  DECL_ARTIFICIAL (offset) = 1;
+	  DECL_ARG_TYPE (offset) = TREE_VALUE (typelist);
+	  TREE_READONLY (offset) = 1;
+	  hidden_arglist = chainon (hidden_arglist, offset);
+	  gfc_finish_decl (offset);
+	}
+
+      arglist = chainon (arglist, parm);
+      typelist = TREE_CHAIN (typelist);
+    }
+
+  /* Add the hidden string length parameters, unless the procedure
+     is bind(C).  */
+  if (!sym->attr.is_bind_c)
+    arglist = chainon (arglist, hidden_arglist);
+
+  gcc_assert (hidden_typelist == NULL_TREE
+              || TREE_VALUE (hidden_typelist) == void_type_node);
+  DECL_ARGUMENTS (fndecl) = arglist;
+}
+
+/* Do the setup necessary before generating the body of a function.  */
+
+static void
+trans_function_start (gfc_symbol * sym)
+{
+  tree fndecl;
+
+  fndecl = sym->backend_decl;
+
+  /* Let GCC know the current scope is this function.  */
+  current_function_decl = fndecl;
+
+  /* Let the world know what we're about to do.  */
+  announce_function (fndecl);
+
+  if (DECL_FILE_SCOPE_P (fndecl))
+    {
+      /* Create RTL for function declaration.  */
+      rest_of_decl_compilation (fndecl, 1, 0);
+    }
+
+  /* Create RTL for function definition.  */
+  make_decl_rtl (fndecl);
+
+  allocate_struct_function (fndecl, false);
+
+  /* function.c requires a push at the start of the function.  */
+  pushlevel ();
+}
+
+/* Create thunks for alternate entry points.  */
+
+static void
+build_entry_thunks (gfc_namespace * ns, bool global)
+{
+  gfc_formal_arglist *formal;
+  gfc_formal_arglist *thunk_formal;
+  gfc_entry_list *el;
+  gfc_symbol *thunk_sym;
+  stmtblock_t body;
+  tree thunk_fndecl;
+  tree tmp;
+  locus old_loc;
+
+  /* This should always be a toplevel function.  */
+  gcc_assert (current_function_decl == NULL_TREE);
+
+  gfc_save_backend_locus (&old_loc);
+  for (el = ns->entries; el; el = el->next)
+    {
+      vec<tree, va_gc> *args = NULL;
+      vec<tree, va_gc> *string_args = NULL;
+
+      thunk_sym = el->sym;
+
+      build_function_decl (thunk_sym, global);
+      create_function_arglist (thunk_sym);
+
+      trans_function_start (thunk_sym);
+
+      thunk_fndecl = thunk_sym->backend_decl;
+
+      gfc_init_block (&body);
+
+      /* Pass extra parameter identifying this entry point.  */
+      tmp = build_int_cst (gfc_array_index_type, el->id);
+      vec_safe_push (args, tmp);
+
+      if (thunk_sym->attr.function)
+	{
+	  if (gfc_return_by_reference (ns->proc_name))
+	    {
+	      tree ref = DECL_ARGUMENTS (current_function_decl);
+	      vec_safe_push (args, ref);
+	      if (ns->proc_name->ts.type == BT_CHARACTER)
+		vec_safe_push (args, DECL_CHAIN (ref));
+	    }
+	}
+
+      for (formal = gfc_sym_get_dummy_args (ns->proc_name); formal;
+	   formal = formal->next)
+	{
+	  /* Ignore alternate returns.  */
+	  if (formal->sym == NULL)
+	    continue;
+
+	  /* We don't have a clever way of identifying arguments, so resort to
+	     a brute-force search.  */
+	  for (thunk_formal = gfc_sym_get_dummy_args (thunk_sym);
+	       thunk_formal;
+	       thunk_formal = thunk_formal->next)
+	    {
+	      if (thunk_formal->sym == formal->sym)
+		break;
+	    }
+
+	  if (thunk_formal)
+	    {
+	      /* Pass the argument.  */
+	      DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
+	      vec_safe_push (args, thunk_formal->sym->backend_decl);
+	      if (formal->sym->ts.type == BT_CHARACTER)
+		{
+		  tmp = thunk_formal->sym->ts.u.cl->backend_decl;
+		  vec_safe_push (string_args, tmp);
+		}
+	    }
+	  else
+	    {
+	      /* Pass NULL for a missing argument.  */
+	      vec_safe_push (args, null_pointer_node);
+	      if (formal->sym->ts.type == BT_CHARACTER)
+		{
+		  tmp = build_int_cst (gfc_charlen_type_node, 0);
+		  vec_safe_push (string_args, tmp);
+		}
+	    }
+	}
+
+      /* Call the master function.  */
+      vec_safe_splice (args, string_args);
+      tmp = ns->proc_name->backend_decl;
+      tmp = build_call_expr_loc_vec (input_location, tmp, args);
+      if (ns->proc_name->attr.mixed_entry_master)
+	{
+	  tree union_decl, field;
+	  tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
+
+	  union_decl = build_decl (input_location,
+				   VAR_DECL, get_identifier ("__result"),
+				   TREE_TYPE (master_type));
+	  DECL_ARTIFICIAL (union_decl) = 1;
+	  DECL_EXTERNAL (union_decl) = 0;
+	  TREE_PUBLIC (union_decl) = 0;
+	  TREE_USED (union_decl) = 1;
+	  layout_decl (union_decl, 0);
+	  pushdecl (union_decl);
+
+	  DECL_CONTEXT (union_decl) = current_function_decl;
+	  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+				 TREE_TYPE (union_decl), union_decl, tmp);
+	  gfc_add_expr_to_block (&body, tmp);
+
+	  for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
+	       field; field = DECL_CHAIN (field))
+	    if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
+		thunk_sym->result->name) == 0)
+	      break;
+	  gcc_assert (field != NULL_TREE);
+	  tmp = fold_build3_loc (input_location, COMPONENT_REF,
+				 TREE_TYPE (field), union_decl, field,
+				 NULL_TREE);
+	  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+			     TREE_TYPE (DECL_RESULT (current_function_decl)),
+			     DECL_RESULT (current_function_decl), tmp);
+	  tmp = build1_v (RETURN_EXPR, tmp);
+	}
+      else if (TREE_TYPE (DECL_RESULT (current_function_decl))
+	       != void_type_node)
+	{
+	  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+			     TREE_TYPE (DECL_RESULT (current_function_decl)),
+			     DECL_RESULT (current_function_decl), tmp);
+	  tmp = build1_v (RETURN_EXPR, tmp);
+	}
+      gfc_add_expr_to_block (&body, tmp);
+
+      /* Finish off this function and send it for code generation.  */
+      DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
+      tmp = getdecls ();
+      poplevel (1, 1);
+      BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
+      DECL_SAVED_TREE (thunk_fndecl)
+	= build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
+		    DECL_INITIAL (thunk_fndecl));
+
+      /* Output the GENERIC tree.  */
+      dump_function (TDI_original, thunk_fndecl);
+
+      /* Store the end of the function, so that we get good line number
+	 info for the epilogue.  */
+      cfun->function_end_locus = input_location;
+
+      /* We're leaving the context of this function, so zap cfun.
+	 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
+	 tree_rest_of_compilation.  */
+      set_cfun (NULL);
+
+      current_function_decl = NULL_TREE;
+
+      cgraph_finalize_function (thunk_fndecl, true);
+
+      /* We share the symbols in the formal argument list with other entry
+	 points and the master function.  Clear them so that they are
+	 recreated for each function.  */
+      for (formal = gfc_sym_get_dummy_args (thunk_sym); formal;
+	   formal = formal->next)
+	if (formal->sym != NULL)  /* Ignore alternate returns.  */
+	  {
+	    formal->sym->backend_decl = NULL_TREE;
+	    if (formal->sym->ts.type == BT_CHARACTER)
+	      formal->sym->ts.u.cl->backend_decl = NULL_TREE;
+	  }
+
+      if (thunk_sym->attr.function)
+	{
+	  if (thunk_sym->ts.type == BT_CHARACTER)
+	    thunk_sym->ts.u.cl->backend_decl = NULL_TREE;
+	  if (thunk_sym->result->ts.type == BT_CHARACTER)
+	    thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE;
+	}
+    }
+
+  gfc_restore_backend_locus (&old_loc);
+}
+
+
+/* Create a decl for a function, and create any thunks for alternate entry
+   points. If global is true, generate the function in the global binding
+   level, otherwise in the current binding level (which can be global).  */
+
+void
+gfc_create_function_decl (gfc_namespace * ns, bool global)
+{
+  /* Create a declaration for the master function.  */
+  build_function_decl (ns->proc_name, global);
+
+  /* Compile the entry thunks.  */
+  if (ns->entries)
+    build_entry_thunks (ns, global);
+
+  /* Now create the read argument list.  */
+  create_function_arglist (ns->proc_name);
+}
+
+/* Return the decl used to hold the function return value.  If
+   parent_flag is set, the context is the parent_scope.  */
+
+tree
+gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
+{
+  tree decl;
+  tree length;
+  tree this_fake_result_decl;
+  tree this_function_decl;
+
+  char name[GFC_MAX_SYMBOL_LEN + 10];
+
+  if (parent_flag)
+    {
+      this_fake_result_decl = parent_fake_result_decl;
+      this_function_decl = DECL_CONTEXT (current_function_decl);
+    }
+  else
+    {
+      this_fake_result_decl = current_fake_result_decl;
+      this_function_decl = current_function_decl;
+    }
+
+  if (sym
+      && sym->ns->proc_name->backend_decl == this_function_decl
+      && sym->ns->proc_name->attr.entry_master
+      && sym != sym->ns->proc_name)
+    {
+      tree t = NULL, var;
+      if (this_fake_result_decl != NULL)
+	for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
+	  if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
+	    break;
+      if (t)
+	return TREE_VALUE (t);
+      decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
+
+      if (parent_flag)
+	this_fake_result_decl = parent_fake_result_decl;
+      else
+	this_fake_result_decl = current_fake_result_decl;
+
+      if (decl && sym->ns->proc_name->attr.mixed_entry_master)
+	{
+	  tree field;
+
+	  for (field = TYPE_FIELDS (TREE_TYPE (decl));
+	       field; field = DECL_CHAIN (field))
+	    if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
+		sym->name) == 0)
+	      break;
+
+	  gcc_assert (field != NULL_TREE);
+	  decl = fold_build3_loc (input_location, COMPONENT_REF,
+				  TREE_TYPE (field), decl, field, NULL_TREE);
+	}
+
+      var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
+      if (parent_flag)
+	gfc_add_decl_to_parent_function (var);
+      else
+	gfc_add_decl_to_function (var);
+
+      SET_DECL_VALUE_EXPR (var, decl);
+      DECL_HAS_VALUE_EXPR_P (var) = 1;
+      GFC_DECL_RESULT (var) = 1;
+
+      TREE_CHAIN (this_fake_result_decl)
+	  = tree_cons (get_identifier (sym->name), var,
+		       TREE_CHAIN (this_fake_result_decl));
+      return var;
+    }
+
+  if (this_fake_result_decl != NULL_TREE)
+    return TREE_VALUE (this_fake_result_decl);
+
+  /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
+     sym is NULL.  */
+  if (!sym)
+    return NULL_TREE;
+
+  if (sym->ts.type == BT_CHARACTER)
+    {
+      if (sym->ts.u.cl->backend_decl == NULL_TREE)
+	length = gfc_create_string_length (sym);
+      else
+	length = sym->ts.u.cl->backend_decl;
+      if (TREE_CODE (length) == VAR_DECL
+	  && DECL_CONTEXT (length) == NULL_TREE)
+	gfc_add_decl_to_function (length);
+    }
+
+  if (gfc_return_by_reference (sym))
+    {
+      decl = DECL_ARGUMENTS (this_function_decl);
+
+      if (sym->ns->proc_name->backend_decl == this_function_decl
+	  && sym->ns->proc_name->attr.entry_master)
+	decl = DECL_CHAIN (decl);
+
+      TREE_USED (decl) = 1;
+      if (sym->as)
+	decl = gfc_build_dummy_array_decl (sym, decl);
+    }
+  else
+    {
+      sprintf (name, "__result_%.20s",
+	       IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
+
+      if (!sym->attr.mixed_entry_master && sym->attr.function)
+	decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
+			   VAR_DECL, get_identifier (name),
+			   gfc_sym_type (sym));
+      else
+	decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
+			   VAR_DECL, get_identifier (name),
+			   TREE_TYPE (TREE_TYPE (this_function_decl)));
+      DECL_ARTIFICIAL (decl) = 1;
+      DECL_EXTERNAL (decl) = 0;
+      TREE_PUBLIC (decl) = 0;
+      TREE_USED (decl) = 1;
+      GFC_DECL_RESULT (decl) = 1;
+      TREE_ADDRESSABLE (decl) = 1;
+
+      layout_decl (decl, 0);
+
+      if (parent_flag)
+	gfc_add_decl_to_parent_function (decl);
+      else
+	gfc_add_decl_to_function (decl);
+    }
+
+  if (parent_flag)
+    parent_fake_result_decl = build_tree_list (NULL, decl);
+  else
+    current_fake_result_decl = build_tree_list (NULL, decl);
+
+  return decl;
+}
+
+
+/* Builds a function decl.  The remaining parameters are the types of the
+   function arguments.  Negative nargs indicates a varargs function.  */
+
+static tree
+build_library_function_decl_1 (tree name, const char *spec,
+			       tree rettype, int nargs, va_list p)
+{
+  vec<tree, va_gc> *arglist;
+  tree fntype;
+  tree fndecl;
+  int n;
+
+  /* Library functions must be declared with global scope.  */
+  gcc_assert (current_function_decl == NULL_TREE);
+
+  /* Create a list of the argument types.  */
+  vec_alloc (arglist, abs (nargs));
+  for (n = abs (nargs); n > 0; n--)
+    {
+      tree argtype = va_arg (p, tree);
+      arglist->quick_push (argtype);
+    }
+
+  /* Build the function type and decl.  */
+  if (nargs >= 0)
+    fntype = build_function_type_vec (rettype, arglist);
+  else
+    fntype = build_varargs_function_type_vec (rettype, arglist);
+  if (spec)
+    {
+      tree attr_args = build_tree_list (NULL_TREE,
+					build_string (strlen (spec), spec));
+      tree attrs = tree_cons (get_identifier ("fn spec"),
+			      attr_args, TYPE_ATTRIBUTES (fntype));
+      fntype = build_type_attribute_variant (fntype, attrs);
+    }
+  fndecl = build_decl (input_location,
+		       FUNCTION_DECL, name, fntype);
+
+  /* Mark this decl as external.  */
+  DECL_EXTERNAL (fndecl) = 1;
+  TREE_PUBLIC (fndecl) = 1;
+
+  pushdecl (fndecl);
+
+  rest_of_decl_compilation (fndecl, 1, 0);
+
+  return fndecl;
+}
+
+/* Builds a function decl.  The remaining parameters are the types of the
+   function arguments.  Negative nargs indicates a varargs function.  */
+
+tree
+gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
+{
+  tree ret;
+  va_list args;
+  va_start (args, nargs);
+  ret = build_library_function_decl_1 (name, NULL, rettype, nargs, args);
+  va_end (args);
+  return ret;
+}
+
+/* Builds a function decl.  The remaining parameters are the types of the
+   function arguments.  Negative nargs indicates a varargs function.
+   The SPEC parameter specifies the function argument and return type
+   specification according to the fnspec function type attribute.  */
+
+tree
+gfc_build_library_function_decl_with_spec (tree name, const char *spec,
+					   tree rettype, int nargs, ...)
+{
+  tree ret;
+  va_list args;
+  va_start (args, nargs);
+  ret = build_library_function_decl_1 (name, spec, rettype, nargs, args);
+  va_end (args);
+  return ret;
+}
+
+static void
+gfc_build_intrinsic_function_decls (void)
+{
+  tree gfc_int4_type_node = gfc_get_int_type (4);
+  tree gfc_int8_type_node = gfc_get_int_type (8);
+  tree gfc_int16_type_node = gfc_get_int_type (16);
+  tree gfc_logical4_type_node = gfc_get_logical_type (4);
+  tree pchar1_type_node = gfc_get_pchar_type (1);
+  tree pchar4_type_node = gfc_get_pchar_type (4);
+
+  /* String functions.  */
+  gfor_fndecl_compare_string = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("compare_string")), "..R.R",
+	integer_type_node, 4, gfc_charlen_type_node, pchar1_type_node,
+	gfc_charlen_type_node, pchar1_type_node);
+  DECL_PURE_P (gfor_fndecl_compare_string) = 1;
+  TREE_NOTHROW (gfor_fndecl_compare_string) = 1;
+
+  gfor_fndecl_concat_string = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("concat_string")), "..W.R.R",
+	void_type_node, 6, gfc_charlen_type_node, pchar1_type_node,
+	gfc_charlen_type_node, pchar1_type_node,
+	gfc_charlen_type_node, pchar1_type_node);
+  TREE_NOTHROW (gfor_fndecl_concat_string) = 1;
+
+  gfor_fndecl_string_len_trim = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("string_len_trim")), "..R",
+	gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar1_type_node);
+  DECL_PURE_P (gfor_fndecl_string_len_trim) = 1;
+  TREE_NOTHROW (gfor_fndecl_string_len_trim) = 1;
+
+  gfor_fndecl_string_index = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("string_index")), "..R.R.",
+	gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
+	gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
+  DECL_PURE_P (gfor_fndecl_string_index) = 1;
+  TREE_NOTHROW (gfor_fndecl_string_index) = 1;
+
+  gfor_fndecl_string_scan = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("string_scan")), "..R.R.",
+	gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
+	gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
+  DECL_PURE_P (gfor_fndecl_string_scan) = 1;
+  TREE_NOTHROW (gfor_fndecl_string_scan) = 1;
+
+  gfor_fndecl_string_verify = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("string_verify")), "..R.R.",
+	gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
+	gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
+  DECL_PURE_P (gfor_fndecl_string_verify) = 1;
+  TREE_NOTHROW (gfor_fndecl_string_verify) = 1;
+
+  gfor_fndecl_string_trim = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("string_trim")), ".Ww.R",
+	void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
+	build_pointer_type (pchar1_type_node), gfc_charlen_type_node,
+	pchar1_type_node);
+
+  gfor_fndecl_string_minmax = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("string_minmax")), ".Ww.R",
+	void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
+	build_pointer_type (pchar1_type_node), integer_type_node,
+	integer_type_node);
+
+  gfor_fndecl_adjustl = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("adjustl")), ".W.R",
+	void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
+	pchar1_type_node);
+  TREE_NOTHROW (gfor_fndecl_adjustl) = 1;
+
+  gfor_fndecl_adjustr = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("adjustr")), ".W.R",
+	void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
+	pchar1_type_node);
+  TREE_NOTHROW (gfor_fndecl_adjustr) = 1;
+
+  gfor_fndecl_select_string =  gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("select_string")), ".R.R.",
+	integer_type_node, 4, pvoid_type_node, integer_type_node,
+	pchar1_type_node, gfc_charlen_type_node);
+  DECL_PURE_P (gfor_fndecl_select_string) = 1;
+  TREE_NOTHROW (gfor_fndecl_select_string) = 1;
+
+  gfor_fndecl_compare_string_char4 = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("compare_string_char4")), "..R.R",
+	integer_type_node, 4, gfc_charlen_type_node, pchar4_type_node,
+	gfc_charlen_type_node, pchar4_type_node);
+  DECL_PURE_P (gfor_fndecl_compare_string_char4) = 1;
+  TREE_NOTHROW (gfor_fndecl_compare_string_char4) = 1;
+
+  gfor_fndecl_concat_string_char4 = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("concat_string_char4")), "..W.R.R",
+	void_type_node, 6, gfc_charlen_type_node, pchar4_type_node,
+	gfc_charlen_type_node, pchar4_type_node, gfc_charlen_type_node,
+	pchar4_type_node);
+  TREE_NOTHROW (gfor_fndecl_concat_string_char4) = 1;
+
+  gfor_fndecl_string_len_trim_char4 = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("string_len_trim_char4")), "..R",
+	gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar4_type_node);
+  DECL_PURE_P (gfor_fndecl_string_len_trim_char4) = 1;
+  TREE_NOTHROW (gfor_fndecl_string_len_trim_char4) = 1;
+
+  gfor_fndecl_string_index_char4 = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("string_index_char4")), "..R.R.",
+	gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
+	gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
+  DECL_PURE_P (gfor_fndecl_string_index_char4) = 1;
+  TREE_NOTHROW (gfor_fndecl_string_index_char4) = 1;
+
+  gfor_fndecl_string_scan_char4 = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("string_scan_char4")), "..R.R.",
+	gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
+	gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
+  DECL_PURE_P (gfor_fndecl_string_scan_char4) = 1;
+  TREE_NOTHROW (gfor_fndecl_string_scan_char4) = 1;
+
+  gfor_fndecl_string_verify_char4 = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("string_verify_char4")), "..R.R.",
+	gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
+	gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
+  DECL_PURE_P (gfor_fndecl_string_verify_char4) = 1;
+  TREE_NOTHROW (gfor_fndecl_string_verify_char4) = 1;
+
+  gfor_fndecl_string_trim_char4 = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("string_trim_char4")), ".Ww.R",
+	void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
+	build_pointer_type (pchar4_type_node), gfc_charlen_type_node,
+	pchar4_type_node);
+
+  gfor_fndecl_string_minmax_char4 = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("string_minmax_char4")), ".Ww.R",
+	void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
+	build_pointer_type (pchar4_type_node), integer_type_node,
+	integer_type_node);
+
+  gfor_fndecl_adjustl_char4 = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("adjustl_char4")), ".W.R",
+	void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
+	pchar4_type_node);
+  TREE_NOTHROW (gfor_fndecl_adjustl_char4) = 1;
+
+  gfor_fndecl_adjustr_char4 = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("adjustr_char4")), ".W.R",
+	void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
+	pchar4_type_node);
+  TREE_NOTHROW (gfor_fndecl_adjustr_char4) = 1;
+
+  gfor_fndecl_select_string_char4 = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("select_string_char4")), ".R.R.",
+	integer_type_node, 4, pvoid_type_node, integer_type_node,
+	pvoid_type_node, gfc_charlen_type_node);
+  DECL_PURE_P (gfor_fndecl_select_string_char4) = 1;
+  TREE_NOTHROW (gfor_fndecl_select_string_char4) = 1;
+
+
+  /* Conversion between character kinds.  */
+
+  gfor_fndecl_convert_char1_to_char4 = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("convert_char1_to_char4")), ".w.R",
+	void_type_node, 3, build_pointer_type (pchar4_type_node),
+	gfc_charlen_type_node, pchar1_type_node);
+
+  gfor_fndecl_convert_char4_to_char1 = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("convert_char4_to_char1")), ".w.R",
+	void_type_node, 3, build_pointer_type (pchar1_type_node),
+	gfc_charlen_type_node, pchar4_type_node);
+
+  /* Misc. functions.  */
+
+  gfor_fndecl_ttynam = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("ttynam")), ".W",
+	void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
+	integer_type_node);
+
+  gfor_fndecl_fdate = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("fdate")), ".W",
+	void_type_node, 2, pchar_type_node, gfc_charlen_type_node);
+
+  gfor_fndecl_ctime = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("ctime")), ".W",
+	void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
+	gfc_int8_type_node);
+
+  gfor_fndecl_sc_kind = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("selected_char_kind")), "..R",
+	gfc_int4_type_node, 2, gfc_charlen_type_node, pchar_type_node);
+  DECL_PURE_P (gfor_fndecl_sc_kind) = 1;
+  TREE_NOTHROW (gfor_fndecl_sc_kind) = 1;
+
+  gfor_fndecl_si_kind = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("selected_int_kind")), ".R",
+	gfc_int4_type_node, 1, pvoid_type_node);
+  DECL_PURE_P (gfor_fndecl_si_kind) = 1;
+  TREE_NOTHROW (gfor_fndecl_si_kind) = 1;
+
+  gfor_fndecl_sr_kind = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("selected_real_kind2008")), ".RR",
+	gfc_int4_type_node, 3, pvoid_type_node, pvoid_type_node,
+	pvoid_type_node);
+  DECL_PURE_P (gfor_fndecl_sr_kind) = 1;
+  TREE_NOTHROW (gfor_fndecl_sr_kind) = 1;
+
+  /* Power functions.  */
+  {
+    tree ctype, rtype, itype, jtype;
+    int rkind, ikind, jkind;
+#define NIKINDS 3
+#define NRKINDS 4
+    static int ikinds[NIKINDS] = {4, 8, 16};
+    static int rkinds[NRKINDS] = {4, 8, 10, 16};
+    char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
+
+    for (ikind=0; ikind < NIKINDS; ikind++)
+      {
+	itype = gfc_get_int_type (ikinds[ikind]);
+
+	for (jkind=0; jkind < NIKINDS; jkind++)
+	  {
+	    jtype = gfc_get_int_type (ikinds[jkind]);
+	    if (itype && jtype)
+	      {
+		sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
+			ikinds[jkind]);
+		gfor_fndecl_math_powi[jkind][ikind].integer =
+		  gfc_build_library_function_decl (get_identifier (name),
+		    jtype, 2, jtype, itype);
+		TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
+		TREE_NOTHROW (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
+	      }
+	  }
+
+	for (rkind = 0; rkind < NRKINDS; rkind ++)
+	  {
+	    rtype = gfc_get_real_type (rkinds[rkind]);
+	    if (rtype && itype)
+	      {
+		sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
+			ikinds[ikind]);
+		gfor_fndecl_math_powi[rkind][ikind].real =
+		  gfc_build_library_function_decl (get_identifier (name),
+		    rtype, 2, rtype, itype);
+		TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
+		TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
+	      }
+
+	    ctype = gfc_get_complex_type (rkinds[rkind]);
+	    if (ctype && itype)
+	      {
+		sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
+			ikinds[ikind]);
+		gfor_fndecl_math_powi[rkind][ikind].cmplx =
+		  gfc_build_library_function_decl (get_identifier (name),
+		    ctype, 2,ctype, itype);
+		TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
+		TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
+	      }
+	  }
+      }
+#undef NIKINDS
+#undef NRKINDS
+  }
+
+  gfor_fndecl_math_ishftc4 = gfc_build_library_function_decl (
+	get_identifier (PREFIX("ishftc4")),
+	gfc_int4_type_node, 3, gfc_int4_type_node, gfc_int4_type_node,
+	gfc_int4_type_node);
+  TREE_READONLY (gfor_fndecl_math_ishftc4) = 1;
+  TREE_NOTHROW (gfor_fndecl_math_ishftc4) = 1;
+
+  gfor_fndecl_math_ishftc8 = gfc_build_library_function_decl (
+	get_identifier (PREFIX("ishftc8")),
+	gfc_int8_type_node, 3, gfc_int8_type_node, gfc_int4_type_node,
+	gfc_int4_type_node);
+  TREE_READONLY (gfor_fndecl_math_ishftc8) = 1;
+  TREE_NOTHROW (gfor_fndecl_math_ishftc8) = 1;
+
+  if (gfc_int16_type_node)
+    {
+      gfor_fndecl_math_ishftc16 = gfc_build_library_function_decl (
+	get_identifier (PREFIX("ishftc16")),
+	gfc_int16_type_node, 3, gfc_int16_type_node, gfc_int4_type_node,
+	gfc_int4_type_node);
+      TREE_READONLY (gfor_fndecl_math_ishftc16) = 1;
+      TREE_NOTHROW (gfor_fndecl_math_ishftc16) = 1;
+    }
+
+  /* BLAS functions.  */
+  {
+    tree pint = build_pointer_type (integer_type_node);
+    tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
+    tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
+    tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
+    tree pz = build_pointer_type
+		(gfc_get_complex_type (gfc_default_double_kind));
+
+    gfor_fndecl_sgemm = gfc_build_library_function_decl
+			  (get_identifier
+			     (gfc_option.flag_underscoring ? "sgemm_"
+							   : "sgemm"),
+			   void_type_node, 15, pchar_type_node,
+			   pchar_type_node, pint, pint, pint, ps, ps, pint,
+			   ps, pint, ps, ps, pint, integer_type_node,
+			   integer_type_node);
+    gfor_fndecl_dgemm = gfc_build_library_function_decl
+			  (get_identifier
+			     (gfc_option.flag_underscoring ? "dgemm_"
+							   : "dgemm"),
+			   void_type_node, 15, pchar_type_node,
+			   pchar_type_node, pint, pint, pint, pd, pd, pint,
+			   pd, pint, pd, pd, pint, integer_type_node,
+			   integer_type_node);
+    gfor_fndecl_cgemm = gfc_build_library_function_decl
+			  (get_identifier
+			     (gfc_option.flag_underscoring ? "cgemm_"
+							   : "cgemm"),
+			   void_type_node, 15, pchar_type_node,
+			   pchar_type_node, pint, pint, pint, pc, pc, pint,
+			   pc, pint, pc, pc, pint, integer_type_node,
+			   integer_type_node);
+    gfor_fndecl_zgemm = gfc_build_library_function_decl
+			  (get_identifier
+			     (gfc_option.flag_underscoring ? "zgemm_"
+							   : "zgemm"),
+			   void_type_node, 15, pchar_type_node,
+			   pchar_type_node, pint, pint, pint, pz, pz, pint,
+			   pz, pint, pz, pz, pint, integer_type_node,
+			   integer_type_node);
+  }
+
+  /* Other functions.  */
+  gfor_fndecl_size0 = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("size0")), ".R",
+	gfc_array_index_type, 1, pvoid_type_node);
+  DECL_PURE_P (gfor_fndecl_size0) = 1;
+  TREE_NOTHROW (gfor_fndecl_size0) = 1;
+
+  gfor_fndecl_size1 = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("size1")), ".R",
+	gfc_array_index_type, 2, pvoid_type_node, gfc_array_index_type);
+  DECL_PURE_P (gfor_fndecl_size1) = 1;
+  TREE_NOTHROW (gfor_fndecl_size1) = 1;
+
+  gfor_fndecl_iargc = gfc_build_library_function_decl (
+	get_identifier (PREFIX ("iargc")), gfc_int4_type_node, 0);
+  TREE_NOTHROW (gfor_fndecl_iargc) = 1;
+}
+
+
+/* Make prototypes for runtime library functions.  */
+
+void
+gfc_build_builtin_function_decls (void)
+{
+  tree gfc_int4_type_node = gfc_get_int_type (4);
+
+  gfor_fndecl_stop_numeric = gfc_build_library_function_decl (
+	get_identifier (PREFIX("stop_numeric")),
+	void_type_node, 1, gfc_int4_type_node);
+  /* STOP doesn't return.  */
+  TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
+
+  gfor_fndecl_stop_numeric_f08 = gfc_build_library_function_decl (
+	get_identifier (PREFIX("stop_numeric_f08")),
+	void_type_node, 1, gfc_int4_type_node);
+  /* STOP doesn't return.  */
+  TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric_f08) = 1;
+
+  gfor_fndecl_stop_string = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("stop_string")), ".R.",
+	void_type_node, 2, pchar_type_node, gfc_int4_type_node);
+  /* STOP doesn't return.  */
+  TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
+
+  gfor_fndecl_error_stop_numeric = gfc_build_library_function_decl (
+        get_identifier (PREFIX("error_stop_numeric")),
+        void_type_node, 1, gfc_int4_type_node);
+  /* ERROR STOP doesn't return.  */
+  TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric) = 1;
+
+  gfor_fndecl_error_stop_string = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("error_stop_string")), ".R.",
+	void_type_node, 2, pchar_type_node, gfc_int4_type_node);
+  /* ERROR STOP doesn't return.  */
+  TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1;
+
+  gfor_fndecl_pause_numeric = gfc_build_library_function_decl (
+	get_identifier (PREFIX("pause_numeric")),
+	void_type_node, 1, gfc_int4_type_node);
+
+  gfor_fndecl_pause_string = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("pause_string")), ".R.",
+	void_type_node, 2, pchar_type_node, gfc_int4_type_node);
+
+  gfor_fndecl_runtime_error = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("runtime_error")), ".R",
+	void_type_node, -1, pchar_type_node);
+  /* The runtime_error function does not return.  */
+  TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
+
+  gfor_fndecl_runtime_error_at = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("runtime_error_at")), ".RR",
+	void_type_node, -2, pchar_type_node, pchar_type_node);
+  /* The runtime_error_at function does not return.  */
+  TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
+
+  gfor_fndecl_runtime_warning_at = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("runtime_warning_at")), ".RR",
+	void_type_node, -2, pchar_type_node, pchar_type_node);
+
+  gfor_fndecl_generate_error = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("generate_error")), ".R.R",
+	void_type_node, 3, pvoid_type_node, integer_type_node,
+	pchar_type_node);
+
+  gfor_fndecl_os_error = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("os_error")), ".R",
+	void_type_node, 1, pchar_type_node);
+  /* The runtime_error function does not return.  */
+  TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
+
+  gfor_fndecl_set_args = gfc_build_library_function_decl (
+	get_identifier (PREFIX("set_args")),
+	void_type_node, 2, integer_type_node,
+	build_pointer_type (pchar_type_node));
+
+  gfor_fndecl_set_fpe = gfc_build_library_function_decl (
+	get_identifier (PREFIX("set_fpe")),
+	void_type_node, 1, integer_type_node);
+
+  /* Keep the array dimension in sync with the call, later in this file.  */
+  gfor_fndecl_set_options = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("set_options")), "..R",
+	void_type_node, 2, integer_type_node,
+	build_pointer_type (integer_type_node));
+
+  gfor_fndecl_set_convert = gfc_build_library_function_decl (
+	get_identifier (PREFIX("set_convert")),
+	void_type_node, 1, integer_type_node);
+
+  gfor_fndecl_set_record_marker = gfc_build_library_function_decl (
+	get_identifier (PREFIX("set_record_marker")),
+	void_type_node, 1, integer_type_node);
+
+  gfor_fndecl_set_max_subrecord_length = gfc_build_library_function_decl (
+	get_identifier (PREFIX("set_max_subrecord_length")),
+	void_type_node, 1, integer_type_node);
+
+  gfor_fndecl_in_pack = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("internal_pack")), ".r",
+	pvoid_type_node, 1, pvoid_type_node);
+
+  gfor_fndecl_in_unpack = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("internal_unpack")), ".wR",
+	void_type_node, 2, pvoid_type_node, pvoid_type_node);
+
+  gfor_fndecl_associated = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("associated")), ".RR",
+	integer_type_node, 2, ppvoid_type_node, ppvoid_type_node);
+  DECL_PURE_P (gfor_fndecl_associated) = 1;
+  TREE_NOTHROW (gfor_fndecl_associated) = 1;
+
+  /* Coarray library calls.  */
+  if (gfc_option.coarray == GFC_FCOARRAY_LIB)
+    {
+      tree pint_type, pppchar_type;
+
+      pint_type = build_pointer_type (integer_type_node);
+      pppchar_type
+	= build_pointer_type (build_pointer_type (pchar_type_node));
+
+      gfor_fndecl_caf_init = gfc_build_library_function_decl (
+		   get_identifier (PREFIX("caf_init")),  void_type_node,
+		   4, pint_type, pppchar_type, pint_type, pint_type);
+
+      gfor_fndecl_caf_finalize = gfc_build_library_function_decl (
+	get_identifier (PREFIX("caf_finalize")), void_type_node, 0);
+
+      gfor_fndecl_caf_register = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("caf_register")), "...WWW", pvoid_type_node, 6,
+        size_type_node, integer_type_node, ppvoid_type_node, pint_type,
+        pchar_type_node, integer_type_node);
+
+      gfor_fndecl_caf_deregister = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("caf_deregister")), ".WWW", void_type_node, 4,
+        ppvoid_type_node, pint_type, pchar_type_node, integer_type_node);
+
+      gfor_fndecl_caf_critical = gfc_build_library_function_decl (
+	get_identifier (PREFIX("caf_critical")), void_type_node, 0);
+
+      gfor_fndecl_caf_end_critical = gfc_build_library_function_decl (
+	get_identifier (PREFIX("caf_end_critical")), void_type_node, 0);
+
+      gfor_fndecl_caf_sync_all = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("caf_sync_all")), ".WW", void_type_node,
+	3, pint_type, build_pointer_type (pchar_type_node), integer_type_node);
+
+      gfor_fndecl_caf_sync_images = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("caf_sync_images")), ".RRWW", void_type_node,
+	5, integer_type_node, pint_type, pint_type,
+	build_pointer_type (pchar_type_node), integer_type_node);
+
+      gfor_fndecl_caf_error_stop = gfc_build_library_function_decl (
+	get_identifier (PREFIX("caf_error_stop")),
+	void_type_node, 1, gfc_int4_type_node);
+      /* CAF's ERROR STOP doesn't return.  */
+      TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop) = 1;
+
+      gfor_fndecl_caf_error_stop_str = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("caf_error_stop_str")), ".R.",
+	void_type_node, 2, pchar_type_node, gfc_int4_type_node);
+      /* CAF's ERROR STOP doesn't return.  */
+      TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str) = 1;
+    }
+
+  gfc_build_intrinsic_function_decls ();
+  gfc_build_intrinsic_lib_fndecls ();
+  gfc_build_io_library_fndecls ();
+}
+
+
+/* Evaluate the length of dummy character variables.  */
+
+static void
+gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl,
+			   gfc_wrapped_block *block)
+{
+  stmtblock_t init;
+
+  gfc_finish_decl (cl->backend_decl);
+
+  gfc_start_block (&init);
+
+  /* Evaluate the string length expression.  */
+  gfc_conv_string_length (cl, NULL, &init);
+
+  gfc_trans_vla_type_sizes (sym, &init);
+
+  gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
+}
+
+
+/* Allocate and cleanup an automatic character variable.  */
+
+static void
+gfc_trans_auto_character_variable (gfc_symbol * sym, gfc_wrapped_block * block)
+{
+  stmtblock_t init;
+  tree decl;
+  tree tmp;
+
+  gcc_assert (sym->backend_decl);
+  gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
+
+  gfc_init_block (&init);
+
+  /* Evaluate the string length expression.  */
+  gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
+
+  gfc_trans_vla_type_sizes (sym, &init);
+
+  decl = sym->backend_decl;
+
+  /* Emit a DECL_EXPR for this variable, which will cause the
+     gimplifier to allocate storage, and all that good stuff.  */
+  tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
+  gfc_add_expr_to_block (&init, tmp);
+
+  gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
+}
+
+/* Set the initial value of ASSIGN statement auxiliary variable explicitly.  */
+
+static void
+gfc_trans_assign_aux_var (gfc_symbol * sym, gfc_wrapped_block * block)
+{
+  stmtblock_t init;
+
+  gcc_assert (sym->backend_decl);
+  gfc_start_block (&init);
+
+  /* Set the initial value to length. See the comments in
+     function gfc_add_assign_aux_vars in this file.  */
+  gfc_add_modify (&init, GFC_DECL_STRING_LEN (sym->backend_decl),
+		  build_int_cst (gfc_charlen_type_node, -2));
+
+  gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
+}
+
+static void
+gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
+{
+  tree t = *tp, var, val;
+
+  if (t == NULL || t == error_mark_node)
+    return;
+  if (TREE_CONSTANT (t) || DECL_P (t))
+    return;
+
+  if (TREE_CODE (t) == SAVE_EXPR)
+    {
+      if (SAVE_EXPR_RESOLVED_P (t))
+	{
+	  *tp = TREE_OPERAND (t, 0);
+	  return;
+	}
+      val = TREE_OPERAND (t, 0);
+    }
+  else
+    val = t;
+
+  var = gfc_create_var_np (TREE_TYPE (t), NULL);
+  gfc_add_decl_to_function (var);
+  gfc_add_modify (body, var, val);
+  if (TREE_CODE (t) == SAVE_EXPR)
+    TREE_OPERAND (t, 0) = var;
+  *tp = var;
+}
+
+static void
+gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
+{
+  tree t;
+
+  if (type == NULL || type == error_mark_node)
+    return;
+
+  type = TYPE_MAIN_VARIANT (type);
+
+  if (TREE_CODE (type) == INTEGER_TYPE)
+    {
+      gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
+      gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
+
+      for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
+	{
+	  TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
+	  TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
+	}
+    }
+  else if (TREE_CODE (type) == ARRAY_TYPE)
+    {
+      gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
+      gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
+      gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
+      gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
+
+      for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
+	{
+	  TYPE_SIZE (t) = TYPE_SIZE (type);
+	  TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
+	}
+    }
+}
+
+/* Make sure all type sizes and array domains are either constant,
+   or variable or parameter decls.  This is a simplified variant
+   of gimplify_type_sizes, but we can't use it here, as none of the
+   variables in the expressions have been gimplified yet.
+   As type sizes and domains for various variable length arrays
+   contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
+   time, without this routine gimplify_type_sizes in the middle-end
+   could result in the type sizes being gimplified earlier than where
+   those variables are initialized.  */
+
+void
+gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
+{
+  tree type = TREE_TYPE (sym->backend_decl);
+
+  if (TREE_CODE (type) == FUNCTION_TYPE
+      && (sym->attr.function || sym->attr.result || sym->attr.entry))
+    {
+      if (! current_fake_result_decl)
+	return;
+
+      type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
+    }
+
+  while (POINTER_TYPE_P (type))
+    type = TREE_TYPE (type);
+
+  if (GFC_DESCRIPTOR_TYPE_P (type))
+    {
+      tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
+
+      while (POINTER_TYPE_P (etype))
+	etype = TREE_TYPE (etype);
+
+      gfc_trans_vla_type_sizes_1 (etype, body);
+    }
+
+  gfc_trans_vla_type_sizes_1 (type, body);
+}
+
+
+/* Initialize a derived type by building an lvalue from the symbol
+   and using trans_assignment to do the work. Set dealloc to false
+   if no deallocation prior the assignment is needed.  */
+void
+gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc)
+{
+  gfc_expr *e;
+  tree tmp;
+  tree present;
+
+  gcc_assert (block);
+
+  gcc_assert (!sym->attr.allocatable);
+  gfc_set_sym_referenced (sym);
+  e = gfc_lval_expr_from_sym (sym);
+  tmp = gfc_trans_assignment (e, sym->value, false, dealloc);
+  if (sym->attr.dummy && (sym->attr.optional
+			  || sym->ns->proc_name->attr.entry_master))
+    {
+      present = gfc_conv_expr_present (sym);
+      tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
+			tmp, build_empty_stmt (input_location));
+    }
+  gfc_add_expr_to_block (block, tmp);
+  gfc_free_expr (e);
+}
+
+
+/* Initialize INTENT(OUT) derived type dummies.  As well as giving
+   them their default initializer, if they do not have allocatable
+   components, they have their allocatable components deallocated. */
+
+static void
+init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
+{
+  stmtblock_t init;
+  gfc_formal_arglist *f;
+  tree tmp;
+  tree present;
+
+  gfc_init_block (&init);
+  for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
+    if (f->sym && f->sym->attr.intent == INTENT_OUT
+	&& !f->sym->attr.pointer
+	&& f->sym->ts.type == BT_DERIVED)
+      {
+	tmp = NULL_TREE;
+
+	/* Note: Allocatables are excluded as they are already handled
+	   by the caller.  */
+	if (!f->sym->attr.allocatable
+	    && gfc_is_finalizable (f->sym->ts.u.derived, NULL))
+	  {
+	    stmtblock_t block;
+	    gfc_expr *e;
+
+	    gfc_init_block (&block);
+	    f->sym->attr.referenced = 1;
+	    e = gfc_lval_expr_from_sym (f->sym);
+	    gfc_add_finalizer_call (&block, e);
+	    gfc_free_expr (e);
+	    tmp = gfc_finish_block (&block);
+	  }
+
+	if (tmp == NULL_TREE && !f->sym->attr.allocatable
+	    && f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
+	  tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
+					   f->sym->backend_decl,
+					   f->sym->as ? f->sym->as->rank : 0);
+
+	if (tmp != NULL_TREE && (f->sym->attr.optional
+				 || f->sym->ns->proc_name->attr.entry_master))
+	  {
+	    present = gfc_conv_expr_present (f->sym);
+	    tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
+			      present, tmp, build_empty_stmt (input_location));
+	  }
+
+	if (tmp != NULL_TREE)
+	  gfc_add_expr_to_block (&init, tmp);
+	else if (f->sym->value && !f->sym->attr.allocatable)
+	  gfc_init_default_dt (f->sym, &init, true);
+      }
+    else if (f->sym && f->sym->attr.intent == INTENT_OUT
+	     && f->sym->ts.type == BT_CLASS
+	     && !CLASS_DATA (f->sym)->attr.class_pointer
+	     && !CLASS_DATA (f->sym)->attr.allocatable)
+      {
+	stmtblock_t block;
+	gfc_expr *e;
+
+	gfc_init_block (&block);
+	f->sym->attr.referenced = 1;
+	e = gfc_lval_expr_from_sym (f->sym);
+	gfc_add_finalizer_call (&block, e);
+	gfc_free_expr (e);
+	tmp = gfc_finish_block (&block);
+
+	if (f->sym->attr.optional || f->sym->ns->proc_name->attr.entry_master)
+	  {
+	    present = gfc_conv_expr_present (f->sym);
+	    tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
+			      present, tmp,
+			      build_empty_stmt (input_location));
+	  }
+
+	gfc_add_expr_to_block (&init, tmp);
+      }
+
+  gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
+}
+
+
+/* Generate function entry and exit code, and add it to the function body.
+   This includes:
+    Allocation and initialization of array variables.
+    Allocation of character string variables.
+    Initialization and possibly repacking of dummy arrays.
+    Initialization of ASSIGN statement auxiliary variable.
+    Initialization of ASSOCIATE names.
+    Automatic deallocation.  */
+
+void
+gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
+{
+  locus loc;
+  gfc_symbol *sym;
+  gfc_formal_arglist *f;
+  stmtblock_t tmpblock;
+  bool seen_trans_deferred_array = false;
+  tree tmp = NULL;
+  gfc_expr *e;
+  gfc_se se;
+  stmtblock_t init;
+
+  /* Deal with implicit return variables.  Explicit return variables will
+     already have been added.  */
+  if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
+    {
+      if (!current_fake_result_decl)
+	{
+	  gfc_entry_list *el = NULL;
+	  if (proc_sym->attr.entry_master)
+	    {
+	      for (el = proc_sym->ns->entries; el; el = el->next)
+		if (el->sym != el->sym->result)
+		  break;
+	    }
+	  /* TODO: move to the appropriate place in resolve.c.  */
+	  if (warn_return_type && el == NULL)
+	    gfc_warning ("Return value of function '%s' at %L not set",
+			 proc_sym->name, &proc_sym->declared_at);
+	}
+      else if (proc_sym->as)
+	{
+	  tree result = TREE_VALUE (current_fake_result_decl);
+	  gfc_trans_dummy_array_bias (proc_sym, result, block);
+
+	  /* An automatic character length, pointer array result.  */
+	  if (proc_sym->ts.type == BT_CHARACTER
+		&& TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
+	    gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
+	}
+      else if (proc_sym->ts.type == BT_CHARACTER)
+	{
+	  if (proc_sym->ts.deferred)
+	    {
+	      tmp = NULL;
+	      gfc_save_backend_locus (&loc);
+	      gfc_set_backend_locus (&proc_sym->declared_at);
+	      gfc_start_block (&init);
+	      /* Zero the string length on entry.  */
+	      gfc_add_modify (&init, proc_sym->ts.u.cl->backend_decl,
+			      build_int_cst (gfc_charlen_type_node, 0));
+	      /* Null the pointer.  */
+	      e = gfc_lval_expr_from_sym (proc_sym);
+	      gfc_init_se (&se, NULL);
+	      se.want_pointer = 1;
+	      gfc_conv_expr (&se, e);
+	      gfc_free_expr (e);
+	      tmp = se.expr;
+	      gfc_add_modify (&init, tmp,
+			      fold_convert (TREE_TYPE (se.expr),
+					    null_pointer_node));
+	      gfc_restore_backend_locus (&loc);
+
+	      /* Pass back the string length on exit.  */
+	      tmp = proc_sym->ts.u.cl->passed_length;
+	      tmp = build_fold_indirect_ref_loc (input_location, tmp);
+	      tmp = fold_convert (gfc_charlen_type_node, tmp);
+	      tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+				     gfc_charlen_type_node, tmp,
+				     proc_sym->ts.u.cl->backend_decl);
+	      gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
+	    }
+	  else if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
+	    gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
+	}
+      else
+	gcc_assert (gfc_option.flag_f2c
+		    && proc_sym->ts.type == BT_COMPLEX);
+    }
+
+  /* Initialize the INTENT(OUT) derived type dummy arguments.  This
+     should be done here so that the offsets and lbounds of arrays
+     are available.  */
+  gfc_save_backend_locus (&loc);
+  gfc_set_backend_locus (&proc_sym->declared_at);
+  init_intent_out_dt (proc_sym, block);
+  gfc_restore_backend_locus (&loc);
+
+  for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
+    {
+      bool alloc_comp_or_fini = (sym->ts.type == BT_DERIVED)
+				&& (sym->ts.u.derived->attr.alloc_comp
+				    || gfc_is_finalizable (sym->ts.u.derived,
+							   NULL));
+      if (sym->assoc)
+	continue;
+
+      if (sym->attr.subref_array_pointer
+	  && GFC_DECL_SPAN (sym->backend_decl)
+	  && !TREE_STATIC (GFC_DECL_SPAN (sym->backend_decl)))
+	{
+	  gfc_init_block (&tmpblock);
+	  gfc_add_modify (&tmpblock, GFC_DECL_SPAN (sym->backend_decl),
+			  build_int_cst (gfc_array_index_type, 0));
+	  gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
+				NULL_TREE);
+	}
+
+      if (sym->ts.type == BT_CLASS
+	  && (sym->attr.save || gfc_option.flag_max_stack_var_size == 0)
+	  && CLASS_DATA (sym)->attr.allocatable)
+	{
+	  tree vptr;
+
+          if (UNLIMITED_POLY (sym))
+	    vptr = null_pointer_node;
+	  else
+	    {
+	      gfc_symbol *vsym;
+	      vsym = gfc_find_derived_vtab (sym->ts.u.derived);
+	      vptr = gfc_get_symbol_decl (vsym);
+	      vptr = gfc_build_addr_expr (NULL, vptr);
+	    }
+
+	  if (CLASS_DATA (sym)->attr.dimension
+	      || (CLASS_DATA (sym)->attr.codimension
+		  && gfc_option.coarray != GFC_FCOARRAY_LIB))
+	    {
+	      tmp = gfc_class_data_get (sym->backend_decl);
+	      tmp = gfc_build_null_descriptor (TREE_TYPE (tmp));
+	    }
+	  else
+	    tmp = null_pointer_node;
+
+	  DECL_INITIAL (sym->backend_decl)
+		= 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)
+	{
+          /* 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)
+	    {
+	    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)
+		{
+		  if (TREE_STATIC (sym->backend_decl))
+		    {
+		      gfc_save_backend_locus (&loc);
+		      gfc_set_backend_locus (&sym->declared_at);
+		      gfc_trans_static_array_pointer (sym);
+		      gfc_restore_backend_locus (&loc);
+		    }
+		  else
+		    {
+		      seen_trans_deferred_array = true;
+		      gfc_trans_deferred_array (sym, block);
+		    }
+		}
+	      else if (sym->attr.codimension && TREE_STATIC (sym->backend_decl))
+		{
+		  gfc_init_block (&tmpblock);
+		  gfc_trans_array_cobounds (TREE_TYPE (sym->backend_decl),
+					    &tmpblock, sym);
+		  gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
+					NULL_TREE);
+		  continue;
+		}
+	      else if (gfc_option.coarray != GFC_FCOARRAY_LIB)
+		{
+		  gfc_save_backend_locus (&loc);
+		  gfc_set_backend_locus (&sym->declared_at);
+
+		  if (alloc_comp_or_fini)
+		    {
+		      seen_trans_deferred_array = true;
+		      gfc_trans_deferred_array (sym, block);
+		    }
+		  else if (sym->ts.type == BT_DERIVED
+			     && sym->value
+			     && !sym->attr.data
+			     && sym->attr.save == SAVE_NONE)
+		    {
+		      gfc_start_block (&tmpblock);
+		      gfc_init_default_dt (sym, &tmpblock, false);
+		      gfc_add_init_cleanup (block,
+					    gfc_finish_block (&tmpblock),
+					    NULL_TREE);
+		    }
+
+		  gfc_trans_auto_array_allocation (sym->backend_decl,
+						   sym, block);
+		  gfc_restore_backend_locus (&loc);
+		}
+	      break;
+
+	    case AS_ASSUMED_SIZE:
+	      /* Must be a dummy parameter.  */
+	      gcc_assert (sym->attr.dummy || sym->as->cp_was_assumed);
+
+	      /* We should always pass assumed size arrays the g77 way.  */
+	      if (sym->attr.dummy)
+		gfc_trans_g77_array (sym, block);
+	      break;
+
+	    case AS_ASSUMED_SHAPE:
+	      /* Must be a dummy parameter.  */
+	      gcc_assert (sym->attr.dummy);
+
+	      gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
+	      break;
+
+	    case AS_ASSUMED_RANK:
+	    case AS_DEFERRED:
+	      seen_trans_deferred_array = true;
+	      gfc_trans_deferred_array (sym, block);
+	      break;
+
+	    default:
+	      gcc_unreachable ();
+	    }
+	  if (alloc_comp_or_fini && !seen_trans_deferred_array)
+	    gfc_trans_deferred_array (sym, block);
+	}
+      else if ((!sym->attr.dummy || sym->ts.deferred)
+		&& (sym->ts.type == BT_CLASS
+		&& CLASS_DATA (sym)->attr.class_pointer))
+	continue;
+      else if ((!sym->attr.dummy || sym->ts.deferred)
+		&& (sym->attr.allocatable
+		    || (sym->ts.type == BT_CLASS
+			&& CLASS_DATA (sym)->attr.allocatable)))
+	{
+	  if (!sym->attr.save && gfc_option.flag_max_stack_var_size != 0)
+	    {
+	      tree descriptor = NULL_TREE;
+
+	      /* Nullify and automatic deallocation of allocatable
+		 scalars.  */
+	      e = gfc_lval_expr_from_sym (sym);
+	      if (sym->ts.type == BT_CLASS)
+		gfc_add_data_component (e);
+
+	      gfc_init_se (&se, NULL);
+	      if (sym->ts.type != BT_CLASS
+		  || sym->ts.u.derived->attr.dimension
+		  || sym->ts.u.derived->attr.codimension)
+		{
+		  se.want_pointer = 1;
+		  gfc_conv_expr (&se, e);
+		}
+	      else if (sym->ts.type == BT_CLASS
+		       && !CLASS_DATA (sym)->attr.dimension
+		       && !CLASS_DATA (sym)->attr.codimension)
+		{
+		  se.want_pointer = 1;
+		  gfc_conv_expr (&se, e);
+		}
+	      else
+		{
+		  gfc_conv_expr (&se, e);
+		  descriptor = se.expr;
+		  se.expr = gfc_conv_descriptor_data_addr (se.expr);
+		  se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
+		}
+	      gfc_free_expr (e);
+
+	      gfc_save_backend_locus (&loc);
+	      gfc_set_backend_locus (&sym->declared_at);
+	      gfc_start_block (&init);
+
+	      if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
+		{
+		  /* Nullify when entering the scope.  */
+		  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+					 TREE_TYPE (se.expr), se.expr,
+					 fold_convert (TREE_TYPE (se.expr),
+						       null_pointer_node));
+		  if (sym->attr.optional)
+		    {
+		      tree present = gfc_conv_expr_present (sym);
+		      tmp = build3_loc (input_location, COND_EXPR,
+					void_type_node, present, tmp,
+					build_empty_stmt (input_location));
+		    }
+		  gfc_add_expr_to_block (&init, tmp);
+		}
+
+	      if ((sym->attr.dummy || sym->attr.result)
+		    && sym->ts.type == BT_CHARACTER
+		    && sym->ts.deferred)
+		{
+		  /* Character length passed by reference.  */
+		  tmp = sym->ts.u.cl->passed_length;
+		  tmp = build_fold_indirect_ref_loc (input_location, tmp);
+		  tmp = fold_convert (gfc_charlen_type_node, tmp);
+
+		  if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
+		    /* Zero the string length when entering the scope.  */
+		    gfc_add_modify (&init, sym->ts.u.cl->backend_decl,
+				build_int_cst (gfc_charlen_type_node, 0));
+		  else
+		    {
+		      tree tmp2;
+
+		      tmp2 = fold_build2_loc (input_location, MODIFY_EXPR,
+					      gfc_charlen_type_node,
+					      sym->ts.u.cl->backend_decl, tmp);
+		      if (sym->attr.optional)
+			{
+			  tree present = gfc_conv_expr_present (sym);
+			  tmp2 = build3_loc (input_location, COND_EXPR,
+					     void_type_node, present, tmp2,
+					     build_empty_stmt (input_location));
+			}
+		      gfc_add_expr_to_block (&init, tmp2);
+		    }
+
+		  gfc_restore_backend_locus (&loc);
+
+		  /* Pass the final character length back.  */
+		  if (sym->attr.intent != INTENT_IN)
+		    {
+		      tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+					     gfc_charlen_type_node, tmp,
+					     sym->ts.u.cl->backend_decl);
+		      if (sym->attr.optional)
+			{
+			  tree present = gfc_conv_expr_present (sym);
+			  tmp = build3_loc (input_location, COND_EXPR,
+					    void_type_node, present, tmp,
+					    build_empty_stmt (input_location));
+			}
+		    }
+		  else
+		    tmp = NULL_TREE;
+		}
+	      else
+		gfc_restore_backend_locus (&loc);
+
+	      /* Deallocate when leaving the scope. Nullifying is not
+		 needed.  */
+	      if (!sym->attr.result && !sym->attr.dummy
+		  && !sym->ns->proc_name->attr.is_main_program)
+		{
+		  if (sym->ts.type == BT_CLASS
+		      && CLASS_DATA (sym)->attr.codimension)
+		    tmp = gfc_deallocate_with_status (descriptor, NULL_TREE,
+						      NULL_TREE, NULL_TREE,
+						      NULL_TREE, true, NULL,
+						      true);
+		  else
+		    {
+		      gfc_expr *expr = gfc_lval_expr_from_sym (sym);
+		      tmp = gfc_deallocate_scalar_with_status (se.expr, NULL_TREE,
+						   true, expr, sym->ts);
+		      gfc_free_expr (expr);
+		    }
+		}
+	      if (sym->ts.type == BT_CLASS)
+		{
+		  /* Initialize _vptr to declared type.  */
+		  gfc_symbol *vtab;
+		  tree rhs;
+
+		  gfc_save_backend_locus (&loc);
+		  gfc_set_backend_locus (&sym->declared_at);
+		  e = gfc_lval_expr_from_sym (sym);
+		  gfc_add_vptr_component (e);
+		  gfc_init_se (&se, NULL);
+		  se.want_pointer = 1;
+		  gfc_conv_expr (&se, e);
+		  gfc_free_expr (e);
+		  if (UNLIMITED_POLY (sym))
+		    rhs = build_int_cst (TREE_TYPE (se.expr), 0);
+		  else
+		    {
+		      vtab = gfc_find_derived_vtab (sym->ts.u.derived);
+		      rhs = gfc_build_addr_expr (TREE_TYPE (se.expr),
+						gfc_get_symbol_decl (vtab));
+		    }
+		  gfc_add_modify (&init, se.expr, rhs);
+		  gfc_restore_backend_locus (&loc);
+		}
+
+	      gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
+	    }
+	}
+      else if (sym->ts.type == BT_CHARACTER && sym->ts.deferred)
+	{
+	  tree tmp = NULL;
+	  stmtblock_t init;
+
+	  /* If we get to here, all that should be left are pointers.  */
+	  gcc_assert (sym->attr.pointer);
+
+	  if (sym->attr.dummy)
+	    {
+	      gfc_start_block (&init);
+
+	      /* Character length passed by reference.  */
+	      tmp = sym->ts.u.cl->passed_length;
+	      tmp = build_fold_indirect_ref_loc (input_location, tmp);
+	      tmp = fold_convert (gfc_charlen_type_node, tmp);
+	      gfc_add_modify (&init, sym->ts.u.cl->backend_decl, tmp);
+	      /* Pass the final character length back.  */
+	      if (sym->attr.intent != INTENT_IN)
+		tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+				       gfc_charlen_type_node, tmp,
+				       sym->ts.u.cl->backend_decl);
+	      else
+		tmp = NULL_TREE;
+	      gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
+	    }
+	}
+      else if (sym->ts.deferred)
+	gfc_fatal_error ("Deferred type parameter not yet supported");
+      else if (alloc_comp_or_fini)
+	gfc_trans_deferred_array (sym, block);
+      else if (sym->ts.type == BT_CHARACTER)
+	{
+	  gfc_save_backend_locus (&loc);
+	  gfc_set_backend_locus (&sym->declared_at);
+	  if (sym->attr.dummy || sym->attr.result)
+	    gfc_trans_dummy_character (sym, sym->ts.u.cl, block);
+	  else
+	    gfc_trans_auto_character_variable (sym, block);
+	  gfc_restore_backend_locus (&loc);
+	}
+      else if (sym->attr.assign)
+	{
+	  gfc_save_backend_locus (&loc);
+	  gfc_set_backend_locus (&sym->declared_at);
+	  gfc_trans_assign_aux_var (sym, block);
+	  gfc_restore_backend_locus (&loc);
+	}
+      else if (sym->ts.type == BT_DERIVED
+		 && sym->value
+		 && !sym->attr.data
+		 && sym->attr.save == SAVE_NONE)
+	{
+	  gfc_start_block (&tmpblock);
+	  gfc_init_default_dt (sym, &tmpblock, false);
+	  gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
+				NULL_TREE);
+	}
+      else if (!(UNLIMITED_POLY(sym)))
+	gcc_unreachable ();
+    }
+
+  gfc_init_block (&tmpblock);
+
+  for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
+    {
+      if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
+	{
+	  gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
+	  if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
+	    gfc_trans_vla_type_sizes (f->sym, &tmpblock);
+	}
+    }
+
+  if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
+      && current_fake_result_decl != NULL)
+    {
+      gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
+      if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
+	gfc_trans_vla_type_sizes (proc_sym, &tmpblock);
+    }
+
+  gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE);
+}
+
+static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
+
+/* Hash and equality functions for module_htab.  */
+
+static hashval_t
+module_htab_do_hash (const void *x)
+{
+  return htab_hash_string (((const struct module_htab_entry *)x)->name);
+}
+
+static int
+module_htab_eq (const void *x1, const void *x2)
+{
+  return strcmp ((((const struct module_htab_entry *)x1)->name),
+		 (const char *)x2) == 0;
+}
+
+/* Hash and equality functions for module_htab's decls.  */
+
+static hashval_t
+module_htab_decls_hash (const void *x)
+{
+  const_tree t = (const_tree) x;
+  const_tree n = DECL_NAME (t);
+  if (n == NULL_TREE)
+    n = TYPE_NAME (TREE_TYPE (t));
+  return htab_hash_string (IDENTIFIER_POINTER (n));
+}
+
+static int
+module_htab_decls_eq (const void *x1, const void *x2)
+{
+  const_tree t1 = (const_tree) x1;
+  const_tree n1 = DECL_NAME (t1);
+  if (n1 == NULL_TREE)
+    n1 = TYPE_NAME (TREE_TYPE (t1));
+  return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
+}
+
+struct module_htab_entry *
+gfc_find_module (const char *name)
+{
+  void **slot;
+
+  if (! module_htab)
+    module_htab = htab_create_ggc (10, module_htab_do_hash,
+				   module_htab_eq, NULL);
+
+  slot = htab_find_slot_with_hash (module_htab, name,
+				   htab_hash_string (name), INSERT);
+  if (*slot == NULL)
+    {
+      struct module_htab_entry *entry = ggc_alloc_cleared_module_htab_entry ();
+
+      entry->name = gfc_get_string (name);
+      entry->decls = htab_create_ggc (10, module_htab_decls_hash,
+				      module_htab_decls_eq, NULL);
+      *slot = (void *) entry;
+    }
+  return (struct module_htab_entry *) *slot;
+}
+
+void
+gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
+{
+  void **slot;
+  const char *name;
+
+  if (DECL_NAME (decl))
+    name = IDENTIFIER_POINTER (DECL_NAME (decl));
+  else
+    {
+      gcc_assert (TREE_CODE (decl) == TYPE_DECL);
+      name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
+    }
+  slot = htab_find_slot_with_hash (entry->decls, name,
+				   htab_hash_string (name), INSERT);
+  if (*slot == NULL)
+    *slot = (void *) decl;
+}
+
+static struct module_htab_entry *cur_module;
+
+
+/* Generate debugging symbols for namelists. This function must come after
+   generate_local_decl to ensure that the variables in the namelist are
+   already declared.  */
+
+static tree
+generate_namelist_decl (gfc_symbol * sym)
+{
+  gfc_namelist *nml;
+  tree decl;
+  vec<constructor_elt, va_gc> *nml_decls = NULL;
+
+  gcc_assert (sym->attr.flavor == FL_NAMELIST);
+  for (nml = sym->namelist; nml; nml = nml->next)
+    {
+      if (nml->sym->backend_decl == NULL_TREE)
+	{
+	  nml->sym->attr.referenced = 1;
+	  nml->sym->backend_decl = gfc_get_symbol_decl (nml->sym);
+	}
+      DECL_IGNORED_P (nml->sym->backend_decl) = 0;
+      CONSTRUCTOR_APPEND_ELT (nml_decls, NULL_TREE, nml->sym->backend_decl);
+    }
+
+  decl = make_node (NAMELIST_DECL);
+  TREE_TYPE (decl) = void_type_node;
+  NAMELIST_DECL_ASSOCIATED_DECL (decl) = build_constructor (NULL_TREE, nml_decls);
+  DECL_NAME (decl) = get_identifier (sym->name);
+  return decl;
+}
+
+
+/* Output an initialized decl for a module variable.  */
+
+static void
+gfc_create_module_variable (gfc_symbol * sym)
+{
+  tree decl;
+
+  /* Module functions with alternate entries are dealt with later and
+     would get caught by the next condition.  */
+  if (sym->attr.entry)
+    return;
+
+  /* Make sure we convert the types of the derived types from iso_c_binding
+     into (void *).  */
+  if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
+      && sym->ts.type == BT_DERIVED)
+    sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
+
+  if (sym->attr.flavor == FL_DERIVED
+      && sym->backend_decl
+      && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
+    {
+      decl = sym->backend_decl;
+      gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
+
+      if (!sym->attr.use_assoc)
+	{
+	  gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
+		      || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
+	  gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
+		      || DECL_CONTEXT (TYPE_STUB_DECL (decl))
+			   == sym->ns->proc_name->backend_decl);
+	}
+      TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
+      DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
+      gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
+    }
+
+  /* Only output variables, procedure pointers and array valued,
+     or derived type, parameters.  */
+  if (sym->attr.flavor != FL_VARIABLE
+	&& !(sym->attr.flavor == FL_PARAMETER
+	       && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
+	&& !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
+    return;
+
+  if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
+    {
+      decl = sym->backend_decl;
+      gcc_assert (DECL_FILE_SCOPE_P (decl));
+      gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
+      DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
+      gfc_module_add_decl (cur_module, decl);
+    }
+
+  /* Don't generate variables from other modules. Variables from
+     COMMONs will already have been generated.  */
+  if (sym->attr.use_assoc || sym->attr.in_common)
+    return;
+
+  /* Equivalenced variables arrive here after creation.  */
+  if (sym->backend_decl
+      && (sym->equiv_built || sym->attr.in_equivalence))
+    return;
+
+  if (sym->backend_decl && !sym->attr.vtab && !sym->attr.target)
+    internal_error ("backend decl for module variable %s already exists",
+		    sym->name);
+
+  if (sym->module && !sym->attr.result && !sym->attr.dummy
+      && (sym->attr.access == ACCESS_UNKNOWN
+	  && (sym->ns->default_access == ACCESS_PRIVATE
+	      || (sym->ns->default_access == ACCESS_UNKNOWN
+		  && gfc_option.flag_module_private))))
+    sym->attr.access = ACCESS_PRIVATE;
+
+  if (warn_unused_variable && !sym->attr.referenced
+      && sym->attr.access == ACCESS_PRIVATE)
+    gfc_warning ("Unused PRIVATE module variable '%s' declared at %L",
+		 sym->name, &sym->declared_at);
+
+  /* We always want module variables to be created.  */
+  sym->attr.referenced = 1;
+  /* Create the decl.  */
+  decl = gfc_get_symbol_decl (sym);
+
+  /* Create the variable.  */
+  pushdecl (decl);
+  gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
+  DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
+  rest_of_decl_compilation (decl, 1, 0);
+  gfc_module_add_decl (cur_module, decl);
+
+  /* Also add length of strings.  */
+  if (sym->ts.type == BT_CHARACTER)
+    {
+      tree length;
+
+      length = sym->ts.u.cl->backend_decl;
+      gcc_assert (length || sym->attr.proc_pointer);
+      if (length && !INTEGER_CST_P (length))
+        {
+          pushdecl (length);
+          rest_of_decl_compilation (length, 1, 0);
+        }
+    }
+
+  if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable
+      && sym->attr.referenced && !sym->attr.use_assoc)
+    has_coarray_vars = true;
+}
+
+/* Emit debug information for USE statements.  */
+
+static void
+gfc_trans_use_stmts (gfc_namespace * ns)
+{
+  gfc_use_list *use_stmt;
+  for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
+    {
+      struct module_htab_entry *entry
+	= gfc_find_module (use_stmt->module_name);
+      gfc_use_rename *rent;
+
+      if (entry->namespace_decl == NULL)
+	{
+	  entry->namespace_decl
+	    = build_decl (input_location,
+			  NAMESPACE_DECL,
+			  get_identifier (use_stmt->module_name),
+			  void_type_node);
+	  DECL_EXTERNAL (entry->namespace_decl) = 1;
+	}
+      gfc_set_backend_locus (&use_stmt->where);
+      if (!use_stmt->only_flag)
+	(*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
+						 NULL_TREE,
+						 ns->proc_name->backend_decl,
+						 false);
+      for (rent = use_stmt->rename; rent; rent = rent->next)
+	{
+	  tree decl, local_name;
+	  void **slot;
+
+	  if (rent->op != INTRINSIC_NONE)
+	    continue;
+
+	  slot = htab_find_slot_with_hash (entry->decls, rent->use_name,
+					   htab_hash_string (rent->use_name),
+					   INSERT);
+	  if (*slot == NULL)
+	    {
+	      gfc_symtree *st;
+
+	      st = gfc_find_symtree (ns->sym_root,
+				     rent->local_name[0]
+				     ? rent->local_name : rent->use_name);
+
+	      /* The following can happen if a derived type is renamed.  */
+	      if (!st)
+		{
+		  char *name;
+		  name = xstrdup (rent->local_name[0]
+				  ? rent->local_name : rent->use_name);
+		  name[0] = (char) TOUPPER ((unsigned char) name[0]);
+		  st = gfc_find_symtree (ns->sym_root, name);
+		  free (name);
+		  gcc_assert (st);
+		}
+
+	      /* Sometimes, generic interfaces wind up being over-ruled by a
+		 local symbol (see PR41062).  */
+	      if (!st->n.sym->attr.use_assoc)
+		continue;
+
+	      if (st->n.sym->backend_decl
+		  && DECL_P (st->n.sym->backend_decl)
+		  && st->n.sym->module
+		  && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
+		{
+		  gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
+			      || (TREE_CODE (st->n.sym->backend_decl)
+				  != VAR_DECL));
+		  decl = copy_node (st->n.sym->backend_decl);
+		  DECL_CONTEXT (decl) = entry->namespace_decl;
+		  DECL_EXTERNAL (decl) = 1;
+		  DECL_IGNORED_P (decl) = 0;
+		  DECL_INITIAL (decl) = NULL_TREE;
+		}
+	      else if (st->n.sym->attr.flavor == FL_NAMELIST
+		       && st->n.sym->attr.use_only
+		       && st->n.sym->module
+		       && strcmp (st->n.sym->module, use_stmt->module_name)
+			  == 0)
+		{
+		  decl = generate_namelist_decl (st->n.sym);
+		  DECL_CONTEXT (decl) = entry->namespace_decl;
+		  DECL_EXTERNAL (decl) = 1;
+		  DECL_IGNORED_P (decl) = 0;
+		  DECL_INITIAL (decl) = NULL_TREE;
+		}
+	      else
+		{
+		  *slot = error_mark_node;
+		  htab_clear_slot (entry->decls, slot);
+		  continue;
+		}
+	      *slot = decl;
+	    }
+	  decl = (tree) *slot;
+	  if (rent->local_name[0])
+	    local_name = get_identifier (rent->local_name);
+	  else
+	    local_name = NULL_TREE;
+	  gfc_set_backend_locus (&rent->where);
+	  (*debug_hooks->imported_module_or_decl) (decl, local_name,
+						   ns->proc_name->backend_decl,
+						   !use_stmt->only_flag);
+	}
+    }
+}
+
+
+/* Return true if expr is a constant initializer that gfc_conv_initializer
+   will handle.  */
+
+static bool
+check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
+			    bool pointer)
+{
+  gfc_constructor *c;
+  gfc_component *cm;
+
+  if (pointer)
+    return true;
+  else if (array)
+    {
+      if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
+	return true;
+      else if (expr->expr_type == EXPR_STRUCTURE)
+	return check_constant_initializer (expr, ts, false, false);
+      else if (expr->expr_type != EXPR_ARRAY)
+	return false;
+      for (c = gfc_constructor_first (expr->value.constructor);
+	   c; c = gfc_constructor_next (c))
+	{
+	  if (c->iterator)
+	    return false;
+	  if (c->expr->expr_type == EXPR_STRUCTURE)
+	    {
+	      if (!check_constant_initializer (c->expr, ts, false, false))
+		return false;
+	    }
+	  else if (c->expr->expr_type != EXPR_CONSTANT)
+	    return false;
+	}
+      return true;
+    }
+  else switch (ts->type)
+    {
+    case BT_DERIVED:
+      if (expr->expr_type != EXPR_STRUCTURE)
+	return false;
+      cm = expr->ts.u.derived->components;
+      for (c = gfc_constructor_first (expr->value.constructor);
+	   c; c = gfc_constructor_next (c), cm = cm->next)
+	{
+	  if (!c->expr || cm->attr.allocatable)
+	    continue;
+	  if (!check_constant_initializer (c->expr, &cm->ts,
+					   cm->attr.dimension,
+					   cm->attr.pointer))
+	    return false;
+	}
+      return true;
+    default:
+      return expr->expr_type == EXPR_CONSTANT;
+    }
+}
+
+/* Emit debug info for parameters and unreferenced variables with
+   initializers.  */
+
+static void
+gfc_emit_parameter_debug_info (gfc_symbol *sym)
+{
+  tree decl;
+
+  if (sym->attr.flavor != FL_PARAMETER
+      && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
+    return;
+
+  if (sym->backend_decl != NULL
+      || sym->value == NULL
+      || sym->attr.use_assoc
+      || sym->attr.dummy
+      || sym->attr.result
+      || sym->attr.function
+      || sym->attr.intrinsic
+      || sym->attr.pointer
+      || sym->attr.allocatable
+      || sym->attr.cray_pointee
+      || sym->attr.threadprivate
+      || sym->attr.is_bind_c
+      || sym->attr.subref_array_pointer
+      || sym->attr.assign)
+    return;
+
+  if (sym->ts.type == BT_CHARACTER)
+    {
+      gfc_conv_const_charlen (sym->ts.u.cl);
+      if (sym->ts.u.cl->backend_decl == NULL
+	  || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)
+	return;
+    }
+  else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
+    return;
+
+  if (sym->as)
+    {
+      int n;
+
+      if (sym->as->type != AS_EXPLICIT)
+	return;
+      for (n = 0; n < sym->as->rank; n++)
+	if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
+	    || sym->as->upper[n] == NULL
+	    || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
+	  return;
+    }
+
+  if (!check_constant_initializer (sym->value, &sym->ts,
+				   sym->attr.dimension, false))
+    return;
+
+  if (gfc_option.coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
+    return;
+
+  /* Create the decl for the variable or constant.  */
+  decl = build_decl (input_location,
+		     sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
+		     gfc_sym_identifier (sym), gfc_sym_type (sym));
+  if (sym->attr.flavor == FL_PARAMETER)
+    TREE_READONLY (decl) = 1;
+  gfc_set_decl_location (decl, &sym->declared_at);
+  if (sym->attr.dimension)
+    GFC_DECL_PACKED_ARRAY (decl) = 1;
+  DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
+  TREE_STATIC (decl) = 1;
+  TREE_USED (decl) = 1;
+  if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
+    TREE_PUBLIC (decl) = 1;
+  DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
+					      TREE_TYPE (decl),
+					      sym->attr.dimension,
+					      false, false);
+  debug_hooks->global_decl (decl);
+}
+
+
+static void
+generate_coarray_sym_init (gfc_symbol *sym)
+{
+  tree tmp, size, decl, token;
+
+  if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension
+      || sym->attr.use_assoc || !sym->attr.referenced)
+    return;
+
+  decl = sym->backend_decl;
+  TREE_USED(decl) = 1;
+  gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
+
+  /* FIXME: Workaround for PR middle-end/49106, cf. also PR middle-end/49108
+     to make sure the variable is not optimized away.  */
+  DECL_PRESERVE_P (DECL_CONTEXT (decl)) = 1;
+
+  size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl)));
+
+  /* Ensure that we do not have size=0 for zero-sized arrays.  */
+  size = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
+			  fold_convert (size_type_node, size),
+			  build_int_cst (size_type_node, 1));
+
+  if (GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)))
+    {
+      tmp = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (decl));
+      size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
+			      fold_convert (size_type_node, tmp), size);
+    }
+
+  gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (decl)) != NULL_TREE);
+  token = gfc_build_addr_expr (ppvoid_type_node,
+			       GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE(decl)));
+
+  tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 6, size,
+			     build_int_cst (integer_type_node,
+					    GFC_CAF_COARRAY_STATIC), /* type.  */
+			     token, null_pointer_node, /* token, stat.  */
+			     null_pointer_node, /* errgmsg, errmsg_len.  */
+			     build_int_cst (integer_type_node, 0));
+
+  gfc_add_modify (&caf_init_block, decl, fold_convert (TREE_TYPE (decl), tmp));
+
+
+  /* Handle "static" initializer.  */
+  if (sym->value)
+    {
+      sym->attr.pointer = 1;
+      tmp = gfc_trans_assignment (gfc_lval_expr_from_sym (sym), sym->value,
+				  true, false);
+      sym->attr.pointer = 0;
+      gfc_add_expr_to_block (&caf_init_block, tmp);
+    }
+}
+
+
+/* Generate constructor function to initialize static, nonallocatable
+   coarrays.  */
+
+static void
+generate_coarray_init (gfc_namespace * ns __attribute((unused)))
+{
+  tree fndecl, tmp, decl, save_fn_decl;
+
+  save_fn_decl = current_function_decl;
+  push_function_context ();
+
+  tmp = build_function_type_list (void_type_node, NULL_TREE);
+  fndecl = build_decl (input_location, FUNCTION_DECL,
+		       create_tmp_var_name ("_caf_init"), tmp);
+
+  DECL_STATIC_CONSTRUCTOR (fndecl) = 1;
+  SET_DECL_INIT_PRIORITY (fndecl, DEFAULT_INIT_PRIORITY);
+
+  decl = build_decl (input_location, RESULT_DECL, NULL_TREE, void_type_node);
+  DECL_ARTIFICIAL (decl) = 1;
+  DECL_IGNORED_P (decl) = 1;
+  DECL_CONTEXT (decl) = fndecl;
+  DECL_RESULT (fndecl) = decl;
+
+  pushdecl (fndecl);
+  current_function_decl = fndecl;
+  announce_function (fndecl);
+
+  rest_of_decl_compilation (fndecl, 0, 0);
+  make_decl_rtl (fndecl);
+  allocate_struct_function (fndecl, false);
+
+  pushlevel ();
+  gfc_init_block (&caf_init_block);
+
+  gfc_traverse_ns (ns, generate_coarray_sym_init);
+
+  DECL_SAVED_TREE (fndecl) = gfc_finish_block (&caf_init_block);
+  decl = getdecls ();
+
+  poplevel (1, 1);
+  BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
+
+  DECL_SAVED_TREE (fndecl)
+    = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
+                DECL_INITIAL (fndecl));
+  dump_function (TDI_original, fndecl);
+
+  cfun->function_end_locus = input_location;
+  set_cfun (NULL);
+
+  if (decl_function_context (fndecl))
+    (void) cgraph_create_node (fndecl);
+  else
+    cgraph_finalize_function (fndecl, true);
+
+  pop_function_context ();
+  current_function_decl = save_fn_decl;
+}
+
+
+static void
+create_module_nml_decl (gfc_symbol *sym)
+{
+  if (sym->attr.flavor == FL_NAMELIST)
+    {
+      tree decl = generate_namelist_decl (sym);
+      pushdecl (decl);
+      gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
+      DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
+      rest_of_decl_compilation (decl, 1, 0);
+      gfc_module_add_decl (cur_module, decl);
+    }
+}
+
+
+/* Generate all the required code for module variables.  */
+
+void
+gfc_generate_module_vars (gfc_namespace * ns)
+{
+  module_namespace = ns;
+  cur_module = gfc_find_module (ns->proc_name->name);
+
+  /* Check if the frontend left the namespace in a reasonable state.  */
+  gcc_assert (ns->proc_name && !ns->proc_name->tlink);
+
+  /* Generate COMMON blocks.  */
+  gfc_trans_common (ns);
+
+  has_coarray_vars = false;
+
+  /* Create decls for all the module variables.  */
+  gfc_traverse_ns (ns, gfc_create_module_variable);
+  gfc_traverse_ns (ns, create_module_nml_decl);
+
+  if (gfc_option.coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
+    generate_coarray_init (ns);
+
+  cur_module = NULL;
+
+  gfc_trans_use_stmts (ns);
+  gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
+}
+
+
+static void
+gfc_generate_contained_functions (gfc_namespace * parent)
+{
+  gfc_namespace *ns;
+
+  /* We create all the prototypes before generating any code.  */
+  for (ns = parent->contained; ns; ns = ns->sibling)
+    {
+      /* Skip namespaces from used modules.  */
+      if (ns->parent != parent)
+	continue;
+
+      gfc_create_function_decl (ns, false);
+    }
+
+  for (ns = parent->contained; ns; ns = ns->sibling)
+    {
+      /* Skip namespaces from used modules.  */
+      if (ns->parent != parent)
+	continue;
+
+      gfc_generate_function_code (ns);
+    }
+}
+
+
+/* Drill down through expressions for the array specification bounds and
+   character length calling generate_local_decl for all those variables
+   that have not already been declared.  */
+
+static void
+generate_local_decl (gfc_symbol *);
+
+/* Traverse expr, marking all EXPR_VARIABLE symbols referenced.  */
+
+static bool
+expr_decls (gfc_expr *e, gfc_symbol *sym,
+	    int *f ATTRIBUTE_UNUSED)
+{
+  if (e->expr_type != EXPR_VARIABLE
+	    || sym == e->symtree->n.sym
+	    || e->symtree->n.sym->mark
+	    || e->symtree->n.sym->ns != sym->ns)
+	return false;
+
+  generate_local_decl (e->symtree->n.sym);
+  return false;
+}
+
+static void
+generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
+{
+  gfc_traverse_expr (e, sym, expr_decls, 0);
+}
+
+
+/* Check for dependencies in the character length and array spec.  */
+
+static void
+generate_dependency_declarations (gfc_symbol *sym)
+{
+  int i;
+
+  if (sym->ts.type == BT_CHARACTER
+      && sym->ts.u.cl
+      && sym->ts.u.cl->length
+      && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
+    generate_expr_decls (sym, sym->ts.u.cl->length);
+
+  if (sym->as && sym->as->rank)
+    {
+      for (i = 0; i < sym->as->rank; i++)
+	{
+          generate_expr_decls (sym, sym->as->lower[i]);
+          generate_expr_decls (sym, sym->as->upper[i]);
+	}
+    }
+}
+
+
+/* Generate decls for all local variables.  We do this to ensure correct
+   handling of expressions which only appear in the specification of
+   other functions.  */
+
+static void
+generate_local_decl (gfc_symbol * sym)
+{
+  if (sym->attr.flavor == FL_VARIABLE)
+    {
+      if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable
+	  && sym->attr.referenced && !sym->attr.use_assoc)
+	has_coarray_vars = true;
+
+      if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
+	generate_dependency_declarations (sym);
+
+      if (sym->attr.referenced)
+	gfc_get_symbol_decl (sym);
+
+      /* Warnings for unused dummy arguments.  */
+      else if (sym->attr.dummy && !sym->attr.in_namelist)
+	{
+	  /* INTENT(out) dummy arguments are likely meant to be set.  */
+	  if (gfc_option.warn_unused_dummy_argument
+	      && sym->attr.intent == INTENT_OUT)
+	    {
+	      if (sym->ts.type != BT_DERIVED)
+		gfc_warning ("Dummy argument '%s' at %L was declared "
+			     "INTENT(OUT) but was not set",  sym->name,
+			     &sym->declared_at);
+	      else if (!gfc_has_default_initializer (sym->ts.u.derived)
+		       && !sym->ts.u.derived->attr.zero_comp)
+		gfc_warning ("Derived-type dummy argument '%s' at %L was "
+			     "declared INTENT(OUT) but was not set and "
+			     "does not have a default initializer",
+			     sym->name, &sym->declared_at);
+	      if (sym->backend_decl != NULL_TREE)
+		TREE_NO_WARNING(sym->backend_decl) = 1;
+	    }
+	  else if (gfc_option.warn_unused_dummy_argument)
+	    {
+	      gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
+			 &sym->declared_at);
+	      if (sym->backend_decl != NULL_TREE)
+		TREE_NO_WARNING(sym->backend_decl) = 1;
+	    }
+	}
+
+      /* Warn for unused variables, but not if they're inside a common
+	 block or a namelist.  */
+      else if (warn_unused_variable
+	       && !(sym->attr.in_common || sym->mark || sym->attr.in_namelist))
+	{
+	  if (sym->attr.use_only)
+	    {
+	      gfc_warning ("Unused module variable '%s' which has been "
+			   "explicitly imported at %L", sym->name,
+			   &sym->declared_at);
+	      if (sym->backend_decl != NULL_TREE)
+		TREE_NO_WARNING(sym->backend_decl) = 1;
+	    }
+	  else if (!sym->attr.use_assoc)
+	    {
+	      gfc_warning ("Unused variable '%s' declared at %L",
+			   sym->name, &sym->declared_at);
+	      if (sym->backend_decl != NULL_TREE)
+		TREE_NO_WARNING(sym->backend_decl) = 1;
+	    }
+	}
+
+      /* For variable length CHARACTER parameters, the PARM_DECL already
+	 references the length variable, so force gfc_get_symbol_decl
+	 even when not referenced.  If optimize > 0, it will be optimized
+	 away anyway.  But do this only after emitting -Wunused-parameter
+	 warning if requested.  */
+      if (sym->attr.dummy && !sym->attr.referenced
+	    && sym->ts.type == BT_CHARACTER
+	    && sym->ts.u.cl->backend_decl != NULL
+	    && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
+	{
+	  sym->attr.referenced = 1;
+	  gfc_get_symbol_decl (sym);
+	}
+
+      /* INTENT(out) dummy arguments and result variables with allocatable
+	 components are reset by default and need to be set referenced to
+	 generate the code for nullification and automatic lengths.  */
+      if (!sym->attr.referenced
+	    && sym->ts.type == BT_DERIVED
+	    && sym->ts.u.derived->attr.alloc_comp
+	    && !sym->attr.pointer
+	    && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)
+		  ||
+		(sym->attr.result && sym != sym->result)))
+	{
+	  sym->attr.referenced = 1;
+	  gfc_get_symbol_decl (sym);
+	}
+
+      /* Check for dependencies in the array specification and string
+	length, adding the necessary declarations to the function.  We
+	mark the symbol now, as well as in traverse_ns, to prevent
+	getting stuck in a circular dependency.  */
+      sym->mark = 1;
+    }
+  else if (sym->attr.flavor == FL_PARAMETER)
+    {
+      if (warn_unused_parameter
+           && !sym->attr.referenced)
+	{
+           if (!sym->attr.use_assoc)
+	     gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
+			  &sym->declared_at);
+	   else if (sym->attr.use_only)
+	     gfc_warning ("Unused parameter '%s' which has been explicitly "
+			  "imported at %L", sym->name, &sym->declared_at);
+	}
+    }
+  else if (sym->attr.flavor == FL_PROCEDURE)
+    {
+      /* TODO: move to the appropriate place in resolve.c.  */
+      if (warn_return_type
+	  && sym->attr.function
+	  && sym->result
+	  && sym != sym->result
+	  && !sym->result->attr.referenced
+	  && !sym->attr.use_assoc
+	  && sym->attr.if_source != IFSRC_IFBODY)
+	{
+	  gfc_warning ("Return value '%s' of function '%s' declared at "
+		       "%L not set", sym->result->name, sym->name,
+		        &sym->result->declared_at);
+
+	  /* Prevents "Unused variable" warning for RESULT variables.  */
+	  sym->result->mark = 1;
+	}
+    }
+
+  if (sym->attr.dummy == 1)
+    {
+      /* Modify the tree type for scalar character dummy arguments of bind(c)
+	 procedures if they are passed by value.  The tree type for them will
+	 be promoted to INTEGER_TYPE for the middle end, which appears to be
+	 what C would do with characters passed by-value.  The value attribute
+         implies the dummy is a scalar.  */
+      if (sym->attr.value == 1 && sym->backend_decl != NULL
+	  && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
+	  && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
+	gfc_conv_scalar_char_value (sym, NULL, NULL);
+
+      /* Unused procedure passed as dummy argument.  */
+      if (sym->attr.flavor == FL_PROCEDURE)
+	{
+	  if (!sym->attr.referenced)
+	    {
+	      if (gfc_option.warn_unused_dummy_argument)
+		gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
+			     &sym->declared_at);
+	    }
+
+	  /* Silence bogus "unused parameter" warnings from the
+	     middle end.  */
+	  if (sym->backend_decl != NULL_TREE)
+		TREE_NO_WARNING (sym->backend_decl) = 1;
+	}
+    }
+
+  /* Make sure we convert the types of the derived types from iso_c_binding
+     into (void *).  */
+  if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
+      && sym->ts.type == BT_DERIVED)
+    sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
+}
+
+
+static void
+generate_local_nml_decl (gfc_symbol * sym)
+{
+  if (sym->attr.flavor == FL_NAMELIST && !sym->attr.use_assoc)
+    {
+      tree decl = generate_namelist_decl (sym);
+      pushdecl (decl);
+    }
+}
+
+
+static void
+generate_local_vars (gfc_namespace * ns)
+{
+  gfc_traverse_ns (ns, generate_local_decl);
+  gfc_traverse_ns (ns, generate_local_nml_decl);
+}
+
+
+/* Generate a switch statement to jump to the correct entry point.  Also
+   creates the label decls for the entry points.  */
+
+static tree
+gfc_trans_entry_master_switch (gfc_entry_list * el)
+{
+  stmtblock_t block;
+  tree label;
+  tree tmp;
+  tree val;
+
+  gfc_init_block (&block);
+  for (; el; el = el->next)
+    {
+      /* Add the case label.  */
+      label = gfc_build_label_decl (NULL_TREE);
+      val = build_int_cst (gfc_array_index_type, el->id);
+      tmp = build_case_label (val, NULL_TREE, label);
+      gfc_add_expr_to_block (&block, tmp);
+
+      /* And jump to the actual entry point.  */
+      label = gfc_build_label_decl (NULL_TREE);
+      tmp = build1_v (GOTO_EXPR, label);
+      gfc_add_expr_to_block (&block, tmp);
+
+      /* Save the label decl.  */
+      el->label = label;
+    }
+  tmp = gfc_finish_block (&block);
+  /* The first argument selects the entry point.  */
+  val = DECL_ARGUMENTS (current_function_decl);
+  tmp = fold_build3_loc (input_location, SWITCH_EXPR, NULL_TREE,
+			 val, tmp, NULL_TREE);
+  return tmp;
+}
+
+
+/* Add code to string lengths of actual arguments passed to a function against
+   the expected lengths of the dummy arguments.  */
+
+static void
+add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
+{
+  gfc_formal_arglist *formal;
+
+  for (formal = gfc_sym_get_dummy_args (sym); formal; formal = formal->next)
+    if (formal->sym && formal->sym->ts.type == BT_CHARACTER
+	&& !formal->sym->ts.deferred)
+      {
+	enum tree_code comparison;
+	tree cond;
+	tree argname;
+	gfc_symbol *fsym;
+	gfc_charlen *cl;
+	const char *message;
+
+	fsym = formal->sym;
+	cl = fsym->ts.u.cl;
+
+	gcc_assert (cl);
+	gcc_assert (cl->passed_length != NULL_TREE);
+	gcc_assert (cl->backend_decl != NULL_TREE);
+
+	/* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
+	   string lengths must match exactly.  Otherwise, it is only required
+	   that the actual string length is *at least* the expected one.
+	   Sequence association allows for a mismatch of the string length
+	   if the actual argument is (part of) an array, but only if the
+	   dummy argument is an array. (See "Sequence association" in
+	   Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.)  */
+	if (fsym->attr.pointer || fsym->attr.allocatable
+	    || (fsym->as && (fsym->as->type == AS_ASSUMED_SHAPE
+			     || fsym->as->type == AS_ASSUMED_RANK)))
+	  {
+	    comparison = NE_EXPR;
+	    message = _("Actual string length does not match the declared one"
+			" for dummy argument '%s' (%ld/%ld)");
+	  }
+	else if (fsym->as && fsym->as->rank != 0)
+	  continue;
+	else
+	  {
+	    comparison = LT_EXPR;
+	    message = _("Actual string length is shorter than the declared one"
+			" for dummy argument '%s' (%ld/%ld)");
+	  }
+
+	/* Build the condition.  For optional arguments, an actual length
+	   of 0 is also acceptable if the associated string is NULL, which
+	   means the argument was not passed.  */
+	cond = fold_build2_loc (input_location, comparison, boolean_type_node,
+				cl->passed_length, cl->backend_decl);
+	if (fsym->attr.optional)
+	  {
+	    tree not_absent;
+	    tree not_0length;
+	    tree absent_failed;
+
+	    not_0length = fold_build2_loc (input_location, NE_EXPR,
+					   boolean_type_node,
+					   cl->passed_length,
+					   build_zero_cst (gfc_charlen_type_node));
+	    /* The symbol needs to be referenced for gfc_get_symbol_decl.  */
+	    fsym->attr.referenced = 1;
+	    not_absent = gfc_conv_expr_present (fsym);
+
+	    absent_failed = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+					     boolean_type_node, not_0length,
+					     not_absent);
+
+	    cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+				    boolean_type_node, cond, absent_failed);
+	  }
+
+	/* Build the runtime check.  */
+	argname = gfc_build_cstring_const (fsym->name);
+	argname = gfc_build_addr_expr (pchar_type_node, argname);
+	gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
+				 message, argname,
+				 fold_convert (long_integer_type_node,
+					       cl->passed_length),
+				 fold_convert (long_integer_type_node,
+					       cl->backend_decl));
+      }
+}
+
+
+/* Generate the _gfortran_caf_this_image and _gfortran_caf_num_images
+   global variables for -fcoarray=lib. They are placed into the translation
+   unit of the main program.  Make sure that in one TU (the one of the main
+   program), the first call to gfc_init_coarray_decl is done with true.
+   Otherwise, expect link errors.  */
+
+void
+gfc_init_coarray_decl (bool main_tu)
+{
+  if (gfc_option.coarray != GFC_FCOARRAY_LIB)
+    return;
+
+  if (gfort_gvar_caf_this_image || gfort_gvar_caf_num_images)
+    return;
+
+  push_cfun (cfun);
+
+  gfort_gvar_caf_this_image
+	= build_decl (input_location, VAR_DECL,
+		      get_identifier (PREFIX("caf_this_image")),
+		      integer_type_node);
+  DECL_ARTIFICIAL (gfort_gvar_caf_this_image) = 1;
+  TREE_USED (gfort_gvar_caf_this_image) = 1;
+  TREE_PUBLIC (gfort_gvar_caf_this_image) = 1;
+  TREE_READONLY (gfort_gvar_caf_this_image) = 0;
+
+  if (main_tu)
+    TREE_STATIC (gfort_gvar_caf_this_image) = 1;
+  else
+    DECL_EXTERNAL (gfort_gvar_caf_this_image) = 1;
+
+  pushdecl_top_level (gfort_gvar_caf_this_image);
+
+  gfort_gvar_caf_num_images
+	= build_decl (input_location, VAR_DECL,
+		      get_identifier (PREFIX("caf_num_images")),
+		      integer_type_node);
+  DECL_ARTIFICIAL (gfort_gvar_caf_num_images) = 1;
+  TREE_USED (gfort_gvar_caf_num_images) = 1;
+  TREE_PUBLIC (gfort_gvar_caf_num_images) = 1;
+  TREE_READONLY (gfort_gvar_caf_num_images) = 0;
+
+  if (main_tu)
+    TREE_STATIC (gfort_gvar_caf_num_images) = 1;
+  else
+    DECL_EXTERNAL (gfort_gvar_caf_num_images) = 1;
+
+  pushdecl_top_level (gfort_gvar_caf_num_images);
+
+  pop_cfun ();
+}
+
+
+static void
+create_main_function (tree fndecl)
+{
+  tree old_context;
+  tree ftn_main;
+  tree tmp, decl, result_decl, argc, argv, typelist, arglist;
+  stmtblock_t body;
+
+  old_context = current_function_decl;
+
+  if (old_context)
+    {
+      push_function_context ();
+      saved_parent_function_decls = saved_function_decls;
+      saved_function_decls = NULL_TREE;
+    }
+
+  /* main() function must be declared with global scope.  */
+  gcc_assert (current_function_decl == NULL_TREE);
+
+  /* Declare the function.  */
+  tmp =  build_function_type_list (integer_type_node, integer_type_node,
+				   build_pointer_type (pchar_type_node),
+				   NULL_TREE);
+  main_identifier_node = get_identifier ("main");
+  ftn_main = build_decl (input_location, FUNCTION_DECL,
+      			 main_identifier_node, tmp);
+  DECL_EXTERNAL (ftn_main) = 0;
+  TREE_PUBLIC (ftn_main) = 1;
+  TREE_STATIC (ftn_main) = 1;
+  DECL_ATTRIBUTES (ftn_main)
+      = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
+
+  /* Setup the result declaration (for "return 0").  */
+  result_decl = build_decl (input_location,
+			    RESULT_DECL, NULL_TREE, integer_type_node);
+  DECL_ARTIFICIAL (result_decl) = 1;
+  DECL_IGNORED_P (result_decl) = 1;
+  DECL_CONTEXT (result_decl) = ftn_main;
+  DECL_RESULT (ftn_main) = result_decl;
+
+  pushdecl (ftn_main);
+
+  /* Get the arguments.  */
+
+  arglist = NULL_TREE;
+  typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
+
+  tmp = TREE_VALUE (typelist);
+  argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);
+  DECL_CONTEXT (argc) = ftn_main;
+  DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
+  TREE_READONLY (argc) = 1;
+  gfc_finish_decl (argc);
+  arglist = chainon (arglist, argc);
+
+  typelist = TREE_CHAIN (typelist);
+  tmp = TREE_VALUE (typelist);
+  argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);
+  DECL_CONTEXT (argv) = ftn_main;
+  DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
+  TREE_READONLY (argv) = 1;
+  DECL_BY_REFERENCE (argv) = 1;
+  gfc_finish_decl (argv);
+  arglist = chainon (arglist, argv);
+
+  DECL_ARGUMENTS (ftn_main) = arglist;
+  current_function_decl = ftn_main;
+  announce_function (ftn_main);
+
+  rest_of_decl_compilation (ftn_main, 1, 0);
+  make_decl_rtl (ftn_main);
+  allocate_struct_function (ftn_main, false);
+  pushlevel ();
+
+  gfc_init_block (&body);
+
+  /* Call some libgfortran initialization routines, call then MAIN__(). */
+
+  /* Call _gfortran_caf_init (*argc, ***argv, *this_image, *num_images).  */
+  if (gfc_option.coarray == GFC_FCOARRAY_LIB)
+    {
+      tree pint_type, pppchar_type;
+      pint_type = build_pointer_type (integer_type_node);
+      pppchar_type
+	= build_pointer_type (build_pointer_type (pchar_type_node));
+
+      gfc_init_coarray_decl (true);
+      tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_init, 4,
+		gfc_build_addr_expr (pint_type, argc),
+		gfc_build_addr_expr (pppchar_type, argv),
+		gfc_build_addr_expr (pint_type, gfort_gvar_caf_this_image),
+		gfc_build_addr_expr (pint_type, gfort_gvar_caf_num_images));
+      gfc_add_expr_to_block (&body, tmp);
+    }
+
+  /* Call _gfortran_set_args (argc, argv).  */
+  TREE_USED (argc) = 1;
+  TREE_USED (argv) = 1;
+  tmp = build_call_expr_loc (input_location,
+			 gfor_fndecl_set_args, 2, argc, argv);
+  gfc_add_expr_to_block (&body, tmp);
+
+  /* Add a call to set_options to set up the runtime library Fortran
+     language standard parameters.  */
+  {
+    tree array_type, array, var;
+    vec<constructor_elt, va_gc> *v = NULL;
+
+    /* Passing a new option to the library requires four modifications:
+     + add it to the tree_cons list below
+          + change the array size in the call to build_array_type
+          + change the first argument to the library call
+            gfor_fndecl_set_options
+          + modify the library (runtime/compile_options.c)!  */
+
+    CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
+                            build_int_cst (integer_type_node,
+                                           gfc_option.warn_std));
+    CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
+                            build_int_cst (integer_type_node,
+                                           gfc_option.allow_std));
+    CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
+                            build_int_cst (integer_type_node, pedantic));
+    /* TODO: This is the old -fdump-core option, which is unused but
+       passed due to ABI compatibility; remove when bumping the
+       library ABI.  */
+    CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
+                            build_int_cst (integer_type_node,
+                                           0));
+    CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
+                            build_int_cst (integer_type_node,
+                                           gfc_option.flag_backtrace));
+    CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
+                            build_int_cst (integer_type_node,
+                                           gfc_option.flag_sign_zero));
+    CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
+                            build_int_cst (integer_type_node,
+                                           (gfc_option.rtcheck
+                                            & GFC_RTCHECK_BOUNDS)));
+    /* TODO: This is the -frange-check option, which no longer affects
+       library behavior; when bumping the library ABI this slot can be
+       reused for something else. As it is the last element in the
+       array, we can instead leave it out altogether. */
+    CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
+                            build_int_cst (integer_type_node, 0));
+    CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
+                            build_int_cst (integer_type_node,
+                                           gfc_option.fpe_summary));
+
+    array_type = build_array_type (integer_type_node,
+				   build_index_type (size_int (8)));
+    array = build_constructor (array_type, v);
+    TREE_CONSTANT (array) = 1;
+    TREE_STATIC (array) = 1;
+
+    /* Create a static variable to hold the jump table.  */
+    var = gfc_create_var (array_type, "options");
+    TREE_CONSTANT (var) = 1;
+    TREE_STATIC (var) = 1;
+    TREE_READONLY (var) = 1;
+    DECL_INITIAL (var) = array;
+    var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
+
+    tmp = build_call_expr_loc (input_location,
+			   gfor_fndecl_set_options, 2,
+			   build_int_cst (integer_type_node, 9), var);
+    gfc_add_expr_to_block (&body, tmp);
+  }
+
+  /* If -ffpe-trap option was provided, add a call to set_fpe so that
+     the library will raise a FPE when needed.  */
+  if (gfc_option.fpe != 0)
+    {
+      tmp = build_call_expr_loc (input_location,
+			     gfor_fndecl_set_fpe, 1,
+			     build_int_cst (integer_type_node,
+					    gfc_option.fpe));
+      gfc_add_expr_to_block (&body, tmp);
+    }
+
+  /* If this is the main program and an -fconvert option was provided,
+     add a call to set_convert.  */
+
+  if (gfc_option.convert != GFC_CONVERT_NATIVE)
+    {
+      tmp = build_call_expr_loc (input_location,
+			     gfor_fndecl_set_convert, 1,
+			     build_int_cst (integer_type_node,
+					    gfc_option.convert));
+      gfc_add_expr_to_block (&body, tmp);
+    }
+
+  /* If this is the main program and an -frecord-marker option was provided,
+     add a call to set_record_marker.  */
+
+  if (gfc_option.record_marker != 0)
+    {
+      tmp = build_call_expr_loc (input_location,
+			     gfor_fndecl_set_record_marker, 1,
+			     build_int_cst (integer_type_node,
+					    gfc_option.record_marker));
+      gfc_add_expr_to_block (&body, tmp);
+    }
+
+  if (gfc_option.max_subrecord_length != 0)
+    {
+      tmp = build_call_expr_loc (input_location,
+			     gfor_fndecl_set_max_subrecord_length, 1,
+			     build_int_cst (integer_type_node,
+					    gfc_option.max_subrecord_length));
+      gfc_add_expr_to_block (&body, tmp);
+    }
+
+  /* Call MAIN__().  */
+  tmp = build_call_expr_loc (input_location,
+			 fndecl, 0);
+  gfc_add_expr_to_block (&body, tmp);
+
+  /* Mark MAIN__ as used.  */
+  TREE_USED (fndecl) = 1;
+
+  /* Coarray: Call _gfortran_caf_finalize(void).  */
+  if (gfc_option.coarray == GFC_FCOARRAY_LIB)
+    {
+      /* Per F2008, 8.5.1 END of the main program implies a
+	 SYNC MEMORY.  */
+      tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
+      tmp = build_call_expr_loc (input_location, tmp, 0);
+      gfc_add_expr_to_block (&body, tmp);
+
+      tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0);
+      gfc_add_expr_to_block (&body, tmp);
+    }
+
+  /* "return 0".  */
+  tmp = fold_build2_loc (input_location, MODIFY_EXPR, integer_type_node,
+			 DECL_RESULT (ftn_main),
+			 build_int_cst (integer_type_node, 0));
+  tmp = build1_v (RETURN_EXPR, tmp);
+  gfc_add_expr_to_block (&body, tmp);
+
+
+  DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
+  decl = getdecls ();
+
+  /* Finish off this function and send it for code generation.  */
+  poplevel (1, 1);
+  BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
+
+  DECL_SAVED_TREE (ftn_main)
+    = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
+		DECL_INITIAL (ftn_main));
+
+  /* Output the GENERIC tree.  */
+  dump_function (TDI_original, ftn_main);
+
+  cgraph_finalize_function (ftn_main, true);
+
+  if (old_context)
+    {
+      pop_function_context ();
+      saved_function_decls = saved_parent_function_decls;
+    }
+  current_function_decl = old_context;
+}
+
+
+/* Get the result expression for a procedure.  */
+
+static tree
+get_proc_result (gfc_symbol* sym)
+{
+  if (sym->attr.subroutine || sym == sym->result)
+    {
+      if (current_fake_result_decl != NULL)
+	return TREE_VALUE (current_fake_result_decl);
+
+      return NULL_TREE;
+    }
+
+  return sym->result->backend_decl;
+}
+
+
+/* Generate an appropriate return-statement for a procedure.  */
+
+tree
+gfc_generate_return (void)
+{
+  gfc_symbol* sym;
+  tree result;
+  tree fndecl;
+
+  sym = current_procedure_symbol;
+  fndecl = sym->backend_decl;
+
+  if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node)
+    result = NULL_TREE;
+  else
+    {
+      result = get_proc_result (sym);
+
+      /* Set the return value to the dummy result variable.  The
+	 types may be different for scalar default REAL functions
+	 with -ff2c, therefore we have to convert.  */
+      if (result != NULL_TREE)
+	{
+	  result = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
+	  result = fold_build2_loc (input_location, MODIFY_EXPR,
+				    TREE_TYPE (result), DECL_RESULT (fndecl),
+				    result);
+	}
+    }
+
+  return build1_v (RETURN_EXPR, result);
+}
+
+
+/* Generate code for a function.  */
+
+void
+gfc_generate_function_code (gfc_namespace * ns)
+{
+  tree fndecl;
+  tree old_context;
+  tree decl;
+  tree tmp;
+  stmtblock_t init, cleanup;
+  stmtblock_t body;
+  gfc_wrapped_block try_block;
+  tree recurcheckvar = NULL_TREE;
+  gfc_symbol *sym;
+  gfc_symbol *previous_procedure_symbol;
+  int rank;
+  bool is_recursive;
+
+  sym = ns->proc_name;
+  previous_procedure_symbol = current_procedure_symbol;
+  current_procedure_symbol = sym;
+
+  /* Check that the frontend isn't still using this.  */
+  gcc_assert (sym->tlink == NULL);
+  sym->tlink = sym;
+
+  /* Create the declaration for functions with global scope.  */
+  if (!sym->backend_decl)
+    gfc_create_function_decl (ns, false);
+
+  fndecl = sym->backend_decl;
+  old_context = current_function_decl;
+
+  if (old_context)
+    {
+      push_function_context ();
+      saved_parent_function_decls = saved_function_decls;
+      saved_function_decls = NULL_TREE;
+    }
+
+  trans_function_start (sym);
+
+  gfc_init_block (&init);
+
+  if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
+    {
+      /* Copy length backend_decls to all entry point result
+	 symbols.  */
+      gfc_entry_list *el;
+      tree backend_decl;
+
+      gfc_conv_const_charlen (ns->proc_name->ts.u.cl);
+      backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;
+      for (el = ns->entries; el; el = el->next)
+	el->sym->result->ts.u.cl->backend_decl = backend_decl;
+    }
+
+  /* Translate COMMON blocks.  */
+  gfc_trans_common (ns);
+
+  /* Null the parent fake result declaration if this namespace is
+     a module function or an external procedures.  */
+  if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
+	|| ns->parent == NULL)
+    parent_fake_result_decl = NULL_TREE;
+
+  gfc_generate_contained_functions (ns);
+
+  nonlocal_dummy_decls = NULL;
+  nonlocal_dummy_decl_pset = NULL;
+
+  has_coarray_vars = false;
+  generate_local_vars (ns);
+
+  if (gfc_option.coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
+    generate_coarray_init (ns);
+
+  /* Keep the parent fake result declaration in module functions
+     or external procedures.  */
+  if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
+	|| ns->parent == NULL)
+    current_fake_result_decl = parent_fake_result_decl;
+  else
+    current_fake_result_decl = NULL_TREE;
+
+  is_recursive = sym->attr.recursive
+		 || (sym->attr.entry_master
+		     && sym->ns->entries->sym->attr.recursive);
+  if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
+	&& !is_recursive
+	&& !gfc_option.flag_recursive)
+    {
+      char * msg;
+
+      asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
+		sym->name);
+      recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
+      TREE_STATIC (recurcheckvar) = 1;
+      DECL_INITIAL (recurcheckvar) = boolean_false_node;
+      gfc_add_expr_to_block (&init, recurcheckvar);
+      gfc_trans_runtime_check (true, false, recurcheckvar, &init,
+			       &sym->declared_at, msg);
+      gfc_add_modify (&init, recurcheckvar, boolean_true_node);
+      free (msg);
+    }
+
+  /* Now generate the code for the body of this function.  */
+  gfc_init_block (&body);
+
+  if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
+	&& sym->attr.subroutine)
+    {
+      tree alternate_return;
+      alternate_return = gfc_get_fake_result_decl (sym, 0);
+      gfc_add_modify (&body, alternate_return, integer_zero_node);
+    }
+
+  if (ns->entries)
+    {
+      /* Jump to the correct entry point.  */
+      tmp = gfc_trans_entry_master_switch (ns->entries);
+      gfc_add_expr_to_block (&body, tmp);
+    }
+
+  /* If bounds-checking is enabled, generate code to check passed in actual
+     arguments against the expected dummy argument attributes (e.g. string
+     lengths).  */
+  if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)
+    add_argument_checking (&body, sym);
+
+  tmp = gfc_trans_code (ns->code);
+  gfc_add_expr_to_block (&body, tmp);
+
+  if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
+    {
+      tree result = get_proc_result (sym);
+
+      if (result != NULL_TREE && sym->attr.function && !sym->attr.pointer)
+	{
+	  if (sym->attr.allocatable && sym->attr.dimension == 0
+	      && sym->result == sym)
+	    gfc_add_modify (&init, result, fold_convert (TREE_TYPE (result),
+							 null_pointer_node));
+	  else if (sym->ts.type == BT_CLASS
+		   && CLASS_DATA (sym)->attr.allocatable
+		   && CLASS_DATA (sym)->attr.dimension == 0
+		   && sym->result == sym)
+	    {
+	      tmp = CLASS_DATA (sym)->backend_decl;
+	      tmp = fold_build3_loc (input_location, COMPONENT_REF,
+				     TREE_TYPE (tmp), result, tmp, NULL_TREE);
+	      gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp),
+							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);
+	    }
+	}
+
+      if (result == NULL_TREE)
+	{
+	  /* TODO: move to the appropriate place in resolve.c.  */
+	  if (warn_return_type && sym == sym->result)
+	    gfc_warning ("Return value of function '%s' at %L not set",
+			 sym->name, &sym->declared_at);
+	  if (warn_return_type)
+	    TREE_NO_WARNING(sym->backend_decl) = 1;
+	}
+      else
+	gfc_add_expr_to_block (&body, gfc_generate_return ());
+    }
+
+  gfc_init_block (&cleanup);
+
+  /* Reset recursion-check variable.  */
+  if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
+	 && !is_recursive
+	 && !gfc_option.gfc_flag_openmp
+	 && recurcheckvar != NULL_TREE)
+    {
+      gfc_add_modify (&cleanup, recurcheckvar, boolean_false_node);
+      recurcheckvar = NULL;
+    }
+
+  /* Finish the function body and add init and cleanup code.  */
+  tmp = gfc_finish_block (&body);
+  gfc_start_wrapped_block (&try_block, tmp);
+  /* Add code to create and cleanup arrays.  */
+  gfc_trans_deferred_vars (sym, &try_block);
+  gfc_add_init_cleanup (&try_block, gfc_finish_block (&init),
+			gfc_finish_block (&cleanup));
+
+  /* Add all the decls we created during processing.  */
+  decl = saved_function_decls;
+  while (decl)
+    {
+      tree next;
+
+      next = DECL_CHAIN (decl);
+      DECL_CHAIN (decl) = NULL_TREE;
+      pushdecl (decl);
+      decl = next;
+    }
+  saved_function_decls = NULL_TREE;
+
+  DECL_SAVED_TREE (fndecl) = gfc_finish_wrapped_block (&try_block);
+  decl = getdecls ();
+
+  /* Finish off this function and send it for code generation.  */
+  poplevel (1, 1);
+  BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
+
+  DECL_SAVED_TREE (fndecl)
+    = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
+		DECL_INITIAL (fndecl));
+
+  if (nonlocal_dummy_decls)
+    {
+      BLOCK_VARS (DECL_INITIAL (fndecl))
+	= chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
+      pointer_set_destroy (nonlocal_dummy_decl_pset);
+      nonlocal_dummy_decls = NULL;
+      nonlocal_dummy_decl_pset = NULL;
+    }
+
+  /* Output the GENERIC tree.  */
+  dump_function (TDI_original, fndecl);
+
+  /* Store the end of the function, so that we get good line number
+     info for the epilogue.  */
+  cfun->function_end_locus = input_location;
+
+  /* We're leaving the context of this function, so zap cfun.
+     It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
+     tree_rest_of_compilation.  */
+  set_cfun (NULL);
+
+  if (old_context)
+    {
+      pop_function_context ();
+      saved_function_decls = saved_parent_function_decls;
+    }
+  current_function_decl = old_context;
+
+  if (decl_function_context (fndecl))
+    {
+      /* Register this function with cgraph just far enough to get it
+	 added to our parent's nested function list.
+	 If there are static coarrays in this function, the nested _caf_init
+	 function has already called cgraph_create_node, which also created
+	 the cgraph node for this function.  */
+      if (!has_coarray_vars || gfc_option.coarray != GFC_FCOARRAY_LIB)
+	(void) cgraph_create_node (fndecl);
+    }
+  else
+    cgraph_finalize_function (fndecl, true);
+
+  gfc_trans_use_stmts (ns);
+  gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
+
+  if (sym->attr.is_main_program)
+    create_main_function (fndecl);
+
+  current_procedure_symbol = previous_procedure_symbol;
+}
+
+
+void
+gfc_generate_constructors (void)
+{
+  gcc_assert (gfc_static_ctors == NULL_TREE);
+#if 0
+  tree fnname;
+  tree type;
+  tree fndecl;
+  tree decl;
+  tree tmp;
+
+  if (gfc_static_ctors == NULL_TREE)
+    return;
+
+  fnname = get_file_function_name ("I");
+  type = build_function_type_list (void_type_node, NULL_TREE);
+
+  fndecl = build_decl (input_location,
+		       FUNCTION_DECL, fnname, type);
+  TREE_PUBLIC (fndecl) = 1;
+
+  decl = build_decl (input_location,
+		     RESULT_DECL, NULL_TREE, void_type_node);
+  DECL_ARTIFICIAL (decl) = 1;
+  DECL_IGNORED_P (decl) = 1;
+  DECL_CONTEXT (decl) = fndecl;
+  DECL_RESULT (fndecl) = decl;
+
+  pushdecl (fndecl);
+
+  current_function_decl = fndecl;
+
+  rest_of_decl_compilation (fndecl, 1, 0);
+
+  make_decl_rtl (fndecl);
+
+  allocate_struct_function (fndecl, false);
+
+  pushlevel ();
+
+  for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
+    {
+      tmp = build_call_expr_loc (input_location,
+			     TREE_VALUE (gfc_static_ctors), 0);
+      DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
+    }
+
+  decl = getdecls ();
+  poplevel (1, 1);
+
+  BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
+  DECL_SAVED_TREE (fndecl)
+    = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
+		DECL_INITIAL (fndecl));
+
+  free_after_parsing (cfun);
+  free_after_compilation (cfun);
+
+  tree_rest_of_compilation (fndecl);
+
+  current_function_decl = NULL_TREE;
+#endif
+}
+
+/* Translates a BLOCK DATA program unit. This means emitting the
+   commons contained therein plus their initializations. We also emit
+   a globally visible symbol to make sure that each BLOCK DATA program
+   unit remains unique.  */
+
+void
+gfc_generate_block_data (gfc_namespace * ns)
+{
+  tree decl;
+  tree id;
+
+  /* Tell the backend the source location of the block data.  */
+  if (ns->proc_name)
+    gfc_set_backend_locus (&ns->proc_name->declared_at);
+  else
+    gfc_set_backend_locus (&gfc_current_locus);
+
+  /* Process the DATA statements.  */
+  gfc_trans_common (ns);
+
+  /* Create a global symbol with the mane of the block data.  This is to
+     generate linker errors if the same name is used twice.  It is never
+     really used.  */
+  if (ns->proc_name)
+    id = gfc_sym_mangled_function_id (ns->proc_name);
+  else
+    id = get_identifier ("__BLOCK_DATA__");
+
+  decl = build_decl (input_location,
+		     VAR_DECL, id, gfc_array_index_type);
+  TREE_PUBLIC (decl) = 1;
+  TREE_STATIC (decl) = 1;
+  DECL_IGNORED_P (decl) = 1;
+
+  pushdecl (decl);
+  rest_of_decl_compilation (decl, 1, 0);
+}
+
+
+/* Process the local variables of a BLOCK construct.  */
+
+void
+gfc_process_block_locals (gfc_namespace* ns)
+{
+  tree decl;
+
+  gcc_assert (saved_local_decls == NULL_TREE);
+  has_coarray_vars = false;
+
+  generate_local_vars (ns);
+
+  if (gfc_option.coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
+    generate_coarray_init (ns);
+
+  decl = saved_local_decls;
+  while (decl)
+    {
+      tree next;
+
+      next = DECL_CHAIN (decl);
+      DECL_CHAIN (decl) = NULL_TREE;
+      pushdecl (decl);
+      decl = next;
+    }
+  saved_local_decls = NULL_TREE;
+}
+
+
+#include "gt-fortran-trans-decl.h"
diff --git a/gcc-4.9/gcc/fortran/trans-expr.c b/gcc-4.9/gcc/fortran/trans-expr.c
new file mode 100644
index 000000000..f5350bb5b
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/trans-expr.c
@@ -0,0 +1,8215 @@
+/* Expression translation
+   Copyright (C) 2002-2014 Free Software Foundation, Inc.
+   Contributed by Paul Brook <paul@nowt.org>
+   and Steven Bosscher <s.bosscher@student.tudelft.nl>
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+/* trans-expr.c-- generate GENERIC trees for gfc_expr.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "tree.h"
+#include "stringpool.h"
+#include "diagnostic-core.h"	/* For fatal_error.  */
+#include "langhooks.h"
+#include "flags.h"
+#include "gfortran.h"
+#include "arith.h"
+#include "constructor.h"
+#include "trans.h"
+#include "trans-const.h"
+#include "trans-types.h"
+#include "trans-array.h"
+/* Only for gfc_trans_assign and gfc_trans_pointer_assign.  */
+#include "trans-stmt.h"
+#include "dependency.h"
+#include "gimplify.h"
+
+
+/* Convert a scalar to an array descriptor. To be used for assumed-rank
+   arrays.  */
+
+static tree
+get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
+{
+  enum gfc_array_kind akind;
+
+  if (attr.pointer)
+    akind = GFC_ARRAY_POINTER_CONT;
+  else if (attr.allocatable)
+    akind = GFC_ARRAY_ALLOCATABLE;
+  else
+    akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
+
+  return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
+				    akind, !(attr.pointer || attr.target));
+}
+
+tree
+gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
+{
+  tree desc, type;
+
+  type = get_scalar_to_descriptor_type (scalar, attr);
+  desc = gfc_create_var (type, "desc");
+  DECL_ARTIFICIAL (desc) = 1;
+  gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
+		  gfc_get_dtype (type));
+  gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
+
+  /* Copy pointer address back - but only if it could have changed and
+     if the actual argument is a pointer and not, e.g., NULL().  */
+  if ((attr.pointer || attr.allocatable)
+       && attr.intent != INTENT_IN && POINTER_TYPE_P (TREE_TYPE (scalar)))
+    gfc_add_modify (&se->post, scalar,
+		    fold_convert (TREE_TYPE (scalar),
+				  gfc_conv_descriptor_data_get (desc)));
+  return desc;
+}
+
+
+/* This is the seed for an eventual trans-class.c
+
+   The following parameters should not be used directly since they might
+   in future implementations.  Use the corresponding APIs.  */
+#define CLASS_DATA_FIELD 0
+#define CLASS_VPTR_FIELD 1
+#define VTABLE_HASH_FIELD 0
+#define VTABLE_SIZE_FIELD 1
+#define VTABLE_EXTENDS_FIELD 2
+#define VTABLE_DEF_INIT_FIELD 3
+#define VTABLE_COPY_FIELD 4
+#define VTABLE_FINAL_FIELD 5
+
+
+tree
+gfc_class_set_static_fields (tree decl, tree vptr, tree data)
+{
+  tree tmp;
+  tree field;
+  vec<constructor_elt, va_gc> *init = NULL;
+
+  field = TYPE_FIELDS (TREE_TYPE (decl));
+  tmp = gfc_advance_chain (field, CLASS_DATA_FIELD);
+  CONSTRUCTOR_APPEND_ELT (init, tmp, data);
+
+  tmp = gfc_advance_chain (field, CLASS_VPTR_FIELD);
+  CONSTRUCTOR_APPEND_ELT (init, tmp, vptr);
+
+  return build_constructor (TREE_TYPE (decl), init);
+}
+
+
+tree
+gfc_class_data_get (tree decl)
+{
+  tree data;
+  if (POINTER_TYPE_P (TREE_TYPE (decl)))
+    decl = build_fold_indirect_ref_loc (input_location, decl);
+  data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
+			    CLASS_DATA_FIELD);
+  return fold_build3_loc (input_location, COMPONENT_REF,
+			  TREE_TYPE (data), decl, data,
+			  NULL_TREE);
+}
+
+
+tree
+gfc_class_vptr_get (tree decl)
+{
+  tree vptr;
+  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)),
+			    CLASS_VPTR_FIELD);
+  return fold_build3_loc (input_location, COMPONENT_REF,
+			  TREE_TYPE (vptr), decl, vptr,
+			  NULL_TREE);
+}
+
+
+static tree
+gfc_vtable_field_get (tree decl, int field)
+{
+  tree size;
+  tree vptr;
+  vptr = gfc_class_vptr_get (decl);
+  vptr = build_fold_indirect_ref_loc (input_location, vptr);
+  size = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
+			    field);
+  size = fold_build3_loc (input_location, COMPONENT_REF,
+			  TREE_TYPE (size), vptr, size,
+			  NULL_TREE);
+  /* Always return size as an array index type.  */
+  if (field == VTABLE_SIZE_FIELD)
+    size = fold_convert (gfc_array_index_type, size);
+  gcc_assert (size);
+  return size;
+}
+
+
+tree
+gfc_vtable_hash_get (tree decl)
+{
+  return gfc_vtable_field_get (decl, VTABLE_HASH_FIELD);
+}
+
+
+tree
+gfc_vtable_size_get (tree decl)
+{
+  return gfc_vtable_field_get (decl, VTABLE_SIZE_FIELD);
+}
+
+
+tree
+gfc_vtable_extends_get (tree decl)
+{
+  return gfc_vtable_field_get (decl, VTABLE_EXTENDS_FIELD);
+}
+
+
+tree
+gfc_vtable_def_init_get (tree decl)
+{
+  return gfc_vtable_field_get (decl, VTABLE_DEF_INIT_FIELD);
+}
+
+
+tree
+gfc_vtable_copy_get (tree decl)
+{
+  return gfc_vtable_field_get (decl, VTABLE_COPY_FIELD);
+}
+
+
+tree
+gfc_vtable_final_get (tree decl)
+{
+  return gfc_vtable_field_get (decl, VTABLE_FINAL_FIELD);
+}
+
+
+#undef CLASS_DATA_FIELD
+#undef CLASS_VPTR_FIELD
+#undef VTABLE_HASH_FIELD
+#undef VTABLE_SIZE_FIELD
+#undef VTABLE_EXTENDS_FIELD
+#undef VTABLE_DEF_INIT_FIELD
+#undef VTABLE_COPY_FIELD
+#undef VTABLE_FINAL_FIELD
+
+
+/* Reset the vptr to the declared type, e.g. after deallocation.  */
+
+void
+gfc_reset_vptr (stmtblock_t *block, gfc_expr *e)
+{
+  gfc_expr *rhs, *lhs = gfc_copy_expr (e);
+  gfc_symbol *vtab;
+  tree tmp;
+  gfc_ref *ref;
+
+  /* If we have a class array, we need go back to the class
+     container. */
+  if (lhs->ref && lhs->ref->next && !lhs->ref->next->next
+      && lhs->ref->next->type == REF_ARRAY
+      && lhs->ref->next->u.ar.type == AR_FULL
+      && lhs->ref->type == REF_COMPONENT
+      && strcmp (lhs->ref->u.c.component->name, "_data") == 0)
+    {
+      gfc_free_ref_list (lhs->ref);
+      lhs->ref = NULL;
+    }
+  else
+    for (ref = lhs->ref; ref; ref = ref->next)
+      if (ref->next && ref->next->next && !ref->next->next->next
+	  && ref->next->next->type == REF_ARRAY
+	  && ref->next->next->u.ar.type == AR_FULL
+	  && ref->next->type == REF_COMPONENT
+	  && strcmp (ref->next->u.c.component->name, "_data") == 0)
+	{
+	  gfc_free_ref_list (ref->next);
+	  ref->next = NULL;
+	}
+
+  gfc_add_vptr_component (lhs);
+
+  if (UNLIMITED_POLY (e))
+    rhs = gfc_get_null_expr (NULL);
+  else
+    {
+      vtab = gfc_find_derived_vtab (e->ts.u.derived);
+      rhs = gfc_lval_expr_from_sym (vtab);
+    }
+  tmp = gfc_trans_pointer_assignment (lhs, rhs);
+  gfc_add_expr_to_block (block, tmp);
+  gfc_free_expr (lhs);
+  gfc_free_expr (rhs);
+}
+
+
+/* Obtain the vptr of the last class reference in an expression.
+   Return NULL_TREE if no class reference is found.  */
+
+tree
+gfc_get_vptr_from_expr (tree expr)
+{
+  tree tmp;
+  tree type;
+
+  for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
+    {
+      type = TREE_TYPE (tmp);
+      while (type)
+	{
+	  if (GFC_CLASS_TYPE_P (type))
+	    return gfc_class_vptr_get (tmp);
+	  if (type != TYPE_CANONICAL (type))
+	    type = TYPE_CANONICAL (type);
+	  else
+	    type = NULL_TREE;
+	}
+      if (TREE_CODE (tmp) == VAR_DECL)
+	break;
+    }
+  return NULL_TREE;
+}
+
+
+static void
+class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
+			 bool lhs_type)
+{
+  tree tmp, tmp2, type;
+
+  gfc_conv_descriptor_data_set (block, lhs_desc,
+				gfc_conv_descriptor_data_get (rhs_desc));
+  gfc_conv_descriptor_offset_set (block, lhs_desc,
+				  gfc_conv_descriptor_offset_get (rhs_desc));
+
+  gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc),
+		  gfc_conv_descriptor_dtype (rhs_desc));
+
+  /* Assign the dimension as range-ref.  */
+  tmp = gfc_get_descriptor_dimension (lhs_desc);
+  tmp2 = gfc_get_descriptor_dimension (rhs_desc);
+
+  type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2);
+  tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
+		    gfc_index_zero_node, NULL_TREE, NULL_TREE);
+  tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2,
+		     gfc_index_zero_node, NULL_TREE, NULL_TREE);
+  gfc_add_modify (block, tmp, tmp2);
+}
+
+
+/* Takes a derived type expression and returns the address of a temporary
+   class object of the 'declared' type.  If vptr is not NULL, this is
+   used for the temporary class object.
+   optional_alloc_ptr is false when the dummy is neither allocatable
+   nor a pointer; that's only relevant for the optional handling.  */
+void
+gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
+			   gfc_typespec class_ts, tree vptr, bool optional,
+			   bool optional_alloc_ptr)
+{
+  gfc_symbol *vtab;
+  tree cond_optional = NULL_TREE;
+  gfc_ss *ss;
+  tree ctree;
+  tree var;
+  tree tmp;
+
+  /* The derived type needs to be converted to a temporary
+     CLASS object.  */
+  tmp = gfc_typenode_for_spec (&class_ts);
+  var = gfc_create_var (tmp, "class");
+
+  /* Set the vptr.  */
+  ctree =  gfc_class_vptr_get (var);
+
+  if (vptr != NULL_TREE)
+    {
+      /* Use the dynamic vptr.  */
+      tmp = vptr;
+    }
+  else
+    {
+      /* In this case the vtab corresponds to the derived type and the
+	 vptr must point to it.  */
+      vtab = gfc_find_derived_vtab (e->ts.u.derived);
+      gcc_assert (vtab);
+      tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+    }
+  gfc_add_modify (&parmse->pre, ctree,
+		  fold_convert (TREE_TYPE (ctree), tmp));
+
+  /* Now set the data field.  */
+  ctree =  gfc_class_data_get (var);
+
+  if (optional)
+    cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
+
+  if (parmse->ss && parmse->ss->info->useflags)
+    {
+      /* For an array reference in an elemental procedure call we need
+	 to retain the ss to provide the scalarized array reference.  */
+      gfc_conv_expr_reference (parmse, e);
+      tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
+      if (optional)
+	tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
+			  cond_optional, tmp,
+			  fold_convert (TREE_TYPE (tmp), null_pointer_node));
+      gfc_add_modify (&parmse->pre, ctree, tmp);
+
+    }
+  else
+    {
+      ss = gfc_walk_expr (e);
+      if (ss == gfc_ss_terminator)
+	{
+	  parmse->ss = NULL;
+	  gfc_conv_expr_reference (parmse, e);
+
+	  /* Scalar to an assumed-rank array.  */
+	  if (class_ts.u.derived->components->as)
+	    {
+	      tree type;
+	      type = get_scalar_to_descriptor_type (parmse->expr,
+						    gfc_expr_attr (e));
+	      gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
+			      gfc_get_dtype (type));
+	      if (optional)
+		parmse->expr = build3_loc (input_location, COND_EXPR,
+					   TREE_TYPE (parmse->expr),
+					   cond_optional, parmse->expr,
+					   fold_convert (TREE_TYPE (parmse->expr),
+							 null_pointer_node));
+	      gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
+	    }
+          else
+	    {
+	      tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
+	      if (optional)
+		tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
+				  cond_optional, tmp,
+				  fold_convert (TREE_TYPE (tmp),
+						null_pointer_node));
+	      gfc_add_modify (&parmse->pre, ctree, tmp);
+	    }
+	}
+      else
+	{
+	  stmtblock_t block;
+	  gfc_init_block (&block);
+
+	  parmse->ss = ss;
+	  gfc_conv_expr_descriptor (parmse, e);
+
+	  if (e->rank != class_ts.u.derived->components->as->rank)
+	    class_array_data_assign (&block, ctree, parmse->expr, true);
+	  else
+	    {
+	      if (gfc_expr_attr (e).codimension)
+		parmse->expr = fold_build1_loc (input_location,
+						VIEW_CONVERT_EXPR,
+						TREE_TYPE (ctree),
+						parmse->expr);
+	      gfc_add_modify (&block, ctree, parmse->expr);
+	    }
+
+	  if (optional)
+	    {
+	      tmp = gfc_finish_block (&block);
+
+	      gfc_init_block (&block);
+	      gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node);
+
+	      tmp = build3_v (COND_EXPR, cond_optional, tmp,
+			      gfc_finish_block (&block));
+	      gfc_add_expr_to_block (&parmse->pre, tmp);
+	    }
+	  else
+	    gfc_add_block_to_block (&parmse->pre, &block);
+	}
+    }
+
+  /* Pass the address of the class object.  */
+  parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
+
+  if (optional && optional_alloc_ptr)
+    parmse->expr = build3_loc (input_location, COND_EXPR,
+			       TREE_TYPE (parmse->expr),
+			       cond_optional, parmse->expr,
+			       fold_convert (TREE_TYPE (parmse->expr),
+					     null_pointer_node));
+}
+
+
+/* Create a new class container, which is required as scalar coarrays
+   have an array descriptor while normal scalars haven't. Optionally,
+   NULL pointer checks are added if the argument is OPTIONAL.  */
+
+static void
+class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
+			       gfc_typespec class_ts, bool optional)
+{
+  tree var, ctree, tmp;
+  stmtblock_t block;
+  gfc_ref *ref;
+  gfc_ref *class_ref;
+
+  gfc_init_block (&block);
+
+  class_ref = NULL;
+  for (ref = e->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_COMPONENT
+	    && ref->u.c.component->ts.type == BT_CLASS)
+	class_ref = ref;
+    }
+
+  if (class_ref == NULL
+	&& e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
+    tmp = e->symtree->n.sym->backend_decl;
+  else
+    {
+      /* Remove everything after the last class reference, convert the
+	 expression and then recover its tailend once more.  */
+      gfc_se tmpse;
+      ref = class_ref->next;
+      class_ref->next = NULL;
+      gfc_init_se (&tmpse, NULL);
+      gfc_conv_expr (&tmpse, e);
+      class_ref->next = ref;
+      tmp = tmpse.expr;
+    }
+
+  var = gfc_typenode_for_spec (&class_ts);
+  var = gfc_create_var (var, "class");
+
+  ctree = gfc_class_vptr_get (var);
+  gfc_add_modify (&block, ctree,
+		  fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
+
+  ctree = gfc_class_data_get (var);
+  tmp = gfc_conv_descriptor_data_get (gfc_class_data_get (tmp));
+  gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
+
+  /* Pass the address of the class object.  */
+  parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
+
+  if (optional)
+    {
+      tree cond = gfc_conv_expr_present (e->symtree->n.sym);
+      tree tmp2;
+
+      tmp = gfc_finish_block (&block);
+
+      gfc_init_block (&block);
+      tmp2 = gfc_class_data_get (var);
+      gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
+						  null_pointer_node));
+      tmp2 = gfc_finish_block (&block);
+
+      tmp = build3_loc (input_location, COND_EXPR, void_type_node,
+			cond, tmp, tmp2);
+      gfc_add_expr_to_block (&parmse->pre, tmp);
+    }
+  else
+    gfc_add_block_to_block (&parmse->pre, &block);
+}
+
+
+/* Takes an intrinsic type expression and returns the address of a temporary
+   class object of the 'declared' type.  */
+void
+gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
+			     gfc_typespec class_ts)
+{
+  gfc_symbol *vtab;
+  gfc_ss *ss;
+  tree ctree;
+  tree var;
+  tree tmp;
+
+  /* The intrinsic type needs to be converted to a temporary
+     CLASS object.  */
+  tmp = gfc_typenode_for_spec (&class_ts);
+  var = gfc_create_var (tmp, "class");
+
+  /* Set the vptr.  */
+  ctree =  gfc_class_vptr_get (var);
+
+  vtab = gfc_find_vtab (&e->ts);
+  gcc_assert (vtab);
+  tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+  gfc_add_modify (&parmse->pre, ctree,
+		  fold_convert (TREE_TYPE (ctree), tmp));
+
+  /* Now set the data field.  */
+  ctree =  gfc_class_data_get (var);
+  if (parmse->ss && parmse->ss->info->useflags)
+    {
+      /* For an array reference in an elemental procedure call we need
+	 to retain the ss to provide the scalarized array reference.  */
+      gfc_conv_expr_reference (parmse, e);
+      tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
+      gfc_add_modify (&parmse->pre, ctree, tmp);
+    }
+  else
+    {
+      ss = gfc_walk_expr (e);
+      if (ss == gfc_ss_terminator)
+	{
+	  parmse->ss = NULL;
+	  gfc_conv_expr_reference (parmse, e);
+	  tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
+	  gfc_add_modify (&parmse->pre, ctree, tmp);
+	}
+      else
+	{
+	  parmse->ss = ss;
+	  gfc_conv_expr_descriptor (parmse, e);
+	  gfc_add_modify (&parmse->pre, ctree, parmse->expr);
+	}
+    }
+
+  /* Pass the address of the class object.  */
+  parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
+}
+
+
+/* Takes a scalarized class array expression and returns the
+   address of a temporary scalar class object of the 'declared'
+   type.
+   OOP-TODO: This could be improved by adding code that branched on
+   the dynamic type being the same as the declared type. In this case
+   the original class expression can be passed directly.
+   optional_alloc_ptr is false when the dummy is neither allocatable
+   nor a pointer; that's relevant for the optional handling.
+   Set copyback to true if class container's _data and _vtab pointers
+   might get modified.  */
+
+void
+gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
+			 bool elemental, bool copyback, bool optional,
+		         bool optional_alloc_ptr)
+{
+  tree ctree;
+  tree var;
+  tree tmp;
+  tree vptr;
+  tree cond = NULL_TREE;
+  gfc_ref *ref;
+  gfc_ref *class_ref;
+  stmtblock_t block;
+  bool full_array = false;
+
+  gfc_init_block (&block);
+
+  class_ref = NULL;
+  for (ref = e->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_COMPONENT
+	    && ref->u.c.component->ts.type == BT_CLASS)
+	class_ref = ref;
+
+      if (ref->next == NULL)
+	break;
+    }
+
+  if ((ref == NULL || class_ref == ref)
+      && (!class_ts.u.derived->components->as
+	  || class_ts.u.derived->components->as->rank != -1))
+    return;
+
+  /* Test for FULL_ARRAY.  */
+  if (e->rank == 0 && gfc_expr_attr (e).codimension
+      && gfc_expr_attr (e).dimension)
+    full_array = true;
+  else
+    gfc_is_class_array_ref (e, &full_array);
+
+  /* The derived type needs to be converted to a temporary
+     CLASS object.  */
+  tmp = gfc_typenode_for_spec (&class_ts);
+  var = gfc_create_var (tmp, "class");
+
+  /* Set the data.  */
+  ctree = gfc_class_data_get (var);
+  if (class_ts.u.derived->components->as
+      && e->rank != class_ts.u.derived->components->as->rank)
+    {
+      if (e->rank == 0)
+	{
+	  tree type = get_scalar_to_descriptor_type (parmse->expr,
+						     gfc_expr_attr (e));
+	  gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
+			  gfc_get_dtype (type));
+
+	  tmp = gfc_class_data_get (parmse->expr);
+	  if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+	    tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+
+	  gfc_conv_descriptor_data_set (&block, ctree, tmp);
+	}
+      else
+	class_array_data_assign (&block, ctree, parmse->expr, false);
+    }
+  else
+    {
+      if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
+	parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
+					TREE_TYPE (ctree), parmse->expr);
+      gfc_add_modify (&block, ctree, parmse->expr);
+    }
+
+  /* Return the data component, except in the case of scalarized array
+     references, where nullification of the cannot occur and so there
+     is no need.  */
+  if (!elemental && full_array && copyback)
+    {
+      if (class_ts.u.derived->components->as
+	  && e->rank != class_ts.u.derived->components->as->rank)
+	{
+	  if (e->rank == 0)
+	    gfc_add_modify (&parmse->post, gfc_class_data_get (parmse->expr),
+			    gfc_conv_descriptor_data_get (ctree));
+	  else
+	    class_array_data_assign (&parmse->post, parmse->expr, ctree, true);
+	}
+      else
+	gfc_add_modify (&parmse->post, parmse->expr, ctree);
+    }
+
+  /* Set the vptr.  */
+  ctree = gfc_class_vptr_get (var);
+
+  /* The vptr is the second field of the actual argument.
+     First we have to find the corresponding class reference. */
+
+  tmp = NULL_TREE;
+  if (class_ref == NULL
+	&& e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
+    tmp = e->symtree->n.sym->backend_decl;
+  else
+    {
+      /* Remove everything after the last class reference, convert the
+	 expression and then recover its tailend once more.  */
+      gfc_se tmpse;
+      ref = class_ref->next;
+      class_ref->next = NULL;
+      gfc_init_se (&tmpse, NULL);
+      gfc_conv_expr (&tmpse, e);
+      class_ref->next = ref;
+      tmp = tmpse.expr;
+    }
+
+  gcc_assert (tmp != NULL_TREE);
+
+  /* Dereference if needs be.  */
+  if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
+    tmp = build_fold_indirect_ref_loc (input_location, tmp);
+
+  vptr = gfc_class_vptr_get (tmp);
+  gfc_add_modify (&block, ctree,
+		  fold_convert (TREE_TYPE (ctree), vptr));
+
+  /* Return the vptr component, except in the case of scalarized array
+     references, where the dynamic type cannot change.  */
+  if (!elemental && full_array && copyback)
+    gfc_add_modify (&parmse->post, vptr,
+		    fold_convert (TREE_TYPE (vptr), ctree));
+
+  if (optional)
+    {
+      tree tmp2;
+
+      cond = gfc_conv_expr_present (e->symtree->n.sym);
+      tmp = gfc_finish_block (&block);
+
+      if (optional_alloc_ptr)
+	tmp2 = build_empty_stmt (input_location);
+      else
+	{
+	  gfc_init_block (&block);
+
+	  tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var));
+	  gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
+						      null_pointer_node));
+	  tmp2 = gfc_finish_block (&block);
+	}
+
+      tmp = build3_loc (input_location, COND_EXPR, void_type_node,
+			cond, tmp, tmp2);
+      gfc_add_expr_to_block (&parmse->pre, tmp);
+    }
+  else
+    gfc_add_block_to_block (&parmse->pre, &block);
+
+  /* Pass the address of the class object.  */
+  parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
+
+  if (optional && optional_alloc_ptr)
+    parmse->expr = build3_loc (input_location, COND_EXPR,
+			       TREE_TYPE (parmse->expr),
+			       cond, parmse->expr,
+			       fold_convert (TREE_TYPE (parmse->expr),
+					     null_pointer_node));
+}
+
+
+/* Given a class array declaration and an index, returns the address
+   of the referenced element.  */
+
+tree
+gfc_get_class_array_ref (tree index, tree class_decl)
+{
+  tree data = gfc_class_data_get (class_decl);
+  tree size = gfc_vtable_size_get (class_decl);
+  tree offset = fold_build2_loc (input_location, MULT_EXPR,
+				 gfc_array_index_type,
+				 index, size);
+  tree ptr;
+  data = gfc_conv_descriptor_data_get (data);
+  ptr = fold_convert (pvoid_type_node, data);
+  ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
+  return fold_convert (TREE_TYPE (data), ptr);
+}
+
+
+/* Copies one class expression to another, assuming that if either
+   'to' or 'from' are arrays they are packed.  Should 'from' be
+   NULL_TREE, the initialization expression for 'to' is used, assuming
+   that the _vptr is set.  */
+
+tree
+gfc_copy_class_to_class (tree from, tree to, tree nelems)
+{
+  tree fcn;
+  tree fcn_type;
+  tree from_data;
+  tree to_data;
+  tree to_ref;
+  tree from_ref;
+  vec<tree, va_gc> *args;
+  tree tmp;
+  tree index;
+  stmtblock_t loopbody;
+  stmtblock_t body;
+  gfc_loopinfo loop;
+
+  args = NULL;
+
+  if (from != NULL_TREE)
+    fcn = gfc_vtable_copy_get (from);
+  else
+    fcn = gfc_vtable_copy_get (to);
+
+  fcn_type = TREE_TYPE (TREE_TYPE (fcn));
+
+  if (from != NULL_TREE)
+    from_data = gfc_class_data_get (from);
+  else
+    from_data = gfc_vtable_def_init_get (to);
+
+  to_data = gfc_class_data_get (to);
+
+  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
+    {
+      gfc_init_block (&body);
+      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+			     gfc_array_index_type, nelems,
+			     gfc_index_one_node);
+      nelems = gfc_evaluate_now (tmp, &body);
+      index = gfc_create_var (gfc_array_index_type, "S");
+
+      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data)))
+	{
+	  from_ref = gfc_get_class_array_ref (index, from);
+	  vec_safe_push (args, from_ref);
+	}
+      else
+        vec_safe_push (args, from_data);
+
+      to_ref = gfc_get_class_array_ref (index, to);
+      vec_safe_push (args, to_ref);
+
+      tmp = build_call_vec (fcn_type, fcn, args);
+
+      /* Build the body of the loop.  */
+      gfc_init_block (&loopbody);
+      gfc_add_expr_to_block (&loopbody, tmp);
+
+      /* Build the loop and return.  */
+      gfc_init_loopinfo (&loop);
+      loop.dimen = 1;
+      loop.from[0] = gfc_index_zero_node;
+      loop.loopvar[0] = index;
+      loop.to[0] = nelems;
+      gfc_trans_scalarizing_loops (&loop, &loopbody);
+      gfc_add_block_to_block (&body, &loop.pre);
+      tmp = gfc_finish_block (&body);
+      gfc_cleanup_loop (&loop);
+    }
+  else
+    {
+      gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data)));
+      vec_safe_push (args, from_data);
+      vec_safe_push (args, to_data);
+      tmp = build_call_vec (fcn_type, fcn, args);
+    }
+
+  return tmp;
+}
+
+static tree
+gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
+{
+  gfc_actual_arglist *actual;
+  gfc_expr *ppc;
+  gfc_code *ppc_code;
+  tree res;
+
+  actual = gfc_get_actual_arglist ();
+  actual->expr = gfc_copy_expr (rhs);
+  actual->next = gfc_get_actual_arglist ();
+  actual->next->expr = gfc_copy_expr (lhs);
+  ppc = gfc_copy_expr (obj);
+  gfc_add_vptr_component (ppc);
+  gfc_add_component_ref (ppc, "_copy");
+  ppc_code = gfc_get_code (EXEC_CALL);
+  ppc_code->resolved_sym = ppc->symtree->n.sym;
+  /* Although '_copy' is set to be elemental in class.c, it is
+     not staying that way.  Find out why, sometime....  */
+  ppc_code->resolved_sym->attr.elemental = 1;
+  ppc_code->ext.actual = actual;
+  ppc_code->expr1 = ppc;
+  /* Since '_copy' is elemental, the scalarizer will take care
+     of arrays in gfc_trans_call.  */
+  res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
+  gfc_free_statements (ppc_code);
+  return res;
+}
+
+/* Special case for initializing a polymorphic dummy with INTENT(OUT).
+   A MEMCPY is needed to copy the full data from the default initializer
+   of the dynamic type.  */
+
+tree
+gfc_trans_class_init_assign (gfc_code *code)
+{
+  stmtblock_t block;
+  tree tmp;
+  gfc_se dst,src,memsz;
+  gfc_expr *lhs, *rhs, *sz;
+
+  gfc_start_block (&block);
+
+  lhs = gfc_copy_expr (code->expr1);
+  gfc_add_data_component (lhs);
+
+  rhs = gfc_copy_expr (code->expr1);
+  gfc_add_vptr_component (rhs);
+
+  /* Make sure that the component backend_decls have been built, which
+     will not have happened if the derived types concerned have not
+     been referenced.  */
+  gfc_get_derived_type (rhs->ts.u.derived);
+  gfc_add_def_init_component (rhs);
+
+  if (code->expr1->ts.type == BT_CLASS
+	&& CLASS_DATA (code->expr1)->attr.dimension)
+    tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
+  else
+    {
+      sz = gfc_copy_expr (code->expr1);
+      gfc_add_vptr_component (sz);
+      gfc_add_size_component (sz);
+
+      gfc_init_se (&dst, NULL);
+      gfc_init_se (&src, NULL);
+      gfc_init_se (&memsz, NULL);
+      gfc_conv_expr (&dst, lhs);
+      gfc_conv_expr (&src, rhs);
+      gfc_conv_expr (&memsz, sz);
+      gfc_add_block_to_block (&block, &src.pre);
+      src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
+
+      tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
+    }
+
+  if (code->expr1->symtree->n.sym->attr.optional
+      || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master)
+    {
+      tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym);
+      tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
+			present, tmp,
+			build_empty_stmt (input_location));
+    }
+
+  gfc_add_expr_to_block (&block, tmp);
+
+  return gfc_finish_block (&block);
+}
+
+
+/* Translate an assignment to a CLASS object
+   (pointer or ordinary assignment).  */
+
+tree
+gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
+{
+  stmtblock_t block;
+  tree tmp;
+  gfc_expr *lhs;
+  gfc_expr *rhs;
+  gfc_ref *ref;
+
+  gfc_start_block (&block);
+
+  ref = expr1->ref;
+  while (ref && ref->next)
+     ref = ref->next;
+
+  /* Class valued proc_pointer assignments do not need any further
+     preparation.  */
+  if (ref && ref->type == REF_COMPONENT
+	&& ref->u.c.component->attr.proc_pointer
+	&& expr2->expr_type == EXPR_VARIABLE
+	&& expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE
+	&& op == EXEC_POINTER_ASSIGN)
+    goto assign;
+
+  if (expr2->ts.type != BT_CLASS)
+    {
+      /* Insert an additional assignment which sets the '_vptr' field.  */
+      gfc_symbol *vtab = NULL;
+      gfc_symtree *st;
+
+      lhs = gfc_copy_expr (expr1);
+      gfc_add_vptr_component (lhs);
+
+      if (UNLIMITED_POLY (expr1)
+	  && expr2->expr_type == EXPR_NULL && expr2->ts.type == BT_UNKNOWN)
+	{
+	  rhs = gfc_get_null_expr (&expr2->where);
+ 	  goto assign_vptr;
+	}
+
+      if (expr2->expr_type == EXPR_NULL)
+	vtab = gfc_find_vtab (&expr1->ts);
+      else
+	vtab = gfc_find_vtab (&expr2->ts);
+      gcc_assert (vtab);
+
+      rhs = gfc_get_expr ();
+      rhs->expr_type = EXPR_VARIABLE;
+      gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
+      rhs->symtree = st;
+      rhs->ts = vtab->ts;
+assign_vptr:
+      tmp = gfc_trans_pointer_assignment (lhs, rhs);
+      gfc_add_expr_to_block (&block, tmp);
+
+      gfc_free_expr (lhs);
+      gfc_free_expr (rhs);
+    }
+  else if (expr1->ts.type == BT_DERIVED && UNLIMITED_POLY (expr2))
+    {
+      /* F2003:C717 only sequence and bind-C types can come here.  */
+      gcc_assert (expr1->ts.u.derived->attr.sequence
+		  || expr1->ts.u.derived->attr.is_bind_c);
+      gfc_add_data_component (expr2);
+      goto assign;
+    }
+  else if (CLASS_DATA (expr2)->attr.dimension && expr2->expr_type != EXPR_FUNCTION)
+    {
+      /* Insert an additional assignment which sets the '_vptr' field.  */
+      lhs = gfc_copy_expr (expr1);
+      gfc_add_vptr_component (lhs);
+
+      rhs = gfc_copy_expr (expr2);
+      gfc_add_vptr_component (rhs);
+
+      tmp = gfc_trans_pointer_assignment (lhs, rhs);
+      gfc_add_expr_to_block (&block, tmp);
+
+      gfc_free_expr (lhs);
+      gfc_free_expr (rhs);
+    }
+
+  /* Do the actual CLASS assignment.  */
+  if (expr2->ts.type == BT_CLASS
+      && !CLASS_DATA (expr2)->attr.dimension)
+    op = EXEC_ASSIGN;
+  else if (expr2->expr_type != EXPR_FUNCTION || expr2->ts.type != BT_CLASS
+	   || !CLASS_DATA (expr2)->attr.dimension)
+    gfc_add_data_component (expr1);
+
+assign:
+
+  if (op == EXEC_ASSIGN)
+    tmp = gfc_trans_assignment (expr1, expr2, false, true);
+  else if (op == EXEC_POINTER_ASSIGN)
+    tmp = gfc_trans_pointer_assignment (expr1, expr2);
+  else
+    gcc_unreachable();
+
+  gfc_add_expr_to_block (&block, tmp);
+
+  return gfc_finish_block (&block);
+}
+
+
+/* End of prototype trans-class.c  */
+
+
+static void
+realloc_lhs_warning (bt type, bool array, locus *where)
+{
+  if (array && type != BT_CLASS && type != BT_DERIVED
+      && gfc_option.warn_realloc_lhs)
+    gfc_warning ("Code for reallocating the allocatable array at %L will "
+		 "be added", where);
+  else if (gfc_option.warn_realloc_lhs_all)
+    gfc_warning ("Code for reallocating the allocatable variable at %L "
+		 "will be added", where);
+}
+
+
+static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
+static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
+						 gfc_expr *);
+
+/* Copy the scalarization loop variables.  */
+
+static void
+gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
+{
+  dest->ss = src->ss;
+  dest->loop = src->loop;
+}
+
+
+/* Initialize a simple expression holder.
+
+   Care must be taken when multiple se are created with the same parent.
+   The child se must be kept in sync.  The easiest way is to delay creation
+   of a child se until after after the previous se has been translated.  */
+
+void
+gfc_init_se (gfc_se * se, gfc_se * parent)
+{
+  memset (se, 0, sizeof (gfc_se));
+  gfc_init_block (&se->pre);
+  gfc_init_block (&se->post);
+
+  se->parent = parent;
+
+  if (parent)
+    gfc_copy_se_loopvars (se, parent);
+}
+
+
+/* Advances to the next SS in the chain.  Use this rather than setting
+   se->ss = se->ss->next because all the parents needs to be kept in sync.
+   See gfc_init_se.  */
+
+void
+gfc_advance_se_ss_chain (gfc_se * se)
+{
+  gfc_se *p;
+  gfc_ss *ss;
+
+  gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
+
+  p = se;
+  /* Walk down the parent chain.  */
+  while (p != NULL)
+    {
+      /* Simple consistency check.  */
+      gcc_assert (p->parent == NULL || p->parent->ss == p->ss
+		  || p->parent->ss->nested_ss == p->ss);
+
+      /* If we were in a nested loop, the next scalarized expression can be
+	 on the parent ss' next pointer.  Thus we should not take the next
+	 pointer blindly, but rather go up one nest level as long as next
+	 is the end of chain.  */
+      ss = p->ss;
+      while (ss->next == gfc_ss_terminator && ss->parent != NULL)
+	ss = ss->parent;
+
+      p->ss = ss->next;
+
+      p = p->parent;
+    }
+}
+
+
+/* Ensures the result of the expression as either a temporary variable
+   or a constant so that it can be used repeatedly.  */
+
+void
+gfc_make_safe_expr (gfc_se * se)
+{
+  tree var;
+
+  if (CONSTANT_CLASS_P (se->expr))
+    return;
+
+  /* We need a temporary for this result.  */
+  var = gfc_create_var (TREE_TYPE (se->expr), NULL);
+  gfc_add_modify (&se->pre, var, se->expr);
+  se->expr = var;
+}
+
+
+/* Return an expression which determines if a dummy parameter is present.
+   Also used for arguments to procedures with multiple entry points.  */
+
+tree
+gfc_conv_expr_present (gfc_symbol * sym)
+{
+  tree decl, cond;
+
+  gcc_assert (sym->attr.dummy);
+  decl = gfc_get_symbol_decl (sym);
+
+  /* Intrinsic scalars with VALUE attribute which are passed by value
+     use a hidden argument to denote the present status.  */
+  if (sym->attr.value && sym->ts.type != BT_CHARACTER
+      && sym->ts.type != BT_CLASS && sym->ts.type != BT_DERIVED
+      && !sym->attr.dimension)
+    {
+      char name[GFC_MAX_SYMBOL_LEN + 2];
+      tree tree_name;
+
+      gcc_assert (TREE_CODE (decl) == PARM_DECL);
+      name[0] = '_';
+      strcpy (&name[1], sym->name);
+      tree_name = get_identifier (name);
+
+      /* Walk function argument list to find hidden arg.  */
+      cond = DECL_ARGUMENTS (DECL_CONTEXT (decl));
+      for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond))
+	if (DECL_NAME (cond) == tree_name)
+	  break;
+
+      gcc_assert (cond);
+      return cond;
+    }
+
+  if (TREE_CODE (decl) != PARM_DECL)
+    {
+      /* Array parameters use a temporary descriptor, we want the real
+         parameter.  */
+      gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
+             || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
+      decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
+    }
+
+  cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, decl,
+			  fold_convert (TREE_TYPE (decl), null_pointer_node));
+
+  /* Fortran 2008 allows to pass null pointers and non-associated pointers
+     as actual argument to denote absent dummies. For array descriptors,
+     we thus also need to check the array descriptor.  For BT_CLASS, it
+     can also occur for scalars and F2003 due to type->class wrapping and
+     class->class wrapping.  Note further that BT_CLASS always uses an
+     array descriptor for arrays, also for explicit-shape/assumed-size.  */
+
+  if (!sym->attr.allocatable
+      && ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
+	  || (sym->ts.type == BT_CLASS
+	      && !CLASS_DATA (sym)->attr.allocatable
+	      && !CLASS_DATA (sym)->attr.class_pointer))
+      && ((gfc_option.allow_std & GFC_STD_F2008) != 0
+	  || sym->ts.type == BT_CLASS))
+    {
+      tree tmp;
+
+      if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
+		       || sym->as->type == AS_ASSUMED_RANK
+		       || sym->attr.codimension))
+	  || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
+	{
+	  tmp = build_fold_indirect_ref_loc (input_location, decl);
+	  if (sym->ts.type == BT_CLASS)
+	    tmp = gfc_class_data_get (tmp);
+	  tmp = gfc_conv_array_data (tmp);
+	}
+      else if (sym->ts.type == BT_CLASS)
+	tmp = gfc_class_data_get (decl);
+      else
+	tmp = NULL_TREE;
+
+      if (tmp != NULL_TREE)
+	{
+	  tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
+				 fold_convert (TREE_TYPE (tmp), null_pointer_node));
+	  cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
+				  boolean_type_node, cond, tmp);
+	}
+    }
+
+  return cond;
+}
+
+
+/* Converts a missing, dummy argument into a null or zero.  */
+
+void
+gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
+{
+  tree present;
+  tree tmp;
+
+  present = gfc_conv_expr_present (arg->symtree->n.sym);
+
+  if (kind > 0)
+    {
+      /* Create a temporary and convert it to the correct type.  */
+      tmp = gfc_get_int_type (kind);
+      tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
+							se->expr));
+
+      /* Test for a NULL value.  */
+      tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
+			tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
+      tmp = gfc_evaluate_now (tmp, &se->pre);
+      se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
+    }
+  else
+    {
+      tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
+			present, se->expr,
+			build_zero_cst (TREE_TYPE (se->expr)));
+      tmp = gfc_evaluate_now (tmp, &se->pre);
+      se->expr = tmp;
+    }
+
+  if (ts.type == BT_CHARACTER)
+    {
+      tmp = build_int_cst (gfc_charlen_type_node, 0);
+      tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
+			     present, se->string_length, tmp);
+      tmp = gfc_evaluate_now (tmp, &se->pre);
+      se->string_length = tmp;
+    }
+  return;
+}
+
+
+/* Get the character length of an expression, looking through gfc_refs
+   if necessary.  */
+
+tree
+gfc_get_expr_charlen (gfc_expr *e)
+{
+  gfc_ref *r;
+  tree length;
+
+  gcc_assert (e->expr_type == EXPR_VARIABLE
+	      && e->ts.type == BT_CHARACTER);
+
+  length = NULL; /* To silence compiler warning.  */
+
+  if (is_subref_array (e) && e->ts.u.cl->length)
+    {
+      gfc_se tmpse;
+      gfc_init_se (&tmpse, NULL);
+      gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
+      e->ts.u.cl->backend_decl = tmpse.expr;
+      return tmpse.expr;
+    }
+
+  /* First candidate: if the variable is of type CHARACTER, the
+     expression's length could be the length of the character
+     variable.  */
+  if (e->symtree->n.sym->ts.type == BT_CHARACTER)
+    length = e->symtree->n.sym->ts.u.cl->backend_decl;
+
+  /* Look through the reference chain for component references.  */
+  for (r = e->ref; r; r = r->next)
+    {
+      switch (r->type)
+	{
+	case REF_COMPONENT:
+	  if (r->u.c.component->ts.type == BT_CHARACTER)
+	    length = r->u.c.component->ts.u.cl->backend_decl;
+	  break;
+
+	case REF_ARRAY:
+	  /* Do nothing.  */
+	  break;
+
+	default:
+	  /* We should never got substring references here.  These will be
+	     broken down by the scalarizer.  */
+	  gcc_unreachable ();
+	  break;
+	}
+    }
+
+  gcc_assert (length != NULL);
+  return length;
+}
+
+
+/* Return for an expression the backend decl of the coarray.  */
+
+static tree
+get_tree_for_caf_expr (gfc_expr *expr)
+{
+   tree caf_decl = NULL_TREE;
+   gfc_ref *ref;
+
+   gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
+   if (expr->symtree->n.sym->attr.codimension)
+     caf_decl = expr->symtree->n.sym->backend_decl;
+
+   for (ref = expr->ref; ref; ref = ref->next)
+     if (ref->type == REF_COMPONENT)
+       {
+	gfc_component *comp = ref->u.c.component;
+        if (comp->attr.pointer || comp->attr.allocatable)
+	  caf_decl = NULL_TREE;
+	if (comp->attr.codimension)
+	  caf_decl = comp->backend_decl;
+       }
+
+   gcc_assert (caf_decl != NULL_TREE);
+   return caf_decl;
+}
+
+
+/* For each character array constructor subexpression without a ts.u.cl->length,
+   replace it by its first element (if there aren't any elements, the length
+   should already be set to zero).  */
+
+static void
+flatten_array_ctors_without_strlen (gfc_expr* e)
+{
+  gfc_actual_arglist* arg;
+  gfc_constructor* c;
+
+  if (!e)
+    return;
+
+  switch (e->expr_type)
+    {
+
+    case EXPR_OP:
+      flatten_array_ctors_without_strlen (e->value.op.op1);
+      flatten_array_ctors_without_strlen (e->value.op.op2);
+      break;
+
+    case EXPR_COMPCALL:
+      /* TODO: Implement as with EXPR_FUNCTION when needed.  */
+      gcc_unreachable ();
+
+    case EXPR_FUNCTION:
+      for (arg = e->value.function.actual; arg; arg = arg->next)
+	flatten_array_ctors_without_strlen (arg->expr);
+      break;
+
+    case EXPR_ARRAY:
+
+      /* We've found what we're looking for.  */
+      if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
+	{
+	  gfc_constructor *c;
+	  gfc_expr* new_expr;
+
+	  gcc_assert (e->value.constructor);
+
+	  c = gfc_constructor_first (e->value.constructor);
+	  new_expr = c->expr;
+	  c->expr = NULL;
+
+	  flatten_array_ctors_without_strlen (new_expr);
+	  gfc_replace_expr (e, new_expr);
+	  break;
+	}
+
+      /* Otherwise, fall through to handle constructor elements.  */
+    case EXPR_STRUCTURE:
+      for (c = gfc_constructor_first (e->value.constructor);
+	   c; c = gfc_constructor_next (c))
+	flatten_array_ctors_without_strlen (c->expr);
+      break;
+
+    default:
+      break;
+
+    }
+}
+
+
+/* Generate code to initialize a string length variable. Returns the
+   value.  For array constructors, cl->length might be NULL and in this case,
+   the first element of the constructor is needed.  expr is the original
+   expression so we can access it but can be NULL if this is not needed.  */
+
+void
+gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
+{
+  gfc_se se;
+
+  gfc_init_se (&se, NULL);
+
+  if (!cl->length
+	&& cl->backend_decl
+	&& TREE_CODE (cl->backend_decl) == VAR_DECL)
+    return;
+
+  /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
+     "flatten" array constructors by taking their first element; all elements
+     should be the same length or a cl->length should be present.  */
+  if (!cl->length)
+    {
+      gfc_expr* expr_flat;
+      gcc_assert (expr);
+      expr_flat = gfc_copy_expr (expr);
+      flatten_array_ctors_without_strlen (expr_flat);
+      gfc_resolve_expr (expr_flat);
+
+      gfc_conv_expr (&se, expr_flat);
+      gfc_add_block_to_block (pblock, &se.pre);
+      cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
+
+      gfc_free_expr (expr_flat);
+      return;
+    }
+
+  /* Convert cl->length.  */
+
+  gcc_assert (cl->length);
+
+  gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
+  se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
+			     se.expr, build_int_cst (gfc_charlen_type_node, 0));
+  gfc_add_block_to_block (pblock, &se.pre);
+
+  if (cl->backend_decl)
+    gfc_add_modify (pblock, cl->backend_decl, se.expr);
+  else
+    cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
+}
+
+
+static void
+gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
+		    const char *name, locus *where)
+{
+  tree tmp;
+  tree type;
+  tree fault;
+  gfc_se start;
+  gfc_se end;
+  char *msg;
+  mpz_t length;
+
+  type = gfc_get_character_type (kind, ref->u.ss.length);
+  type = build_pointer_type (type);
+
+  gfc_init_se (&start, se);
+  gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
+  gfc_add_block_to_block (&se->pre, &start.pre);
+
+  if (integer_onep (start.expr))
+    gfc_conv_string_parameter (se);
+  else
+    {
+      tmp = start.expr;
+      STRIP_NOPS (tmp);
+      /* Avoid multiple evaluation of substring start.  */
+      if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
+	start.expr = gfc_evaluate_now (start.expr, &se->pre);
+
+      /* Change the start of the string.  */
+      if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
+	tmp = se->expr;
+      else
+	tmp = build_fold_indirect_ref_loc (input_location,
+				       se->expr);
+      tmp = gfc_build_array_ref (tmp, start.expr, NULL);
+      se->expr = gfc_build_addr_expr (type, tmp);
+    }
+
+  /* Length = end + 1 - start.  */
+  gfc_init_se (&end, se);
+  if (ref->u.ss.end == NULL)
+    end.expr = se->string_length;
+  else
+    {
+      gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
+      gfc_add_block_to_block (&se->pre, &end.pre);
+    }
+  tmp = end.expr;
+  STRIP_NOPS (tmp);
+  if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
+    end.expr = gfc_evaluate_now (end.expr, &se->pre);
+
+  if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+    {
+      tree nonempty = fold_build2_loc (input_location, LE_EXPR,
+				       boolean_type_node, start.expr,
+				       end.expr);
+
+      /* Check lower bound.  */
+      fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+			       start.expr,
+			       build_int_cst (gfc_charlen_type_node, 1));
+      fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
+			       boolean_type_node, nonempty, fault);
+      if (name)
+	asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
+		  "is less than one", name);
+      else
+	asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
+		  "is less than one");
+      gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
+			       fold_convert (long_integer_type_node,
+					     start.expr));
+      free (msg);
+
+      /* Check upper bound.  */
+      fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+			       end.expr, se->string_length);
+      fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
+			       boolean_type_node, nonempty, fault);
+      if (name)
+	asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
+		  "exceeds string length (%%ld)", name);
+      else
+	asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
+		  "exceeds string length (%%ld)");
+      gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
+			       fold_convert (long_integer_type_node, end.expr),
+			       fold_convert (long_integer_type_node,
+					     se->string_length));
+      free (msg);
+    }
+
+  /* Try to calculate the length from the start and end expressions.  */
+  if (ref->u.ss.end
+      && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
+    {
+      int i_len;
+
+      i_len = mpz_get_si (length) + 1;
+      if (i_len < 0)
+	i_len = 0;
+
+      tmp = build_int_cst (gfc_charlen_type_node, i_len);
+      mpz_clear (length);  /* Was initialized by gfc_dep_difference.  */
+    }
+  else
+    {
+      tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
+			     end.expr, start.expr);
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
+			     build_int_cst (gfc_charlen_type_node, 1), tmp);
+      tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
+			     tmp, build_int_cst (gfc_charlen_type_node, 0));
+    }
+
+  se->string_length = tmp;
+}
+
+
+/* Convert a derived type component reference.  */
+
+static void
+gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
+{
+  gfc_component *c;
+  tree tmp;
+  tree decl;
+  tree field;
+
+  c = ref->u.c.component;
+
+  gcc_assert (c->backend_decl);
+
+  field = c->backend_decl;
+  gcc_assert (TREE_CODE (field) == FIELD_DECL);
+  decl = se->expr;
+
+  /* Components can correspond to fields of different containing
+     types, as components are created without context, whereas
+     a concrete use of a component has the type of decl as context.
+     So, if the type doesn't match, we search the corresponding
+     FIELD_DECL in the parent type.  To not waste too much time
+     we cache this result in norestrict_decl.  */
+
+  if (DECL_FIELD_CONTEXT (field) != TREE_TYPE (decl))
+    {
+      tree f2 = c->norestrict_decl;
+      if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
+	for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
+	  if (TREE_CODE (f2) == FIELD_DECL
+	      && DECL_NAME (f2) == DECL_NAME (field))
+	    break;
+      gcc_assert (f2);
+      c->norestrict_decl = f2;
+      field = f2;
+    }
+
+  tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+			 decl, field, NULL_TREE);
+
+  se->expr = tmp;
+
+  if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
+    {
+      tmp = c->ts.u.cl->backend_decl;
+      /* Components must always be constant length.  */
+      gcc_assert (tmp && INTEGER_CST_P (tmp));
+      se->string_length = tmp;
+    }
+
+  if (gfc_deferred_strlen (c, &field))
+    {
+      tmp = fold_build3_loc (input_location, COMPONENT_REF,
+			     TREE_TYPE (field),
+			     decl, field, NULL_TREE);
+      se->string_length = tmp;
+    }
+
+  if (((c->attr.pointer || c->attr.allocatable)
+       && (!c->attr.dimension && !c->attr.codimension)
+       && c->ts.type != BT_CHARACTER)
+      || c->attr.proc_pointer)
+    se->expr = build_fold_indirect_ref_loc (input_location,
+					se->expr);
+}
+
+
+/* This function deals with component references to components of the
+   parent type for derived type extensions.  */
+static void
+conv_parent_component_references (gfc_se * se, gfc_ref * ref)
+{
+  gfc_component *c;
+  gfc_component *cmp;
+  gfc_symbol *dt;
+  gfc_ref parent;
+
+  dt = ref->u.c.sym;
+  c = ref->u.c.component;
+
+  /* Return if the component is in the parent type.  */
+  for (cmp = dt->components; cmp; cmp = cmp->next)
+    if (strcmp (c->name, cmp->name) == 0)
+      return;
+
+  /* Build a gfc_ref to recursively call gfc_conv_component_ref.  */
+  parent.type = REF_COMPONENT;
+  parent.next = NULL;
+  parent.u.c.sym = dt;
+  parent.u.c.component = dt->components;
+
+  if (dt->backend_decl == NULL)
+    gfc_get_derived_type (dt);
+
+  /* Build the reference and call self.  */
+  gfc_conv_component_ref (se, &parent);
+  parent.u.c.sym = dt->components->ts.u.derived;
+  parent.u.c.component = c;
+  conv_parent_component_references (se, &parent);
+}
+
+/* Return the contents of a variable. Also handles reference/pointer
+   variables (all Fortran pointer references are implicit).  */
+
+static void
+gfc_conv_variable (gfc_se * se, gfc_expr * expr)
+{
+  gfc_ss *ss;
+  gfc_ref *ref;
+  gfc_symbol *sym;
+  tree parent_decl = NULL_TREE;
+  int parent_flag;
+  bool return_value;
+  bool alternate_entry;
+  bool entry_master;
+
+  sym = expr->symtree->n.sym;
+  ss = se->ss;
+  if (ss != NULL)
+    {
+      gfc_ss_info *ss_info = ss->info;
+
+      /* Check that something hasn't gone horribly wrong.  */
+      gcc_assert (ss != gfc_ss_terminator);
+      gcc_assert (ss_info->expr == expr);
+
+      /* A scalarized term.  We already know the descriptor.  */
+      se->expr = ss_info->data.array.descriptor;
+      se->string_length = ss_info->string_length;
+      ref = ss_info->data.array.ref;
+      if (ref)
+	gcc_assert (ref->type == REF_ARRAY
+		    && ref->u.ar.type != AR_ELEMENT);
+      else
+	gfc_conv_tmp_array_ref (se);
+    }
+  else
+    {
+      tree se_expr = NULL_TREE;
+
+      se->expr = gfc_get_symbol_decl (sym);
+
+      /* Deal with references to a parent results or entries by storing
+	 the current_function_decl and moving to the parent_decl.  */
+      return_value = sym->attr.function && sym->result == sym;
+      alternate_entry = sym->attr.function && sym->attr.entry
+			&& sym->result == sym;
+      entry_master = sym->attr.result
+		     && sym->ns->proc_name->attr.entry_master
+		     && !gfc_return_by_reference (sym->ns->proc_name);
+      if (current_function_decl)
+	parent_decl = DECL_CONTEXT (current_function_decl);
+
+      if ((se->expr == parent_decl && return_value)
+	   || (sym->ns && sym->ns->proc_name
+	       && parent_decl
+	       && sym->ns->proc_name->backend_decl == parent_decl
+	       && (alternate_entry || entry_master)))
+	parent_flag = 1;
+      else
+	parent_flag = 0;
+
+      /* Special case for assigning the return value of a function.
+	 Self recursive functions must have an explicit return value.  */
+      if (return_value && (se->expr == current_function_decl || parent_flag))
+	se_expr = gfc_get_fake_result_decl (sym, parent_flag);
+
+      /* Similarly for alternate entry points.  */
+      else if (alternate_entry
+	       && (sym->ns->proc_name->backend_decl == current_function_decl
+		   || parent_flag))
+	{
+	  gfc_entry_list *el = NULL;
+
+	  for (el = sym->ns->entries; el; el = el->next)
+	    if (sym == el->sym)
+	      {
+		se_expr = gfc_get_fake_result_decl (sym, parent_flag);
+		break;
+	      }
+	}
+
+      else if (entry_master
+	       && (sym->ns->proc_name->backend_decl == current_function_decl
+		   || parent_flag))
+	se_expr = gfc_get_fake_result_decl (sym, parent_flag);
+
+      if (se_expr)
+	se->expr = se_expr;
+
+      /* Procedure actual arguments.  */
+      else if (sym->attr.flavor == FL_PROCEDURE
+	       && se->expr != current_function_decl)
+	{
+	  if (!sym->attr.dummy && !sym->attr.proc_pointer)
+	    {
+	      gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
+	      se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
+	    }
+	  return;
+	}
+
+
+      /* Dereference the expression, where needed. Since characters
+	 are entirely different from other types, they are treated
+	 separately.  */
+      if (sym->ts.type == BT_CHARACTER)
+	{
+	  /* Dereference character pointer dummy arguments
+	     or results.  */
+	  if ((sym->attr.pointer || sym->attr.allocatable)
+	      && (sym->attr.dummy
+		  || sym->attr.function
+		  || sym->attr.result))
+	    se->expr = build_fold_indirect_ref_loc (input_location,
+						se->expr);
+
+	}
+      else if (!sym->attr.value)
+	{
+	  /* Dereference non-character scalar dummy arguments.  */
+	  if (sym->attr.dummy && !sym->attr.dimension
+	      && !(sym->attr.codimension && sym->attr.allocatable))
+	    se->expr = build_fold_indirect_ref_loc (input_location,
+						se->expr);
+
+          /* Dereference scalar hidden result.  */
+	  if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
+	      && (sym->attr.function || sym->attr.result)
+	      && !sym->attr.dimension && !sym->attr.pointer
+	      && !sym->attr.always_explicit)
+	    se->expr = build_fold_indirect_ref_loc (input_location,
+						se->expr);
+
+	  /* Dereference non-character 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))
+	      && (sym->attr.dummy
+		  || sym->attr.function
+		  || sym->attr.result
+		  || (!sym->attr.dimension
+		      && (!sym->attr.codimension || !sym->attr.allocatable))))
+	    se->expr = build_fold_indirect_ref_loc (input_location,
+						se->expr);
+	}
+
+      ref = expr->ref;
+    }
+
+  /* For character variables, also get the length.  */
+  if (sym->ts.type == BT_CHARACTER)
+    {
+      /* If the character length of an entry isn't set, get the length from
+         the master function instead.  */
+      if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
+        se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
+      else
+        se->string_length = sym->ts.u.cl->backend_decl;
+      gcc_assert (se->string_length);
+    }
+
+  while (ref)
+    {
+      switch (ref->type)
+	{
+	case REF_ARRAY:
+	  /* Return the descriptor if that's what we want and this is an array
+	     section reference.  */
+	  if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
+	    return;
+/* TODO: Pointers to single elements of array sections, eg elemental subs.  */
+	  /* Return the descriptor for array pointers and allocations.  */
+	  if (se->want_pointer
+	      && ref->next == NULL && (se->descriptor_only))
+	    return;
+
+	  gfc_conv_array_ref (se, &ref->u.ar, expr, &expr->where);
+	  /* Return a pointer to an element.  */
+	  break;
+
+	case REF_COMPONENT:
+	  if (ref->u.c.sym->attr.extension)
+	    conv_parent_component_references (se, ref);
+
+	  gfc_conv_component_ref (se, ref);
+	  if (!ref->next && ref->u.c.sym->attr.codimension
+	      && se->want_pointer && se->descriptor_only)
+	    return;
+
+	  break;
+
+	case REF_SUBSTRING:
+	  gfc_conv_substring (se, ref, expr->ts.kind,
+			      expr->symtree->name, &expr->where);
+	  break;
+
+	default:
+	  gcc_unreachable ();
+	  break;
+	}
+      ref = ref->next;
+    }
+  /* Pointer assignment, allocation or pass by reference.  Arrays are handled
+     separately.  */
+  if (se->want_pointer)
+    {
+      if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
+	gfc_conv_string_parameter (se);
+      else
+	se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
+    }
+}
+
+
+/* Unary ops are easy... Or they would be if ! was a valid op.  */
+
+static void
+gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
+{
+  gfc_se operand;
+  tree type;
+
+  gcc_assert (expr->ts.type != BT_CHARACTER);
+  /* Initialize the operand.  */
+  gfc_init_se (&operand, se);
+  gfc_conv_expr_val (&operand, expr->value.op.op1);
+  gfc_add_block_to_block (&se->pre, &operand.pre);
+
+  type = gfc_typenode_for_spec (&expr->ts);
+
+  /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
+     We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
+     All other unary operators have an equivalent GIMPLE unary operator.  */
+  if (code == TRUTH_NOT_EXPR)
+    se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
+				build_int_cst (type, 0));
+  else
+    se->expr = fold_build1_loc (input_location, code, type, operand.expr);
+
+}
+
+/* Expand power operator to optimal multiplications when a value is raised
+   to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
+   Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
+   Programming", 3rd Edition, 1998.  */
+
+/* This code is mostly duplicated from expand_powi in the backend.
+   We establish the "optimal power tree" lookup table with the defined size.
+   The items in the table are the exponents used to calculate the index
+   exponents. Any integer n less than the value can get an "addition chain",
+   with the first node being one.  */
+#define POWI_TABLE_SIZE 256
+
+/* The table is from builtins.c.  */
+static const unsigned char powi_table[POWI_TABLE_SIZE] =
+  {
+      0,   1,   1,   2,   2,   3,   3,   4,  /*   0 -   7 */
+      4,   6,   5,   6,   6,  10,   7,   9,  /*   8 -  15 */
+      8,  16,   9,  16,  10,  12,  11,  13,  /*  16 -  23 */
+     12,  17,  13,  18,  14,  24,  15,  26,  /*  24 -  31 */
+     16,  17,  17,  19,  18,  33,  19,  26,  /*  32 -  39 */
+     20,  25,  21,  40,  22,  27,  23,  44,  /*  40 -  47 */
+     24,  32,  25,  34,  26,  29,  27,  44,  /*  48 -  55 */
+     28,  31,  29,  34,  30,  60,  31,  36,  /*  56 -  63 */
+     32,  64,  33,  34,  34,  46,  35,  37,  /*  64 -  71 */
+     36,  65,  37,  50,  38,  48,  39,  69,  /*  72 -  79 */
+     40,  49,  41,  43,  42,  51,  43,  58,  /*  80 -  87 */
+     44,  64,  45,  47,  46,  59,  47,  76,  /*  88 -  95 */
+     48,  65,  49,  66,  50,  67,  51,  66,  /*  96 - 103 */
+     52,  70,  53,  74,  54, 104,  55,  74,  /* 104 - 111 */
+     56,  64,  57,  69,  58,  78,  59,  68,  /* 112 - 119 */
+     60,  61,  61,  80,  62,  75,  63,  68,  /* 120 - 127 */
+     64,  65,  65, 128,  66, 129,  67,  90,  /* 128 - 135 */
+     68,  73,  69, 131,  70,  94,  71,  88,  /* 136 - 143 */
+     72, 128,  73,  98,  74, 132,  75, 121,  /* 144 - 151 */
+     76, 102,  77, 124,  78, 132,  79, 106,  /* 152 - 159 */
+     80,  97,  81, 160,  82,  99,  83, 134,  /* 160 - 167 */
+     84,  86,  85,  95,  86, 160,  87, 100,  /* 168 - 175 */
+     88, 113,  89,  98,  90, 107,  91, 122,  /* 176 - 183 */
+     92, 111,  93, 102,  94, 126,  95, 150,  /* 184 - 191 */
+     96, 128,  97, 130,  98, 133,  99, 195,  /* 192 - 199 */
+    100, 128, 101, 123, 102, 164, 103, 138,  /* 200 - 207 */
+    104, 145, 105, 146, 106, 109, 107, 149,  /* 208 - 215 */
+    108, 200, 109, 146, 110, 170, 111, 157,  /* 216 - 223 */
+    112, 128, 113, 130, 114, 182, 115, 132,  /* 224 - 231 */
+    116, 200, 117, 132, 118, 158, 119, 206,  /* 232 - 239 */
+    120, 240, 121, 162, 122, 147, 123, 152,  /* 240 - 247 */
+    124, 166, 125, 214, 126, 138, 127, 153,  /* 248 - 255 */
+  };
+
+/* If n is larger than lookup table's max index, we use the "window
+   method".  */
+#define POWI_WINDOW_SIZE 3
+
+/* Recursive function to expand the power operator. The temporary
+   values are put in tmpvar. The function returns tmpvar[1] ** n.  */
+static tree
+gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
+{
+  tree op0;
+  tree op1;
+  tree tmp;
+  int digit;
+
+  if (n < POWI_TABLE_SIZE)
+    {
+      if (tmpvar[n])
+        return tmpvar[n];
+
+      op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
+      op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
+    }
+  else if (n & 1)
+    {
+      digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
+      op0 = gfc_conv_powi (se, n - digit, tmpvar);
+      op1 = gfc_conv_powi (se, digit, tmpvar);
+    }
+  else
+    {
+      op0 = gfc_conv_powi (se, n >> 1, tmpvar);
+      op1 = op0;
+    }
+
+  tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
+  tmp = gfc_evaluate_now (tmp, &se->pre);
+
+  if (n < POWI_TABLE_SIZE)
+    tmpvar[n] = tmp;
+
+  return tmp;
+}
+
+
+/* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
+   return 1. Else return 0 and a call to runtime library functions
+   will have to be built.  */
+static int
+gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
+{
+  tree cond;
+  tree tmp;
+  tree type;
+  tree vartmp[POWI_TABLE_SIZE];
+  HOST_WIDE_INT m;
+  unsigned HOST_WIDE_INT n;
+  int sgn;
+
+  /* If exponent is too large, we won't expand it anyway, so don't bother
+     with large integer values.  */
+  if (!TREE_INT_CST (rhs).fits_shwi ())
+    return 0;
+
+  m = TREE_INT_CST (rhs).to_shwi ();
+  /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
+     of the asymmetric range of the integer type.  */
+  n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
+
+  type = TREE_TYPE (lhs);
+  sgn = tree_int_cst_sgn (rhs);
+
+  if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
+       || optimize_size) && (m > 2 || m < -1))
+    return 0;
+
+  /* rhs == 0  */
+  if (sgn == 0)
+    {
+      se->expr = gfc_build_const (type, integer_one_node);
+      return 1;
+    }
+
+  /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1.  */
+  if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
+    {
+      tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+			     lhs, build_int_cst (TREE_TYPE (lhs), -1));
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+			      lhs, build_int_cst (TREE_TYPE (lhs), 1));
+
+      /* If rhs is even,
+	 result = (lhs == 1 || lhs == -1) ? 1 : 0.  */
+      if ((n & 1) == 0)
+        {
+	  tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+				 boolean_type_node, tmp, cond);
+	  se->expr = fold_build3_loc (input_location, COND_EXPR, type,
+				      tmp, build_int_cst (type, 1),
+				      build_int_cst (type, 0));
+	  return 1;
+	}
+      /* If rhs is odd,
+	 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0.  */
+      tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
+			     build_int_cst (type, -1),
+			     build_int_cst (type, 0));
+      se->expr = fold_build3_loc (input_location, COND_EXPR, type,
+				  cond, build_int_cst (type, 1), tmp);
+      return 1;
+    }
+
+  memset (vartmp, 0, sizeof (vartmp));
+  vartmp[1] = lhs;
+  if (sgn == -1)
+    {
+      tmp = gfc_build_const (type, integer_one_node);
+      vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
+				   vartmp[1]);
+    }
+
+  se->expr = gfc_conv_powi (se, n, vartmp);
+
+  return 1;
+}
+
+
+/* Power op (**).  Constant integer exponent has special handling.  */
+
+static void
+gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
+{
+  tree gfc_int4_type_node;
+  int kind;
+  int ikind;
+  int res_ikind_1, res_ikind_2;
+  gfc_se lse;
+  gfc_se rse;
+  tree fndecl = NULL;
+
+  gfc_init_se (&lse, se);
+  gfc_conv_expr_val (&lse, expr->value.op.op1);
+  lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
+  gfc_add_block_to_block (&se->pre, &lse.pre);
+
+  gfc_init_se (&rse, se);
+  gfc_conv_expr_val (&rse, expr->value.op.op2);
+  gfc_add_block_to_block (&se->pre, &rse.pre);
+
+  if (expr->value.op.op2->ts.type == BT_INTEGER
+      && expr->value.op.op2->expr_type == EXPR_CONSTANT)
+    if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
+      return;
+
+  gfc_int4_type_node = gfc_get_int_type (4);
+
+  /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
+     library routine.  But in the end, we have to convert the result back
+     if this case applies -- with res_ikind_K, we keep track whether operand K
+     falls into this case.  */
+  res_ikind_1 = -1;
+  res_ikind_2 = -1;
+
+  kind = expr->value.op.op1->ts.kind;
+  switch (expr->value.op.op2->ts.type)
+    {
+    case BT_INTEGER:
+      ikind = expr->value.op.op2->ts.kind;
+      switch (ikind)
+	{
+	case 1:
+	case 2:
+	  rse.expr = convert (gfc_int4_type_node, rse.expr);
+	  res_ikind_2 = ikind;
+	  /* Fall through.  */
+
+	case 4:
+	  ikind = 0;
+	  break;
+
+	case 8:
+	  ikind = 1;
+	  break;
+
+	case 16:
+	  ikind = 2;
+	  break;
+
+	default:
+	  gcc_unreachable ();
+	}
+      switch (kind)
+	{
+	case 1:
+	case 2:
+	  if (expr->value.op.op1->ts.type == BT_INTEGER)
+	    {
+	      lse.expr = convert (gfc_int4_type_node, lse.expr);
+	      res_ikind_1 = kind;
+	    }
+	  else
+	    gcc_unreachable ();
+	  /* Fall through.  */
+
+	case 4:
+	  kind = 0;
+	  break;
+
+	case 8:
+	  kind = 1;
+	  break;
+
+	case 10:
+	  kind = 2;
+	  break;
+
+	case 16:
+	  kind = 3;
+	  break;
+
+	default:
+	  gcc_unreachable ();
+	}
+
+      switch (expr->value.op.op1->ts.type)
+	{
+	case BT_INTEGER:
+	  if (kind == 3) /* Case 16 was not handled properly above.  */
+	    kind = 2;
+	  fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
+	  break;
+
+	case BT_REAL:
+	  /* Use builtins for real ** int4.  */
+	  if (ikind == 0)
+	    {
+	      switch (kind)
+		{
+		case 0:
+		  fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
+		  break;
+
+		case 1:
+		  fndecl = builtin_decl_explicit (BUILT_IN_POWI);
+		  break;
+
+		case 2:
+		  fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
+		  break;
+
+		case 3:
+		  /* Use the __builtin_powil() only if real(kind=16) is
+		     actually the C long double type.  */
+		  if (!gfc_real16_is_float128)
+		    fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
+		  break;
+
+		default:
+		  gcc_unreachable ();
+		}
+	    }
+
+	  /* If we don't have a good builtin for this, go for the
+	     library function.  */
+	  if (!fndecl)
+	    fndecl = gfor_fndecl_math_powi[kind][ikind].real;
+	  break;
+
+	case BT_COMPLEX:
+	  fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
+	  break;
+
+	default:
+	  gcc_unreachable ();
+ 	}
+      break;
+
+    case BT_REAL:
+      fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
+      break;
+
+    case BT_COMPLEX:
+      fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
+      break;
+
+    default:
+      gcc_unreachable ();
+      break;
+    }
+
+  se->expr = build_call_expr_loc (input_location,
+			      fndecl, 2, lse.expr, rse.expr);
+
+  /* Convert the result back if it is of wrong integer kind.  */
+  if (res_ikind_1 != -1 && res_ikind_2 != -1)
+    {
+      /* We want the maximum of both operand kinds as result.  */
+      if (res_ikind_1 < res_ikind_2)
+	res_ikind_1 = res_ikind_2;
+      se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
+    }
+}
+
+
+/* Generate code to allocate a string temporary.  */
+
+tree
+gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
+{
+  tree var;
+  tree tmp;
+
+  if (gfc_can_put_var_on_stack (len))
+    {
+      /* Create a temporary variable to hold the result.  */
+      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+			     gfc_charlen_type_node, len,
+			     build_int_cst (gfc_charlen_type_node, 1));
+      tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
+
+      if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
+	tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
+      else
+	tmp = build_array_type (TREE_TYPE (type), tmp);
+
+      var = gfc_create_var (tmp, "str");
+      var = gfc_build_addr_expr (type, var);
+    }
+  else
+    {
+      /* Allocate a temporary to hold the result.  */
+      var = gfc_create_var (type, "pstr");
+      gcc_assert (POINTER_TYPE_P (type));
+      tmp = TREE_TYPE (type);
+      if (TREE_CODE (tmp) == ARRAY_TYPE)
+        tmp = TREE_TYPE (tmp);
+      tmp = TYPE_SIZE_UNIT (tmp);
+      tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
+			    fold_convert (size_type_node, len),
+			    fold_convert (size_type_node, tmp));
+      tmp = gfc_call_malloc (&se->pre, type, tmp);
+      gfc_add_modify (&se->pre, var, tmp);
+
+      /* Free the temporary afterwards.  */
+      tmp = gfc_call_free (convert (pvoid_type_node, var));
+      gfc_add_expr_to_block (&se->post, tmp);
+    }
+
+  return var;
+}
+
+
+/* Handle a string concatenation operation.  A temporary will be allocated to
+   hold the result.  */
+
+static void
+gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
+{
+  gfc_se lse, rse;
+  tree len, type, var, tmp, fndecl;
+
+  gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
+	      && expr->value.op.op2->ts.type == BT_CHARACTER);
+  gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
+
+  gfc_init_se (&lse, se);
+  gfc_conv_expr (&lse, expr->value.op.op1);
+  gfc_conv_string_parameter (&lse);
+  gfc_init_se (&rse, se);
+  gfc_conv_expr (&rse, expr->value.op.op2);
+  gfc_conv_string_parameter (&rse);
+
+  gfc_add_block_to_block (&se->pre, &lse.pre);
+  gfc_add_block_to_block (&se->pre, &rse.pre);
+
+  type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
+  len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
+  if (len == NULL_TREE)
+    {
+      len = fold_build2_loc (input_location, PLUS_EXPR,
+			     TREE_TYPE (lse.string_length),
+			     lse.string_length, rse.string_length);
+    }
+
+  type = build_pointer_type (type);
+
+  var = gfc_conv_string_tmp (se, type, len);
+
+  /* Do the actual concatenation.  */
+  if (expr->ts.kind == 1)
+    fndecl = gfor_fndecl_concat_string;
+  else if (expr->ts.kind == 4)
+    fndecl = gfor_fndecl_concat_string_char4;
+  else
+    gcc_unreachable ();
+
+  tmp = build_call_expr_loc (input_location,
+			 fndecl, 6, len, var, lse.string_length, lse.expr,
+			 rse.string_length, rse.expr);
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  /* Add the cleanup for the operands.  */
+  gfc_add_block_to_block (&se->pre, &rse.post);
+  gfc_add_block_to_block (&se->pre, &lse.post);
+
+  se->expr = var;
+  se->string_length = len;
+}
+
+/* Translates an op expression. Common (binary) cases are handled by this
+   function, others are passed on. Recursion is used in either case.
+   We use the fact that (op1.ts == op2.ts) (except for the power
+   operator **).
+   Operators need no special handling for scalarized expressions as long as
+   they call gfc_conv_simple_val to get their operands.
+   Character strings get special handling.  */
+
+static void
+gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
+{
+  enum tree_code code;
+  gfc_se lse;
+  gfc_se rse;
+  tree tmp, type;
+  int lop;
+  int checkstring;
+
+  checkstring = 0;
+  lop = 0;
+  switch (expr->value.op.op)
+    {
+    case INTRINSIC_PARENTHESES:
+      if ((expr->ts.type == BT_REAL
+	   || expr->ts.type == BT_COMPLEX)
+	  && gfc_option.flag_protect_parens)
+	{
+	  gfc_conv_unary_op (PAREN_EXPR, se, expr);
+	  gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
+	  return;
+	}
+
+      /* Fallthrough.  */
+    case INTRINSIC_UPLUS:
+      gfc_conv_expr (se, expr->value.op.op1);
+      return;
+
+    case INTRINSIC_UMINUS:
+      gfc_conv_unary_op (NEGATE_EXPR, se, expr);
+      return;
+
+    case INTRINSIC_NOT:
+      gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
+      return;
+
+    case INTRINSIC_PLUS:
+      code = PLUS_EXPR;
+      break;
+
+    case INTRINSIC_MINUS:
+      code = MINUS_EXPR;
+      break;
+
+    case INTRINSIC_TIMES:
+      code = MULT_EXPR;
+      break;
+
+    case INTRINSIC_DIVIDE:
+      /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
+         an integer, we must round towards zero, so we use a
+         TRUNC_DIV_EXPR.  */
+      if (expr->ts.type == BT_INTEGER)
+	code = TRUNC_DIV_EXPR;
+      else
+	code = RDIV_EXPR;
+      break;
+
+    case INTRINSIC_POWER:
+      gfc_conv_power_op (se, expr);
+      return;
+
+    case INTRINSIC_CONCAT:
+      gfc_conv_concat_op (se, expr);
+      return;
+
+    case INTRINSIC_AND:
+      code = TRUTH_ANDIF_EXPR;
+      lop = 1;
+      break;
+
+    case INTRINSIC_OR:
+      code = TRUTH_ORIF_EXPR;
+      lop = 1;
+      break;
+
+      /* EQV and NEQV only work on logicals, but since we represent them
+         as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE.  */
+    case INTRINSIC_EQ:
+    case INTRINSIC_EQ_OS:
+    case INTRINSIC_EQV:
+      code = EQ_EXPR;
+      checkstring = 1;
+      lop = 1;
+      break;
+
+    case INTRINSIC_NE:
+    case INTRINSIC_NE_OS:
+    case INTRINSIC_NEQV:
+      code = NE_EXPR;
+      checkstring = 1;
+      lop = 1;
+      break;
+
+    case INTRINSIC_GT:
+    case INTRINSIC_GT_OS:
+      code = GT_EXPR;
+      checkstring = 1;
+      lop = 1;
+      break;
+
+    case INTRINSIC_GE:
+    case INTRINSIC_GE_OS:
+      code = GE_EXPR;
+      checkstring = 1;
+      lop = 1;
+      break;
+
+    case INTRINSIC_LT:
+    case INTRINSIC_LT_OS:
+      code = LT_EXPR;
+      checkstring = 1;
+      lop = 1;
+      break;
+
+    case INTRINSIC_LE:
+    case INTRINSIC_LE_OS:
+      code = LE_EXPR;
+      checkstring = 1;
+      lop = 1;
+      break;
+
+    case INTRINSIC_USER:
+    case INTRINSIC_ASSIGN:
+      /* These should be converted into function calls by the frontend.  */
+      gcc_unreachable ();
+
+    default:
+      fatal_error ("Unknown intrinsic op");
+      return;
+    }
+
+  /* The only exception to this is **, which is handled separately anyway.  */
+  gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
+
+  if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
+    checkstring = 0;
+
+  /* lhs */
+  gfc_init_se (&lse, se);
+  gfc_conv_expr (&lse, expr->value.op.op1);
+  gfc_add_block_to_block (&se->pre, &lse.pre);
+
+  /* rhs */
+  gfc_init_se (&rse, se);
+  gfc_conv_expr (&rse, expr->value.op.op2);
+  gfc_add_block_to_block (&se->pre, &rse.pre);
+
+  if (checkstring)
+    {
+      gfc_conv_string_parameter (&lse);
+      gfc_conv_string_parameter (&rse);
+
+      lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
+					   rse.string_length, rse.expr,
+					   expr->value.op.op1->ts.kind,
+					   code);
+      rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
+      gfc_add_block_to_block (&lse.post, &rse.post);
+    }
+
+  type = gfc_typenode_for_spec (&expr->ts);
+
+  if (lop)
+    {
+      /* The result of logical ops is always boolean_type_node.  */
+      tmp = fold_build2_loc (input_location, code, boolean_type_node,
+			     lse.expr, rse.expr);
+      se->expr = convert (type, tmp);
+    }
+  else
+    se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
+
+  /* Add the post blocks.  */
+  gfc_add_block_to_block (&se->post, &rse.post);
+  gfc_add_block_to_block (&se->post, &lse.post);
+}
+
+/* If a string's length is one, we convert it to a single character.  */
+
+tree
+gfc_string_to_single_character (tree len, tree str, int kind)
+{
+
+  if (len == NULL
+      || !INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0
+      || !POINTER_TYPE_P (TREE_TYPE (str)))
+    return NULL_TREE;
+
+  if (TREE_INT_CST_LOW (len) == 1)
+    {
+      str = fold_convert (gfc_get_pchar_type (kind), str);
+      return build_fold_indirect_ref_loc (input_location, str);
+    }
+
+  if (kind == 1
+      && TREE_CODE (str) == ADDR_EXPR
+      && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
+      && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
+      && array_ref_low_bound (TREE_OPERAND (str, 0))
+	 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
+      && TREE_INT_CST_LOW (len) > 1
+      && TREE_INT_CST_LOW (len)
+	 == (unsigned HOST_WIDE_INT)
+	    TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
+    {
+      tree ret = fold_convert (gfc_get_pchar_type (kind), str);
+      ret = build_fold_indirect_ref_loc (input_location, ret);
+      if (TREE_CODE (ret) == INTEGER_CST)
+	{
+	  tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
+	  int i, length = TREE_STRING_LENGTH (string_cst);
+	  const char *ptr = TREE_STRING_POINTER (string_cst);
+
+	  for (i = 1; i < length; i++)
+	    if (ptr[i] != ' ')
+	      return NULL_TREE;
+
+	  return ret;
+	}
+    }
+
+  return NULL_TREE;
+}
+
+
+void
+gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
+{
+
+  if (sym->backend_decl)
+    {
+      /* This becomes the nominal_type in
+	 function.c:assign_parm_find_data_types.  */
+      TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
+      /* This becomes the passed_type in
+	 function.c:assign_parm_find_data_types.  C promotes char to
+	 integer for argument passing.  */
+      DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
+
+      DECL_BY_REFERENCE (sym->backend_decl) = 0;
+    }
+
+  if (expr != NULL)
+    {
+      /* If we have a constant character expression, make it into an
+	 integer.  */
+      if ((*expr)->expr_type == EXPR_CONSTANT)
+        {
+	  gfc_typespec ts;
+          gfc_clear_ts (&ts);
+
+	  *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+				    (int)(*expr)->value.character.string[0]);
+	  if ((*expr)->ts.kind != gfc_c_int_kind)
+	    {
+  	      /* The expr needs to be compatible with a C int.  If the
+		 conversion fails, then the 2 causes an ICE.  */
+	      ts.type = BT_INTEGER;
+	      ts.kind = gfc_c_int_kind;
+	      gfc_convert_type (*expr, &ts, 2);
+	    }
+	}
+      else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
+        {
+	  if ((*expr)->ref == NULL)
+	    {
+	      se->expr = gfc_string_to_single_character
+		(build_int_cst (integer_type_node, 1),
+		 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
+				      gfc_get_symbol_decl
+				      ((*expr)->symtree->n.sym)),
+		 (*expr)->ts.kind);
+	    }
+	  else
+	    {
+	      gfc_conv_variable (se, *expr);
+	      se->expr = gfc_string_to_single_character
+		(build_int_cst (integer_type_node, 1),
+		 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
+				      se->expr),
+		 (*expr)->ts.kind);
+	    }
+	}
+    }
+}
+
+/* Helper function for gfc_build_compare_string.  Return LEN_TRIM value
+   if STR is a string literal, otherwise return -1.  */
+
+static int
+gfc_optimize_len_trim (tree len, tree str, int kind)
+{
+  if (kind == 1
+      && TREE_CODE (str) == ADDR_EXPR
+      && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
+      && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
+      && array_ref_low_bound (TREE_OPERAND (str, 0))
+	 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
+      && TREE_INT_CST_LOW (len) >= 1
+      && TREE_INT_CST_LOW (len)
+	 == (unsigned HOST_WIDE_INT)
+	    TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
+    {
+      tree folded = fold_convert (gfc_get_pchar_type (kind), str);
+      folded = build_fold_indirect_ref_loc (input_location, folded);
+      if (TREE_CODE (folded) == INTEGER_CST)
+	{
+	  tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
+	  int length = TREE_STRING_LENGTH (string_cst);
+	  const char *ptr = TREE_STRING_POINTER (string_cst);
+
+	  for (; length > 0; length--)
+	    if (ptr[length - 1] != ' ')
+	      break;
+
+	  return length;
+	}
+    }
+  return -1;
+}
+
+/* Helper to build a call to memcmp.  */
+
+static tree
+build_memcmp_call (tree s1, tree s2, tree n)
+{
+  tree tmp;
+
+  if (!POINTER_TYPE_P (TREE_TYPE (s1)))
+    s1 = gfc_build_addr_expr (pvoid_type_node, s1);
+  else
+    s1 = fold_convert (pvoid_type_node, s1);
+
+  if (!POINTER_TYPE_P (TREE_TYPE (s2)))
+    s2 = gfc_build_addr_expr (pvoid_type_node, s2);
+  else
+    s2 = fold_convert (pvoid_type_node, s2);
+
+  n = fold_convert (size_type_node, n);
+
+  tmp = build_call_expr_loc (input_location,
+			     builtin_decl_explicit (BUILT_IN_MEMCMP),
+			     3, s1, s2, n);
+
+  return fold_convert (integer_type_node, tmp);
+}
+
+/* Compare two strings. If they are all single characters, the result is the
+   subtraction of them. Otherwise, we build a library call.  */
+
+tree
+gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
+			  enum tree_code code)
+{
+  tree sc1;
+  tree sc2;
+  tree fndecl;
+
+  gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
+  gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
+
+  sc1 = gfc_string_to_single_character (len1, str1, kind);
+  sc2 = gfc_string_to_single_character (len2, str2, kind);
+
+  if (sc1 != NULL_TREE && sc2 != NULL_TREE)
+    {
+      /* Deal with single character specially.  */
+      sc1 = fold_convert (integer_type_node, sc1);
+      sc2 = fold_convert (integer_type_node, sc2);
+      return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
+			      sc1, sc2);
+    }
+
+  if ((code == EQ_EXPR || code == NE_EXPR)
+      && optimize
+      && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
+    {
+      /* If one string is a string literal with LEN_TRIM longer
+	 than the length of the second string, the strings
+	 compare unequal.  */
+      int len = gfc_optimize_len_trim (len1, str1, kind);
+      if (len > 0 && compare_tree_int (len2, len) < 0)
+	return integer_one_node;
+      len = gfc_optimize_len_trim (len2, str2, kind);
+      if (len > 0 && compare_tree_int (len1, len) < 0)
+	return integer_one_node;
+    }
+
+  /* We can compare via memcpy if the strings are known to be equal
+     in length and they are
+     - kind=1
+     - kind=4 and the comparison is for (in)equality.  */
+
+  if (INTEGER_CST_P (len1) && INTEGER_CST_P (len2)
+      && tree_int_cst_equal (len1, len2)
+      && (kind == 1 || code == EQ_EXPR || code == NE_EXPR))
+    {
+      tree tmp;
+      tree chartype;
+
+      chartype = gfc_get_char_type (kind);
+      tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1),
+			     fold_convert (TREE_TYPE(len1),
+					   TYPE_SIZE_UNIT(chartype)),
+			     len1);
+      return build_memcmp_call (str1, str2, tmp);
+    }
+
+  /* Build a call for the comparison.  */
+  if (kind == 1)
+    fndecl = gfor_fndecl_compare_string;
+  else if (kind == 4)
+    fndecl = gfor_fndecl_compare_string_char4;
+  else
+    gcc_unreachable ();
+
+  return build_call_expr_loc (input_location, fndecl, 4,
+			      len1, str1, len2, str2);
+}
+
+
+/* Return the backend_decl for a procedure pointer component.  */
+
+static tree
+get_proc_ptr_comp (gfc_expr *e)
+{
+  gfc_se comp_se;
+  gfc_expr *e2;
+  expr_t old_type;
+
+  gfc_init_se (&comp_se, NULL);
+  e2 = gfc_copy_expr (e);
+  /* We have to restore the expr type later so that gfc_free_expr frees
+     the exact same thing that was allocated.
+     TODO: This is ugly.  */
+  old_type = e2->expr_type;
+  e2->expr_type = EXPR_VARIABLE;
+  gfc_conv_expr (&comp_se, e2);
+  e2->expr_type = old_type;
+  gfc_free_expr (e2);
+  return build_fold_addr_expr_loc (input_location, comp_se.expr);
+}
+
+
+/* Convert a typebound function reference from a class object.  */
+static void
+conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
+{
+  gfc_ref *ref;
+  tree var;
+
+  if (TREE_CODE (base_object) != VAR_DECL)
+    {
+      var = gfc_create_var (TREE_TYPE (base_object), NULL);
+      gfc_add_modify (&se->pre, var, base_object);
+    }
+  se->expr = gfc_class_vptr_get (base_object);
+  se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
+  ref = expr->ref;
+  while (ref && ref->next)
+    ref = ref->next;
+  gcc_assert (ref && ref->type == REF_COMPONENT);
+  if (ref->u.c.sym->attr.extension)
+    conv_parent_component_references (se, ref);
+  gfc_conv_component_ref (se, ref);
+  se->expr = build_fold_addr_expr_loc (input_location, se->expr);
+}
+
+
+static void
+conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
+{
+  tree tmp;
+
+  if (gfc_is_proc_ptr_comp (expr))
+    tmp = get_proc_ptr_comp (expr);
+  else if (sym->attr.dummy)
+    {
+      tmp = gfc_get_symbol_decl (sym);
+      if (sym->attr.proc_pointer)
+        tmp = build_fold_indirect_ref_loc (input_location,
+				       tmp);
+      gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
+	      && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
+    }
+  else
+    {
+      if (!sym->backend_decl)
+	sym->backend_decl = gfc_get_extern_function_decl (sym);
+
+      TREE_USED (sym->backend_decl) = 1;
+
+      tmp = sym->backend_decl;
+
+      if (sym->attr.cray_pointee)
+	{
+	  /* TODO - make the cray pointee a pointer to a procedure,
+	     assign the pointer to it and use it for the call.  This
+	     will do for now!  */
+	  tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
+			 gfc_get_symbol_decl (sym->cp_pointer));
+	  tmp = gfc_evaluate_now (tmp, &se->pre);
+	}
+
+      if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+	{
+	  gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
+	  tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+	}
+    }
+  se->expr = tmp;
+}
+
+
+/* Initialize MAPPING.  */
+
+void
+gfc_init_interface_mapping (gfc_interface_mapping * mapping)
+{
+  mapping->syms = NULL;
+  mapping->charlens = NULL;
+}
+
+
+/* Free all memory held by MAPPING (but not MAPPING itself).  */
+
+void
+gfc_free_interface_mapping (gfc_interface_mapping * mapping)
+{
+  gfc_interface_sym_mapping *sym;
+  gfc_interface_sym_mapping *nextsym;
+  gfc_charlen *cl;
+  gfc_charlen *nextcl;
+
+  for (sym = mapping->syms; sym; sym = nextsym)
+    {
+      nextsym = sym->next;
+      sym->new_sym->n.sym->formal = NULL;
+      gfc_free_symbol (sym->new_sym->n.sym);
+      gfc_free_expr (sym->expr);
+      free (sym->new_sym);
+      free (sym);
+    }
+  for (cl = mapping->charlens; cl; cl = nextcl)
+    {
+      nextcl = cl->next;
+      gfc_free_expr (cl->length);
+      free (cl);
+    }
+}
+
+
+/* Return a copy of gfc_charlen CL.  Add the returned structure to
+   MAPPING so that it will be freed by gfc_free_interface_mapping.  */
+
+static gfc_charlen *
+gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
+				   gfc_charlen * cl)
+{
+  gfc_charlen *new_charlen;
+
+  new_charlen = gfc_get_charlen ();
+  new_charlen->next = mapping->charlens;
+  new_charlen->length = gfc_copy_expr (cl->length);
+
+  mapping->charlens = new_charlen;
+  return new_charlen;
+}
+
+
+/* A subroutine of gfc_add_interface_mapping.  Return a descriptorless
+   array variable that can be used as the actual argument for dummy
+   argument SYM.  Add any initialization code to BLOCK.  PACKED is as
+   for gfc_get_nodesc_array_type and DATA points to the first element
+   in the passed array.  */
+
+static tree
+gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
+				 gfc_packed packed, tree data)
+{
+  tree type;
+  tree var;
+
+  type = gfc_typenode_for_spec (&sym->ts);
+  type = gfc_get_nodesc_array_type (type, sym->as, packed,
+				    !sym->attr.target && !sym->attr.pointer
+				    && !sym->attr.proc_pointer);
+
+  var = gfc_create_var (type, "ifm");
+  gfc_add_modify (block, var, fold_convert (type, data));
+
+  return var;
+}
+
+
+/* A subroutine of gfc_add_interface_mapping.  Set the stride, upper bounds
+   and offset of descriptorless array type TYPE given that it has the same
+   size as DESC.  Add any set-up code to BLOCK.  */
+
+static void
+gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
+{
+  int n;
+  tree dim;
+  tree offset;
+  tree tmp;
+
+  offset = gfc_index_zero_node;
+  for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
+    {
+      dim = gfc_rank_cst[n];
+      GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
+      if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
+	{
+	  GFC_TYPE_ARRAY_LBOUND (type, n)
+		= gfc_conv_descriptor_lbound_get (desc, dim);
+	  GFC_TYPE_ARRAY_UBOUND (type, n)
+		= gfc_conv_descriptor_ubound_get (desc, dim);
+	}
+      else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
+	{
+	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				 gfc_array_index_type,
+				 gfc_conv_descriptor_ubound_get (desc, dim),
+				 gfc_conv_descriptor_lbound_get (desc, dim));
+	  tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type,
+				 GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
+	  tmp = gfc_evaluate_now (tmp, block);
+	  GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
+	}
+      tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			     GFC_TYPE_ARRAY_LBOUND (type, n),
+			     GFC_TYPE_ARRAY_STRIDE (type, n));
+      offset = fold_build2_loc (input_location, MINUS_EXPR,
+				gfc_array_index_type, offset, tmp);
+    }
+  offset = gfc_evaluate_now (offset, block);
+  GFC_TYPE_ARRAY_OFFSET (type) = offset;
+}
+
+
+/* Extend MAPPING so that it maps dummy argument SYM to the value stored
+   in SE.  The caller may still use se->expr and se->string_length after
+   calling this function.  */
+
+void
+gfc_add_interface_mapping (gfc_interface_mapping * mapping,
+			   gfc_symbol * sym, gfc_se * se,
+			   gfc_expr *expr)
+{
+  gfc_interface_sym_mapping *sm;
+  tree desc;
+  tree tmp;
+  tree value;
+  gfc_symbol *new_sym;
+  gfc_symtree *root;
+  gfc_symtree *new_symtree;
+
+  /* Create a new symbol to represent the actual argument.  */
+  new_sym = gfc_new_symbol (sym->name, NULL);
+  new_sym->ts = sym->ts;
+  new_sym->as = gfc_copy_array_spec (sym->as);
+  new_sym->attr.referenced = 1;
+  new_sym->attr.dimension = sym->attr.dimension;
+  new_sym->attr.contiguous = sym->attr.contiguous;
+  new_sym->attr.codimension = sym->attr.codimension;
+  new_sym->attr.pointer = sym->attr.pointer;
+  new_sym->attr.allocatable = sym->attr.allocatable;
+  new_sym->attr.flavor = sym->attr.flavor;
+  new_sym->attr.function = sym->attr.function;
+
+  /* Ensure that the interface is available and that
+     descriptors are passed for array actual arguments.  */
+  if (sym->attr.flavor == FL_PROCEDURE)
+    {
+      new_sym->formal = expr->symtree->n.sym->formal;
+      new_sym->attr.always_explicit
+	    = expr->symtree->n.sym->attr.always_explicit;
+    }
+
+  /* Create a fake symtree for it.  */
+  root = NULL;
+  new_symtree = gfc_new_symtree (&root, sym->name);
+  new_symtree->n.sym = new_sym;
+  gcc_assert (new_symtree == root);
+
+  /* Create a dummy->actual mapping.  */
+  sm = XCNEW (gfc_interface_sym_mapping);
+  sm->next = mapping->syms;
+  sm->old = sym;
+  sm->new_sym = new_symtree;
+  sm->expr = gfc_copy_expr (expr);
+  mapping->syms = sm;
+
+  /* Stabilize the argument's value.  */
+  if (!sym->attr.function && se)
+    se->expr = gfc_evaluate_now (se->expr, &se->pre);
+
+  if (sym->ts.type == BT_CHARACTER)
+    {
+      /* Create a copy of the dummy argument's length.  */
+      new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
+      sm->expr->ts.u.cl = new_sym->ts.u.cl;
+
+      /* If the length is specified as "*", record the length that
+	 the caller is passing.  We should use the callee's length
+	 in all other cases.  */
+      if (!new_sym->ts.u.cl->length && se)
+	{
+	  se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
+	  new_sym->ts.u.cl->backend_decl = se->string_length;
+	}
+    }
+
+  if (!se)
+    return;
+
+  /* Use the passed value as-is if the argument is a function.  */
+  if (sym->attr.flavor == FL_PROCEDURE)
+    value = se->expr;
+
+  /* If the argument is either a string or a pointer to a string,
+     convert it to a boundless character type.  */
+  else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
+    {
+      tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
+      tmp = build_pointer_type (tmp);
+      if (sym->attr.pointer)
+        value = build_fold_indirect_ref_loc (input_location,
+					 se->expr);
+      else
+        value = se->expr;
+      value = fold_convert (tmp, value);
+    }
+
+  /* If the argument is a scalar, a pointer to an array or an allocatable,
+     dereference it.  */
+  else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
+    value = build_fold_indirect_ref_loc (input_location,
+				     se->expr);
+
+  /* For character(*), use the actual argument's descriptor.  */
+  else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
+    value = build_fold_indirect_ref_loc (input_location,
+				     se->expr);
+
+  /* If the argument is an array descriptor, use it to determine
+     information about the actual argument's shape.  */
+  else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
+	   && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
+    {
+      /* Get the actual argument's descriptor.  */
+      desc = build_fold_indirect_ref_loc (input_location,
+				      se->expr);
+
+      /* Create the replacement variable.  */
+      tmp = gfc_conv_descriptor_data_get (desc);
+      value = gfc_get_interface_mapping_array (&se->pre, sym,
+					       PACKED_NO, tmp);
+
+      /* Use DESC to work out the upper bounds, strides and offset.  */
+      gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
+    }
+  else
+    /* Otherwise we have a packed array.  */
+    value = gfc_get_interface_mapping_array (&se->pre, sym,
+					     PACKED_FULL, se->expr);
+
+  new_sym->backend_decl = value;
+}
+
+
+/* Called once all dummy argument mappings have been added to MAPPING,
+   but before the mapping is used to evaluate expressions.  Pre-evaluate
+   the length of each argument, adding any initialization code to PRE and
+   any finalization code to POST.  */
+
+void
+gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
+			      stmtblock_t * pre, stmtblock_t * post)
+{
+  gfc_interface_sym_mapping *sym;
+  gfc_expr *expr;
+  gfc_se se;
+
+  for (sym = mapping->syms; sym; sym = sym->next)
+    if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
+	&& !sym->new_sym->n.sym->ts.u.cl->backend_decl)
+      {
+	expr = sym->new_sym->n.sym->ts.u.cl->length;
+	gfc_apply_interface_mapping_to_expr (mapping, expr);
+	gfc_init_se (&se, NULL);
+	gfc_conv_expr (&se, expr);
+	se.expr = fold_convert (gfc_charlen_type_node, se.expr);
+	se.expr = gfc_evaluate_now (se.expr, &se.pre);
+	gfc_add_block_to_block (pre, &se.pre);
+	gfc_add_block_to_block (post, &se.post);
+
+	sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
+      }
+}
+
+
+/* Like gfc_apply_interface_mapping_to_expr, but applied to
+   constructor C.  */
+
+static void
+gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
+				     gfc_constructor_base base)
+{
+  gfc_constructor *c;
+  for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
+    {
+      gfc_apply_interface_mapping_to_expr (mapping, c->expr);
+      if (c->iterator)
+	{
+	  gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
+	  gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
+	  gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
+	}
+    }
+}
+
+
+/* Like gfc_apply_interface_mapping_to_expr, but applied to
+   reference REF.  */
+
+static void
+gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
+				    gfc_ref * ref)
+{
+  int n;
+
+  for (; ref; ref = ref->next)
+    switch (ref->type)
+      {
+      case REF_ARRAY:
+	for (n = 0; n < ref->u.ar.dimen; n++)
+	  {
+	    gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
+	    gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
+	    gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
+	  }
+	break;
+
+      case REF_COMPONENT:
+	break;
+
+      case REF_SUBSTRING:
+	gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
+	gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
+	break;
+      }
+}
+
+
+/* Convert intrinsic function calls into result expressions.  */
+
+static bool
+gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
+{
+  gfc_symbol *sym;
+  gfc_expr *new_expr;
+  gfc_expr *arg1;
+  gfc_expr *arg2;
+  int d, dup;
+
+  arg1 = expr->value.function.actual->expr;
+  if (expr->value.function.actual->next)
+    arg2 = expr->value.function.actual->next->expr;
+  else
+    arg2 = NULL;
+
+  sym = arg1->symtree->n.sym;
+
+  if (sym->attr.dummy)
+    return false;
+
+  new_expr = NULL;
+
+  switch (expr->value.function.isym->id)
+    {
+    case GFC_ISYM_LEN:
+      /* TODO figure out why this condition is necessary.  */
+      if (sym->attr.function
+	  && (arg1->ts.u.cl->length == NULL
+	      || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
+		  && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
+	return false;
+
+      new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
+      break;
+
+    case GFC_ISYM_SIZE:
+      if (!sym->as || sym->as->rank == 0)
+	return false;
+
+      if (arg2 && arg2->expr_type == EXPR_CONSTANT)
+	{
+	  dup = mpz_get_si (arg2->value.integer);
+	  d = dup - 1;
+	}
+      else
+	{
+	  dup = sym->as->rank;
+	  d = 0;
+	}
+
+      for (; d < dup; d++)
+	{
+	  gfc_expr *tmp;
+
+	  if (!sym->as->upper[d] || !sym->as->lower[d])
+	    {
+	      gfc_free_expr (new_expr);
+	      return false;
+	    }
+
+	  tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
+					gfc_get_int_expr (gfc_default_integer_kind,
+							  NULL, 1));
+	  tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
+	  if (new_expr)
+	    new_expr = gfc_multiply (new_expr, tmp);
+	  else
+	    new_expr = tmp;
+	}
+      break;
+
+    case GFC_ISYM_LBOUND:
+    case GFC_ISYM_UBOUND:
+	/* TODO These implementations of lbound and ubound do not limit if
+	   the size < 0, according to F95's 13.14.53 and 13.14.113.  */
+
+      if (!sym->as || sym->as->rank == 0)
+	return false;
+
+      if (arg2 && arg2->expr_type == EXPR_CONSTANT)
+	d = mpz_get_si (arg2->value.integer) - 1;
+      else
+	/* TODO: If the need arises, this could produce an array of
+	   ubound/lbounds.  */
+	gcc_unreachable ();
+
+      if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
+	{
+	  if (sym->as->lower[d])
+	    new_expr = gfc_copy_expr (sym->as->lower[d]);
+	}
+      else
+	{
+	  if (sym->as->upper[d])
+	    new_expr = gfc_copy_expr (sym->as->upper[d]);
+	}
+      break;
+
+    default:
+      break;
+    }
+
+  gfc_apply_interface_mapping_to_expr (mapping, new_expr);
+  if (!new_expr)
+    return false;
+
+  gfc_replace_expr (expr, new_expr);
+  return true;
+}
+
+
+static void
+gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
+			      gfc_interface_mapping * mapping)
+{
+  gfc_formal_arglist *f;
+  gfc_actual_arglist *actual;
+
+  actual = expr->value.function.actual;
+  f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
+
+  for (; f && actual; f = f->next, actual = actual->next)
+    {
+      if (!actual->expr)
+	continue;
+
+      gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
+    }
+
+  if (map_expr->symtree->n.sym->attr.dimension)
+    {
+      int d;
+      gfc_array_spec *as;
+
+      as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
+
+      for (d = 0; d < as->rank; d++)
+	{
+	  gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
+	  gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
+	}
+
+      expr->value.function.esym->as = as;
+    }
+
+  if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
+    {
+      expr->value.function.esym->ts.u.cl->length
+	= gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
+
+      gfc_apply_interface_mapping_to_expr (mapping,
+			expr->value.function.esym->ts.u.cl->length);
+    }
+}
+
+
+/* EXPR is a copy of an expression that appeared in the interface
+   associated with MAPPING.  Walk it recursively looking for references to
+   dummy arguments that MAPPING maps to actual arguments.  Replace each such
+   reference with a reference to the associated actual argument.  */
+
+static void
+gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
+				     gfc_expr * expr)
+{
+  gfc_interface_sym_mapping *sym;
+  gfc_actual_arglist *actual;
+
+  if (!expr)
+    return;
+
+  /* Copying an expression does not copy its length, so do that here.  */
+  if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
+    {
+      expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
+      gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
+    }
+
+  /* Apply the mapping to any references.  */
+  gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
+
+  /* ...and to the expression's symbol, if it has one.  */
+  /* TODO Find out why the condition on expr->symtree had to be moved into
+     the loop rather than being outside it, as originally.  */
+  for (sym = mapping->syms; sym; sym = sym->next)
+    if (expr->symtree && sym->old == expr->symtree->n.sym)
+      {
+	if (sym->new_sym->n.sym->backend_decl)
+	  expr->symtree = sym->new_sym;
+	else if (sym->expr)
+	  gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
+	/* Replace base type for polymorphic arguments.  */
+	if (expr->ref && expr->ref->type == REF_COMPONENT
+	    && sym->expr && sym->expr->ts.type == BT_CLASS)
+	  expr->ref->u.c.sym = sym->expr->ts.u.derived;
+      }
+
+      /* ...and to subexpressions in expr->value.  */
+  switch (expr->expr_type)
+    {
+    case EXPR_VARIABLE:
+    case EXPR_CONSTANT:
+    case EXPR_NULL:
+    case EXPR_SUBSTRING:
+      break;
+
+    case EXPR_OP:
+      gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
+      gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
+      break;
+
+    case EXPR_FUNCTION:
+      for (actual = expr->value.function.actual; actual; actual = actual->next)
+	gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
+
+      if (expr->value.function.esym == NULL
+	    && expr->value.function.isym != NULL
+	    && expr->value.function.actual->expr->symtree
+	    && gfc_map_intrinsic_function (expr, mapping))
+	break;
+
+      for (sym = mapping->syms; sym; sym = sym->next)
+	if (sym->old == expr->value.function.esym)
+	  {
+	    expr->value.function.esym = sym->new_sym->n.sym;
+	    gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
+	    expr->value.function.esym->result = sym->new_sym->n.sym;
+	  }
+      break;
+
+    case EXPR_ARRAY:
+    case EXPR_STRUCTURE:
+      gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
+      break;
+
+    case EXPR_COMPCALL:
+    case EXPR_PPC:
+      gcc_unreachable ();
+      break;
+    }
+
+  return;
+}
+
+
+/* Evaluate interface expression EXPR using MAPPING.  Store the result
+   in SE.  */
+
+void
+gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
+			     gfc_se * se, gfc_expr * expr)
+{
+  expr = gfc_copy_expr (expr);
+  gfc_apply_interface_mapping_to_expr (mapping, expr);
+  gfc_conv_expr (se, expr);
+  se->expr = gfc_evaluate_now (se->expr, &se->pre);
+  gfc_free_expr (expr);
+}
+
+
+/* Returns a reference to a temporary array into which a component of
+   an actual argument derived type array is copied and then returned
+   after the function call.  */
+void
+gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
+			   sym_intent intent, bool formal_ptr)
+{
+  gfc_se lse;
+  gfc_se rse;
+  gfc_ss *lss;
+  gfc_ss *rss;
+  gfc_loopinfo loop;
+  gfc_loopinfo loop2;
+  gfc_array_info *info;
+  tree offset;
+  tree tmp_index;
+  tree tmp;
+  tree base_type;
+  tree size;
+  stmtblock_t body;
+  int n;
+  int dimen;
+
+  gcc_assert (expr->expr_type == EXPR_VARIABLE);
+
+  gfc_init_se (&lse, NULL);
+  gfc_init_se (&rse, NULL);
+
+  /* Walk the argument expression.  */
+  rss = gfc_walk_expr (expr);
+
+  gcc_assert (rss != gfc_ss_terminator);
+
+  /* Initialize the scalarizer.  */
+  gfc_init_loopinfo (&loop);
+  gfc_add_ss_to_loop (&loop, rss);
+
+  /* Calculate the bounds of the scalarization.  */
+  gfc_conv_ss_startstride (&loop);
+
+  /* Build an ss for the temporary.  */
+  if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
+    gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
+
+  base_type = gfc_typenode_for_spec (&expr->ts);
+  if (GFC_ARRAY_TYPE_P (base_type)
+		|| GFC_DESCRIPTOR_TYPE_P (base_type))
+    base_type = gfc_get_element_type (base_type);
+
+  if (expr->ts.type == BT_CLASS)
+    base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
+
+  loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
+					      ? expr->ts.u.cl->backend_decl
+					      : NULL),
+				  loop.dimen);
+
+  parmse->string_length = loop.temp_ss->info->string_length;
+
+  /* Associate the SS with the loop.  */
+  gfc_add_ss_to_loop (&loop, loop.temp_ss);
+
+  /* Setup the scalarizing loops.  */
+  gfc_conv_loop_setup (&loop, &expr->where);
+
+  /* Pass the temporary descriptor back to the caller.  */
+  info = &loop.temp_ss->info->data.array;
+  parmse->expr = info->descriptor;
+
+  /* Setup the gfc_se structures.  */
+  gfc_copy_loopinfo_to_se (&lse, &loop);
+  gfc_copy_loopinfo_to_se (&rse, &loop);
+
+  rse.ss = rss;
+  lse.ss = loop.temp_ss;
+  gfc_mark_ss_chain_used (rss, 1);
+  gfc_mark_ss_chain_used (loop.temp_ss, 1);
+
+  /* Start the scalarized loop body.  */
+  gfc_start_scalarized_body (&loop, &body);
+
+  /* Translate the expression.  */
+  gfc_conv_expr (&rse, expr);
+
+  gfc_conv_tmp_array_ref (&lse);
+
+  if (intent != INTENT_OUT)
+    {
+      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true);
+      gfc_add_expr_to_block (&body, tmp);
+      gcc_assert (rse.ss == gfc_ss_terminator);
+      gfc_trans_scalarizing_loops (&loop, &body);
+    }
+  else
+    {
+      /* Make sure that the temporary declaration survives by merging
+       all the loop declarations into the current context.  */
+      for (n = 0; n < loop.dimen; n++)
+	{
+	  gfc_merge_block_scope (&body);
+	  body = loop.code[loop.order[n]];
+	}
+      gfc_merge_block_scope (&body);
+    }
+
+  /* Add the post block after the second loop, so that any
+     freeing of allocated memory is done at the right time.  */
+  gfc_add_block_to_block (&parmse->pre, &loop.pre);
+
+  /**********Copy the temporary back again.*********/
+
+  gfc_init_se (&lse, NULL);
+  gfc_init_se (&rse, NULL);
+
+  /* Walk the argument expression.  */
+  lss = gfc_walk_expr (expr);
+  rse.ss = loop.temp_ss;
+  lse.ss = lss;
+
+  /* Initialize the scalarizer.  */
+  gfc_init_loopinfo (&loop2);
+  gfc_add_ss_to_loop (&loop2, lss);
+
+  /* Calculate the bounds of the scalarization.  */
+  gfc_conv_ss_startstride (&loop2);
+
+  /* Setup the scalarizing loops.  */
+  gfc_conv_loop_setup (&loop2, &expr->where);
+
+  gfc_copy_loopinfo_to_se (&lse, &loop2);
+  gfc_copy_loopinfo_to_se (&rse, &loop2);
+
+  gfc_mark_ss_chain_used (lss, 1);
+  gfc_mark_ss_chain_used (loop.temp_ss, 1);
+
+  /* Declare the variable to hold the temporary offset and start the
+     scalarized loop body.  */
+  offset = gfc_create_var (gfc_array_index_type, NULL);
+  gfc_start_scalarized_body (&loop2, &body);
+
+  /* Build the offsets for the temporary from the loop variables.  The
+     temporary array has lbounds of zero and strides of one in all
+     dimensions, so this is very simple.  The offset is only computed
+     outside the innermost loop, so the overall transfer could be
+     optimized further.  */
+  info = &rse.ss->info->data.array;
+  dimen = rse.ss->dimen;
+
+  tmp_index = gfc_index_zero_node;
+  for (n = dimen - 1; n > 0; n--)
+    {
+      tree tmp_str;
+      tmp = rse.loop->loopvar[n];
+      tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			     tmp, rse.loop->from[n]);
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			     tmp, tmp_index);
+
+      tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
+				 gfc_array_index_type,
+				 rse.loop->to[n-1], rse.loop->from[n-1]);
+      tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type,
+				 tmp_str, gfc_index_one_node);
+
+      tmp_index = fold_build2_loc (input_location, MULT_EXPR,
+				   gfc_array_index_type, tmp, tmp_str);
+    }
+
+  tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
+			       gfc_array_index_type,
+			       tmp_index, rse.loop->from[0]);
+  gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
+
+  tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
+			       gfc_array_index_type,
+			       rse.loop->loopvar[0], offset);
+
+  /* Now use the offset for the reference.  */
+  tmp = build_fold_indirect_ref_loc (input_location,
+				 info->data);
+  rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
+
+  if (expr->ts.type == BT_CHARACTER)
+    rse.string_length = expr->ts.u.cl->backend_decl;
+
+  gfc_conv_expr (&lse, expr);
+
+  gcc_assert (lse.ss == gfc_ss_terminator);
+
+  tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
+  gfc_add_expr_to_block (&body, tmp);
+
+  /* Generate the copying loops.  */
+  gfc_trans_scalarizing_loops (&loop2, &body);
+
+  /* Wrap the whole thing up by adding the second loop to the post-block
+     and following it by the post-block of the first loop.  In this way,
+     if the temporary needs freeing, it is done after use!  */
+  if (intent != INTENT_IN)
+    {
+      gfc_add_block_to_block (&parmse->post, &loop2.pre);
+      gfc_add_block_to_block (&parmse->post, &loop2.post);
+    }
+
+  gfc_add_block_to_block (&parmse->post, &loop.post);
+
+  gfc_cleanup_loop (&loop);
+  gfc_cleanup_loop (&loop2);
+
+  /* Pass the string length to the argument expression.  */
+  if (expr->ts.type == BT_CHARACTER)
+    parmse->string_length = expr->ts.u.cl->backend_decl;
+
+  /* Determine the offset for pointer formal arguments and set the
+     lbounds to one.  */
+  if (formal_ptr)
+    {
+      size = gfc_index_one_node;
+      offset = gfc_index_zero_node;
+      for (n = 0; n < dimen; n++)
+	{
+	  tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
+						gfc_rank_cst[n]);
+	  tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type, tmp,
+				 gfc_index_one_node);
+	  gfc_conv_descriptor_ubound_set (&parmse->pre,
+					  parmse->expr,
+					  gfc_rank_cst[n],
+					  tmp);
+	  gfc_conv_descriptor_lbound_set (&parmse->pre,
+					  parmse->expr,
+					  gfc_rank_cst[n],
+					  gfc_index_one_node);
+	  size = gfc_evaluate_now (size, &parmse->pre);
+	  offset = fold_build2_loc (input_location, MINUS_EXPR,
+				    gfc_array_index_type,
+				    offset, size);
+	  offset = gfc_evaluate_now (offset, &parmse->pre);
+	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				 gfc_array_index_type,
+				 rse.loop->to[n], rse.loop->from[n]);
+	  tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type,
+				 tmp, gfc_index_one_node);
+	  size = fold_build2_loc (input_location, MULT_EXPR,
+				  gfc_array_index_type, size, tmp);
+	}
+
+      gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
+				      offset);
+    }
+
+  /* We want either the address for the data or the address of the descriptor,
+     depending on the mode of passing array arguments.  */
+  if (g77)
+    parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
+  else
+    parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
+
+  return;
+}
+
+
+/* Generate the code for argument list functions.  */
+
+static void
+conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
+{
+  /* Pass by value for g77 %VAL(arg), pass the address
+     indirectly for %LOC, else by reference.  Thus %REF
+     is a "do-nothing" and %LOC is the same as an F95
+     pointer.  */
+  if (strncmp (name, "%VAL", 4) == 0)
+    gfc_conv_expr (se, expr);
+  else if (strncmp (name, "%LOC", 4) == 0)
+    {
+      gfc_conv_expr_reference (se, expr);
+      se->expr = gfc_build_addr_expr (NULL, se->expr);
+    }
+  else if (strncmp (name, "%REF", 4) == 0)
+    gfc_conv_expr_reference (se, expr);
+  else
+    gfc_error ("Unknown argument list function at %L", &expr->where);
+}
+
+
+/* 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.
+   'expr' is only needed for procedure pointer components.  */
+
+int
+gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
+			 gfc_actual_arglist * args, gfc_expr * expr,
+			 vec<tree, va_gc> *append_args)
+{
+  gfc_interface_mapping mapping;
+  vec<tree, va_gc> *arglist;
+  vec<tree, va_gc> *retargs;
+  tree tmp;
+  tree fntype;
+  gfc_se parmse;
+  gfc_array_info *info;
+  int byref;
+  int parm_kind;
+  tree type;
+  tree var;
+  tree len;
+  tree base_object;
+  vec<tree, va_gc> *stringargs;
+  vec<tree, va_gc> *optionalargs;
+  tree result = NULL;
+  gfc_formal_arglist *formal;
+  gfc_actual_arglist *arg;
+  int has_alternate_specifier = 0;
+  bool need_interface_mapping;
+  bool callee_alloc;
+  gfc_typespec ts;
+  gfc_charlen cl;
+  gfc_expr *e;
+  gfc_symbol *fsym;
+  stmtblock_t post;
+  enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
+  gfc_component *comp = NULL;
+  int arglen;
+
+  arglist = NULL;
+  retargs = NULL;
+  stringargs = NULL;
+  optionalargs = NULL;
+  var = NULL_TREE;
+  len = NULL_TREE;
+  gfc_clear_ts (&ts);
+
+  comp = gfc_get_proc_ptr_comp (expr);
+
+  if (se->ss != NULL)
+    {
+      if (!sym->attr.elemental && !(comp && comp->attr.elemental))
+	{
+	  gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
+	  if (se->ss->info->useflags)
+	    {
+	      gcc_assert ((!comp && gfc_return_by_reference (sym)
+			   && sym->result->attr.dimension)
+			  || (comp && comp->attr.dimension));
+	      gcc_assert (se->loop != NULL);
+
+	      /* Access the previously obtained result.  */
+	      gfc_conv_tmp_array_ref (se);
+	      return 0;
+	    }
+	}
+      info = &se->ss->info->data.array;
+    }
+  else
+    info = NULL;
+
+  gfc_init_block (&post);
+  gfc_init_interface_mapping (&mapping);
+  if (!comp)
+    {
+      formal = gfc_sym_get_dummy_args (sym);
+      need_interface_mapping = sym->attr.dimension ||
+			       (sym->ts.type == BT_CHARACTER
+				&& sym->ts.u.cl->length
+				&& sym->ts.u.cl->length->expr_type
+				   != EXPR_CONSTANT);
+    }
+  else
+    {
+      formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
+      need_interface_mapping = comp->attr.dimension ||
+			       (comp->ts.type == BT_CHARACTER
+				&& comp->ts.u.cl->length
+				&& comp->ts.u.cl->length->expr_type
+				   != EXPR_CONSTANT);
+    }
+
+  base_object = NULL_TREE;
+
+  /* Evaluate the arguments.  */
+  for (arg = args; arg != NULL;
+       arg = arg->next, formal = formal ? formal->next : NULL)
+    {
+      e = arg->expr;
+      fsym = formal ? formal->sym : NULL;
+      parm_kind = MISSING;
+
+      /* Class array expressions are sometimes coming completely unadorned
+	 with either arrayspec or _data component.  Correct that here.
+	 OOP-TODO: Move this to the frontend.  */
+      if (e && e->expr_type == EXPR_VARIABLE
+	    && !e->ref
+	    && e->ts.type == BT_CLASS
+	    && (CLASS_DATA (e)->attr.codimension
+		|| CLASS_DATA (e)->attr.dimension))
+	{
+	  gfc_typespec temp_ts = e->ts;
+	  gfc_add_class_array_ref (e);
+	  e->ts = temp_ts;
+	}
+
+      if (e == NULL)
+	{
+	  if (se->ignore_optional)
+	    {
+	      /* Some intrinsics have already been resolved to the correct
+	         parameters.  */
+	      continue;
+	    }
+	  else if (arg->label)
+	    {
+	      has_alternate_specifier = 1;
+	      continue;
+	    }
+	  else
+	    {
+	      gfc_init_se (&parmse, NULL);
+
+	      /* For scalar arguments with VALUE attribute which are passed by
+		 value, pass "0" and a hidden argument gives the optional
+		 status.  */
+	      if (fsym && fsym->attr.optional && fsym->attr.value
+		  && !fsym->attr.dimension && fsym->ts.type != BT_CHARACTER
+		  && fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED)
+		{
+		  parmse.expr = fold_convert (gfc_sym_type (fsym),
+					      integer_zero_node);
+		  vec_safe_push (optionalargs, boolean_false_node);
+		}
+	      else
+		{
+		  /* Pass a NULL pointer for an absent arg.  */
+		  parmse.expr = null_pointer_node;
+		  if (arg->missing_arg_type == BT_CHARACTER)
+		    parmse.string_length = build_int_cst (gfc_charlen_type_node,
+							  0);
+		}
+	    }
+	}
+      else if (arg->expr->expr_type == EXPR_NULL
+	       && fsym && !fsym->attr.pointer
+	       && (fsym->ts.type != BT_CLASS
+		   || !CLASS_DATA (fsym)->attr.class_pointer))
+	{
+	  /* Pass a NULL pointer to denote an absent arg.  */
+	  gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
+		      && (fsym->ts.type != BT_CLASS
+			  || !CLASS_DATA (fsym)->attr.allocatable));
+	  gfc_init_se (&parmse, NULL);
+	  parmse.expr = null_pointer_node;
+	  if (arg->missing_arg_type == BT_CHARACTER)
+	    parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
+	}
+      else if (fsym && fsym->ts.type == BT_CLASS
+		 && e->ts.type == BT_DERIVED)
+	{
+	  /* The derived type needs to be converted to a temporary
+	     CLASS object.  */
+	  gfc_init_se (&parmse, se);
+	  gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL,
+				     fsym->attr.optional
+				     && e->expr_type == EXPR_VARIABLE
+				     && e->symtree->n.sym->attr.optional,
+				     CLASS_DATA (fsym)->attr.class_pointer
+				     || CLASS_DATA (fsym)->attr.allocatable);
+	}
+      else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS)
+	{
+	  /* The intrinsic type needs to be converted to a temporary
+	     CLASS object for the unlimited polymorphic formal.  */
+	  gfc_init_se (&parmse, se);
+	  gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
+	}
+      else if (se->ss && se->ss->info->useflags)
+	{
+	  gfc_ss *ss;
+
+	  ss = se->ss;
+
+	  /* An elemental function inside a scalarized loop.  */
+	  gfc_init_se (&parmse, se);
+	  parm_kind = ELEMENTAL;
+
+	  if (fsym && fsym->attr.value)
+	    gfc_conv_expr (&parmse, e);
+	  else
+	    gfc_conv_expr_reference (&parmse, e);
+
+	  if (e->ts.type == BT_CHARACTER && !e->rank
+	      && e->expr_type == EXPR_FUNCTION)
+	    parmse.expr = build_fold_indirect_ref_loc (input_location,
+						       parmse.expr);
+
+	  if (fsym && fsym->ts.type == BT_DERIVED
+	      && gfc_is_class_container_ref (e))
+	    {
+	      parmse.expr = gfc_class_data_get (parmse.expr);
+
+	      if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
+		  && e->symtree->n.sym->attr.optional)
+		{
+		  tree cond = gfc_conv_expr_present (e->symtree->n.sym);
+		  parmse.expr = build3_loc (input_location, COND_EXPR,
+					TREE_TYPE (parmse.expr),
+					cond, parmse.expr,
+					fold_convert (TREE_TYPE (parmse.expr),
+						      null_pointer_node));
+		}
+	    }
+
+	  /* If we are passing an absent array as optional dummy to an
+	     elemental procedure, make sure that we pass NULL when the data
+	     pointer is NULL.  We need this extra conditional because of
+	     scalarization which passes arrays elements to the procedure,
+	     ignoring the fact that the array can be absent/unallocated/...  */
+	  if (ss->info->can_be_null_ref && ss->info->type != GFC_SS_REFERENCE)
+	    {
+	      tree descriptor_data;
+
+	      descriptor_data = ss->info->data.array.data;
+	      tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+				     descriptor_data,
+				     fold_convert (TREE_TYPE (descriptor_data),
+						   null_pointer_node));
+	      parmse.expr
+		= fold_build3_loc (input_location, COND_EXPR,
+				   TREE_TYPE (parmse.expr),
+				   gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY),
+				   fold_convert (TREE_TYPE (parmse.expr),
+						 null_pointer_node),
+				   parmse.expr);
+	    }
+
+	  /* The scalarizer does not repackage the reference to a class
+	     array - instead it returns a pointer to the data element.  */
+	  if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
+	    gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
+				     fsym->attr.intent != INTENT_IN
+				     && (CLASS_DATA (fsym)->attr.class_pointer
+					 || CLASS_DATA (fsym)->attr.allocatable),
+				     fsym->attr.optional
+				     && e->expr_type == EXPR_VARIABLE
+				     && e->symtree->n.sym->attr.optional,
+				     CLASS_DATA (fsym)->attr.class_pointer
+				     || CLASS_DATA (fsym)->attr.allocatable);
+	}
+      else
+	{
+	  bool scalar;
+	  gfc_ss *argss;
+
+	  gfc_init_se (&parmse, NULL);
+
+	  /* Check whether the expression is a scalar or not; we cannot use
+	     e->rank as it can be nonzero for functions arguments.  */
+	  argss = gfc_walk_expr (e);
+	  scalar = argss == gfc_ss_terminator;
+	  if (!scalar)
+	    gfc_free_ss_chain (argss);
+
+	  /* Special handling for passing scalar polymorphic coarrays;
+	     otherwise one passes "class->_data.data" instead of "&class".  */
+	  if (e->rank == 0 && e->ts.type == BT_CLASS
+	      && fsym && fsym->ts.type == BT_CLASS
+	      && CLASS_DATA (fsym)->attr.codimension
+	      && !CLASS_DATA (fsym)->attr.dimension)
+	    {
+	      gfc_add_class_array_ref (e);
+              parmse.want_coarray = 1;
+	      scalar = false;
+	    }
+
+	  /* A scalar or transformational function.  */
+	  if (scalar)
+	    {
+	      if (e->expr_type == EXPR_VARIABLE
+		    && e->symtree->n.sym->attr.cray_pointee
+		    && fsym && fsym->attr.flavor == FL_PROCEDURE)
+		{
+		    /* The Cray pointer needs to be converted to a pointer to
+		       a type given by the expression.  */
+		    gfc_conv_expr (&parmse, e);
+		    type = build_pointer_type (TREE_TYPE (parmse.expr));
+		    tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
+		    parmse.expr = convert (type, tmp);
+		}
+ 	      else if (fsym && fsym->attr.value)
+		{
+		  if (fsym->ts.type == BT_CHARACTER
+		      && fsym->ts.is_c_interop
+		      && fsym->ns->proc_name != NULL
+		      && fsym->ns->proc_name->attr.is_bind_c)
+		    {
+		      parmse.expr = NULL;
+		      gfc_conv_scalar_char_value (fsym, &parmse, &e);
+		      if (parmse.expr == NULL)
+			gfc_conv_expr (&parmse, e);
+		    }
+		  else
+		    {
+		    gfc_conv_expr (&parmse, e);
+		    if (fsym->attr.optional
+			&& fsym->ts.type != BT_CLASS
+			&& fsym->ts.type != BT_DERIVED)
+		      {
+			if (e->expr_type != EXPR_VARIABLE
+			    || !e->symtree->n.sym->attr.optional
+			    || e->ref != NULL)
+			  vec_safe_push (optionalargs, boolean_true_node);
+			else
+			  {
+			    tmp = gfc_conv_expr_present (e->symtree->n.sym);
+			    if (!e->symtree->n.sym->attr.value)
+			      parmse.expr
+				= fold_build3_loc (input_location, COND_EXPR,
+					TREE_TYPE (parmse.expr),
+					tmp, parmse.expr,
+					fold_convert (TREE_TYPE (parmse.expr),
+						      integer_zero_node));
+
+			    vec_safe_push (optionalargs, tmp);
+			  }
+		      }
+		    }
+		}
+	      else if (arg->name && arg->name[0] == '%')
+		/* Argument list functions %VAL, %LOC and %REF are signalled
+		   through arg->name.  */
+		conv_arglist_function (&parmse, arg->expr, arg->name);
+	      else if ((e->expr_type == EXPR_FUNCTION)
+			&& ((e->value.function.esym
+			     && e->value.function.esym->result->attr.pointer)
+			    || (!e->value.function.esym
+				&& e->symtree->n.sym->attr.pointer))
+			&& fsym && fsym->attr.target)
+		{
+		  gfc_conv_expr (&parmse, e);
+		  parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
+		}
+	      else if (e->expr_type == EXPR_FUNCTION
+		       && e->symtree->n.sym->result
+		       && e->symtree->n.sym->result != e->symtree->n.sym
+		       && e->symtree->n.sym->result->attr.proc_pointer)
+		{
+		  /* Functions returning procedure pointers.  */
+		  gfc_conv_expr (&parmse, e);
+		  if (fsym && fsym->attr.proc_pointer)
+		    parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
+		}
+	      else
+		{
+		  if (e->ts.type == BT_CLASS && fsym
+		      && fsym->ts.type == BT_CLASS
+		      && (!CLASS_DATA (fsym)->as
+			  || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
+		      && CLASS_DATA (e)->attr.codimension)
+		    {
+		      gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
+		      gcc_assert (!CLASS_DATA (fsym)->as);
+		      gfc_add_class_array_ref (e);
+		      parmse.want_coarray = 1;
+		      gfc_conv_expr_reference (&parmse, e);
+		      class_scalar_coarray_to_class (&parmse, e, fsym->ts,
+				     fsym->attr.optional
+				     && e->expr_type == EXPR_VARIABLE);
+		    }
+		  else
+		    gfc_conv_expr_reference (&parmse, e);
+
+		  /* Catch base objects that are not variables.  */
+		  if (e->ts.type == BT_CLASS
+			&& e->expr_type != EXPR_VARIABLE
+			&& expr && e == expr->base_expr)
+		    base_object = build_fold_indirect_ref_loc (input_location,
+							       parmse.expr);
+
+		  /* A class array element needs converting back to be a
+		     class object, if the formal argument is a class object.  */
+		  if (fsym && fsym->ts.type == BT_CLASS
+			&& e->ts.type == BT_CLASS
+			&& ((CLASS_DATA (fsym)->as
+			     && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
+			    || CLASS_DATA (e)->attr.dimension))
+		    gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
+				     fsym->attr.intent != INTENT_IN
+				     && (CLASS_DATA (fsym)->attr.class_pointer
+					 || CLASS_DATA (fsym)->attr.allocatable),
+				     fsym->attr.optional
+				     && e->expr_type == EXPR_VARIABLE
+				     && e->symtree->n.sym->attr.optional,
+				     CLASS_DATA (fsym)->attr.class_pointer
+				     || CLASS_DATA (fsym)->attr.allocatable);
+
+		  /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
+		     allocated on entry, it must be deallocated.  */
+		  if (fsym && fsym->attr.intent == INTENT_OUT
+		      && (fsym->attr.allocatable
+			  || (fsym->ts.type == BT_CLASS
+			      && CLASS_DATA (fsym)->attr.allocatable)))
+		    {
+		      stmtblock_t block;
+		      tree ptr;
+
+		      gfc_init_block  (&block);
+		      ptr = parmse.expr;
+		      if (e->ts.type == BT_CLASS)
+			ptr = gfc_class_data_get (ptr);
+
+		      tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
+							       true, e, e->ts);
+		      gfc_add_expr_to_block (&block, tmp);
+		      tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+					     void_type_node, ptr,
+					     null_pointer_node);
+		      gfc_add_expr_to_block (&block, tmp);
+
+		      if (fsym->ts.type == BT_CLASS && UNLIMITED_POLY (fsym))
+			{
+			  gfc_add_modify (&block, ptr,
+					  fold_convert (TREE_TYPE (ptr),
+							null_pointer_node));
+			  gfc_add_expr_to_block (&block, tmp);
+			}
+		      else if (fsym->ts.type == BT_CLASS)
+			{
+			  gfc_symbol *vtab;
+			  vtab = gfc_find_derived_vtab (fsym->ts.u.derived);
+			  tmp = gfc_get_symbol_decl (vtab);
+			  tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+			  ptr = gfc_class_vptr_get (parmse.expr);
+			  gfc_add_modify (&block, ptr,
+					  fold_convert (TREE_TYPE (ptr), tmp));
+			  gfc_add_expr_to_block (&block, tmp);
+			}
+
+		      if (fsym->attr.optional
+			  && e->expr_type == EXPR_VARIABLE
+			  && e->symtree->n.sym->attr.optional)
+			{
+			  tmp = fold_build3_loc (input_location, COND_EXPR,
+				     void_type_node,
+				     gfc_conv_expr_present (e->symtree->n.sym),
+					    gfc_finish_block (&block),
+					    build_empty_stmt (input_location));
+			}
+		      else
+			tmp = gfc_finish_block (&block);
+
+		      gfc_add_expr_to_block (&se->pre, tmp);
+		    }
+
+		  if (fsym && (fsym->ts.type == BT_DERIVED
+			       || fsym->ts.type == BT_ASSUMED)
+		      && e->ts.type == BT_CLASS
+		      && !CLASS_DATA (e)->attr.dimension
+		      && !CLASS_DATA (e)->attr.codimension)
+		    parmse.expr = gfc_class_data_get (parmse.expr);
+
+		  /* Wrap scalar variable in a descriptor. We need to convert
+		     the address of a pointer back to the pointer itself before,
+		     we can assign it to the data field.  */
+
+		  if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
+		      && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
+		    {
+		      tmp = parmse.expr;
+		      if (TREE_CODE (tmp) == ADDR_EXPR
+			  && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp, 0))))
+			tmp = TREE_OPERAND (tmp, 0);
+		      parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
+								   fsym->attr);
+		      parmse.expr = gfc_build_addr_expr (NULL_TREE,
+							 parmse.expr);
+		    }
+		  else if (fsym && e->expr_type != EXPR_NULL
+		      && ((fsym->attr.pointer
+			   && fsym->attr.flavor != FL_PROCEDURE)
+			  || (fsym->attr.proc_pointer
+			      && !(e->expr_type == EXPR_VARIABLE
+				   && e->symtree->n.sym->attr.dummy))
+			  || (fsym->attr.proc_pointer
+			      && e->expr_type == EXPR_VARIABLE
+			      && gfc_is_proc_ptr_comp (e))
+			  || (fsym->attr.allocatable
+			      && fsym->attr.flavor != FL_PROCEDURE)))
+		    {
+		      /* Scalar pointer dummy args require an extra level of
+			 indirection. The null pointer already contains
+			 this level of indirection.  */
+		      parm_kind = SCALAR_POINTER;
+		      parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
+		    }
+		}
+	    }
+	  else if (e->ts.type == BT_CLASS
+		    && fsym && fsym->ts.type == BT_CLASS
+		    && (CLASS_DATA (fsym)->attr.dimension
+			|| CLASS_DATA (fsym)->attr.codimension))
+	    {
+	      /* Pass a class array.  */
+	      gfc_conv_expr_descriptor (&parmse, e);
+
+	      /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
+		 allocated on entry, it must be deallocated.  */
+	      if (fsym->attr.intent == INTENT_OUT
+		  && CLASS_DATA (fsym)->attr.allocatable)
+		{
+		  stmtblock_t block;
+		  tree ptr;
+
+		  gfc_init_block  (&block);
+		  ptr = parmse.expr;
+		  ptr = gfc_class_data_get (ptr);
+
+		  tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
+						    NULL_TREE, NULL_TREE,
+						    NULL_TREE, true, e,
+						    false);
+		  gfc_add_expr_to_block (&block, tmp);
+		  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+					 void_type_node, ptr,
+					 null_pointer_node);
+		  gfc_add_expr_to_block (&block, tmp);
+		  gfc_reset_vptr (&block, e);
+
+		  if (fsym->attr.optional
+		      && e->expr_type == EXPR_VARIABLE
+		      && (!e->ref
+			  || (e->ref->type == REF_ARRAY
+			      && !e->ref->u.ar.type != AR_FULL))
+		      && e->symtree->n.sym->attr.optional)
+		    {
+		      tmp = fold_build3_loc (input_location, COND_EXPR,
+				    void_type_node,
+				    gfc_conv_expr_present (e->symtree->n.sym),
+				    gfc_finish_block (&block),
+				    build_empty_stmt (input_location));
+		    }
+		  else
+		    tmp = gfc_finish_block (&block);
+
+		  gfc_add_expr_to_block (&se->pre, tmp);
+		}
+
+	      /* The conversion does not repackage the reference to a class
+	         array - _data descriptor.  */
+	      gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
+				     fsym->attr.intent != INTENT_IN
+				     && (CLASS_DATA (fsym)->attr.class_pointer
+					 || CLASS_DATA (fsym)->attr.allocatable),
+				     fsym->attr.optional
+				     && e->expr_type == EXPR_VARIABLE
+				     && e->symtree->n.sym->attr.optional,
+				     CLASS_DATA (fsym)->attr.class_pointer
+				     || CLASS_DATA (fsym)->attr.allocatable);
+	    }
+	  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
+		 argument and another one.  */
+	      if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
+		{
+		  gfc_expr *iarg;
+		  sym_intent intent;
+
+		  if (fsym != NULL)
+		    intent = fsym->attr.intent;
+		  else
+		    intent = INTENT_UNKNOWN;
+
+		  if (gfc_check_fncall_dependency (e, intent, sym, args,
+						   NOT_ELEMENTAL))
+		    parmse.force_tmp = 1;
+
+		  iarg = e->value.function.actual->expr;
+
+		  /* Temporary needed if aliasing due to host association.  */
+		  if (sym->attr.contained
+			&& !sym->attr.pure
+			&& !sym->attr.implicit_pure
+			&& !sym->attr.use_assoc
+			&& iarg->expr_type == EXPR_VARIABLE
+			&& sym->ns == iarg->symtree->n.sym->ns)
+		    parmse.force_tmp = 1;
+
+		  /* Ditto within module.  */
+		  if (sym->attr.use_assoc
+			&& !sym->attr.pure
+			&& !sym->attr.implicit_pure
+			&& iarg->expr_type == EXPR_VARIABLE
+			&& sym->module == iarg->symtree->n.sym->module)
+		    parmse.force_tmp = 1;
+		}
+
+	      if (e->expr_type == EXPR_VARIABLE
+		    && is_subref_array (e))
+		/* The actual argument is a component reference to an
+		   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,
+				fsym ? fsym->attr.intent : INTENT_INOUT,
+				fsym && fsym->attr.pointer);
+	      else if (gfc_is_class_array_ref (e, NULL)
+			 && fsym && fsym->ts.type == BT_DERIVED)
+		/* The actual argument is a component reference to an
+		   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.
+		   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,
+				fsym ? fsym->attr.intent : INTENT_INOUT,
+				fsym && fsym->attr.pointer);
+	      else
+	        gfc_conv_array_parameter (&parmse, e, f, fsym, sym->name, NULL);
+
+	      /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
+		 allocated on entry, it must be deallocated.  */
+	      if (fsym && fsym->attr.allocatable
+		  && fsym->attr.intent == INTENT_OUT)
+		{
+		  tmp = build_fold_indirect_ref_loc (input_location,
+						     parmse.expr);
+		  tmp = gfc_trans_dealloc_allocated (tmp, false, e);
+		  if (fsym->attr.optional
+		      && e->expr_type == EXPR_VARIABLE
+		      && e->symtree->n.sym->attr.optional)
+		    tmp = fold_build3_loc (input_location, COND_EXPR,
+				     void_type_node,
+				     gfc_conv_expr_present (e->symtree->n.sym),
+				       tmp, build_empty_stmt (input_location));
+		  gfc_add_expr_to_block (&se->pre, tmp);
+		}
+	    }
+	}
+
+      /* The case with fsym->attr.optional is that of a user subroutine
+	 with an interface indicating an optional argument.  When we call
+	 an intrinsic subroutine, however, fsym is NULL, but we might still
+	 have an optional argument, so we proceed to the substitution
+	 just in case.  */
+      if (e && (fsym == NULL || fsym->attr.optional))
+	{
+	  /* If an optional argument is itself an optional dummy argument,
+	     check its presence and substitute a null if absent.  This is
+	     only needed when passing an array to an elemental procedure
+	     as then array elements are accessed - or no NULL pointer is
+	     allowed and a "1" or "0" should be passed if not present.
+	     When passing a non-array-descriptor full array to a
+	     non-array-descriptor dummy, no check is needed. For
+	     array-descriptor actual to array-descriptor dummy, see
+	     PR 41911 for why a check has to be inserted.
+	     fsym == NULL is checked as intrinsics required the descriptor
+	     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->representation.length || e->ts.type == BT_CHARACTER
+		  || (e->rank != 0
+		      && (fsym == NULL
+			  || (fsym-> as
+			      && (fsym->as->type == AS_ASSUMED_SHAPE
+				  || fsym->as->type == AS_ASSUMED_RANK
+			      	  || fsym->as->type == AS_DEFERRED))))))
+	    gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
+				    e->representation.length);
+	}
+
+      if (fsym && e)
+	{
+	  /* Obtain the character length of an assumed character length
+	     length procedure from the typespec.  */
+	  if (fsym->ts.type == BT_CHARACTER
+	      && parmse.string_length == NULL_TREE
+	      && e->ts.type == BT_PROCEDURE
+	      && e->symtree->n.sym->ts.type == BT_CHARACTER
+	      && e->symtree->n.sym->ts.u.cl->length != NULL
+	      && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+	    {
+	      gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
+	      parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
+	    }
+	}
+
+      if (fsym && need_interface_mapping && e)
+	gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
+
+      gfc_add_block_to_block (&se->pre, &parmse.pre);
+      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).  */
+      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))
+        {
+	  int parm_rank;
+	  tmp = build_fold_indirect_ref_loc (input_location,
+					 parmse.expr);
+	  parm_rank = e->rank;
+	  switch (parm_kind)
+	    {
+	    case (ELEMENTAL):
+	    case (SCALAR):
+	      parm_rank = 0;
+	      break;
+
+	    case (SCALAR_POINTER):
+              tmp = build_fold_indirect_ref_loc (input_location,
+					     tmp);
+	      break;
+	    }
+
+	  if (e->expr_type == EXPR_OP
+		&& e->value.op.op == INTRINSIC_PARENTHESES
+		&& e->value.op.op1->expr_type == EXPR_VARIABLE)
+	    {
+	      tree local_tmp;
+	      local_tmp = gfc_evaluate_now (tmp, &se->pre);
+	      local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
+	      gfc_add_expr_to_block (&se->post, local_tmp);
+	    }
+
+	  if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
+	    {
+	      /* The derived type is passed to gfc_deallocate_alloc_comp.
+		 Therefore, class actuals can handled correctly but derived
+		 types passed to class formals need the _data component.  */
+	      tmp = gfc_class_data_get (tmp);
+	      if (!CLASS_DATA (fsym)->attr.dimension)
+		tmp = build_fold_indirect_ref_loc (input_location, tmp);
+	    }
+
+	  tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
+
+	  gfc_add_expr_to_block (&se->post, tmp);
+        }
+
+      /* Add argument checking of passing an unallocated/NULL actual to
+         a nonallocatable/nonpointer dummy.  */
+
+      if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
+        {
+	  symbol_attribute attr;
+	  char *msg;
+	  tree cond;
+
+	  if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
+	    attr = gfc_expr_attr (e);
+	  else
+	    goto end_pointer_check;
+
+	  /*  In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
+	      allocatable to an optional dummy, cf. 12.5.2.12.  */
+	  if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
+	      && (gfc_option.allow_std & GFC_STD_F2008) != 0)
+	    goto end_pointer_check;
+
+          if (attr.optional)
+	    {
+              /* If the actual argument is an optional pointer/allocatable and
+		 the formal argument takes an nonpointer optional value,
+		 it is invalid to pass a non-present argument on, even
+		 though there is no technical reason for this in gfortran.
+		 See Fortran 2003, Section 12.4.1.6 item (7)+(8).  */
+	      tree present, null_ptr, type;
+
+	      if (attr.allocatable
+		  && (fsym == NULL || !fsym->attr.allocatable))
+		asprintf (&msg, "Allocatable actual argument '%s' is not "
+			  "allocated or not present", e->symtree->n.sym->name);
+	      else if (attr.pointer
+		       && (fsym == NULL || !fsym->attr.pointer))
+		asprintf (&msg, "Pointer actual argument '%s' is not "
+			  "associated or not present",
+			  e->symtree->n.sym->name);
+	      else if (attr.proc_pointer
+		       && (fsym == NULL || !fsym->attr.proc_pointer))
+		asprintf (&msg, "Proc-pointer actual argument '%s' is not "
+			  "associated or not present",
+			  e->symtree->n.sym->name);
+	      else
+		goto end_pointer_check;
+
+	      present = gfc_conv_expr_present (e->symtree->n.sym);
+	      type = TREE_TYPE (present);
+	      present = fold_build2_loc (input_location, EQ_EXPR,
+					 boolean_type_node, present,
+					 fold_convert (type,
+						       null_pointer_node));
+	      type = TREE_TYPE (parmse.expr);
+	      null_ptr = fold_build2_loc (input_location, EQ_EXPR,
+					  boolean_type_node, parmse.expr,
+					  fold_convert (type,
+							null_pointer_node));
+	      cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
+				      boolean_type_node, present, null_ptr);
+	    }
+          else
+	    {
+	      if (attr.allocatable
+		  && (fsym == NULL || !fsym->attr.allocatable))
+		asprintf (&msg, "Allocatable actual argument '%s' is not "
+		      "allocated", e->symtree->n.sym->name);
+	      else if (attr.pointer
+		       && (fsym == NULL || !fsym->attr.pointer))
+		asprintf (&msg, "Pointer actual argument '%s' is not "
+		      "associated", e->symtree->n.sym->name);
+	      else if (attr.proc_pointer
+		       && (fsym == NULL || !fsym->attr.proc_pointer))
+		asprintf (&msg, "Proc-pointer actual argument '%s' is not "
+		      "associated", e->symtree->n.sym->name);
+	      else
+		goto end_pointer_check;
+
+	      tmp = parmse.expr;
+
+	      /* If the argument is passed by value, we need to strip the
+		 INDIRECT_REF.  */
+	      if (!POINTER_TYPE_P (TREE_TYPE (parmse.expr)))
+		tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+
+	      cond = fold_build2_loc (input_location, EQ_EXPR,
+				      boolean_type_node, tmp,
+				      fold_convert (TREE_TYPE (tmp),
+						    null_pointer_node));
+	    }
+
+	  gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
+				   msg);
+	  free (msg);
+        }
+      end_pointer_check:
+
+      /* Deferred length dummies pass the character length by reference
+	 so that the value can be returned.  */
+      if (parmse.string_length && fsym && fsym->ts.deferred)
+	{
+	  tmp = parmse.string_length;
+	  if (TREE_CODE (tmp) != VAR_DECL)
+	    tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
+	  parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
+	}
+
+      /* Character strings are passed as two parameters, a length and a
+	 pointer - except for Bind(c) which only passes the pointer.
+	 An unlimited polymorphic formal argument likewise does not
+	 need the length.  */
+      if (parmse.string_length != NULL_TREE
+	  && !sym->attr.is_bind_c
+	  && !(fsym && UNLIMITED_POLY (fsym)))
+	vec_safe_push (stringargs, parmse.string_length);
+
+      /* When calling __copy for character expressions to unlimited
+	 polymorphic entities, the dst argument needs a string length.  */
+      if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
+	  && strncmp (sym->name, "__vtab_CHARACTER", 16) == 0
+	  && arg->next && arg->next->expr
+	  && arg->next->expr->ts.type == BT_DERIVED
+	  && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
+	vec_safe_push (stringargs, parmse.string_length);
+
+      /* For descriptorless coarrays and assumed-shape coarray dummies, we
+	 pass the token and the offset as additional arguments.  */
+      if (fsym && fsym->attr.codimension
+	  && gfc_option.coarray == GFC_FCOARRAY_LIB
+	  && !fsym->attr.allocatable
+	  && e == NULL)
+	{
+	  /* Token and offset. */
+	  vec_safe_push (stringargs, null_pointer_node);
+	  vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
+	  gcc_assert (fsym->attr.optional);
+	}
+      else if (fsym && fsym->attr.codimension
+	       && !fsym->attr.allocatable
+	       && gfc_option.coarray == GFC_FCOARRAY_LIB)
+	{
+	  tree caf_decl, caf_type;
+	  tree offset, tmp2;
+
+	  caf_decl = get_tree_for_caf_expr (e);
+	  caf_type = TREE_TYPE (caf_decl);
+
+	  if (GFC_DESCRIPTOR_TYPE_P (caf_type)
+	      && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
+	    tmp = gfc_conv_descriptor_token (caf_decl);
+	  else if (DECL_LANG_SPECIFIC (caf_decl)
+		   && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
+	    tmp = GFC_DECL_TOKEN (caf_decl);
+	  else
+	    {
+	      gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
+			  && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
+	      tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
+	    }
+
+	  vec_safe_push (stringargs, tmp);
+
+	  if (GFC_DESCRIPTOR_TYPE_P (caf_type)
+	      && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
+	    offset = build_int_cst (gfc_array_index_type, 0);
+	  else if (DECL_LANG_SPECIFIC (caf_decl)
+		   && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
+	    offset = GFC_DECL_CAF_OFFSET (caf_decl);
+	  else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
+	    offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
+	  else
+	    offset = build_int_cst (gfc_array_index_type, 0);
+
+	  if (GFC_DESCRIPTOR_TYPE_P (caf_type))
+	    tmp = gfc_conv_descriptor_data_get (caf_decl);
+	  else
+	    {
+	      gcc_assert (POINTER_TYPE_P (caf_type));
+	      tmp = caf_decl;
+	    }
+
+          if (fsym->as->type == AS_ASSUMED_SHAPE
+	      || (fsym->as->type == AS_ASSUMED_RANK && !fsym->attr.pointer
+		  && !fsym->attr.allocatable))
+	    {
+	      gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
+	      gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
+						   (TREE_TYPE (parmse.expr))));
+	      tmp2 = build_fold_indirect_ref_loc (input_location, parmse.expr);
+	      tmp2 = gfc_conv_descriptor_data_get (tmp2);
+	    }
+	  else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse.expr)))
+	    tmp2 = gfc_conv_descriptor_data_get (parmse.expr);
+	  else
+	    {
+	      gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
+	      tmp2 = parmse.expr;
+	    }
+
+	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+                                 gfc_array_index_type,
+                                 fold_convert (gfc_array_index_type, tmp2),
+                                 fold_convert (gfc_array_index_type, tmp));
+	  offset = fold_build2_loc (input_location, PLUS_EXPR,
+				    gfc_array_index_type, offset, tmp);
+
+	  vec_safe_push (stringargs, offset);
+	}
+
+      vec_safe_push (arglist, parmse.expr);
+    }
+  gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
+
+  if (comp)
+    ts = comp->ts;
+  else
+   ts = sym->ts;
+
+  if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
+    se->string_length = build_int_cst (gfc_charlen_type_node, 1);
+  else if (ts.type == BT_CHARACTER)
+    {
+      if (ts.u.cl->length == NULL)
+	{
+	  /* Assumed character length results are not allowed by 5.1.1.5 of the
+	     standard and are trapped in resolve.c; except in the case of SPREAD
+	     (and other intrinsics?) and dummy functions.  In the case of SPREAD,
+	     we take the character length of the first argument for the result.
+	     For dummies, we have to look through the formal argument list for
+	     this function and use the character length found there.*/
+	  if (ts.deferred)
+	    cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
+	  else if (!sym->attr.dummy)
+	    cl.backend_decl = (*stringargs)[0];
+	  else
+	    {
+	      formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
+	      for (; formal; formal = formal->next)
+		if (strcmp (formal->sym->name, sym->name) == 0)
+		  cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
+	    }
+	  len = cl.backend_decl;
+        }
+      else
+        {
+	  tree tmp;
+
+	  /* Calculate the length of the returned string.  */
+	  gfc_init_se (&parmse, NULL);
+	  if (need_interface_mapping)
+	    gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
+	  else
+	    gfc_conv_expr (&parmse, ts.u.cl->length);
+	  gfc_add_block_to_block (&se->pre, &parmse.pre);
+	  gfc_add_block_to_block (&se->post, &parmse.post);
+
+	  tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
+	  tmp = fold_build2_loc (input_location, MAX_EXPR,
+				 gfc_charlen_type_node, tmp,
+				 build_int_cst (gfc_charlen_type_node, 0));
+	  cl.backend_decl = tmp;
+	}
+
+      /* Set up a charlen structure for it.  */
+      cl.next = NULL;
+      cl.length = NULL;
+      ts.u.cl = &cl;
+
+      len = cl.backend_decl;
+    }
+
+  byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
+	  || (!comp && gfc_return_by_reference (sym));
+  if (byref)
+    {
+      if (se->direct_byref)
+	{
+	  /* Sometimes, too much indirection can be applied; e.g. for
+	     function_result = array_valued_recursive_function.  */
+	  if (TREE_TYPE (TREE_TYPE (se->expr))
+		&& TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
+		&& GFC_DESCRIPTOR_TYPE_P
+			(TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
+	    se->expr = build_fold_indirect_ref_loc (input_location,
+						se->expr);
+
+	  /* If the lhs of an assignment x = f(..) is allocatable and
+	     f2003 is allowed, we must do the automatic reallocation.
+	     TODO - deal with intrinsics, without using a temporary.  */
+	  if (gfc_option.flag_realloc_lhs
+		&& se->ss && se->ss->loop_chain
+		&& se->ss->loop_chain->is_alloc_lhs
+		&& !expr->value.function.isym
+		&& sym->result->as != NULL)
+	    {
+	      /* Evaluate the bounds of the result, if known.  */
+	      gfc_set_loop_bounds_from_array_spec (&mapping, se,
+						   sym->result->as);
+
+	      /* Perform the automatic reallocation.  */
+	      tmp = gfc_alloc_allocatable_for_assignment (se->loop,
+							  expr, NULL);
+	      gfc_add_expr_to_block (&se->pre, tmp);
+
+	      /* Pass the temporary as the first argument.  */
+	      result = info->descriptor;
+	    }
+	  else
+	    result = build_fold_indirect_ref_loc (input_location,
+						  se->expr);
+	  vec_safe_push (retargs, se->expr);
+	}
+      else if (comp && comp->attr.dimension)
+	{
+	  gcc_assert (se->loop && info);
+
+	  /* Set the type of the array.  */
+	  tmp = gfc_typenode_for_spec (&comp->ts);
+	  gcc_assert (se->ss->dimen == se->loop->dimen);
+
+	  /* Evaluate the bounds of the result, if known.  */
+	  gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
+
+	  /* If the lhs of an assignment x = f(..) is allocatable and
+	     f2003 is allowed, we must not generate the function call
+	     here but should just send back the results of the mapping.
+	     This is signalled by the function ss being flagged.  */
+	  if (gfc_option.flag_realloc_lhs
+		&& se->ss && se->ss->is_alloc_lhs)
+	    {
+	      gfc_free_interface_mapping (&mapping);
+	      return has_alternate_specifier;
+	    }
+
+	  /* Create a temporary to store the result.  In case the function
+	     returns a pointer, the temporary will be a shallow copy and
+	     mustn't be deallocated.  */
+	  callee_alloc = comp->attr.allocatable || comp->attr.pointer;
+	  gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
+				       tmp, NULL_TREE, false,
+				       !comp->attr.pointer, callee_alloc,
+				       &se->ss->info->expr->where);
+
+	  /* Pass the temporary as the first argument.  */
+	  result = info->descriptor;
+	  tmp = gfc_build_addr_expr (NULL_TREE, result);
+	  vec_safe_push (retargs, tmp);
+	}
+      else if (!comp && sym->result->attr.dimension)
+	{
+	  gcc_assert (se->loop && info);
+
+	  /* Set the type of the array.  */
+	  tmp = gfc_typenode_for_spec (&ts);
+	  gcc_assert (se->ss->dimen == se->loop->dimen);
+
+	  /* Evaluate the bounds of the result, if known.  */
+	  gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
+
+	  /* If the lhs of an assignment x = f(..) is allocatable and
+	     f2003 is allowed, we must not generate the function call
+	     here but should just send back the results of the mapping.
+	     This is signalled by the function ss being flagged.  */
+	  if (gfc_option.flag_realloc_lhs
+		&& se->ss && se->ss->is_alloc_lhs)
+	    {
+	      gfc_free_interface_mapping (&mapping);
+	      return has_alternate_specifier;
+	    }
+
+	  /* Create a temporary to store the result.  In case the function
+	     returns a pointer, the temporary will be a shallow copy and
+	     mustn't be deallocated.  */
+	  callee_alloc = sym->attr.allocatable || sym->attr.pointer;
+	  gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
+				       tmp, NULL_TREE, false,
+				       !sym->attr.pointer, callee_alloc,
+				       &se->ss->info->expr->where);
+
+	  /* Pass the temporary as the first argument.  */
+	  result = info->descriptor;
+	  tmp = gfc_build_addr_expr (NULL_TREE, result);
+	  vec_safe_push (retargs, tmp);
+	}
+      else if (ts.type == BT_CHARACTER)
+	{
+	  /* Pass the string length.  */
+	  type = gfc_get_character_type (ts.kind, ts.u.cl);
+	  type = build_pointer_type (type);
+
+	  /* Return an address to a char[0:len-1]* temporary for
+	     character pointers.  */
+	  if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
+	       || (comp && (comp->attr.pointer || comp->attr.allocatable)))
+	    {
+	      var = gfc_create_var (type, "pstr");
+
+	      if ((!comp && sym->attr.allocatable)
+		  || (comp && comp->attr.allocatable))
+		{
+		  gfc_add_modify (&se->pre, var,
+				  fold_convert (TREE_TYPE (var),
+						null_pointer_node));
+		  tmp = gfc_call_free (convert (pvoid_type_node, var));
+		  gfc_add_expr_to_block (&se->post, tmp);
+		}
+
+	      /* Provide an address expression for the function arguments.  */
+	      var = gfc_build_addr_expr (NULL_TREE, var);
+	    }
+	  else
+	    var = gfc_conv_string_tmp (se, type, len);
+
+	  vec_safe_push (retargs, var);
+	}
+      else
+	{
+	  gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
+
+	  type = gfc_get_complex_type (ts.kind);
+	  var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
+	  vec_safe_push (retargs, var);
+	}
+
+      /* Add the string length to the argument list.  */
+      if (ts.type == BT_CHARACTER && ts.deferred)
+	{
+	  tmp = len;
+	  if (TREE_CODE (tmp) != VAR_DECL)
+	    tmp = gfc_evaluate_now (len, &se->pre);
+	  tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+	  vec_safe_push (retargs, tmp);
+	}
+      else if (ts.type == BT_CHARACTER)
+	vec_safe_push (retargs, len);
+    }
+  gfc_free_interface_mapping (&mapping);
+
+  /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS.  */
+  arglen = (vec_safe_length (arglist) + vec_safe_length (optionalargs)
+	    + vec_safe_length (stringargs) + vec_safe_length (append_args));
+  vec_safe_reserve (retargs, arglen);
+
+  /* Add the return arguments.  */
+  retargs->splice (arglist);
+
+  /* Add the hidden present status for optional+value to the arguments.  */
+  retargs->splice (optionalargs);
+
+  /* Add the hidden string length parameters to the arguments.  */
+  retargs->splice (stringargs);
+
+  /* We may want to append extra arguments here.  This is used e.g. for
+     calls to libgfortran_matmul_??, which need extra information.  */
+  if (!vec_safe_is_empty (append_args))
+    retargs->splice (append_args);
+  arglist = retargs;
+
+  /* Generate the actual call.  */
+  if (base_object == NULL_TREE)
+    conv_function_val (se, sym, expr);
+  else
+    conv_base_obj_fcn_val (se, base_object, expr);
+
+  /* If there are alternate return labels, function type should be
+     integer.  Can't modify the type in place though, since it can be shared
+     with other functions.  For dummy arguments, the typing is done to
+     this result, even if it has to be repeated for each call.  */
+  if (has_alternate_specifier
+      && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
+    {
+      if (!sym->attr.dummy)
+	{
+	  TREE_TYPE (sym->backend_decl)
+		= build_function_type (integer_type_node,
+		      TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
+	  se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
+	}
+      else
+	TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
+    }
+
+  fntype = TREE_TYPE (TREE_TYPE (se->expr));
+  se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
+
+  /* If we have a pointer function, but we don't want a pointer, e.g.
+     something like
+        x = f()
+     where f is pointer valued, we have to dereference the result.  */
+  if (!se->want_pointer && !byref
+      && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
+	  || (comp && (comp->attr.pointer || comp->attr.allocatable))))
+    se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
+
+  /* f2c calling conventions require a scalar default real function to
+     return a double precision result.  Convert this back to default
+     real.  We only care about the cases that can happen in Fortran 77.
+  */
+  if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
+      && sym->ts.kind == gfc_default_real_kind
+      && !sym->attr.always_explicit)
+    se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
+
+  /* A pure function may still have side-effects - it may modify its
+     parameters.  */
+  TREE_SIDE_EFFECTS (se->expr) = 1;
+#if 0
+  if (!sym->attr.pure)
+    TREE_SIDE_EFFECTS (se->expr) = 1;
+#endif
+
+  if (byref)
+    {
+      /* Add the function call to the pre chain.  There is no expression.  */
+      gfc_add_expr_to_block (&se->pre, se->expr);
+      se->expr = NULL_TREE;
+
+      if (!se->direct_byref)
+	{
+	  if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
+	    {
+	      if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+		{
+		  /* Check the data pointer hasn't been modified.  This would
+		     happen in a function returning a pointer.  */
+		  tmp = gfc_conv_descriptor_data_get (info->descriptor);
+		  tmp = fold_build2_loc (input_location, NE_EXPR,
+					 boolean_type_node,
+					 tmp, info->data);
+		  gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
+					   gfc_msg_fault);
+		}
+	      se->expr = info->descriptor;
+	      /* Bundle in the string length.  */
+	      se->string_length = len;
+	    }
+	  else if (ts.type == BT_CHARACTER)
+	    {
+	      /* Dereference for character pointer results.  */
+	      if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
+		  || (comp && (comp->attr.pointer || comp->attr.allocatable)))
+		se->expr = build_fold_indirect_ref_loc (input_location, var);
+	      else
+	        se->expr = var;
+
+	      se->string_length = len;
+	    }
+	  else
+	    {
+	      gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
+	      se->expr = build_fold_indirect_ref_loc (input_location, var);
+	    }
+	}
+    }
+
+  /* Follow the function call with the argument post block.  */
+  if (byref)
+    {
+      gfc_add_block_to_block (&se->pre, &post);
+
+      /* Transformational functions of derived types with allocatable
+         components must have the result allocatable components copied.  */
+      arg = expr->value.function.actual;
+      if (result && arg && expr->rank
+	    && expr->value.function.isym
+	    && expr->value.function.isym->transformational
+	    && arg->expr->ts.type == BT_DERIVED
+	    && arg->expr->ts.u.derived->attr.alloc_comp)
+	{
+	  tree tmp2;
+	  /* Copy the allocatable components.  We have to use a
+	     temporary here to prevent source allocatable components
+	     from being corrupted.  */
+	  tmp2 = gfc_evaluate_now (result, &se->pre);
+	  tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
+				     result, tmp2, expr->rank);
+	  gfc_add_expr_to_block (&se->pre, tmp);
+	  tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
+				           expr->rank);
+	  gfc_add_expr_to_block (&se->pre, tmp);
+
+	  /* Finally free the temporary's data field.  */
+	  tmp = gfc_conv_descriptor_data_get (tmp2);
+	  tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
+					    NULL_TREE, NULL_TREE, true,
+					    NULL, false);
+	  gfc_add_expr_to_block (&se->pre, tmp);
+	}
+    }
+  else
+    gfc_add_block_to_block (&se->post, &post);
+
+  return has_alternate_specifier;
+}
+
+
+/* Fill a character string with spaces.  */
+
+static tree
+fill_with_spaces (tree start, tree type, tree size)
+{
+  stmtblock_t block, loop;
+  tree i, el, exit_label, cond, tmp;
+
+  /* For a simple char type, we can call memset().  */
+  if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
+    return build_call_expr_loc (input_location,
+			    builtin_decl_explicit (BUILT_IN_MEMSET),
+			    3, start,
+			    build_int_cst (gfc_get_int_type (gfc_c_int_kind),
+					   lang_hooks.to_target_charset (' ')),
+			    size);
+
+  /* Otherwise, we use a loop:
+	for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
+	  *el = (type) ' ';
+   */
+
+  /* Initialize variables.  */
+  gfc_init_block (&block);
+  i = gfc_create_var (sizetype, "i");
+  gfc_add_modify (&block, i, fold_convert (sizetype, size));
+  el = gfc_create_var (build_pointer_type (type), "el");
+  gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
+  exit_label = gfc_build_label_decl (NULL_TREE);
+  TREE_USED (exit_label) = 1;
+
+
+  /* Loop body.  */
+  gfc_init_block (&loop);
+
+  /* Exit condition.  */
+  cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, i,
+			  build_zero_cst (sizetype));
+  tmp = build1_v (GOTO_EXPR, exit_label);
+  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
+			 build_empty_stmt (input_location));
+  gfc_add_expr_to_block (&loop, tmp);
+
+  /* Assignment.  */
+  gfc_add_modify (&loop,
+		  fold_build1_loc (input_location, INDIRECT_REF, type, el),
+		  build_int_cst (type, lang_hooks.to_target_charset (' ')));
+
+  /* Increment loop variables.  */
+  gfc_add_modify (&loop, i,
+		  fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
+				   TYPE_SIZE_UNIT (type)));
+  gfc_add_modify (&loop, el,
+		  fold_build_pointer_plus_loc (input_location,
+					       el, TYPE_SIZE_UNIT (type)));
+
+  /* Making the loop... actually loop!  */
+  tmp = gfc_finish_block (&loop);
+  tmp = build1_v (LOOP_EXPR, tmp);
+  gfc_add_expr_to_block (&block, tmp);
+
+  /* The exit label.  */
+  tmp = build1_v (LABEL_EXPR, exit_label);
+  gfc_add_expr_to_block (&block, tmp);
+
+
+  return gfc_finish_block (&block);
+}
+
+
+/* Generate code to copy a string.  */
+
+void
+gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
+		       int dkind, tree slength, tree src, int skind)
+{
+  tree tmp, dlen, slen;
+  tree dsc;
+  tree ssc;
+  tree cond;
+  tree cond2;
+  tree tmp2;
+  tree tmp3;
+  tree tmp4;
+  tree chartype;
+  stmtblock_t tempblock;
+
+  gcc_assert (dkind == skind);
+
+  if (slength != NULL_TREE)
+    {
+      slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
+      ssc = gfc_string_to_single_character (slen, src, skind);
+    }
+  else
+    {
+      slen = build_int_cst (size_type_node, 1);
+      ssc =  src;
+    }
+
+  if (dlength != NULL_TREE)
+    {
+      dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
+      dsc = gfc_string_to_single_character (dlen, dest, dkind);
+    }
+  else
+    {
+      dlen = build_int_cst (size_type_node, 1);
+      dsc =  dest;
+    }
+
+  /* Assign directly if the types are compatible.  */
+  if (dsc != NULL_TREE && ssc != NULL_TREE
+      && TREE_TYPE (dsc) == TREE_TYPE (ssc))
+    {
+      gfc_add_modify (block, dsc, ssc);
+      return;
+    }
+
+  /* Do nothing if the destination length is zero.  */
+  cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, dlen,
+			  build_int_cst (size_type_node, 0));
+
+  /* The following code was previously in _gfortran_copy_string:
+
+       // The two strings may overlap so we use memmove.
+       void
+       copy_string (GFC_INTEGER_4 destlen, char * dest,
+                    GFC_INTEGER_4 srclen, const char * src)
+       {
+         if (srclen >= destlen)
+           {
+             // This will truncate if too long.
+             memmove (dest, src, destlen);
+           }
+         else
+           {
+             memmove (dest, src, srclen);
+             // Pad with spaces.
+             memset (&dest[srclen], ' ', destlen - srclen);
+           }
+       }
+
+     We're now doing it here for better optimization, but the logic
+     is the same.  */
+
+  /* For non-default character kinds, we have to multiply the string
+     length by the base type size.  */
+  chartype = gfc_get_char_type (dkind);
+  slen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
+			  fold_convert (size_type_node, slen),
+			  fold_convert (size_type_node,
+					TYPE_SIZE_UNIT (chartype)));
+  dlen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
+			  fold_convert (size_type_node, dlen),
+			  fold_convert (size_type_node,
+					TYPE_SIZE_UNIT (chartype)));
+
+  if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
+    dest = fold_convert (pvoid_type_node, dest);
+  else
+    dest = gfc_build_addr_expr (pvoid_type_node, dest);
+
+  if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
+    src = fold_convert (pvoid_type_node, src);
+  else
+    src = gfc_build_addr_expr (pvoid_type_node, src);
+
+  /* Truncate string if source is too long.  */
+  cond2 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, slen,
+			   dlen);
+  tmp2 = build_call_expr_loc (input_location,
+			      builtin_decl_explicit (BUILT_IN_MEMMOVE),
+			      3, dest, src, dlen);
+
+  /* Else copy and pad with spaces.  */
+  tmp3 = build_call_expr_loc (input_location,
+			      builtin_decl_explicit (BUILT_IN_MEMMOVE),
+			      3, dest, src, slen);
+
+  tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
+  tmp4 = fill_with_spaces (tmp4, chartype,
+			   fold_build2_loc (input_location, MINUS_EXPR,
+					    TREE_TYPE(dlen), dlen, slen));
+
+  gfc_init_block (&tempblock);
+  gfc_add_expr_to_block (&tempblock, tmp3);
+  gfc_add_expr_to_block (&tempblock, tmp4);
+  tmp3 = gfc_finish_block (&tempblock);
+
+  /* The whole copy_string function is there.  */
+  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
+			 tmp2, tmp3);
+  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
+			 build_empty_stmt (input_location));
+  gfc_add_expr_to_block (block, tmp);
+}
+
+
+/* Translate a statement function.
+   The value of a statement function reference is obtained by evaluating the
+   expression using the values of the actual arguments for the values of the
+   corresponding dummy arguments.  */
+
+static void
+gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
+{
+  gfc_symbol *sym;
+  gfc_symbol *fsym;
+  gfc_formal_arglist *fargs;
+  gfc_actual_arglist *args;
+  gfc_se lse;
+  gfc_se rse;
+  gfc_saved_var *saved_vars;
+  tree *temp_vars;
+  tree type;
+  tree tmp;
+  int n;
+
+  sym = expr->symtree->n.sym;
+  args = expr->value.function.actual;
+  gfc_init_se (&lse, NULL);
+  gfc_init_se (&rse, NULL);
+
+  n = 0;
+  for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next)
+    n++;
+  saved_vars = XCNEWVEC (gfc_saved_var, n);
+  temp_vars = XCNEWVEC (tree, n);
+
+  for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
+       fargs = fargs->next, n++)
+    {
+      /* Each dummy shall be specified, explicitly or implicitly, to be
+         scalar.  */
+      gcc_assert (fargs->sym->attr.dimension == 0);
+      fsym = fargs->sym;
+
+      if (fsym->ts.type == BT_CHARACTER)
+        {
+	  /* Copy string arguments.  */
+	  tree arglen;
+
+	  gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
+		      && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
+
+	  /* Create a temporary to hold the value.  */
+          if (fsym->ts.u.cl->backend_decl == NULL_TREE)
+	     fsym->ts.u.cl->backend_decl
+		= gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
+
+	  type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
+	  temp_vars[n] = gfc_create_var (type, fsym->name);
+
+	  arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
+
+	  gfc_conv_expr (&rse, args->expr);
+	  gfc_conv_string_parameter (&rse);
+	  gfc_add_block_to_block (&se->pre, &lse.pre);
+	  gfc_add_block_to_block (&se->pre, &rse.pre);
+
+	  gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
+				 rse.string_length, rse.expr, fsym->ts.kind);
+	  gfc_add_block_to_block (&se->pre, &lse.post);
+	  gfc_add_block_to_block (&se->pre, &rse.post);
+        }
+      else
+        {
+          /* For everything else, just evaluate the expression.  */
+
+	  /* Create a temporary to hold the value.  */
+	  type = gfc_typenode_for_spec (&fsym->ts);
+	  temp_vars[n] = gfc_create_var (type, fsym->name);
+
+          gfc_conv_expr (&lse, args->expr);
+
+          gfc_add_block_to_block (&se->pre, &lse.pre);
+          gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
+          gfc_add_block_to_block (&se->pre, &lse.post);
+        }
+
+      args = args->next;
+    }
+
+  /* Use the temporary variables in place of the real ones.  */
+  for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
+       fargs = fargs->next, n++)
+    gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
+
+  gfc_conv_expr (se, sym->value);
+
+  if (sym->ts.type == BT_CHARACTER)
+    {
+      gfc_conv_const_charlen (sym->ts.u.cl);
+
+      /* Force the expression to the correct length.  */
+      if (!INTEGER_CST_P (se->string_length)
+	  || tree_int_cst_lt (se->string_length,
+			      sym->ts.u.cl->backend_decl))
+	{
+	  type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
+	  tmp = gfc_create_var (type, sym->name);
+	  tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
+	  gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
+				 sym->ts.kind, se->string_length, se->expr,
+				 sym->ts.kind);
+	  se->expr = tmp;
+	}
+      se->string_length = sym->ts.u.cl->backend_decl;
+    }
+
+  /* Restore the original variables.  */
+  for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
+       fargs = fargs->next, n++)
+    gfc_restore_sym (fargs->sym, &saved_vars[n]);
+  free (temp_vars);
+  free (saved_vars);
+}
+
+
+/* Translate a function expression.  */
+
+static void
+gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
+{
+  gfc_symbol *sym;
+
+  if (expr->value.function.isym)
+    {
+      gfc_conv_intrinsic_function (se, expr);
+      return;
+    }
+
+  /* expr.value.function.esym is the resolved (specific) function symbol for
+     most functions.  However this isn't set for dummy procedures.  */
+  sym = expr->value.function.esym;
+  if (!sym)
+    sym = expr->symtree->n.sym;
+
+  /* We distinguish statement functions from general functions to improve
+     runtime performance.  */
+  if (sym->attr.proc == PROC_ST_FUNCTION)
+    {
+      gfc_conv_statement_function (se, expr);
+      return;
+    }
+
+  gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
+			   NULL);
+}
+
+
+/* Determine whether the given EXPR_CONSTANT is a zero initializer.  */
+
+static bool
+is_zero_initializer_p (gfc_expr * expr)
+{
+  if (expr->expr_type != EXPR_CONSTANT)
+    return false;
+
+  /* We ignore constants with prescribed memory representations for now.  */
+  if (expr->representation.string)
+    return false;
+
+  switch (expr->ts.type)
+    {
+    case BT_INTEGER:
+      return mpz_cmp_si (expr->value.integer, 0) == 0;
+
+    case BT_REAL:
+      return mpfr_zero_p (expr->value.real)
+	     && MPFR_SIGN (expr->value.real) >= 0;
+
+    case BT_LOGICAL:
+      return expr->value.logical == 0;
+
+    case BT_COMPLEX:
+      return mpfr_zero_p (mpc_realref (expr->value.complex))
+	     && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
+             && mpfr_zero_p (mpc_imagref (expr->value.complex))
+	     && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
+
+    default:
+      break;
+    }
+  return false;
+}
+
+
+static void
+gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
+{
+  gfc_ss *ss;
+
+  ss = se->ss;
+  gcc_assert (ss != NULL && ss != gfc_ss_terminator);
+  gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
+
+  gfc_conv_tmp_array_ref (se);
+}
+
+
+/* Build a static initializer.  EXPR is the expression for the initial value.
+   The other parameters describe the variable of the component being
+   initialized. EXPR may be null.  */
+
+tree
+gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
+		      bool array, bool pointer, bool procptr)
+{
+  gfc_se se;
+
+  if (!(expr || pointer || procptr))
+    return NULL_TREE;
+
+  /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
+     (these are the only two iso_c_binding derived types that can be
+     used as initialization expressions).  If so, we need to modify
+     the 'expr' to be that for a (void *).  */
+  if (expr != NULL && expr->ts.type == BT_DERIVED
+      && expr->ts.is_iso_c && expr->ts.u.derived)
+    {
+      gfc_symbol *derived = expr->ts.u.derived;
+
+      /* The derived symbol has already been converted to a (void *).  Use
+	 its kind.  */
+      expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
+      expr->ts.f90_type = derived->ts.f90_type;
+
+      gfc_init_se (&se, NULL);
+      gfc_conv_constant (&se, expr);
+      gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
+      return se.expr;
+    }
+
+  if (array && !procptr)
+    {
+      tree ctor;
+      /* Arrays need special handling.  */
+      if (pointer)
+	ctor = gfc_build_null_descriptor (type);
+      /* Special case assigning an array to zero.  */
+      else if (is_zero_initializer_p (expr))
+        ctor = build_constructor (type, NULL);
+      else
+	ctor = gfc_conv_array_initializer (type, expr);
+      TREE_STATIC (ctor) = 1;
+      return ctor;
+    }
+  else if (pointer || procptr)
+    {
+      if (ts->type == BT_CLASS && !procptr)
+	{
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
+	  gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
+	  TREE_STATIC (se.expr) = 1;
+	  return se.expr;
+	}
+      else if (!expr || expr->expr_type == EXPR_NULL)
+	return fold_convert (type, null_pointer_node);
+      else
+	{
+	  gfc_init_se (&se, NULL);
+	  se.want_pointer = 1;
+	  gfc_conv_expr (&se, expr);
+          gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
+	  return se.expr;
+	}
+    }
+  else
+    {
+      switch (ts->type)
+	{
+	case BT_DERIVED:
+	case BT_CLASS:
+	  gfc_init_se (&se, NULL);
+	  if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
+	    gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
+	  else
+	    gfc_conv_structure (&se, expr, 1);
+	  gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
+	  TREE_STATIC (se.expr) = 1;
+	  return se.expr;
+
+	case BT_CHARACTER:
+	  {
+	    tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
+	    TREE_STATIC (ctor) = 1;
+	    return ctor;
+	  }
+
+	default:
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_constant (&se, expr);
+	  gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
+	  return se.expr;
+	}
+    }
+}
+
+static tree
+gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
+{
+  gfc_se rse;
+  gfc_se lse;
+  gfc_ss *rss;
+  gfc_ss *lss;
+  gfc_array_info *lss_array;
+  stmtblock_t body;
+  stmtblock_t block;
+  gfc_loopinfo loop;
+  int n;
+  tree tmp;
+
+  gfc_start_block (&block);
+
+  /* Initialize the scalarizer.  */
+  gfc_init_loopinfo (&loop);
+
+  gfc_init_se (&lse, NULL);
+  gfc_init_se (&rse, NULL);
+
+  /* Walk the rhs.  */
+  rss = gfc_walk_expr (expr);
+  if (rss == gfc_ss_terminator)
+    /* The rhs is scalar.  Add a ss for the expression.  */
+    rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
+
+  /* Create a SS for the destination.  */
+  lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
+			  GFC_SS_COMPONENT);
+  lss_array = &lss->info->data.array;
+  lss_array->shape = gfc_get_shape (cm->as->rank);
+  lss_array->descriptor = dest;
+  lss_array->data = gfc_conv_array_data (dest);
+  lss_array->offset = gfc_conv_array_offset (dest);
+  for (n = 0; n < cm->as->rank; n++)
+    {
+      lss_array->start[n] = gfc_conv_array_lbound (dest, n);
+      lss_array->stride[n] = gfc_index_one_node;
+
+      mpz_init (lss_array->shape[n]);
+      mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
+	       cm->as->lower[n]->value.integer);
+      mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
+    }
+
+  /* Associate the SS with the loop.  */
+  gfc_add_ss_to_loop (&loop, lss);
+  gfc_add_ss_to_loop (&loop, rss);
+
+  /* Calculate the bounds of the scalarization.  */
+  gfc_conv_ss_startstride (&loop);
+
+  /* Setup the scalarizing loops.  */
+  gfc_conv_loop_setup (&loop, &expr->where);
+
+  /* Setup the gfc_se structures.  */
+  gfc_copy_loopinfo_to_se (&lse, &loop);
+  gfc_copy_loopinfo_to_se (&rse, &loop);
+
+  rse.ss = rss;
+  gfc_mark_ss_chain_used (rss, 1);
+  lse.ss = lss;
+  gfc_mark_ss_chain_used (lss, 1);
+
+  /* Start the scalarized loop body.  */
+  gfc_start_scalarized_body (&loop, &body);
+
+  gfc_conv_tmp_array_ref (&lse);
+  if (cm->ts.type == BT_CHARACTER)
+    lse.string_length = cm->ts.u.cl->backend_decl;
+
+  gfc_conv_expr (&rse, expr);
+
+  tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
+  gfc_add_expr_to_block (&body, tmp);
+
+  gcc_assert (rse.ss == gfc_ss_terminator);
+
+  /* Generate the copying loops.  */
+  gfc_trans_scalarizing_loops (&loop, &body);
+
+  /* Wrap the whole thing up.  */
+  gfc_add_block_to_block (&block, &loop.pre);
+  gfc_add_block_to_block (&block, &loop.post);
+
+  gcc_assert (lss_array->shape != NULL);
+  gfc_free_shape (&lss_array->shape, cm->as->rank);
+  gfc_cleanup_loop (&loop);
+
+  return gfc_finish_block (&block);
+}
+
+
+static tree
+gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
+				 gfc_expr * expr)
+{
+  gfc_se se;
+  stmtblock_t block;
+  tree offset;
+  int n;
+  tree tmp;
+  tree tmp2;
+  gfc_array_spec *as;
+  gfc_expr *arg = NULL;
+
+  gfc_start_block (&block);
+  gfc_init_se (&se, NULL);
+
+  /* Get the descriptor for the expressions.  */
+  se.want_pointer = 0;
+  gfc_conv_expr_descriptor (&se, expr);
+  gfc_add_block_to_block (&block, &se.pre);
+  gfc_add_modify (&block, dest, se.expr);
+
+  /* Deal with arrays of derived types with allocatable components.  */
+  if (cm->ts.type == BT_DERIVED
+	&& cm->ts.u.derived->attr.alloc_comp)
+    tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
+			       se.expr, dest,
+			       cm->as->rank);
+  else
+    tmp = gfc_duplicate_allocatable (dest, se.expr,
+				     TREE_TYPE(cm->backend_decl),
+				     cm->as->rank);
+
+  gfc_add_expr_to_block (&block, tmp);
+  gfc_add_block_to_block (&block, &se.post);
+
+  if (expr->expr_type != EXPR_VARIABLE)
+    gfc_conv_descriptor_data_set (&block, se.expr,
+				  null_pointer_node);
+
+  /* We need to know if the argument of a conversion function is a
+     variable, so that the correct lower bound can be used.  */
+  if (expr->expr_type == EXPR_FUNCTION
+	&& expr->value.function.isym
+	&& expr->value.function.isym->conversion
+	&& expr->value.function.actual->expr
+	&& expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
+    arg = expr->value.function.actual->expr;
+
+  /* Obtain the array spec of full array references.  */
+  if (arg)
+    as = gfc_get_full_arrayspec_from_expr (arg);
+  else
+    as = gfc_get_full_arrayspec_from_expr (expr);
+
+  /* Shift the lbound and ubound of temporaries to being unity,
+     rather than zero, based. Always calculate the offset.  */
+  offset = gfc_conv_descriptor_offset_get (dest);
+  gfc_add_modify (&block, offset, gfc_index_zero_node);
+  tmp2 =gfc_create_var (gfc_array_index_type, NULL);
+
+  for (n = 0; n < expr->rank; n++)
+    {
+      tree span;
+      tree lbound;
+
+      /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
+	 TODO It looks as if gfc_conv_expr_descriptor should return
+	 the correct bounds and that the following should not be
+	 necessary.  This would simplify gfc_conv_intrinsic_bound
+	 as well.  */
+      if (as && as->lower[n])
+	{
+	  gfc_se lbse;
+	  gfc_init_se (&lbse, NULL);
+	  gfc_conv_expr (&lbse, as->lower[n]);
+	  gfc_add_block_to_block (&block, &lbse.pre);
+	  lbound = gfc_evaluate_now (lbse.expr, &block);
+	}
+      else if (as && arg)
+	{
+	  tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
+	  lbound = gfc_conv_descriptor_lbound_get (tmp,
+					gfc_rank_cst[n]);
+	}
+      else if (as)
+	lbound = gfc_conv_descriptor_lbound_get (dest,
+						gfc_rank_cst[n]);
+      else
+	lbound = gfc_index_one_node;
+
+      lbound = fold_convert (gfc_array_index_type, lbound);
+
+      /* Shift the bounds and set the offset accordingly.  */
+      tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
+      span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+		tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			     span, lbound);
+      gfc_conv_descriptor_ubound_set (&block, dest,
+				      gfc_rank_cst[n], tmp);
+      gfc_conv_descriptor_lbound_set (&block, dest,
+				      gfc_rank_cst[n], lbound);
+
+      tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			 gfc_conv_descriptor_lbound_get (dest,
+							 gfc_rank_cst[n]),
+			 gfc_conv_descriptor_stride_get (dest,
+							 gfc_rank_cst[n]));
+      gfc_add_modify (&block, tmp2, tmp);
+      tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			     offset, tmp2);
+      gfc_conv_descriptor_offset_set (&block, dest, tmp);
+    }
+
+  if (arg)
+    {
+      /* If a conversion expression has a null data pointer
+	 argument, nullify the allocatable component.  */
+      tree non_null_expr;
+      tree null_expr;
+
+      if (arg->symtree->n.sym->attr.allocatable
+	    || arg->symtree->n.sym->attr.pointer)
+	{
+	  non_null_expr = gfc_finish_block (&block);
+	  gfc_start_block (&block);
+	  gfc_conv_descriptor_data_set (&block, dest,
+					null_pointer_node);
+	  null_expr = gfc_finish_block (&block);
+	  tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
+	  tmp = build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
+			    fold_convert (TREE_TYPE (tmp), null_pointer_node));
+	  return build3_v (COND_EXPR, tmp,
+			   null_expr, non_null_expr);
+	}
+    }
+
+  return gfc_finish_block (&block);
+}
+
+
+/* Assign a single component of a derived type constructor.  */
+
+static tree
+gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
+{
+  gfc_se se;
+  gfc_se lse;
+  stmtblock_t block;
+  tree tmp;
+
+  gfc_start_block (&block);
+
+  if (cm->attr.pointer || cm->attr.proc_pointer)
+    {
+      gfc_init_se (&se, NULL);
+      /* Pointer component.  */
+      if (cm->attr.dimension && !cm->attr.proc_pointer)
+	{
+	  /* Array pointer.  */
+	  if (expr->expr_type == EXPR_NULL)
+	    gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
+	  else
+	    {
+	      se.direct_byref = 1;
+	      se.expr = dest;
+	      gfc_conv_expr_descriptor (&se, expr);
+	      gfc_add_block_to_block (&block, &se.pre);
+	      gfc_add_block_to_block (&block, &se.post);
+	    }
+	}
+      else
+	{
+	  /* Scalar pointers.  */
+	  se.want_pointer = 1;
+	  gfc_conv_expr (&se, expr);
+	  gfc_add_block_to_block (&block, &se.pre);
+
+	  if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
+	      && expr->symtree->n.sym->attr.dummy)
+	    se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
+
+	  gfc_add_modify (&block, dest,
+			       fold_convert (TREE_TYPE (dest), se.expr));
+	  gfc_add_block_to_block (&block, &se.post);
+	}
+    }
+  else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
+    {
+      /* NULL initialization for CLASS components.  */
+      tmp = gfc_trans_structure_assign (dest,
+					gfc_class_initializer (&cm->ts, expr));
+      gfc_add_expr_to_block (&block, tmp);
+    }
+  else if (cm->attr.dimension && !cm->attr.proc_pointer)
+    {
+      if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
+ 	gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
+      else if (cm->attr.allocatable)
+	{
+	  tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
+	  gfc_add_expr_to_block (&block, tmp);
+	}
+      else
+	{
+	  tmp = gfc_trans_subarray_assign (dest, cm, expr);
+	  gfc_add_expr_to_block (&block, tmp);
+	}
+    }
+  else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
+    {
+      if (expr->expr_type != EXPR_STRUCTURE)
+	{
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_expr (&se, expr);
+	  gfc_add_block_to_block (&block, &se.pre);
+	  gfc_add_modify (&block, dest,
+			       fold_convert (TREE_TYPE (dest), se.expr));
+	  gfc_add_block_to_block (&block, &se.post);
+	}
+      else
+	{
+	  /* Nested constructors.  */
+	  tmp = gfc_trans_structure_assign (dest, expr);
+	  gfc_add_expr_to_block (&block, tmp);
+	}
+    }
+  else if (gfc_deferred_strlen (cm, &tmp))
+    {
+      tree strlen;
+      strlen = tmp;
+      gcc_assert (strlen);
+      strlen = fold_build3_loc (input_location, COMPONENT_REF,
+				TREE_TYPE (strlen),
+				TREE_OPERAND (dest, 0),
+				strlen, NULL_TREE);
+
+      if (expr->expr_type == EXPR_NULL)
+	{
+	  tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0);
+	  gfc_add_modify (&block, dest, tmp);
+	  tmp = build_int_cst (TREE_TYPE (strlen), 0);
+	  gfc_add_modify (&block, strlen, tmp);
+	}
+      else
+	{
+	  tree size;
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_expr (&se, expr);
+	  size = size_of_string_in_bytes (cm->ts.kind, se.string_length);
+	  tmp = build_call_expr_loc (input_location,
+				     builtin_decl_explicit (BUILT_IN_MALLOC),
+				     1, size);
+	  gfc_add_modify (&block, dest,
+			  fold_convert (TREE_TYPE (dest), tmp));
+	  gfc_add_modify (&block, strlen, se.string_length);
+	  tmp = gfc_build_memcpy_call (dest, se.expr, size);
+	  gfc_add_expr_to_block (&block, tmp);
+	}
+    }
+  else if (!cm->attr.deferred_parameter)
+    {
+      /* Scalar component (excluding deferred parameters).  */
+      gfc_init_se (&se, NULL);
+      gfc_init_se (&lse, NULL);
+
+      gfc_conv_expr (&se, expr);
+      if (cm->ts.type == BT_CHARACTER)
+	lse.string_length = cm->ts.u.cl->backend_decl;
+      lse.expr = dest;
+      tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
+      gfc_add_expr_to_block (&block, tmp);
+    }
+  return gfc_finish_block (&block);
+}
+
+/* Assign a derived type constructor to a variable.  */
+
+static tree
+gfc_trans_structure_assign (tree dest, gfc_expr * expr)
+{
+  gfc_constructor *c;
+  gfc_component *cm;
+  stmtblock_t block;
+  tree field;
+  tree tmp;
+
+  gfc_start_block (&block);
+  cm = expr->ts.u.derived->components;
+
+  if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
+      && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
+          || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
+    {
+      gfc_se se, lse;
+
+      gcc_assert (cm->backend_decl == NULL);
+      gfc_init_se (&se, NULL);
+      gfc_init_se (&lse, NULL);
+      gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
+      lse.expr = dest;
+      gfc_add_modify (&block, lse.expr,
+		      fold_convert (TREE_TYPE (lse.expr), se.expr));
+
+      return gfc_finish_block (&block);
+    }
+
+  for (c = gfc_constructor_first (expr->value.constructor);
+       c; c = gfc_constructor_next (c), cm = cm->next)
+    {
+      /* Skip absent members in default initializers.  */
+      if (!c->expr)
+	continue;
+
+      field = cm->backend_decl;
+      tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+			     dest, field, NULL_TREE);
+      tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
+      gfc_add_expr_to_block (&block, tmp);
+    }
+  return gfc_finish_block (&block);
+}
+
+/* Build an expression for a constructor. If init is nonzero then
+   this is part of a static variable initializer.  */
+
+void
+gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
+{
+  gfc_constructor *c;
+  gfc_component *cm;
+  tree val;
+  tree type;
+  tree tmp;
+  vec<constructor_elt, va_gc> *v = NULL;
+
+  gcc_assert (se->ss == NULL);
+  gcc_assert (expr->expr_type == EXPR_STRUCTURE);
+  type = gfc_typenode_for_spec (&expr->ts);
+
+  if (!init)
+    {
+      /* Create a temporary variable and fill it in.  */
+      se->expr = gfc_create_var (type, expr->ts.u.derived->name);
+      tmp = gfc_trans_structure_assign (se->expr, expr);
+      gfc_add_expr_to_block (&se->pre, tmp);
+      return;
+    }
+
+  cm = expr->ts.u.derived->components;
+
+  for (c = gfc_constructor_first (expr->value.constructor);
+       c; c = gfc_constructor_next (c), cm = cm->next)
+    {
+      /* Skip absent members in default initializers and allocatable
+	 components.  Although the latter have a default initializer
+	 of EXPR_NULL,... by default, the static nullify is not needed
+	 since this is done every time we come into scope.  */
+      if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
+        continue;
+
+      if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
+	  && strcmp (cm->name, "_extends") == 0
+	  && cm->initializer->symtree)
+	{
+	  tree vtab;
+	  gfc_symbol *vtabs;
+	  vtabs = cm->initializer->symtree->n.sym;
+	  vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
+	  vtab = unshare_expr_without_location (vtab);
+	  CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
+	}
+      else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0)
+	{
+	  val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
+	  CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
+	}
+      else
+	{
+	  val = gfc_conv_initializer (c->expr, &cm->ts,
+				      TREE_TYPE (cm->backend_decl),
+				      cm->attr.dimension, cm->attr.pointer,
+				      cm->attr.proc_pointer);
+	  val = unshare_expr_without_location (val);
+
+	  /* Append it to the constructor list.  */
+	  CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
+	}
+    }
+  se->expr = build_constructor (type, v);
+  if (init)
+    TREE_CONSTANT (se->expr) = 1;
+}
+
+
+/* Translate a substring expression.  */
+
+static void
+gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
+{
+  gfc_ref *ref;
+
+  ref = expr->ref;
+
+  gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
+
+  se->expr = gfc_build_wide_string_const (expr->ts.kind,
+					  expr->value.character.length,
+					  expr->value.character.string);
+
+  se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
+  TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
+
+  if (ref)
+    gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
+}
+
+
+/* Entry point for expression translation.  Evaluates a scalar quantity.
+   EXPR is the expression to be translated, and SE is the state structure if
+   called from within the scalarized.  */
+
+void
+gfc_conv_expr (gfc_se * se, gfc_expr * expr)
+{
+  gfc_ss *ss;
+
+  ss = se->ss;
+  if (ss && ss->info->expr == expr
+      && (ss->info->type == GFC_SS_SCALAR
+	  || ss->info->type == GFC_SS_REFERENCE))
+    {
+      gfc_ss_info *ss_info;
+
+      ss_info = ss->info;
+      /* Substitute a scalar expression evaluated outside the scalarization
+         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)
+	se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
+
+      se->string_length = ss_info->string_length;
+      gfc_advance_se_ss_chain (se);
+      return;
+    }
+
+  /* We need to convert the expressions for the iso_c_binding derived types.
+     C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
+     null_pointer_node.  C_PTR and C_FUNPTR are converted to match the
+     typespec for the C_PTR and C_FUNPTR symbols, which has already been
+     updated to be an integer with a kind equal to the size of a (void *).  */
+  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID)
+    {
+      if (expr->expr_type == EXPR_VARIABLE
+	  && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
+	      || expr->symtree->n.sym->intmod_sym_id
+		 == ISOCBINDING_NULL_FUNPTR))
+        {
+	  /* Set expr_type to EXPR_NULL, which will result in
+	     null_pointer_node being used below.  */
+          expr->expr_type = EXPR_NULL;
+        }
+      else
+        {
+          /* Update the type/kind of the expression to be what the new
+             type/kind are for the updated symbols of C_PTR/C_FUNPTR.  */
+          expr->ts.type = BT_INTEGER;
+          expr->ts.f90_type = BT_VOID;
+          expr->ts.kind = gfc_index_integer_kind;
+        }
+    }
+
+  gfc_fix_class_refs (expr);
+
+  switch (expr->expr_type)
+    {
+    case EXPR_OP:
+      gfc_conv_expr_op (se, expr);
+      break;
+
+    case EXPR_FUNCTION:
+      gfc_conv_function_expr (se, expr);
+      break;
+
+    case EXPR_CONSTANT:
+      gfc_conv_constant (se, expr);
+      break;
+
+    case EXPR_VARIABLE:
+      gfc_conv_variable (se, expr);
+      break;
+
+    case EXPR_NULL:
+      se->expr = null_pointer_node;
+      break;
+
+    case EXPR_SUBSTRING:
+      gfc_conv_substring_expr (se, expr);
+      break;
+
+    case EXPR_STRUCTURE:
+      gfc_conv_structure (se, expr, 0);
+      break;
+
+    case EXPR_ARRAY:
+      gfc_conv_array_constructor_expr (se, expr);
+      break;
+
+    default:
+      gcc_unreachable ();
+      break;
+    }
+}
+
+/* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
+   of an assignment.  */
+void
+gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
+{
+  gfc_conv_expr (se, expr);
+  /* All numeric lvalues should have empty post chains.  If not we need to
+     figure out a way of rewriting an lvalue so that it has no post chain.  */
+  gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
+}
+
+/* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
+   numeric expressions.  Used for scalar values where inserting cleanup code
+   is inconvenient.  */
+void
+gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
+{
+  tree val;
+
+  gcc_assert (expr->ts.type != BT_CHARACTER);
+  gfc_conv_expr (se, expr);
+  if (se->post.head)
+    {
+      val = gfc_create_var (TREE_TYPE (se->expr), NULL);
+      gfc_add_modify (&se->pre, val, se->expr);
+      se->expr = val;
+      gfc_add_block_to_block (&se->pre, &se->post);
+    }
+}
+
+/* Helper to translate an expression and convert it to a particular type.  */
+void
+gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
+{
+  gfc_conv_expr_val (se, expr);
+  se->expr = convert (type, se->expr);
+}
+
+
+/* Converts an expression so that it can be passed by reference.  Scalar
+   values only.  */
+
+void
+gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
+{
+  gfc_ss *ss;
+  tree var;
+
+  ss = se->ss;
+  if (ss && ss->info->expr == expr
+      && ss->info->type == GFC_SS_REFERENCE)
+    {
+      /* Returns a reference to the scalar evaluated outside the loop
+	 for this case.  */
+      gfc_conv_expr (se, expr);
+
+      if (expr->ts.type == BT_CHARACTER
+	  && expr->expr_type != EXPR_FUNCTION)
+	gfc_conv_string_parameter (se);
+      else
+	se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
+
+      return;
+    }
+
+  if (expr->ts.type == BT_CHARACTER)
+    {
+      gfc_conv_expr (se, expr);
+      gfc_conv_string_parameter (se);
+      return;
+    }
+
+  if (expr->expr_type == EXPR_VARIABLE)
+    {
+      se->want_pointer = 1;
+      gfc_conv_expr (se, expr);
+      if (se->post.head)
+	{
+	  var = gfc_create_var (TREE_TYPE (se->expr), NULL);
+	  gfc_add_modify (&se->pre, var, se->expr);
+	  gfc_add_block_to_block (&se->pre, &se->post);
+	  se->expr = var;
+	}
+      return;
+    }
+
+  if (expr->expr_type == EXPR_FUNCTION
+      && ((expr->value.function.esym
+	   && expr->value.function.esym->result->attr.pointer
+	   && !expr->value.function.esym->result->attr.dimension)
+	  || (!expr->value.function.esym && !expr->ref
+	      && expr->symtree->n.sym->attr.pointer
+	      && !expr->symtree->n.sym->attr.dimension)))
+    {
+      se->want_pointer = 1;
+      gfc_conv_expr (se, expr);
+      var = gfc_create_var (TREE_TYPE (se->expr), NULL);
+      gfc_add_modify (&se->pre, var, se->expr);
+      se->expr = var;
+      return;
+    }
+
+  gfc_conv_expr (se, expr);
+
+  /* Create a temporary var to hold the value.  */
+  if (TREE_CONSTANT (se->expr))
+    {
+      tree tmp = se->expr;
+      STRIP_TYPE_NOPS (tmp);
+      var = build_decl (input_location,
+			CONST_DECL, NULL, TREE_TYPE (tmp));
+      DECL_INITIAL (var) = tmp;
+      TREE_STATIC (var) = 1;
+      pushdecl (var);
+    }
+  else
+    {
+      var = gfc_create_var (TREE_TYPE (se->expr), NULL);
+      gfc_add_modify (&se->pre, var, se->expr);
+    }
+  gfc_add_block_to_block (&se->pre, &se->post);
+
+  /* Take the address of that value.  */
+  se->expr = gfc_build_addr_expr (NULL_TREE, var);
+}
+
+
+tree
+gfc_trans_pointer_assign (gfc_code * code)
+{
+  return gfc_trans_pointer_assignment (code->expr1, code->expr2);
+}
+
+
+/* Generate code for a pointer assignment.  */
+
+tree
+gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
+{
+  gfc_expr *expr1_vptr = NULL;
+  gfc_se lse;
+  gfc_se rse;
+  stmtblock_t block;
+  tree desc;
+  tree tmp;
+  tree decl;
+  bool scalar;
+  gfc_ss *ss;
+
+  gfc_start_block (&block);
+
+  gfc_init_se (&lse, NULL);
+
+  /* Check whether the expression is a scalar or not; we cannot use
+     expr1->rank as it can be nonzero for proc pointers.  */
+  ss = gfc_walk_expr (expr1);
+  scalar = ss == gfc_ss_terminator;
+  if (!scalar)
+    gfc_free_ss_chain (ss);
+
+  if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
+      && expr2->expr_type != EXPR_FUNCTION)
+    {
+      gfc_add_data_component (expr2);
+      /* The following is required as gfc_add_data_component doesn't
+	 update ts.type if there is a tailing REF_ARRAY.  */
+      expr2->ts.type = BT_DERIVED;
+    }
+
+  if (scalar)
+    {
+      /* Scalar pointers.  */
+      lse.want_pointer = 1;
+      gfc_conv_expr (&lse, expr1);
+      gfc_init_se (&rse, NULL);
+      rse.want_pointer = 1;
+      gfc_conv_expr (&rse, expr2);
+
+      if (expr1->symtree->n.sym->attr.proc_pointer
+	  && expr1->symtree->n.sym->attr.dummy)
+	lse.expr = build_fold_indirect_ref_loc (input_location,
+					    lse.expr);
+
+      if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
+	  && expr2->symtree->n.sym->attr.dummy)
+	rse.expr = build_fold_indirect_ref_loc (input_location,
+					    rse.expr);
+
+      gfc_add_block_to_block (&block, &lse.pre);
+      gfc_add_block_to_block (&block, &rse.pre);
+
+      /* Check character lengths if character expression.  The test is only
+	 really added if -fbounds-check is enabled.  Exclude deferred
+	 character length lefthand sides.  */
+      if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
+	  && !expr1->ts.deferred
+	  && !expr1->symtree->n.sym->attr.proc_pointer
+	  && !gfc_is_proc_ptr_comp (expr1))
+	{
+	  gcc_assert (expr2->ts.type == BT_CHARACTER);
+	  gcc_assert (lse.string_length && rse.string_length);
+	  gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
+				       lse.string_length, rse.string_length,
+				       &block);
+	}
+
+      /* The assignment to an deferred character length sets the string
+	 length to that of the rhs.  */
+      if (expr1->ts.deferred)
+	{
+	  if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
+	    gfc_add_modify (&block, lse.string_length, rse.string_length);
+	  else if (lse.string_length != NULL)
+	    gfc_add_modify (&block, lse.string_length,
+			    build_int_cst (gfc_charlen_type_node, 0));
+	}
+
+      if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS)
+	rse.expr = gfc_class_data_get (rse.expr);
+
+      gfc_add_modify (&block, lse.expr,
+		      fold_convert (TREE_TYPE (lse.expr), rse.expr));
+
+      gfc_add_block_to_block (&block, &rse.post);
+      gfc_add_block_to_block (&block, &lse.post);
+    }
+  else
+    {
+      gfc_ref* remap;
+      bool rank_remap;
+      tree strlen_lhs;
+      tree strlen_rhs = NULL_TREE;
+
+      /* Array pointer.  Find the last reference on the LHS and if it is an
+	 array section ref, we're dealing with bounds remapping.  In this case,
+	 set it to AR_FULL so that gfc_conv_expr_descriptor does
+	 not see it and process the bounds remapping afterwards explicitly.  */
+      for (remap = expr1->ref; remap; remap = remap->next)
+	if (!remap->next && remap->type == REF_ARRAY
+	    && remap->u.ar.type == AR_SECTION)
+	  break;
+      rank_remap = (remap && remap->u.ar.end[0]);
+
+      gfc_init_se (&lse, NULL);
+      if (remap)
+	lse.descriptor_only = 1;
+      if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS
+	  && expr1->ts.type == BT_CLASS)
+	expr1_vptr = gfc_copy_expr (expr1);
+      gfc_conv_expr_descriptor (&lse, expr1);
+      strlen_lhs = lse.string_length;
+      desc = lse.expr;
+
+      if (expr2->expr_type == EXPR_NULL)
+	{
+	  /* Just set the data pointer to null.  */
+	  gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
+	}
+      else if (rank_remap)
+	{
+	  /* If we are rank-remapping, just get the RHS's descriptor and
+	     process this later on.  */
+	  gfc_init_se (&rse, NULL);
+	  rse.direct_byref = 1;
+	  rse.byref_noassign = 1;
+
+	  if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
+	    {
+	      gfc_conv_function_expr (&rse, expr2);
+
+	      if (expr1->ts.type != BT_CLASS)
+		rse.expr = gfc_class_data_get (rse.expr);
+	      else
+		{
+		  tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
+		  gfc_add_modify (&lse.pre, tmp, rse.expr);
+
+		  gfc_add_vptr_component (expr1_vptr);
+		  gfc_init_se (&rse, NULL);
+		  rse.want_pointer = 1;
+		  gfc_conv_expr (&rse, expr1_vptr);
+		  gfc_add_modify (&lse.pre, rse.expr,
+				  fold_convert (TREE_TYPE (rse.expr),
+						gfc_class_vptr_get (tmp)));
+		  rse.expr = gfc_class_data_get (tmp);
+		}
+	    }
+	  else if (expr2->expr_type == EXPR_FUNCTION)
+	    {
+	      tree bound[GFC_MAX_DIMENSIONS];
+	      int i;
+
+	      for (i = 0; i < expr2->rank; i++)
+		bound[i] = NULL_TREE;
+	      tmp = gfc_typenode_for_spec (&expr2->ts);
+	      tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
+					       bound, bound, 0,
+					       GFC_ARRAY_POINTER_CONT, false);
+	      tmp = gfc_create_var (tmp, "ptrtemp");
+	      lse.expr = tmp;
+	      lse.direct_byref = 1;
+	      gfc_conv_expr_descriptor (&lse, expr2);
+	      strlen_rhs = lse.string_length;
+	      rse.expr = tmp;
+	    }
+	  else
+	    {
+	      gfc_conv_expr_descriptor (&rse, expr2);
+	      strlen_rhs = rse.string_length;
+	    }
+	}
+      else if (expr2->expr_type == EXPR_VARIABLE)
+	{
+	  /* Assign directly to the LHS's descriptor.  */
+	  lse.direct_byref = 1;
+	  gfc_conv_expr_descriptor (&lse, expr2);
+	  strlen_rhs = lse.string_length;
+
+	  /* If this is a subreference array pointer assignment, use the rhs
+	     descriptor element size for the lhs span.  */
+	  if (expr1->symtree->n.sym->attr.subref_array_pointer)
+	    {
+	      decl = expr1->symtree->n.sym->backend_decl;
+	      gfc_init_se (&rse, NULL);
+	      rse.descriptor_only = 1;
+	      gfc_conv_expr (&rse, expr2);
+	      tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
+	      tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
+	      if (!INTEGER_CST_P (tmp))
+		gfc_add_block_to_block (&lse.post, &rse.pre);
+	      gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
+	    }
+	}
+      else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
+	{
+	  gfc_init_se (&rse, NULL);
+	  rse.want_pointer = 1;
+	  gfc_conv_function_expr (&rse, expr2);
+	  if (expr1->ts.type != BT_CLASS)
+	    {
+	      rse.expr = gfc_class_data_get (rse.expr);
+	      gfc_add_modify (&lse.pre, desc, rse.expr);
+	    }
+	  else
+	    {
+	      tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
+	      gfc_add_modify (&lse.pre, tmp, rse.expr);
+
+	      gfc_add_vptr_component (expr1_vptr);
+	      gfc_init_se (&rse, NULL);
+	      rse.want_pointer = 1;
+	      gfc_conv_expr (&rse, expr1_vptr);
+	      gfc_add_modify (&lse.pre, rse.expr,
+			      fold_convert (TREE_TYPE (rse.expr),
+					gfc_class_vptr_get (tmp)));
+	      rse.expr = gfc_class_data_get (tmp);
+	      gfc_add_modify (&lse.pre, desc, rse.expr);
+	    }
+	}
+      else
+	{
+	  /* Assign to a temporary descriptor and then copy that
+	     temporary to the pointer.  */
+	  tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
+	  lse.expr = tmp;
+	  lse.direct_byref = 1;
+	  gfc_conv_expr_descriptor (&lse, expr2);
+	  strlen_rhs = lse.string_length;
+	  gfc_add_modify (&lse.pre, desc, tmp);
+	}
+
+      if (expr1_vptr)
+	gfc_free_expr (expr1_vptr);
+
+      gfc_add_block_to_block (&block, &lse.pre);
+      if (rank_remap)
+	gfc_add_block_to_block (&block, &rse.pre);
+
+      /* If we do bounds remapping, update LHS descriptor accordingly.  */
+      if (remap)
+	{
+	  int dim;
+	  gcc_assert (remap->u.ar.dimen == expr1->rank);
+
+	  if (rank_remap)
+	    {
+	      /* Do rank remapping.  We already have the RHS's descriptor
+		 converted in rse and now have to build the correct LHS
+		 descriptor for it.  */
+
+	      tree dtype, data;
+	      tree offs, stride;
+	      tree lbound, ubound;
+
+	      /* Set dtype.  */
+	      dtype = gfc_conv_descriptor_dtype (desc);
+	      tmp = gfc_get_dtype (TREE_TYPE (desc));
+	      gfc_add_modify (&block, dtype, tmp);
+
+	      /* Copy data pointer.  */
+	      data = gfc_conv_descriptor_data_get (rse.expr);
+	      gfc_conv_descriptor_data_set (&block, desc, data);
+
+	      /* Copy offset but adjust it such that it would correspond
+		 to a lbound of zero.  */
+	      offs = gfc_conv_descriptor_offset_get (rse.expr);
+	      for (dim = 0; dim < expr2->rank; ++dim)
+		{
+		  stride = gfc_conv_descriptor_stride_get (rse.expr,
+							   gfc_rank_cst[dim]);
+		  lbound = gfc_conv_descriptor_lbound_get (rse.expr,
+							   gfc_rank_cst[dim]);
+		  tmp = fold_build2_loc (input_location, MULT_EXPR,
+					 gfc_array_index_type, stride, lbound);
+		  offs = fold_build2_loc (input_location, PLUS_EXPR,
+					  gfc_array_index_type, offs, tmp);
+		}
+	      gfc_conv_descriptor_offset_set (&block, desc, offs);
+
+	      /* Set the bounds as declared for the LHS and calculate strides as
+		 well as another offset update accordingly.  */
+	      stride = gfc_conv_descriptor_stride_get (rse.expr,
+						       gfc_rank_cst[0]);
+	      for (dim = 0; dim < expr1->rank; ++dim)
+		{
+		  gfc_se lower_se;
+		  gfc_se upper_se;
+
+		  gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
+
+		  /* Convert declared bounds.  */
+		  gfc_init_se (&lower_se, NULL);
+		  gfc_init_se (&upper_se, NULL);
+		  gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
+		  gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
+
+		  gfc_add_block_to_block (&block, &lower_se.pre);
+		  gfc_add_block_to_block (&block, &upper_se.pre);
+
+		  lbound = fold_convert (gfc_array_index_type, lower_se.expr);
+		  ubound = fold_convert (gfc_array_index_type, upper_se.expr);
+
+		  lbound = gfc_evaluate_now (lbound, &block);
+		  ubound = gfc_evaluate_now (ubound, &block);
+
+		  gfc_add_block_to_block (&block, &lower_se.post);
+		  gfc_add_block_to_block (&block, &upper_se.post);
+
+		  /* Set bounds in descriptor.  */
+		  gfc_conv_descriptor_lbound_set (&block, desc,
+						  gfc_rank_cst[dim], lbound);
+		  gfc_conv_descriptor_ubound_set (&block, desc,
+						  gfc_rank_cst[dim], ubound);
+
+		  /* Set stride.  */
+		  stride = gfc_evaluate_now (stride, &block);
+		  gfc_conv_descriptor_stride_set (&block, desc,
+						  gfc_rank_cst[dim], stride);
+
+		  /* Update offset.  */
+		  offs = gfc_conv_descriptor_offset_get (desc);
+		  tmp = fold_build2_loc (input_location, MULT_EXPR,
+					 gfc_array_index_type, lbound, stride);
+		  offs = fold_build2_loc (input_location, MINUS_EXPR,
+					  gfc_array_index_type, offs, tmp);
+		  offs = gfc_evaluate_now (offs, &block);
+		  gfc_conv_descriptor_offset_set (&block, desc, offs);
+
+		  /* Update stride.  */
+		  tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+		  stride = fold_build2_loc (input_location, MULT_EXPR,
+					    gfc_array_index_type, stride, tmp);
+		}
+	    }
+	  else
+	    {
+	      /* Bounds remapping.  Just shift the lower bounds.  */
+
+	      gcc_assert (expr1->rank == expr2->rank);
+
+	      for (dim = 0; dim < remap->u.ar.dimen; ++dim)
+		{
+		  gfc_se lbound_se;
+
+		  gcc_assert (remap->u.ar.start[dim]);
+		  gcc_assert (!remap->u.ar.end[dim]);
+		  gfc_init_se (&lbound_se, NULL);
+		  gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
+
+		  gfc_add_block_to_block (&block, &lbound_se.pre);
+		  gfc_conv_shift_descriptor_lbound (&block, desc,
+						    dim, lbound_se.expr);
+		  gfc_add_block_to_block (&block, &lbound_se.post);
+		}
+	    }
+	}
+
+      /* Check string lengths if applicable.  The check is only really added
+	 to the output code if -fbounds-check is enabled.  */
+      if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
+	{
+	  gcc_assert (expr2->ts.type == BT_CHARACTER);
+	  gcc_assert (strlen_lhs && strlen_rhs);
+	  gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
+				       strlen_lhs, strlen_rhs, &block);
+	}
+
+      /* If rank remapping was done, check with -fcheck=bounds that
+	 the target is at least as large as the pointer.  */
+      if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
+	{
+	  tree lsize, rsize;
+	  tree fault;
+	  const char* msg;
+
+	  lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
+	  rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
+
+	  lsize = gfc_evaluate_now (lsize, &block);
+	  rsize = gfc_evaluate_now (rsize, &block);
+	  fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+				   rsize, lsize);
+
+	  msg = _("Target of rank remapping is too small (%ld < %ld)");
+	  gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
+				   msg, rsize, lsize);
+	}
+
+      gfc_add_block_to_block (&block, &lse.post);
+      if (rank_remap)
+	gfc_add_block_to_block (&block, &rse.post);
+    }
+
+  return gfc_finish_block (&block);
+}
+
+
+/* Makes sure se is suitable for passing as a function string parameter.  */
+/* TODO: Need to check all callers of this function.  It may be abused.  */
+
+void
+gfc_conv_string_parameter (gfc_se * se)
+{
+  tree type;
+
+  if (TREE_CODE (se->expr) == STRING_CST)
+    {
+      type = TREE_TYPE (TREE_TYPE (se->expr));
+      se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
+      return;
+    }
+
+  if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
+    {
+      if (TREE_CODE (se->expr) != INDIRECT_REF)
+	{
+	  type = TREE_TYPE (se->expr);
+          se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
+	}
+      else
+	{
+	  type = gfc_get_character_type_len (gfc_default_character_kind,
+					     se->string_length);
+	  type = build_pointer_type (type);
+	  se->expr = gfc_build_addr_expr (type, se->expr);
+	}
+    }
+
+  gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
+}
+
+
+/* Generate code for assignment of scalar variables.  Includes character
+   strings and derived types with allocatable components.
+   If you know that the LHS has no allocations, set dealloc to false.
+
+   DEEP_COPY has no effect if the typespec TS is not a derived type with
+   allocatable components.  Otherwise, if it is set, an explicit copy of each
+   allocatable component is made.  This is necessary as a simple copy of the
+   whole object would copy array descriptors as is, so that the lhs's
+   allocatable components would point to the rhs's after the assignment.
+   Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
+   necessary if the rhs is a non-pointer function, as the allocatable components
+   are not accessible by other means than the function's result after the
+   function has returned.  It is even more subtle when temporaries are involved,
+   as the two following examples show:
+    1.  When we evaluate an array constructor, a temporary is created.  Thus
+      there is theoretically no alias possible.  However, no deep copy is
+      made for this temporary, so that if the constructor is made of one or
+      more variable with allocatable components, those components still point
+      to the variable's: DEEP_COPY should be set for the assignment from the
+      temporary to the lhs in that case.
+    2.  When assigning a scalar to an array, we evaluate the scalar value out
+      of the loop, store it into a temporary variable, and assign from that.
+      In that case, deep copying when assigning to the temporary would be a
+      waste of resources; however deep copies should happen when assigning from
+      the temporary to each array element: again DEEP_COPY should be set for
+      the assignment from the temporary to the lhs.  */
+
+tree
+gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
+			 bool l_is_temp, bool deep_copy, bool dealloc)
+{
+  stmtblock_t block;
+  tree tmp;
+  tree cond;
+
+  gfc_init_block (&block);
+
+  if (ts.type == BT_CHARACTER)
+    {
+      tree rlen = NULL;
+      tree llen = NULL;
+
+      if (lse->string_length != NULL_TREE)
+	{
+	  gfc_conv_string_parameter (lse);
+	  gfc_add_block_to_block (&block, &lse->pre);
+	  llen = lse->string_length;
+	}
+
+      if (rse->string_length != NULL_TREE)
+	{
+	  gcc_assert (rse->string_length != NULL_TREE);
+	  gfc_conv_string_parameter (rse);
+	  gfc_add_block_to_block (&block, &rse->pre);
+	  rlen = rse->string_length;
+	}
+
+      gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
+			     rse->expr, ts.kind);
+    }
+  else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
+    {
+      tree tmp_var = NULL_TREE;
+      cond = NULL_TREE;
+
+      /* Are the rhs and the lhs the same?  */
+      if (deep_copy)
+	{
+	  cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+				  gfc_build_addr_expr (NULL_TREE, lse->expr),
+				  gfc_build_addr_expr (NULL_TREE, rse->expr));
+	  cond = gfc_evaluate_now (cond, &lse->pre);
+	}
+
+      /* Deallocate the lhs allocated components as long as it is not
+	 the same as the rhs.  This must be done following the assignment
+	 to prevent deallocating data that could be used in the rhs
+	 expression.  */
+      if (!l_is_temp && dealloc)
+	{
+	  tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
+	  tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var, 0);
+	  if (deep_copy)
+	    tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
+			    tmp);
+	  gfc_add_expr_to_block (&lse->post, tmp);
+	}
+
+      gfc_add_block_to_block (&block, &rse->pre);
+      gfc_add_block_to_block (&block, &lse->pre);
+
+      gfc_add_modify (&block, lse->expr,
+			   fold_convert (TREE_TYPE (lse->expr), rse->expr));
+
+      /* Restore pointer address of coarray components.  */
+      if (ts.u.derived->attr.coarray_comp && deep_copy && tmp_var != NULL_TREE)
+	{
+	  tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr);
+	  tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
+			  tmp);
+	  gfc_add_expr_to_block (&block, tmp);
+	}
+
+      /* Do a deep copy if the rhs is a variable, if it is not the
+	 same as the lhs.  */
+      if (deep_copy)
+	{
+	  tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
+	  tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
+			  tmp);
+	  gfc_add_expr_to_block (&block, tmp);
+	}
+    }
+  else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
+    {
+      gfc_add_block_to_block (&block, &lse->pre);
+      gfc_add_block_to_block (&block, &rse->pre);
+      tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
+			     TREE_TYPE (lse->expr), rse->expr);
+      gfc_add_modify (&block, lse->expr, tmp);
+    }
+  else
+    {
+      gfc_add_block_to_block (&block, &lse->pre);
+      gfc_add_block_to_block (&block, &rse->pre);
+
+      gfc_add_modify (&block, lse->expr,
+		      fold_convert (TREE_TYPE (lse->expr), rse->expr));
+    }
+
+  gfc_add_block_to_block (&block, &lse->post);
+  gfc_add_block_to_block (&block, &rse->post);
+
+  return gfc_finish_block (&block);
+}
+
+
+/* There are quite a lot of restrictions on the optimisation in using an
+   array function assign without a temporary.  */
+
+static bool
+arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
+{
+  gfc_ref * ref;
+  bool seen_array_ref;
+  bool c = false;
+  gfc_symbol *sym = expr1->symtree->n.sym;
+
+  /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION.  */
+  if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
+    return true;
+
+  /* Elemental functions are scalarized so that they don't need a
+     temporary in gfc_trans_assignment_1, so return a true.  Otherwise,
+     they would need special treatment in gfc_trans_arrayfunc_assign.  */
+  if (expr2->value.function.esym != NULL
+      && expr2->value.function.esym->attr.elemental)
+    return true;
+
+  /* Need a temporary if rhs is not FULL or a contiguous section.  */
+  if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
+    return true;
+
+  /* Need a temporary if EXPR1 can't be expressed as a descriptor.  */
+  if (gfc_ref_needs_temporary_p (expr1->ref))
+    return true;
+
+  /* Functions returning pointers or allocatables need temporaries.  */
+  c = expr2->value.function.esym
+      ? (expr2->value.function.esym->attr.pointer
+	 || expr2->value.function.esym->attr.allocatable)
+      : (expr2->symtree->n.sym->attr.pointer
+	 || expr2->symtree->n.sym->attr.allocatable);
+  if (c)
+    return true;
+
+  /* Character array functions need temporaries unless the
+     character lengths are the same.  */
+  if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
+    {
+      if (expr1->ts.u.cl->length == NULL
+	    || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
+	return true;
+
+      if (expr2->ts.u.cl->length == NULL
+	    || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
+	return true;
+
+      if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
+		     expr2->ts.u.cl->length->value.integer) != 0)
+	return true;
+    }
+
+  /* Check that no LHS component references appear during an array
+     reference. This is needed because we do not have the means to
+     span any arbitrary stride with an array descriptor. This check
+     is not needed for the rhs because the function result has to be
+     a complete type.  */
+  seen_array_ref = false;
+  for (ref = expr1->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_ARRAY)
+	seen_array_ref= true;
+      else if (ref->type == REF_COMPONENT && seen_array_ref)
+	return true;
+    }
+
+  /* Check for a dependency.  */
+  if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
+				   expr2->value.function.esym,
+				   expr2->value.function.actual,
+				   NOT_ELEMENTAL))
+    return true;
+
+  /* If we have reached here with an intrinsic function, we do not
+     need a temporary except in the particular case that reallocation
+     on assignment is active and the lhs is allocatable and a target.  */
+  if (expr2->value.function.isym)
+    return (gfc_option.flag_realloc_lhs
+	      && sym->attr.allocatable
+	      && sym->attr.target);
+
+  /* If the LHS is a dummy, we need a temporary if it is not
+     INTENT(OUT).  */
+  if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
+    return true;
+
+  /* If the lhs has been host_associated, is in common, a pointer or is
+     a target and the function is not using a RESULT variable, aliasing
+     can occur and a temporary is needed.  */
+  if ((sym->attr.host_assoc
+	   || sym->attr.in_common
+	   || sym->attr.pointer
+	   || sym->attr.cray_pointee
+	   || sym->attr.target)
+	&& expr2->symtree != NULL
+	&& expr2->symtree->n.sym == expr2->symtree->n.sym->result)
+    return true;
+
+  /* A PURE function can unconditionally be called without a temporary.  */
+  if (expr2->value.function.esym != NULL
+      && expr2->value.function.esym->attr.pure)
+    return false;
+
+  /* Implicit_pure functions are those which could legally be declared
+     to be PURE.  */
+  if (expr2->value.function.esym != NULL
+      && expr2->value.function.esym->attr.implicit_pure)
+    return false;
+
+  if (!sym->attr.use_assoc
+	&& !sym->attr.in_common
+	&& !sym->attr.pointer
+	&& !sym->attr.target
+	&& !sym->attr.cray_pointee
+	&& expr2->value.function.esym)
+    {
+      /* A temporary is not needed if the function is not contained and
+	 the variable is local or host associated and not a pointer or
+	 a target. */
+      if (!expr2->value.function.esym->attr.contained)
+	return false;
+
+      /* A temporary is not needed if the lhs has never been host
+	 associated and the procedure is contained.  */
+      else if (!sym->attr.host_assoc)
+	return false;
+
+      /* A temporary is not needed if the variable is local and not
+	 a pointer, a target or a result.  */
+      if (sym->ns->parent
+	    && expr2->value.function.esym->ns == sym->ns->parent)
+	return false;
+    }
+
+  /* Default to temporary use.  */
+  return true;
+}
+
+
+/* Provide the loop info so that the lhs descriptor can be built for
+   reallocatable assignments from extrinsic function calls.  */
+
+static void
+realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
+			       gfc_loopinfo *loop)
+{
+  /* Signal that the function call should not be made by
+     gfc_conv_loop_setup. */
+  se->ss->is_alloc_lhs = 1;
+  gfc_init_loopinfo (loop);
+  gfc_add_ss_to_loop (loop, *ss);
+  gfc_add_ss_to_loop (loop, se->ss);
+  gfc_conv_ss_startstride (loop);
+  gfc_conv_loop_setup (loop, where);
+  gfc_copy_loopinfo_to_se (se, loop);
+  gfc_add_block_to_block (&se->pre, &loop->pre);
+  gfc_add_block_to_block (&se->pre, &loop->post);
+  se->ss->is_alloc_lhs = 0;
+}
+
+
+/* For assignment to a reallocatable lhs from intrinsic functions,
+   replace the se.expr (ie. the result) with a temporary descriptor.
+   Null the data field so that the library allocates space for the
+   result. Free the data of the original descriptor after the function,
+   in case it appears in an argument expression and transfer the
+   result to the original descriptor.  */
+
+static void
+fcncall_realloc_result (gfc_se *se, int rank)
+{
+  tree desc;
+  tree res_desc;
+  tree tmp;
+  tree offset;
+  tree zero_cond;
+  int n;
+
+  /* Use the allocation done by the library.  Substitute the lhs
+     descriptor with a copy, whose data field is nulled.*/
+  desc = build_fold_indirect_ref_loc (input_location, se->expr);
+  if (POINTER_TYPE_P (TREE_TYPE (desc)))
+    desc = build_fold_indirect_ref_loc (input_location, desc);
+
+  /* Unallocated, the descriptor does not have a dtype.  */
+  tmp = gfc_conv_descriptor_dtype (desc);
+  gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+
+  res_desc = gfc_evaluate_now (desc, &se->pre);
+  gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
+  se->expr = gfc_build_addr_expr (TREE_TYPE (se->expr), res_desc);
+
+  /* Free the lhs after the function call and copy the result data to
+     the lhs descriptor.  */
+  tmp = gfc_conv_descriptor_data_get (desc);
+  zero_cond = fold_build2_loc (input_location, EQ_EXPR,
+			       boolean_type_node, tmp,
+			       build_int_cst (TREE_TYPE (tmp), 0));
+  zero_cond = gfc_evaluate_now (zero_cond, &se->post);
+  tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
+  gfc_add_expr_to_block (&se->post, tmp);
+
+  tmp = gfc_conv_descriptor_data_get (res_desc);
+  gfc_conv_descriptor_data_set (&se->post, desc, tmp);
+
+  /* Check that the shapes are the same between lhs and expression.  */
+  for (n = 0 ; n < rank; n++)
+    {
+      tree tmp1;
+      tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
+      tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
+      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+			     gfc_array_index_type, tmp, tmp1);
+      tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
+      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+			     gfc_array_index_type, tmp, tmp1);
+      tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
+      tmp = fold_build2_loc (input_location, PLUS_EXPR,
+			     gfc_array_index_type, tmp, tmp1);
+      tmp = fold_build2_loc (input_location, NE_EXPR,
+			     boolean_type_node, tmp,
+			     gfc_index_zero_node);
+      tmp = gfc_evaluate_now (tmp, &se->post);
+      zero_cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+				   boolean_type_node, tmp,
+				   zero_cond);
+    }
+
+  /* 'zero_cond' being true is equal to lhs not being allocated or the
+     shapes being different.  */
+  zero_cond = gfc_evaluate_now (zero_cond, &se->post);
+
+  /* Now reset the bounds returned from the function call to bounds based
+     on the lhs lbounds, except where the lhs is not allocated or the shapes
+     of 'variable and 'expr' are different. Set the offset accordingly.  */
+  offset = gfc_index_zero_node;
+  for (n = 0 ; n < rank; n++)
+    {
+      tree lbound;
+
+      lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
+      lbound = fold_build3_loc (input_location, COND_EXPR,
+				gfc_array_index_type, zero_cond,
+				gfc_index_one_node, lbound);
+      lbound = gfc_evaluate_now (lbound, &se->post);
+
+      tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
+      tmp = fold_build2_loc (input_location, PLUS_EXPR,
+			     gfc_array_index_type, tmp, lbound);
+      gfc_conv_descriptor_lbound_set (&se->post, desc,
+				      gfc_rank_cst[n], lbound);
+      gfc_conv_descriptor_ubound_set (&se->post, desc,
+				      gfc_rank_cst[n], tmp);
+
+      /* Set stride and accumulate the offset.  */
+      tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
+      gfc_conv_descriptor_stride_set (&se->post, desc,
+				      gfc_rank_cst[n], tmp);
+      tmp = fold_build2_loc (input_location, MULT_EXPR,
+			     gfc_array_index_type, lbound, tmp);
+      offset = fold_build2_loc (input_location, MINUS_EXPR,
+				gfc_array_index_type, offset, tmp);
+      offset = gfc_evaluate_now (offset, &se->post);
+    }
+
+  gfc_conv_descriptor_offset_set (&se->post, desc, offset);
+}
+
+
+
+/* Try to translate array(:) = func (...), where func is a transformational
+   array function, without using a temporary.  Returns NULL if this isn't the
+   case.  */
+
+static tree
+gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
+{
+  gfc_se se;
+  gfc_ss *ss = NULL;
+  gfc_component *comp = NULL;
+  gfc_loopinfo loop;
+
+  if (arrayfunc_assign_needs_temporary (expr1, expr2))
+    return NULL;
+
+  /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
+     functions.  */
+  comp = gfc_get_proc_ptr_comp (expr2);
+  gcc_assert (expr2->value.function.isym
+	      || (comp && comp->attr.dimension)
+	      || (!comp && gfc_return_by_reference (expr2->value.function.esym)
+		  && expr2->value.function.esym->result->attr.dimension));
+
+  gfc_init_se (&se, NULL);
+  gfc_start_block (&se.pre);
+  se.want_pointer = 1;
+
+  gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
+
+  if (expr1->ts.type == BT_DERIVED
+	&& expr1->ts.u.derived->attr.alloc_comp)
+    {
+      tree tmp;
+      tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, se.expr,
+					      expr1->rank);
+      gfc_add_expr_to_block (&se.pre, tmp);
+    }
+
+  se.direct_byref = 1;
+  se.ss = gfc_walk_expr (expr2);
+  gcc_assert (se.ss != gfc_ss_terminator);
+
+  /* Reallocate on assignment needs the loopinfo for extrinsic functions.
+     This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
+     Clearly, this cannot be done for an allocatable function result, since
+     the shape of the result is unknown and, in any case, the function must
+     correctly take care of the reallocation internally. For intrinsic
+     calls, the array data is freed and the library takes care of allocation.
+     TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
+     to the library.  */
+  if (gfc_option.flag_realloc_lhs
+	&& gfc_is_reallocatable_lhs (expr1)
+	&& !gfc_expr_attr (expr1).codimension
+	&& !gfc_is_coindexed (expr1)
+	&& !(expr2->value.function.esym
+	    && expr2->value.function.esym->result->attr.allocatable))
+    {
+      realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
+
+      if (!expr2->value.function.isym)
+	{
+	  ss = gfc_walk_expr (expr1);
+	  gcc_assert (ss != gfc_ss_terminator);
+
+	  realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
+	  ss->is_alloc_lhs = 1;
+	}
+      else
+	fcncall_realloc_result (&se, expr1->rank);
+    }
+
+  gfc_conv_function_expr (&se, expr2);
+  gfc_add_block_to_block (&se.pre, &se.post);
+
+  if (ss)
+    gfc_cleanup_loop (&loop);
+  else
+    gfc_free_ss_chain (se.ss);
+
+  return gfc_finish_block (&se.pre);
+}
+
+
+/* Try to efficiently translate array(:) = 0.  Return NULL if this
+   can't be done.  */
+
+static tree
+gfc_trans_zero_assign (gfc_expr * expr)
+{
+  tree dest, len, type;
+  tree tmp;
+  gfc_symbol *sym;
+
+  sym = expr->symtree->n.sym;
+  dest = gfc_get_symbol_decl (sym);
+
+  type = TREE_TYPE (dest);
+  if (POINTER_TYPE_P (type))
+    type = TREE_TYPE (type);
+  if (!GFC_ARRAY_TYPE_P (type))
+    return NULL_TREE;
+
+  /* Determine the length of the array.  */
+  len = GFC_TYPE_ARRAY_SIZE (type);
+  if (!len || TREE_CODE (len) != INTEGER_CST)
+    return NULL_TREE;
+
+  tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
+  len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
+			 fold_convert (gfc_array_index_type, tmp));
+
+  /* If we are zeroing a local array avoid taking its address by emitting
+     a = {} instead.  */
+  if (!POINTER_TYPE_P (TREE_TYPE (dest)))
+    return build2_loc (input_location, MODIFY_EXPR, void_type_node,
+		       dest, build_constructor (TREE_TYPE (dest),
+					      NULL));
+
+  /* Convert arguments to the correct types.  */
+  dest = fold_convert (pvoid_type_node, dest);
+  len = fold_convert (size_type_node, len);
+
+  /* Construct call to __builtin_memset.  */
+  tmp = build_call_expr_loc (input_location,
+			     builtin_decl_explicit (BUILT_IN_MEMSET),
+			     3, dest, integer_zero_node, len);
+  return fold_convert (void_type_node, tmp);
+}
+
+
+/* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
+   that constructs the call to __builtin_memcpy.  */
+
+tree
+gfc_build_memcpy_call (tree dst, tree src, tree len)
+{
+  tree tmp;
+
+  /* Convert arguments to the correct types.  */
+  if (!POINTER_TYPE_P (TREE_TYPE (dst)))
+    dst = gfc_build_addr_expr (pvoid_type_node, dst);
+  else
+    dst = fold_convert (pvoid_type_node, dst);
+
+  if (!POINTER_TYPE_P (TREE_TYPE (src)))
+    src = gfc_build_addr_expr (pvoid_type_node, src);
+  else
+    src = fold_convert (pvoid_type_node, src);
+
+  len = fold_convert (size_type_node, len);
+
+  /* Construct call to __builtin_memcpy.  */
+  tmp = build_call_expr_loc (input_location,
+			     builtin_decl_explicit (BUILT_IN_MEMCPY),
+			     3, dst, src, len);
+  return fold_convert (void_type_node, tmp);
+}
+
+
+/* Try to efficiently translate dst(:) = src(:).  Return NULL if this
+   can't be done.  EXPR1 is the destination/lhs and EXPR2 is the
+   source/rhs, both are gfc_full_array_ref_p which have been checked for
+   dependencies.  */
+
+static tree
+gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
+{
+  tree dst, dlen, dtype;
+  tree src, slen, stype;
+  tree tmp;
+
+  dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
+  src = gfc_get_symbol_decl (expr2->symtree->n.sym);
+
+  dtype = TREE_TYPE (dst);
+  if (POINTER_TYPE_P (dtype))
+    dtype = TREE_TYPE (dtype);
+  stype = TREE_TYPE (src);
+  if (POINTER_TYPE_P (stype))
+    stype = TREE_TYPE (stype);
+
+  if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
+    return NULL_TREE;
+
+  /* Determine the lengths of the arrays.  */
+  dlen = GFC_TYPE_ARRAY_SIZE (dtype);
+  if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
+    return NULL_TREE;
+  tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
+  dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			  dlen, fold_convert (gfc_array_index_type, tmp));
+
+  slen = GFC_TYPE_ARRAY_SIZE (stype);
+  if (!slen || TREE_CODE (slen) != INTEGER_CST)
+    return NULL_TREE;
+  tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
+  slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			  slen, fold_convert (gfc_array_index_type, tmp));
+
+  /* Sanity check that they are the same.  This should always be
+     the case, as we should already have checked for conformance.  */
+  if (!tree_int_cst_equal (slen, dlen))
+    return NULL_TREE;
+
+  return gfc_build_memcpy_call (dst, src, dlen);
+}
+
+
+/* Try to efficiently translate array(:) = (/ ... /).  Return NULL if
+   this can't be done.  EXPR1 is the destination/lhs for which
+   gfc_full_array_ref_p is true, and EXPR2 is the source/rhs.  */
+
+static tree
+gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
+{
+  unsigned HOST_WIDE_INT nelem;
+  tree dst, dtype;
+  tree src, stype;
+  tree len;
+  tree tmp;
+
+  nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
+  if (nelem == 0)
+    return NULL_TREE;
+
+  dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
+  dtype = TREE_TYPE (dst);
+  if (POINTER_TYPE_P (dtype))
+    dtype = TREE_TYPE (dtype);
+  if (!GFC_ARRAY_TYPE_P (dtype))
+    return NULL_TREE;
+
+  /* Determine the lengths of the array.  */
+  len = GFC_TYPE_ARRAY_SIZE (dtype);
+  if (!len || TREE_CODE (len) != INTEGER_CST)
+    return NULL_TREE;
+
+  /* Confirm that the constructor is the same size.  */
+  if (compare_tree_int (len, nelem) != 0)
+    return NULL_TREE;
+
+  tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
+  len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
+			 fold_convert (gfc_array_index_type, tmp));
+
+  stype = gfc_typenode_for_spec (&expr2->ts);
+  src = gfc_build_constant_array_constructor (expr2, stype);
+
+  stype = TREE_TYPE (src);
+  if (POINTER_TYPE_P (stype))
+    stype = TREE_TYPE (stype);
+
+  return gfc_build_memcpy_call (dst, src, len);
+}
+
+
+/* Tells whether the expression is to be treated as a variable reference.  */
+
+static bool
+expr_is_variable (gfc_expr *expr)
+{
+  gfc_expr *arg;
+  gfc_component *comp;
+  gfc_symbol *func_ifc;
+
+  if (expr->expr_type == EXPR_VARIABLE)
+    return true;
+
+  arg = gfc_get_noncopying_intrinsic_argument (expr);
+  if (arg)
+    {
+      gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
+      return expr_is_variable (arg);
+    }
+
+  /* A data-pointer-returning function should be considered as a variable
+     too.  */
+  if (expr->expr_type == EXPR_FUNCTION
+      && expr->ref == NULL)
+    {
+      if (expr->value.function.isym != NULL)
+	return false;
+
+      if (expr->value.function.esym != NULL)
+	{
+	  func_ifc = expr->value.function.esym;
+	  goto found_ifc;
+	}
+      else
+	{
+	  gcc_assert (expr->symtree);
+	  func_ifc = expr->symtree->n.sym;
+	  goto found_ifc;
+	}
+
+      gcc_unreachable ();
+    }
+
+  comp = gfc_get_proc_ptr_comp (expr);
+  if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION)
+      && comp)
+    {
+      func_ifc = comp->ts.interface;
+      goto found_ifc;
+    }
+
+  if (expr->expr_type == EXPR_COMPCALL)
+    {
+      gcc_assert (!expr->value.compcall.tbp->is_generic);
+      func_ifc = expr->value.compcall.tbp->u.specific->n.sym;
+      goto found_ifc;
+    }
+
+  return false;
+
+found_ifc:
+  gcc_assert (func_ifc->attr.function
+	      && func_ifc->result != NULL);
+  return func_ifc->result->attr.pointer;
+}
+
+
+/* Is the lhs OK for automatic reallocation?  */
+
+static bool
+is_scalar_reallocatable_lhs (gfc_expr *expr)
+{
+  gfc_ref * ref;
+
+  /* An allocatable variable with no reference.  */
+  if (expr->symtree->n.sym->attr.allocatable
+	&& !expr->ref)
+    return true;
+
+  /* All that can be left are allocatable components.  */
+  if ((expr->symtree->n.sym->ts.type != BT_DERIVED
+	&& expr->symtree->n.sym->ts.type != BT_CLASS)
+	|| !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
+    return false;
+
+  /* Find an allocatable component ref last.  */
+  for (ref = expr->ref; ref; ref = ref->next)
+    if (ref->type == REF_COMPONENT
+	  && !ref->next
+	  && ref->u.c.component->attr.allocatable)
+      return true;
+
+  return false;
+}
+
+
+/* Allocate or reallocate scalar lhs, as necessary.  */
+
+static void
+alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
+					 tree string_length,
+					 gfc_expr *expr1,
+					 gfc_expr *expr2)
+
+{
+  tree cond;
+  tree tmp;
+  tree size;
+  tree size_in_bytes;
+  tree jump_label1;
+  tree jump_label2;
+  gfc_se lse;
+
+  if (!expr1 || expr1->rank)
+    return;
+
+  if (!expr2 || expr2->rank)
+    return;
+
+  realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
+
+  /* Since this is a scalar lhs, we can afford to do this.  That is,
+     there is no risk of side effects being repeated.  */
+  gfc_init_se (&lse, NULL);
+  lse.want_pointer = 1;
+  gfc_conv_expr (&lse, expr1);
+
+  jump_label1 = gfc_build_label_decl (NULL_TREE);
+  jump_label2 = gfc_build_label_decl (NULL_TREE);
+
+  /* Do the allocation if the lhs is NULL. Otherwise go to label 1.  */
+  tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
+  cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			  lse.expr, tmp);
+  tmp = build3_v (COND_EXPR, cond,
+		  build1_v (GOTO_EXPR, jump_label1),
+		  build_empty_stmt (input_location));
+  gfc_add_expr_to_block (block, tmp);
+
+  if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+    {
+      /* Use the rhs string length and the lhs element size.  */
+      size = string_length;
+      tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
+      tmp = TYPE_SIZE_UNIT (tmp);
+      size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
+				       TREE_TYPE (tmp), tmp,
+				       fold_convert (TREE_TYPE (tmp), size));
+    }
+  else
+    {
+      /* Otherwise use the length in bytes of the rhs.  */
+      size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
+      size_in_bytes = size;
+    }
+
+  size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
+				   size_in_bytes, size_one_node);
+
+  if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
+    {
+      tmp = build_call_expr_loc (input_location,
+				 builtin_decl_explicit (BUILT_IN_CALLOC),
+				 2, build_one_cst (size_type_node),
+				 size_in_bytes);
+      tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
+      gfc_add_modify (block, lse.expr, tmp);
+    }
+  else
+    {
+      tmp = build_call_expr_loc (input_location,
+				 builtin_decl_explicit (BUILT_IN_MALLOC),
+				 1, size_in_bytes);
+      tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
+      gfc_add_modify (block, lse.expr, tmp);
+    }
+
+  if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+    {
+      /* Deferred characters need checking for lhs and rhs string
+	 length.  Other deferred parameter variables will have to
+	 come here too.  */
+      tmp = build1_v (GOTO_EXPR, jump_label2);
+      gfc_add_expr_to_block (block, tmp);
+    }
+  tmp = build1_v (LABEL_EXPR, jump_label1);
+  gfc_add_expr_to_block (block, tmp);
+
+  /* For a deferred length character, reallocate if lengths of lhs and
+     rhs are different.  */
+  if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+    {
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+			      expr1->ts.u.cl->backend_decl, size);
+      /* Jump past the realloc if the lengths are the same.  */
+      tmp = build3_v (COND_EXPR, cond,
+		      build1_v (GOTO_EXPR, jump_label2),
+		      build_empty_stmt (input_location));
+      gfc_add_expr_to_block (block, tmp);
+      tmp = build_call_expr_loc (input_location,
+				 builtin_decl_explicit (BUILT_IN_REALLOC),
+				 2, fold_convert (pvoid_type_node, lse.expr),
+				 size_in_bytes);
+      tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
+      gfc_add_modify (block, lse.expr, tmp);
+      tmp = build1_v (LABEL_EXPR, jump_label2);
+      gfc_add_expr_to_block (block, tmp);
+
+      /* Update the lhs character length.  */
+      size = string_length;
+      if (TREE_CODE (expr1->ts.u.cl->backend_decl) == VAR_DECL)
+	gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size);
+      else
+	gfc_add_modify (block, lse.string_length, size);
+    }
+}
+
+/* Check for assignments of the type
+
+   a = a + 4
+
+   to make sure we do not check for reallocation unneccessarily.  */
+
+
+static bool
+is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
+{
+  gfc_actual_arglist *a;
+  gfc_expr *e1, *e2;
+
+  switch (expr2->expr_type)
+    {
+    case EXPR_VARIABLE:
+      return gfc_dep_compare_expr (expr1, expr2) == 0;
+
+    case EXPR_FUNCTION:
+      if (expr2->value.function.esym
+	  && expr2->value.function.esym->attr.elemental)
+	{
+	  for (a = expr2->value.function.actual; a != NULL; a = a->next)
+	    {
+	      e1 = a->expr;
+	      if (e1->rank > 0 && !is_runtime_conformable (expr1, e1))
+		return false;
+	    }
+	  return true;
+	}
+      else if (expr2->value.function.isym
+	       && expr2->value.function.isym->elemental)
+	{
+	  for (a = expr2->value.function.actual; a != NULL; a = a->next)
+	    {
+	      e1 = a->expr;
+	      if (e1->rank > 0 && !is_runtime_conformable (expr1, e1))
+		return false;
+	    }
+	  return true;
+	}
+
+      break;
+
+    case EXPR_OP:
+      switch (expr2->value.op.op)
+	{
+	case INTRINSIC_NOT:
+	case INTRINSIC_UPLUS:
+	case INTRINSIC_UMINUS:
+	case INTRINSIC_PARENTHESES:
+	  return is_runtime_conformable (expr1, expr2->value.op.op1);
+
+	case INTRINSIC_PLUS:
+	case INTRINSIC_MINUS:
+	case INTRINSIC_TIMES:
+	case INTRINSIC_DIVIDE:
+	case INTRINSIC_POWER:
+	case INTRINSIC_AND:
+	case INTRINSIC_OR:
+	case INTRINSIC_EQV:
+	case INTRINSIC_NEQV:
+	case INTRINSIC_EQ:
+	case INTRINSIC_NE:
+	case INTRINSIC_GT:
+	case INTRINSIC_GE:
+	case INTRINSIC_LT:
+	case INTRINSIC_LE:
+	case INTRINSIC_EQ_OS:
+	case INTRINSIC_NE_OS:
+	case INTRINSIC_GT_OS:
+	case INTRINSIC_GE_OS:
+	case INTRINSIC_LT_OS:
+	case INTRINSIC_LE_OS:
+
+	  e1 = expr2->value.op.op1;
+	  e2 = expr2->value.op.op2;
+
+	  if (e1->rank == 0 && e2->rank > 0)
+	    return is_runtime_conformable (expr1, e2);
+	  else if (e1->rank > 0 && e2->rank == 0)
+	    return is_runtime_conformable (expr1, e1);
+	  else if (e1->rank > 0 && e2->rank > 0)
+	    return is_runtime_conformable (expr1, e1)
+	      && is_runtime_conformable (expr1, e2);
+	  break;
+
+	default:
+	  break;
+
+	}
+
+      break;
+
+    default:
+      break;
+    }
+  return false;
+}
+
+/* Subroutine of gfc_trans_assignment that actually scalarizes the
+   assignment.  EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
+   init_flag indicates initialization expressions and dealloc that no
+   deallocate prior assignment is needed (if in doubt, set true).  */
+
+static tree
+gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
+			bool dealloc)
+{
+  gfc_se lse;
+  gfc_se rse;
+  gfc_ss *lss;
+  gfc_ss *lss_section;
+  gfc_ss *rss;
+  gfc_loopinfo loop;
+  tree tmp;
+  stmtblock_t block;
+  stmtblock_t body;
+  bool l_is_temp;
+  bool scalar_to_array;
+  tree string_length;
+  int n;
+
+  /* Assignment of the form lhs = rhs.  */
+  gfc_start_block (&block);
+
+  gfc_init_se (&lse, NULL);
+  gfc_init_se (&rse, NULL);
+
+  /* Walk the lhs.  */
+  lss = gfc_walk_expr (expr1);
+  if (gfc_is_reallocatable_lhs (expr1)
+	&& !(expr2->expr_type == EXPR_FUNCTION
+	     && expr2->value.function.isym != NULL))
+    lss->is_alloc_lhs = 1;
+  rss = NULL;
+  if (lss != gfc_ss_terminator)
+    {
+      /* The assignment needs scalarization.  */
+      lss_section = lss;
+
+      /* Find a non-scalar SS from the lhs.  */
+      while (lss_section != gfc_ss_terminator
+	     && lss_section->info->type != GFC_SS_SECTION)
+	lss_section = lss_section->next;
+
+      gcc_assert (lss_section != gfc_ss_terminator);
+
+      /* Initialize the scalarizer.  */
+      gfc_init_loopinfo (&loop);
+
+      /* Walk the rhs.  */
+      rss = gfc_walk_expr (expr2);
+      if (rss == gfc_ss_terminator)
+	/* The rhs is scalar.  Add a ss for the expression.  */
+	rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
+
+      /* Associate the SS with the loop.  */
+      gfc_add_ss_to_loop (&loop, lss);
+      gfc_add_ss_to_loop (&loop, rss);
+
+      /* Calculate the bounds of the scalarization.  */
+      gfc_conv_ss_startstride (&loop);
+      /* Enable loop reversal.  */
+      for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
+	loop.reverse[n] = GFC_ENABLE_REVERSE;
+      /* Resolve any data dependencies in the statement.  */
+      gfc_conv_resolve_dependencies (&loop, lss, rss);
+      /* Setup the scalarizing loops.  */
+      gfc_conv_loop_setup (&loop, &expr2->where);
+
+      /* Setup the gfc_se structures.  */
+      gfc_copy_loopinfo_to_se (&lse, &loop);
+      gfc_copy_loopinfo_to_se (&rse, &loop);
+
+      rse.ss = rss;
+      gfc_mark_ss_chain_used (rss, 1);
+      if (loop.temp_ss == NULL)
+	{
+	  lse.ss = lss;
+	  gfc_mark_ss_chain_used (lss, 1);
+	}
+      else
+	{
+	  lse.ss = loop.temp_ss;
+	  gfc_mark_ss_chain_used (lss, 3);
+	  gfc_mark_ss_chain_used (loop.temp_ss, 3);
+	}
+
+      /* Allow the scalarizer to workshare array assignments.  */
+      if ((ompws_flags & OMPWS_WORKSHARE_FLAG) && loop.temp_ss == NULL)
+	ompws_flags |= OMPWS_SCALARIZER_WS;
+
+      /* Start the scalarized loop body.  */
+      gfc_start_scalarized_body (&loop, &body);
+    }
+  else
+    gfc_init_block (&body);
+
+  l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
+
+  /* Translate the expression.  */
+  gfc_conv_expr (&rse, expr2);
+
+  /* Stabilize a string length for temporaries.  */
+  if (expr2->ts.type == BT_CHARACTER)
+    string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
+  else
+    string_length = NULL_TREE;
+
+  if (l_is_temp)
+    {
+      gfc_conv_tmp_array_ref (&lse);
+      if (expr2->ts.type == BT_CHARACTER)
+	lse.string_length = string_length;
+    }
+  else
+    gfc_conv_expr (&lse, expr1);
+
+  /* Assignments of scalar derived types with allocatable components
+     to arrays must be done with a deep copy and the rhs temporary
+     must have its components deallocated afterwards.  */
+  scalar_to_array = (expr2->ts.type == BT_DERIVED
+		       && expr2->ts.u.derived->attr.alloc_comp
+		       && !expr_is_variable (expr2)
+		       && !gfc_is_constant_expr (expr2)
+		       && expr1->rank && !expr2->rank);
+  if (scalar_to_array && dealloc)
+    {
+      tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
+      gfc_add_expr_to_block (&loop.post, tmp);
+    }
+
+  /* When assigning a character function result to a deferred-length variable,
+     the function call must happen before the (re)allocation of the lhs -
+     otherwise the character length of the result is not known.
+     NOTE: This relies on having the exact dependence of the length type
+     parameter available to the caller; gfortran saves it in the .mod files. */
+  if (gfc_option.flag_realloc_lhs && expr2->ts.type == BT_CHARACTER
+      && expr1->ts.deferred)
+    gfc_add_block_to_block (&block, &rse.pre);
+
+  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
+				 l_is_temp || init_flag,
+				 expr_is_variable (expr2) || scalar_to_array
+				 || expr2->expr_type == EXPR_ARRAY, dealloc);
+  gfc_add_expr_to_block (&body, tmp);
+
+  if (lss == gfc_ss_terminator)
+    {
+      /* F2003: Add the code for reallocation on assignment.  */
+      if (gfc_option.flag_realloc_lhs
+	  && is_scalar_reallocatable_lhs (expr1))
+	alloc_scalar_allocatable_for_assignment (&block, rse.string_length,
+						 expr1, expr2);
+
+      /* Use the scalar assignment as is.  */
+      gfc_add_block_to_block (&block, &body);
+    }
+  else
+    {
+      gcc_assert (lse.ss == gfc_ss_terminator
+		  && rse.ss == gfc_ss_terminator);
+
+      if (l_is_temp)
+	{
+	  gfc_trans_scalarized_loop_boundary (&loop, &body);
+
+	  /* We need to copy the temporary to the actual lhs.  */
+	  gfc_init_se (&lse, NULL);
+	  gfc_init_se (&rse, NULL);
+	  gfc_copy_loopinfo_to_se (&lse, &loop);
+	  gfc_copy_loopinfo_to_se (&rse, &loop);
+
+	  rse.ss = loop.temp_ss;
+	  lse.ss = lss;
+
+	  gfc_conv_tmp_array_ref (&rse);
+	  gfc_conv_expr (&lse, expr1);
+
+	  gcc_assert (lse.ss == gfc_ss_terminator
+		      && rse.ss == gfc_ss_terminator);
+
+	  if (expr2->ts.type == BT_CHARACTER)
+	    rse.string_length = string_length;
+
+	  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
+					 false, false, dealloc);
+	  gfc_add_expr_to_block (&body, tmp);
+	}
+
+      /* F2003: Allocate or reallocate lhs of allocatable array.  */
+      if (gfc_option.flag_realloc_lhs
+	    && gfc_is_reallocatable_lhs (expr1)
+	    && !gfc_expr_attr (expr1).codimension
+	    && !gfc_is_coindexed (expr1)
+	    && expr2->rank
+	    && !is_runtime_conformable (expr1, expr2))
+	{
+	  realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
+	  ompws_flags &= ~OMPWS_SCALARIZER_WS;
+	  tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
+	  if (tmp != NULL_TREE)
+	    gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
+	}
+
+      /* Generate the copying loops.  */
+      gfc_trans_scalarizing_loops (&loop, &body);
+
+      /* Wrap the whole thing up.  */
+      gfc_add_block_to_block (&block, &loop.pre);
+      gfc_add_block_to_block (&block, &loop.post);
+
+      gfc_cleanup_loop (&loop);
+    }
+
+  return gfc_finish_block (&block);
+}
+
+
+/* Check whether EXPR is a copyable array.  */
+
+static bool
+copyable_array_p (gfc_expr * expr)
+{
+  if (expr->expr_type != EXPR_VARIABLE)
+    return false;
+
+  /* First check it's an array.  */
+  if (expr->rank < 1 || !expr->ref || expr->ref->next)
+    return false;
+
+  if (!gfc_full_array_ref_p (expr->ref, NULL))
+    return false;
+
+  /* Next check that it's of a simple enough type.  */
+  switch (expr->ts.type)
+    {
+    case BT_INTEGER:
+    case BT_REAL:
+    case BT_COMPLEX:
+    case BT_LOGICAL:
+      return true;
+
+    case BT_CHARACTER:
+      return false;
+
+    case BT_DERIVED:
+      return !expr->ts.u.derived->attr.alloc_comp;
+
+    default:
+      break;
+    }
+
+  return false;
+}
+
+/* Translate an assignment.  */
+
+tree
+gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
+		      bool dealloc)
+{
+  tree tmp;
+
+  /* Special case a single function returning an array.  */
+  if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
+    {
+      tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
+      if (tmp)
+	return tmp;
+    }
+
+  /* Special case assigning an array to zero.  */
+  if (copyable_array_p (expr1)
+      && is_zero_initializer_p (expr2))
+    {
+      tmp = gfc_trans_zero_assign (expr1);
+      if (tmp)
+        return tmp;
+    }
+
+  /* Special case copying one array to another.  */
+  if (copyable_array_p (expr1)
+      && copyable_array_p (expr2)
+      && gfc_compare_types (&expr1->ts, &expr2->ts)
+      && !gfc_check_dependency (expr1, expr2, 0))
+    {
+      tmp = gfc_trans_array_copy (expr1, expr2);
+      if (tmp)
+        return tmp;
+    }
+
+  /* Special case initializing an array from a constant array constructor.  */
+  if (copyable_array_p (expr1)
+      && expr2->expr_type == EXPR_ARRAY
+      && gfc_compare_types (&expr1->ts, &expr2->ts))
+    {
+      tmp = gfc_trans_array_constructor_copy (expr1, expr2);
+      if (tmp)
+	return tmp;
+    }
+
+  /* Fallback to the scalarizer to generate explicit loops.  */
+  return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
+}
+
+tree
+gfc_trans_init_assign (gfc_code * code)
+{
+  return gfc_trans_assignment (code->expr1, code->expr2, true, false);
+}
+
+tree
+gfc_trans_assign (gfc_code * code)
+{
+  return gfc_trans_assignment (code->expr1, code->expr2, false, true);
+}
diff --git a/gcc-4.9/gcc/fortran/trans-intrinsic.c b/gcc-4.9/gcc/fortran/trans-intrinsic.c
new file mode 100644
index 000000000..e21d52fec
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/trans-intrinsic.c
@@ -0,0 +1,7821 @@
+/* Intrinsic translation
+   Copyright (C) 2002-2014 Free Software Foundation, Inc.
+   Contributed by Paul Brook <paul@nowt.org>
+   and Steven Bosscher <s.bosscher@student.tudelft.nl>
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+/* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "tm.h"		/* For UNITS_PER_WORD.  */
+#include "tree.h"
+#include "stringpool.h"
+#include "tree-nested.h"
+#include "stor-layout.h"
+#include "ggc.h"
+#include "diagnostic-core.h"	/* For internal_error.  */
+#include "toplev.h"	/* For rest_of_decl_compilation.  */
+#include "flags.h"
+#include "gfortran.h"
+#include "arith.h"
+#include "intrinsic.h"
+#include "trans.h"
+#include "trans-const.h"
+#include "trans-types.h"
+#include "trans-array.h"
+/* Only for gfc_trans_assign and gfc_trans_pointer_assign.  */
+#include "trans-stmt.h"
+#include "tree-nested.h"
+
+/* This maps Fortran intrinsic math functions to external library or GCC
+   builtin functions.  */
+typedef struct GTY(()) gfc_intrinsic_map_t {
+  /* The explicit enum is required to work around inadequacies in the
+     garbage collection/gengtype parsing mechanism.  */
+  enum gfc_isym_id id;
+
+  /* Enum value from the "language-independent", aka C-centric, part
+     of gcc, or END_BUILTINS of no such value set.  */
+  enum built_in_function float_built_in;
+  enum built_in_function double_built_in;
+  enum built_in_function long_double_built_in;
+  enum built_in_function complex_float_built_in;
+  enum built_in_function complex_double_built_in;
+  enum built_in_function complex_long_double_built_in;
+
+  /* True if the naming pattern is to prepend "c" for complex and
+     append "f" for kind=4.  False if the naming pattern is to
+     prepend "_gfortran_" and append "[rc](4|8|10|16)".  */
+  bool libm_name;
+
+  /* True if a complex version of the function exists.  */
+  bool complex_available;
+
+  /* True if the function should be marked const.  */
+  bool is_constant;
+
+  /* The base library name of this function.  */
+  const char *name;
+
+  /* Cache decls created for the various operand types.  */
+  tree real4_decl;
+  tree real8_decl;
+  tree real10_decl;
+  tree real16_decl;
+  tree complex4_decl;
+  tree complex8_decl;
+  tree complex10_decl;
+  tree complex16_decl;
+}
+gfc_intrinsic_map_t;
+
+/* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
+   defines complex variants of all of the entries in mathbuiltins.def
+   except for atan2.  */
+#define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
+  { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
+    BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
+    true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
+    NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
+
+#define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
+  { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
+    BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
+    BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
+    NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
+
+#define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
+  { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
+    END_BUILTINS, END_BUILTINS, END_BUILTINS, \
+    false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
+    NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
+
+#define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
+  { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
+    BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
+    true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
+    NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
+
+static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
+{
+  /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
+     DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
+     to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro.  */
+#include "mathbuiltins.def"
+
+  /* Functions in libgfortran.  */
+  LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false),
+
+  /* End the list.  */
+  LIB_FUNCTION (NONE, NULL, false)
+
+};
+#undef OTHER_BUILTIN
+#undef LIB_FUNCTION
+#undef DEFINE_MATH_BUILTIN
+#undef DEFINE_MATH_BUILTIN_C
+
+
+enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
+
+
+/* Find the correct variant of a given builtin from its argument.  */
+static tree
+builtin_decl_for_precision (enum built_in_function base_built_in,
+			    int precision)
+{
+  enum built_in_function i = END_BUILTINS;
+
+  gfc_intrinsic_map_t *m;
+  for (m = gfc_intrinsic_map; m->double_built_in != base_built_in ; m++)
+    ;
+
+  if (precision == TYPE_PRECISION (float_type_node))
+    i = m->float_built_in;
+  else if (precision == TYPE_PRECISION (double_type_node))
+    i = m->double_built_in;
+  else if (precision == TYPE_PRECISION (long_double_type_node))
+    i = m->long_double_built_in;
+  else if (precision == TYPE_PRECISION (float128_type_node))
+    {
+      /* Special treatment, because it is not exactly a built-in, but
+	 a library function.  */
+      return m->real16_decl;
+    }
+
+  return (i == END_BUILTINS ? NULL_TREE : builtin_decl_explicit (i));
+}
+
+
+tree
+gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in,
+				 int kind)
+{
+  int i = gfc_validate_kind (BT_REAL, kind, false);
+
+  if (gfc_real_kinds[i].c_float128)
+    {
+      /* For __float128, the story is a bit different, because we return
+	 a decl to a library function rather than a built-in.  */
+      gfc_intrinsic_map_t *m; 
+      for (m = gfc_intrinsic_map; m->double_built_in != double_built_in ; m++)
+	;
+
+      return m->real16_decl;
+    }
+
+  return builtin_decl_for_precision (double_built_in,
+				     gfc_real_kinds[i].mode_precision);
+}
+
+
+/* Evaluate the arguments to an intrinsic function.  The value
+   of NARGS may be less than the actual number of arguments in EXPR
+   to allow optional "KIND" arguments that are not included in the
+   generated code to be ignored.  */
+
+static void
+gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
+				  tree *argarray, int nargs)
+{
+  gfc_actual_arglist *actual;
+  gfc_expr *e;
+  gfc_intrinsic_arg  *formal;
+  gfc_se argse;
+  int curr_arg;
+
+  formal = expr->value.function.isym->formal;
+  actual = expr->value.function.actual;
+
+   for (curr_arg = 0; curr_arg < nargs; curr_arg++,
+	actual = actual->next,
+	formal = formal ? formal->next : NULL)
+    {
+      gcc_assert (actual);
+      e = actual->expr;
+      /* Skip omitted optional arguments.  */
+      if (!e)
+	{
+	  --curr_arg;
+	  continue;
+	}
+
+      /* Evaluate the parameter.  This will substitute scalarized
+         references automatically.  */
+      gfc_init_se (&argse, se);
+
+      if (e->ts.type == BT_CHARACTER)
+	{
+	  gfc_conv_expr (&argse, e);
+	  gfc_conv_string_parameter (&argse);
+          argarray[curr_arg++] = argse.string_length;
+	  gcc_assert (curr_arg < nargs);
+	}
+      else
+        gfc_conv_expr_val (&argse, e);
+
+      /* If an optional argument is itself an optional dummy argument,
+	 check its presence and substitute a null if absent.  */
+      if (e->expr_type == EXPR_VARIABLE
+	    && e->symtree->n.sym->attr.optional
+	    && formal
+	    && formal->optional)
+	gfc_conv_missing_dummy (&argse, e, formal->ts, 0);
+
+      gfc_add_block_to_block (&se->pre, &argse.pre);
+      gfc_add_block_to_block (&se->post, &argse.post);
+      argarray[curr_arg] = argse.expr;
+    }
+}
+
+/* Count the number of actual arguments to the intrinsic function EXPR
+   including any "hidden" string length arguments.  */
+
+static unsigned int
+gfc_intrinsic_argument_list_length (gfc_expr *expr)
+{
+  int n = 0;
+  gfc_actual_arglist *actual;
+
+  for (actual = expr->value.function.actual; actual; actual = actual->next)
+    {
+      if (!actual->expr)
+	continue;
+
+      if (actual->expr->ts.type == BT_CHARACTER)
+	n += 2;
+      else
+	n++;
+    }
+
+  return n;
+}
+
+
+/* Conversions between different types are output by the frontend as
+   intrinsic functions.  We implement these directly with inline code.  */
+
+static void
+gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
+{
+  tree type;
+  tree *args;
+  int nargs;
+
+  nargs = gfc_intrinsic_argument_list_length (expr);
+  args = XALLOCAVEC (tree, nargs);
+
+  /* Evaluate all the arguments passed. Whilst we're only interested in the 
+     first one here, there are other parts of the front-end that assume this 
+     and will trigger an ICE if it's not the case.  */
+  type = gfc_typenode_for_spec (&expr->ts);
+  gcc_assert (expr->value.function.actual->expr);
+  gfc_conv_intrinsic_function_args (se, expr, args, nargs);
+
+  /* Conversion between character kinds involves a call to a library
+     function.  */
+  if (expr->ts.type == BT_CHARACTER)
+    {
+      tree fndecl, var, addr, tmp;
+
+      if (expr->ts.kind == 1
+	  && expr->value.function.actual->expr->ts.kind == 4)
+	fndecl = gfor_fndecl_convert_char4_to_char1;
+      else if (expr->ts.kind == 4
+	       && expr->value.function.actual->expr->ts.kind == 1)
+	fndecl = gfor_fndecl_convert_char1_to_char4;
+      else
+	gcc_unreachable ();
+
+      /* Create the variable storing the converted value.  */
+      type = gfc_get_pchar_type (expr->ts.kind);
+      var = gfc_create_var (type, "str");
+      addr = gfc_build_addr_expr (build_pointer_type (type), var);
+
+      /* Call the library function that will perform the conversion.  */
+      gcc_assert (nargs >= 2);
+      tmp = build_call_expr_loc (input_location,
+			     fndecl, 3, addr, args[0], args[1]);
+      gfc_add_expr_to_block (&se->pre, tmp);
+
+      /* Free the temporary afterwards.  */
+      tmp = gfc_call_free (var);
+      gfc_add_expr_to_block (&se->post, tmp);
+
+      se->expr = var;
+      se->string_length = args[0];
+
+      return;
+    }
+
+  /* Conversion from complex to non-complex involves taking the real
+     component of the value.  */
+  if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
+      && expr->ts.type != BT_COMPLEX)
+    {
+      tree artype;
+
+      artype = TREE_TYPE (TREE_TYPE (args[0]));
+      args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
+				 args[0]);
+    }
+
+  se->expr = convert (type, args[0]);
+}
+
+/* This is needed because the gcc backend only implements
+   FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
+   FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
+   Similarly for CEILING.  */
+
+static tree
+build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
+{
+  tree tmp;
+  tree cond;
+  tree argtype;
+  tree intval;
+
+  argtype = TREE_TYPE (arg);
+  arg = gfc_evaluate_now (arg, pblock);
+
+  intval = convert (type, arg);
+  intval = gfc_evaluate_now (intval, pblock);
+
+  tmp = convert (argtype, intval);
+  cond = fold_build2_loc (input_location, up ? GE_EXPR : LE_EXPR,
+			  boolean_type_node, tmp, arg);
+
+  tmp = fold_build2_loc (input_location, up ? PLUS_EXPR : MINUS_EXPR, type,
+			 intval, build_int_cst (type, 1));
+  tmp = fold_build3_loc (input_location, COND_EXPR, type, cond, intval, tmp);
+  return tmp;
+}
+
+
+/* Round to nearest integer, away from zero.  */
+
+static tree
+build_round_expr (tree arg, tree restype)
+{
+  tree argtype;
+  tree fn;
+  int argprec, resprec;
+
+  argtype = TREE_TYPE (arg);
+  argprec = TYPE_PRECISION (argtype);
+  resprec = TYPE_PRECISION (restype);
+
+  /* Depending on the type of the result, choose the int intrinsic
+     (iround, available only as a builtin, therefore cannot use it for
+     __float128), long int intrinsic (lround family) or long long
+     intrinsic (llround).  We might also need to convert the result
+     afterwards.  */
+  if (resprec <= INT_TYPE_SIZE && argprec <= LONG_DOUBLE_TYPE_SIZE)
+    fn = builtin_decl_for_precision (BUILT_IN_IROUND, argprec);
+  else if (resprec <= LONG_TYPE_SIZE)
+    fn = builtin_decl_for_precision (BUILT_IN_LROUND, argprec);
+  else if (resprec <= LONG_LONG_TYPE_SIZE)
+    fn = builtin_decl_for_precision (BUILT_IN_LLROUND, argprec);
+  else
+    gcc_unreachable ();
+
+  return fold_convert (restype, build_call_expr_loc (input_location,
+						 fn, 1, arg));
+}
+
+
+/* Convert a real to an integer using a specific rounding mode.
+   Ideally we would just build the corresponding GENERIC node,
+   however the RTL expander only actually supports FIX_TRUNC_EXPR.  */
+
+static tree
+build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
+               enum rounding_mode op)
+{
+  switch (op)
+    {
+    case RND_FLOOR:
+      return build_fixbound_expr (pblock, arg, type, 0);
+      break;
+
+    case RND_CEIL:
+      return build_fixbound_expr (pblock, arg, type, 1);
+      break;
+
+    case RND_ROUND:
+      return build_round_expr (arg, type);
+      break;
+
+    case RND_TRUNC:
+      return fold_build1_loc (input_location, FIX_TRUNC_EXPR, type, arg);
+      break;
+
+    default:
+      gcc_unreachable ();
+    }
+}
+
+
+/* Round a real value using the specified rounding mode.
+   We use a temporary integer of that same kind size as the result.
+   Values larger than those that can be represented by this kind are
+   unchanged, as they will not be accurate enough to represent the
+   rounding.
+    huge = HUGE (KIND (a))
+    aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
+   */
+
+static void
+gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
+{
+  tree type;
+  tree itype;
+  tree arg[2];
+  tree tmp;
+  tree cond;
+  tree decl;
+  mpfr_t huge;
+  int n, nargs;
+  int kind;
+
+  kind = expr->ts.kind;
+  nargs = gfc_intrinsic_argument_list_length (expr);
+
+  decl = NULL_TREE;
+  /* We have builtin functions for some cases.  */
+  switch (op)
+    {
+    case RND_ROUND:
+      decl = gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND, kind);
+      break;
+
+    case RND_TRUNC:
+      decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, kind);
+      break;
+
+    default:
+      gcc_unreachable ();
+    }
+
+  /* Evaluate the argument.  */
+  gcc_assert (expr->value.function.actual->expr);
+  gfc_conv_intrinsic_function_args (se, expr, arg, nargs);
+
+  /* Use a builtin function if one exists.  */
+  if (decl != NULL_TREE)
+    {
+      se->expr = build_call_expr_loc (input_location, decl, 1, arg[0]);
+      return;
+    }
+
+  /* This code is probably redundant, but we'll keep it lying around just
+     in case.  */
+  type = gfc_typenode_for_spec (&expr->ts);
+  arg[0] = gfc_evaluate_now (arg[0], &se->pre);
+
+  /* Test if the value is too large to handle sensibly.  */
+  gfc_set_model_kind (kind);
+  mpfr_init (huge);
+  n = gfc_validate_kind (BT_INTEGER, kind, false);
+  mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
+  tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
+  cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, arg[0],
+			  tmp);
+
+  mpfr_neg (huge, huge, GFC_RND_MODE);
+  tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
+  tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, arg[0],
+			 tmp);
+  cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
+			  cond, tmp);
+  itype = gfc_get_int_type (kind);
+
+  tmp = build_fix_expr (&se->pre, arg[0], itype, op);
+  tmp = convert (type, tmp);
+  se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
+			      arg[0]);
+  mpfr_clear (huge);
+}
+
+
+/* Convert to an integer using the specified rounding mode.  */
+
+static void
+gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
+{
+  tree type;
+  tree *args;
+  int nargs;
+
+  nargs = gfc_intrinsic_argument_list_length (expr);
+  args = XALLOCAVEC (tree, nargs);
+
+  /* Evaluate the argument, we process all arguments even though we only 
+     use the first one for code generation purposes.  */
+  type = gfc_typenode_for_spec (&expr->ts);
+  gcc_assert (expr->value.function.actual->expr);
+  gfc_conv_intrinsic_function_args (se, expr, args, nargs);
+
+  if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
+    {
+      /* Conversion to a different integer kind.  */
+      se->expr = convert (type, args[0]);
+    }
+  else
+    {
+      /* Conversion from complex to non-complex involves taking the real
+         component of the value.  */
+      if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
+	  && expr->ts.type != BT_COMPLEX)
+	{
+	  tree artype;
+
+	  artype = TREE_TYPE (TREE_TYPE (args[0]));
+	  args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
+				     args[0]);
+	}
+
+      se->expr = build_fix_expr (&se->pre, args[0], type, op);
+    }
+}
+
+
+/* Get the imaginary component of a value.  */
+
+static void
+gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
+{
+  tree arg;
+
+  gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+  se->expr = fold_build1_loc (input_location, IMAGPART_EXPR,
+			      TREE_TYPE (TREE_TYPE (arg)), arg);
+}
+
+
+/* Get the complex conjugate of a value.  */
+
+static void
+gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
+{
+  tree arg;
+
+  gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+  se->expr = fold_build1_loc (input_location, CONJ_EXPR, TREE_TYPE (arg), arg);
+}
+
+
+
+static tree
+define_quad_builtin (const char *name, tree type, bool is_const)
+{
+  tree fndecl;
+  fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name),
+		       type);
+
+  /* Mark the decl as external.  */
+  DECL_EXTERNAL (fndecl) = 1;
+  TREE_PUBLIC (fndecl) = 1;
+
+  /* Mark it __attribute__((const)).  */
+  TREE_READONLY (fndecl) = is_const;
+
+  rest_of_decl_compilation (fndecl, 1, 0);
+
+  return fndecl;
+}
+
+
+
+/* Initialize function decls for library functions.  The external functions
+   are created as required.  Builtin functions are added here.  */
+
+void
+gfc_build_intrinsic_lib_fndecls (void)
+{
+  gfc_intrinsic_map_t *m;
+  tree quad_decls[END_BUILTINS + 1];
+
+  if (gfc_real16_is_float128)
+  {
+    /* If we have soft-float types, we create the decls for their
+       C99-like library functions.  For now, we only handle __float128
+       q-suffixed functions.  */
+
+    tree type, complex_type, func_1, func_2, func_cabs, func_frexp;
+    tree func_iround, func_lround, func_llround, func_scalbn, func_cpow;
+
+    memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1));
+
+    type = float128_type_node;
+    complex_type = complex_float128_type_node;
+    /* type (*) (type) */
+    func_1 = build_function_type_list (type, type, NULL_TREE);
+    /* int (*) (type) */
+    func_iround = build_function_type_list (integer_type_node,
+					    type, NULL_TREE);
+    /* long (*) (type) */
+    func_lround = build_function_type_list (long_integer_type_node,
+					    type, NULL_TREE);
+    /* long long (*) (type) */
+    func_llround = build_function_type_list (long_long_integer_type_node,
+					     type, NULL_TREE);
+    /* type (*) (type, type) */
+    func_2 = build_function_type_list (type, type, type, NULL_TREE);
+    /* type (*) (type, &int) */
+    func_frexp
+      = build_function_type_list (type,
+				  type,
+				  build_pointer_type (integer_type_node),
+				  NULL_TREE);
+    /* type (*) (type, int) */
+    func_scalbn = build_function_type_list (type,
+					    type, integer_type_node, NULL_TREE);
+    /* type (*) (complex type) */
+    func_cabs = build_function_type_list (type, complex_type, NULL_TREE);
+    /* complex type (*) (complex type, complex type) */
+    func_cpow
+      = build_function_type_list (complex_type,
+				  complex_type, complex_type, NULL_TREE);
+
+#define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
+#define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
+#define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
+
+    /* Only these built-ins are actually needed here. These are used directly
+       from the code, when calling builtin_decl_for_precision() or
+       builtin_decl_for_float_type(). The others are all constructed by
+       gfc_get_intrinsic_lib_fndecl().  */
+#define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
+  quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
+
+#include "mathbuiltins.def"
+
+#undef OTHER_BUILTIN
+#undef LIB_FUNCTION
+#undef DEFINE_MATH_BUILTIN
+#undef DEFINE_MATH_BUILTIN_C
+
+  }
+
+  /* Add GCC builtin functions.  */
+  for (m = gfc_intrinsic_map;
+       m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
+    {
+      if (m->float_built_in != END_BUILTINS)
+	m->real4_decl = builtin_decl_explicit (m->float_built_in);
+      if (m->complex_float_built_in != END_BUILTINS)
+	m->complex4_decl = builtin_decl_explicit (m->complex_float_built_in);
+      if (m->double_built_in != END_BUILTINS)
+	m->real8_decl = builtin_decl_explicit (m->double_built_in);
+      if (m->complex_double_built_in != END_BUILTINS)
+	m->complex8_decl = builtin_decl_explicit (m->complex_double_built_in);
+
+      /* If real(kind=10) exists, it is always long double.  */
+      if (m->long_double_built_in != END_BUILTINS)
+	m->real10_decl = builtin_decl_explicit (m->long_double_built_in);
+      if (m->complex_long_double_built_in != END_BUILTINS)
+	m->complex10_decl
+	  = builtin_decl_explicit (m->complex_long_double_built_in);
+
+      if (!gfc_real16_is_float128)
+	{
+	  if (m->long_double_built_in != END_BUILTINS)
+	    m->real16_decl = builtin_decl_explicit (m->long_double_built_in);
+	  if (m->complex_long_double_built_in != END_BUILTINS)
+	    m->complex16_decl
+	      = builtin_decl_explicit (m->complex_long_double_built_in);
+	}
+      else if (quad_decls[m->double_built_in] != NULL_TREE)
+        {
+	  /* Quad-precision function calls are constructed when first
+	     needed by builtin_decl_for_precision(), except for those
+	     that will be used directly (define by OTHER_BUILTIN).  */
+	  m->real16_decl = quad_decls[m->double_built_in];
+	}
+      else if (quad_decls[m->complex_double_built_in] != NULL_TREE)
+        {
+	  /* Same thing for the complex ones.  */
+	  m->complex16_decl = quad_decls[m->double_built_in];
+	}
+    }
+}
+
+
+/* Create a fndecl for a simple intrinsic library function.  */
+
+static tree
+gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
+{
+  tree type;
+  vec<tree, va_gc> *argtypes;
+  tree fndecl;
+  gfc_actual_arglist *actual;
+  tree *pdecl;
+  gfc_typespec *ts;
+  char name[GFC_MAX_SYMBOL_LEN + 3];
+
+  ts = &expr->ts;
+  if (ts->type == BT_REAL)
+    {
+      switch (ts->kind)
+	{
+	case 4:
+	  pdecl = &m->real4_decl;
+	  break;
+	case 8:
+	  pdecl = &m->real8_decl;
+	  break;
+	case 10:
+	  pdecl = &m->real10_decl;
+	  break;
+	case 16:
+	  pdecl = &m->real16_decl;
+	  break;
+	default:
+	  gcc_unreachable ();
+	}
+    }
+  else if (ts->type == BT_COMPLEX)
+    {
+      gcc_assert (m->complex_available);
+
+      switch (ts->kind)
+	{
+	case 4:
+	  pdecl = &m->complex4_decl;
+	  break;
+	case 8:
+	  pdecl = &m->complex8_decl;
+	  break;
+	case 10:
+	  pdecl = &m->complex10_decl;
+	  break;
+	case 16:
+	  pdecl = &m->complex16_decl;
+	  break;
+	default:
+	  gcc_unreachable ();
+	}
+    }
+  else
+    gcc_unreachable ();
+
+  if (*pdecl)
+    return *pdecl;
+
+  if (m->libm_name)
+    {
+      int n = gfc_validate_kind (BT_REAL, ts->kind, false);
+      if (gfc_real_kinds[n].c_float)
+	snprintf (name, sizeof (name), "%s%s%s",
+		  ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
+      else if (gfc_real_kinds[n].c_double)
+	snprintf (name, sizeof (name), "%s%s",
+		  ts->type == BT_COMPLEX ? "c" : "", m->name);
+      else if (gfc_real_kinds[n].c_long_double)
+	snprintf (name, sizeof (name), "%s%s%s",
+		  ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
+      else if (gfc_real_kinds[n].c_float128)
+	snprintf (name, sizeof (name), "%s%s%s",
+		  ts->type == BT_COMPLEX ? "c" : "", m->name, "q");
+      else
+	gcc_unreachable ();
+    }
+  else
+    {
+      snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
+		ts->type == BT_COMPLEX ? 'c' : 'r',
+		ts->kind);
+    }
+
+  argtypes = NULL;
+  for (actual = expr->value.function.actual; actual; actual = actual->next)
+    {
+      type = gfc_typenode_for_spec (&actual->expr->ts);
+      vec_safe_push (argtypes, type);
+    }
+  type = build_function_type_vec (gfc_typenode_for_spec (ts), argtypes);
+  fndecl = build_decl (input_location,
+		       FUNCTION_DECL, get_identifier (name), type);
+
+  /* Mark the decl as external.  */
+  DECL_EXTERNAL (fndecl) = 1;
+  TREE_PUBLIC (fndecl) = 1;
+
+  /* Mark it __attribute__((const)), if possible.  */
+  TREE_READONLY (fndecl) = m->is_constant;
+
+  rest_of_decl_compilation (fndecl, 1, 0);
+
+  (*pdecl) = fndecl;
+  return fndecl;
+}
+
+
+/* Convert an intrinsic function into an external or builtin call.  */
+
+static void
+gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
+{
+  gfc_intrinsic_map_t *m;
+  tree fndecl;
+  tree rettype;
+  tree *args;
+  unsigned int num_args;
+  gfc_isym_id id;
+
+  id = expr->value.function.isym->id;
+  /* Find the entry for this function.  */
+  for (m = gfc_intrinsic_map;
+       m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
+    {
+      if (id == m->id)
+	break;
+    }
+
+  if (m->id == GFC_ISYM_NONE)
+    {
+      internal_error ("Intrinsic function %s(%d) not recognized",
+		      expr->value.function.name, id);
+    }
+
+  /* Get the decl and generate the call.  */
+  num_args = gfc_intrinsic_argument_list_length (expr);
+  args = XALLOCAVEC (tree, num_args);
+
+  gfc_conv_intrinsic_function_args (se, expr, args, num_args);
+  fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
+  rettype = TREE_TYPE (TREE_TYPE (fndecl));
+
+  fndecl = build_addr (fndecl, current_function_decl);
+  se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
+}
+
+
+/* If bounds-checking is enabled, create code to verify at runtime that the
+   string lengths for both expressions are the same (needed for e.g. MERGE).
+   If bounds-checking is not enabled, does nothing.  */
+
+void
+gfc_trans_same_strlen_check (const char* intr_name, locus* where,
+			     tree a, tree b, stmtblock_t* target)
+{
+  tree cond;
+  tree name;
+
+  /* If bounds-checking is disabled, do nothing.  */
+  if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
+    return;
+
+  /* Compare the two string lengths.  */
+  cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, a, b);
+
+  /* Output the runtime-check.  */
+  name = gfc_build_cstring_const (intr_name);
+  name = gfc_build_addr_expr (pchar_type_node, name);
+  gfc_trans_runtime_check (true, false, cond, target, where,
+			   "Unequal character lengths (%ld/%ld) in %s",
+			   fold_convert (long_integer_type_node, a),
+			   fold_convert (long_integer_type_node, b), name);
+}
+
+
+/* The EXPONENT(s) intrinsic function is translated into
+       int ret;
+       frexp (s, &ret);
+       return ret;
+ */
+
+static void
+gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
+{
+  tree arg, type, res, tmp, frexp;
+
+  frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP,
+				       expr->value.function.actual->expr->ts.kind);
+
+  gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+
+  res = gfc_create_var (integer_type_node, NULL);
+  tmp = build_call_expr_loc (input_location, frexp, 2, arg,
+			     gfc_build_addr_expr (NULL_TREE, res));
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  type = gfc_typenode_for_spec (&expr->ts);
+  se->expr = fold_convert (type, res);
+}
+
+
+static void
+trans_this_image (gfc_se * se, gfc_expr *expr)
+{
+  stmtblock_t loop;
+  tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var,
+       lbound, ubound, extent, ml;
+  gfc_se argse;
+  int rank, corank;
+
+  /* The case -fcoarray=single is handled elsewhere.  */
+  gcc_assert (gfc_option.coarray != GFC_FCOARRAY_SINGLE);
+
+  gfc_init_coarray_decl (false);
+
+  /* Argument-free version: THIS_IMAGE().  */
+  if (expr->value.function.actual->expr == NULL)
+    {
+      se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
+			       gfort_gvar_caf_this_image);
+      return;
+    }
+
+  /* Coarray-argument version: THIS_IMAGE(coarray [, dim]).  */
+
+  type = gfc_get_int_type (gfc_default_integer_kind);
+  corank = gfc_get_corank (expr->value.function.actual->expr);
+  rank = expr->value.function.actual->expr->rank;
+
+  /* Obtain the descriptor of the COARRAY.  */
+  gfc_init_se (&argse, NULL);
+  argse.want_coarray = 1;
+  gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
+  gfc_add_block_to_block (&se->pre, &argse.pre);
+  gfc_add_block_to_block (&se->post, &argse.post);
+  desc = argse.expr;
+
+  if (se->ss)
+    {
+      /* Create an implicit second parameter from the loop variable.  */
+      gcc_assert (!expr->value.function.actual->next->expr);
+      gcc_assert (corank > 0);
+      gcc_assert (se->loop->dimen == 1);
+      gcc_assert (se->ss->info->expr == expr);
+
+      dim_arg = se->loop->loopvar[0];
+      dim_arg = fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type, dim_arg,
+				 build_int_cst (TREE_TYPE (dim_arg), 1));
+      gfc_advance_se_ss_chain (se);
+    }
+  else
+    {
+      /* Use the passed DIM= argument.  */
+      gcc_assert (expr->value.function.actual->next->expr);
+      gfc_init_se (&argse, NULL);
+      gfc_conv_expr_type (&argse, expr->value.function.actual->next->expr,
+			  gfc_array_index_type);
+      gfc_add_block_to_block (&se->pre, &argse.pre);
+      dim_arg = argse.expr;
+
+      if (INTEGER_CST_P (dim_arg))
+	{
+	  int hi, co_dim;
+
+	  hi = TREE_INT_CST_HIGH (dim_arg);
+	  co_dim = TREE_INT_CST_LOW (dim_arg);
+	  if (hi || co_dim < 1
+	      || co_dim > GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc)))
+	    gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
+		       "dimension index", expr->value.function.isym->name,
+		       &expr->where);
+	}
+     else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+	{
+	  dim_arg = gfc_evaluate_now (dim_arg, &se->pre);
+	  cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+				  dim_arg,
+				  build_int_cst (TREE_TYPE (dim_arg), 1));
+	  tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
+	  tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+				 dim_arg, tmp);
+	  cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
+				  boolean_type_node, cond, tmp);
+	  gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
+			           gfc_msg_fault);
+	}
+    }
+
+  /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
+     one always has a dim_arg argument.
+
+     m = this_image() - 1
+     if (corank == 1)
+       {
+	 sub(1) = m + lcobound(corank)
+	 return;
+       }
+     i = rank
+     min_var = min (rank + corank - 2, rank + dim_arg - 1)
+     for (;;)
+       {
+	 extent = gfc_extent(i)
+	 ml = m
+	 m  = m/extent
+	 if (i >= min_var) 
+	   goto exit_label
+	 i++
+       }
+     exit_label:
+     sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
+				       : m + lcobound(corank)
+  */
+
+  /* this_image () - 1.  */
+  tmp = fold_convert (type, gfort_gvar_caf_this_image);
+  tmp = fold_build2_loc (input_location, MINUS_EXPR, type, tmp,
+		       build_int_cst (type, 1));
+  if (corank == 1)
+    {
+      /* sub(1) = m + lcobound(corank).  */
+      lbound = gfc_conv_descriptor_lbound_get (desc,
+			build_int_cst (TREE_TYPE (gfc_array_index_type),
+				       corank+rank-1));
+      lbound = fold_convert (type, lbound);
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
+
+      se->expr = tmp;
+      return;
+    }
+
+  m = gfc_create_var (type, NULL); 
+  ml = gfc_create_var (type, NULL); 
+  loop_var = gfc_create_var (integer_type_node, NULL); 
+  min_var = gfc_create_var (integer_type_node, NULL); 
+
+  /* m = this_image () - 1.  */
+  gfc_add_modify (&se->pre, m, tmp);
+
+  /* min_var = min (rank + corank-2, rank + dim_arg - 1).  */
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
+			 fold_convert (integer_type_node, dim_arg),
+			 build_int_cst (integer_type_node, rank - 1));
+  tmp = fold_build2_loc (input_location, MIN_EXPR, integer_type_node,
+			 build_int_cst (integer_type_node, rank + corank - 2),
+			 tmp);
+  gfc_add_modify (&se->pre, min_var, tmp);
+
+  /* i = rank.  */
+  tmp = build_int_cst (integer_type_node, rank);
+  gfc_add_modify (&se->pre, loop_var, tmp);
+
+  exit_label = gfc_build_label_decl (NULL_TREE);
+  TREE_USED (exit_label) = 1;
+
+  /* Loop body.  */
+  gfc_init_block (&loop);
+
+  /* ml = m.  */
+  gfc_add_modify (&loop, ml, m);
+
+  /* extent = ...  */
+  lbound = gfc_conv_descriptor_lbound_get (desc, loop_var);
+  ubound = gfc_conv_descriptor_ubound_get (desc, loop_var);
+  extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+  extent = fold_convert (type, extent);
+
+  /* m = m/extent.  */
+  gfc_add_modify (&loop, m, 
+		  fold_build2_loc (input_location, TRUNC_DIV_EXPR, type,
+			  m, extent));
+
+  /* Exit condition:  if (i >= min_var) goto exit_label.  */
+  cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, loop_var,
+		  min_var);
+  tmp = build1_v (GOTO_EXPR, exit_label);
+  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
+                         build_empty_stmt (input_location));
+  gfc_add_expr_to_block (&loop, tmp);
+
+  /* Increment loop variable: i++.  */
+  gfc_add_modify (&loop, loop_var,
+                  fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
+				   loop_var,
+				   build_int_cst (integer_type_node, 1)));
+
+  /* Making the loop... actually loop!  */
+  tmp = gfc_finish_block (&loop);
+  tmp = build1_v (LOOP_EXPR, tmp);
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  /* The exit label.  */
+  tmp = build1_v (LABEL_EXPR, exit_label);
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  /*  sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
+				      : m + lcobound(corank) */
+
+  cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, dim_arg,
+			  build_int_cst (TREE_TYPE (dim_arg), corank));
+
+  lbound = gfc_conv_descriptor_lbound_get (desc,
+		fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type, dim_arg,
+				 build_int_cst (TREE_TYPE (dim_arg), rank-1)));
+  lbound = fold_convert (type, lbound);
+
+  tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml,
+			 fold_build2_loc (input_location, MULT_EXPR, type,
+					  m, extent));
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
+
+  se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
+			      fold_build2_loc (input_location, PLUS_EXPR, type,
+					       m, lbound));
+}
+
+
+static void
+trans_image_index (gfc_se * se, gfc_expr *expr)
+{
+  tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc,
+       tmp, invalid_bound;
+  gfc_se argse, subse;
+  int rank, corank, codim;
+
+  type = gfc_get_int_type (gfc_default_integer_kind);
+  corank = gfc_get_corank (expr->value.function.actual->expr);
+  rank = expr->value.function.actual->expr->rank;
+
+  /* Obtain the descriptor of the COARRAY.  */
+  gfc_init_se (&argse, NULL);
+  argse.want_coarray = 1;
+  gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
+  gfc_add_block_to_block (&se->pre, &argse.pre);
+  gfc_add_block_to_block (&se->post, &argse.post);
+  desc = argse.expr;
+
+  /* Obtain a handle to the SUB argument.  */
+  gfc_init_se (&subse, NULL);
+  gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr);
+  gfc_add_block_to_block (&se->pre, &subse.pre);
+  gfc_add_block_to_block (&se->post, &subse.post);
+  subdesc = build_fold_indirect_ref_loc (input_location,
+			gfc_conv_descriptor_data_get (subse.expr));
+
+  /* Fortran 2008 does not require that the values remain in the cobounds,
+     thus we need explicitly check this - and return 0 if they are exceeded.  */
+
+  lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
+  tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL);
+  invalid_bound = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+				 fold_convert (gfc_array_index_type, tmp),
+				 lbound);
+
+  for (codim = corank + rank - 2; codim >= rank; codim--)
+    {
+      lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
+      ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
+      tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
+      cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+			      fold_convert (gfc_array_index_type, tmp),
+			      lbound);
+      invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+				       boolean_type_node, invalid_bound, cond);
+      cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+			      fold_convert (gfc_array_index_type, tmp),
+			      ubound);
+      invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+				       boolean_type_node, invalid_bound, cond);
+    }
+
+  invalid_bound = gfc_unlikely (invalid_bound, PRED_FORTRAN_INVALID_BOUND);
+
+  /* See Fortran 2008, C.10 for the following algorithm.  */
+
+  /* coindex = sub(corank) - lcobound(n).  */
+  coindex = fold_convert (gfc_array_index_type,
+			  gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1],
+					       NULL));
+  lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
+  coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			     fold_convert (gfc_array_index_type, coindex),
+			     lbound);
+
+  for (codim = corank + rank - 2; codim >= rank; codim--)
+    {
+      tree extent, ubound;
+
+      /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim).  */
+      lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
+      ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
+      extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+
+      /* coindex *= extent.  */
+      coindex = fold_build2_loc (input_location, MULT_EXPR,
+				 gfc_array_index_type, coindex, extent);
+
+      /* coindex += sub(codim).  */
+      tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
+      coindex = fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type, coindex,
+				 fold_convert (gfc_array_index_type, tmp));
+
+      /* coindex -= lbound(codim).  */
+      lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
+      coindex = fold_build2_loc (input_location, MINUS_EXPR,
+				 gfc_array_index_type, coindex, lbound);
+    }
+
+  coindex = fold_build2_loc (input_location, PLUS_EXPR, type,
+			     fold_convert(type, coindex),
+			     build_int_cst (type, 1));
+
+  /* Return 0 if "coindex" exceeds num_images().  */
+
+  if (gfc_option.coarray == GFC_FCOARRAY_SINGLE)
+    num_images = build_int_cst (type, 1);
+  else
+    {
+      gfc_init_coarray_decl (false);
+      num_images = fold_convert (type, gfort_gvar_caf_num_images);
+    }
+
+  tmp = gfc_create_var (type, NULL);
+  gfc_add_modify (&se->pre, tmp, coindex);
+
+  cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp,
+			  num_images);
+  cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
+			  cond,
+			  fold_convert (boolean_type_node, invalid_bound));
+  se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
+			      build_int_cst (type, 0), tmp);
+}
+
+
+static void
+trans_num_images (gfc_se * se)
+{
+  gfc_init_coarray_decl (false);
+  se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
+			   gfort_gvar_caf_num_images);
+}
+
+
+static void
+gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr)
+{
+  gfc_se argse;
+
+  gfc_init_se (&argse, NULL);
+  argse.data_not_needed = 1;
+  argse.descriptor_only = 1;
+
+  gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
+  gfc_add_block_to_block (&se->pre, &argse.pre);
+  gfc_add_block_to_block (&se->post, &argse.post);
+
+  se->expr = gfc_conv_descriptor_rank (argse.expr);
+}
+
+
+/* Evaluate a single upper or lower bound.  */
+/* TODO: bound intrinsic generates way too much unnecessary code.  */
+
+static void
+gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
+{
+  gfc_actual_arglist *arg;
+  gfc_actual_arglist *arg2;
+  tree desc;
+  tree type;
+  tree bound;
+  tree tmp;
+  tree cond, cond1, cond3, cond4, size;
+  tree ubound;
+  tree lbound;
+  gfc_se argse;
+  gfc_array_spec * as;
+  bool assumed_rank_lb_one;
+
+  arg = expr->value.function.actual;
+  arg2 = arg->next;
+
+  if (se->ss)
+    {
+      /* Create an implicit second parameter from the loop variable.  */
+      gcc_assert (!arg2->expr);
+      gcc_assert (se->loop->dimen == 1);
+      gcc_assert (se->ss->info->expr == expr);
+      gfc_advance_se_ss_chain (se);
+      bound = se->loop->loopvar[0];
+      bound = fold_build2_loc (input_location, MINUS_EXPR,
+			       gfc_array_index_type, bound,
+			       se->loop->from[0]);
+    }
+  else
+    {
+      /* use the passed argument.  */
+      gcc_assert (arg2->expr);
+      gfc_init_se (&argse, NULL);
+      gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
+      gfc_add_block_to_block (&se->pre, &argse.pre);
+      bound = argse.expr;
+      /* Convert from one based to zero based.  */
+      bound = fold_build2_loc (input_location, MINUS_EXPR,
+			       gfc_array_index_type, bound,
+			       gfc_index_one_node);
+    }
+
+  /* TODO: don't re-evaluate the descriptor on each iteration.  */
+  /* Get a descriptor for the first parameter.  */
+  gfc_init_se (&argse, NULL);
+  gfc_conv_expr_descriptor (&argse, arg->expr);
+  gfc_add_block_to_block (&se->pre, &argse.pre);
+  gfc_add_block_to_block (&se->post, &argse.post);
+
+  desc = argse.expr;
+
+  as = gfc_get_full_arrayspec_from_expr (arg->expr);
+
+  if (INTEGER_CST_P (bound))
+    {
+      int hi, low;
+
+      hi = TREE_INT_CST_HIGH (bound);
+      low = TREE_INT_CST_LOW (bound);
+      if (hi || low < 0
+	  || ((!as || as->type != AS_ASSUMED_RANK)
+	      && low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
+	  || low > GFC_MAX_DIMENSIONS)
+	gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
+		   "dimension index", upper ? "UBOUND" : "LBOUND",
+		   &expr->where);
+    }
+
+  if (!INTEGER_CST_P (bound) || (as && as->type == AS_ASSUMED_RANK))
+    {
+      if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+        {
+          bound = gfc_evaluate_now (bound, &se->pre);
+          cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+				  bound, build_int_cst (TREE_TYPE (bound), 0));
+	  if (as && as->type == AS_ASSUMED_RANK)
+	    tmp = gfc_conv_descriptor_rank (desc);
+	  else
+	    tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
+          tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
+				 bound, fold_convert(TREE_TYPE (bound), tmp));
+          cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
+				  boolean_type_node, cond, tmp);
+          gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
+				   gfc_msg_fault);
+        }
+    }
+
+  /* Take care of the lbound shift for assumed-rank arrays, which are
+     nonallocatable and nonpointers. Those has a lbound of 1.  */
+  assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK
+			&& ((arg->expr->ts.type != BT_CLASS
+			     && !arg->expr->symtree->n.sym->attr.allocatable
+			     && !arg->expr->symtree->n.sym->attr.pointer)
+			    || (arg->expr->ts.type == BT_CLASS
+			     && !CLASS_DATA (arg->expr)->attr.allocatable
+			     && !CLASS_DATA (arg->expr)->attr.class_pointer));
+
+  ubound = gfc_conv_descriptor_ubound_get (desc, bound);
+  lbound = gfc_conv_descriptor_lbound_get (desc, bound);
+  
+  /* 13.14.53: Result value for LBOUND
+
+     Case (i): For an array section or for an array expression other than a
+               whole array or array structure component, LBOUND(ARRAY, DIM)
+               has the value 1.  For a whole array or array structure
+               component, LBOUND(ARRAY, DIM) has the value:
+                 (a) equal to the lower bound for subscript DIM of ARRAY if
+                     dimension DIM of ARRAY does not have extent zero
+                     or if ARRAY is an assumed-size array of rank DIM,
+              or (b) 1 otherwise.
+
+     13.14.113: Result value for UBOUND
+
+     Case (i): For an array section or for an array expression other than a
+               whole array or array structure component, UBOUND(ARRAY, DIM)
+               has the value equal to the number of elements in the given
+               dimension; otherwise, it has a value equal to the upper bound
+               for subscript DIM of ARRAY if dimension DIM of ARRAY does
+               not have size zero and has value zero if dimension DIM has
+               size zero.  */
+
+  if (!upper && assumed_rank_lb_one)
+    se->expr = gfc_index_one_node;
+  else if (as)
+    {
+      tree stride = gfc_conv_descriptor_stride_get (desc, bound);
+
+      cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
+			       ubound, lbound);
+      cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
+			       stride, gfc_index_zero_node);
+      cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+			       boolean_type_node, cond3, cond1);
+      cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+			       stride, gfc_index_zero_node);
+
+      if (upper)
+	{
+	  tree cond5;
+	  cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+				  boolean_type_node, cond3, cond4);
+	  cond5 = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+				   gfc_index_one_node, lbound);
+	  cond5 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+				   boolean_type_node, cond4, cond5);
+
+	  cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+				  boolean_type_node, cond, cond5);
+
+	  if (assumed_rank_lb_one)
+	    {
+	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+			       gfc_array_index_type, ubound, lbound);
+	      tmp = fold_build2_loc (input_location, PLUS_EXPR,
+			       gfc_array_index_type, tmp, gfc_index_one_node);
+	    }
+          else
+            tmp = ubound;
+
+	  se->expr = fold_build3_loc (input_location, COND_EXPR,
+				      gfc_array_index_type, cond,
+				      tmp, gfc_index_zero_node);
+	}
+      else
+	{
+	  if (as->type == AS_ASSUMED_SIZE)
+	    cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+				    bound, build_int_cst (TREE_TYPE (bound),
+							  arg->expr->rank - 1));
+	  else
+	    cond = boolean_false_node;
+
+	  cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+				   boolean_type_node, cond3, cond4);
+	  cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+				  boolean_type_node, cond, cond1);
+
+	  se->expr = fold_build3_loc (input_location, COND_EXPR,
+				      gfc_array_index_type, cond,
+				      lbound, gfc_index_one_node);
+	}
+    }
+  else
+    {
+      if (upper)
+        {
+	  size = fold_build2_loc (input_location, MINUS_EXPR,
+				  gfc_array_index_type, ubound, lbound);
+	  se->expr = fold_build2_loc (input_location, PLUS_EXPR,
+				      gfc_array_index_type, size,
+				  gfc_index_one_node);
+	  se->expr = fold_build2_loc (input_location, MAX_EXPR,
+				      gfc_array_index_type, se->expr,
+				      gfc_index_zero_node);
+	}
+      else
+	se->expr = gfc_index_one_node;
+    }
+
+  type = gfc_typenode_for_spec (&expr->ts);
+  se->expr = convert (type, se->expr);
+}
+
+
+static void
+conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
+{
+  gfc_actual_arglist *arg;
+  gfc_actual_arglist *arg2;
+  gfc_se argse;
+  tree bound, resbound, resbound2, desc, cond, tmp;
+  tree type;
+  int corank;
+
+  gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND
+	      || expr->value.function.isym->id == GFC_ISYM_UCOBOUND
+	      || expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE);
+
+  arg = expr->value.function.actual;
+  arg2 = arg->next;
+
+  gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
+  corank = gfc_get_corank (arg->expr);
+
+  gfc_init_se (&argse, NULL);
+  argse.want_coarray = 1;
+
+  gfc_conv_expr_descriptor (&argse, arg->expr);
+  gfc_add_block_to_block (&se->pre, &argse.pre);
+  gfc_add_block_to_block (&se->post, &argse.post);
+  desc = argse.expr;
+
+  if (se->ss)
+    {
+      /* Create an implicit second parameter from the loop variable.  */
+      gcc_assert (!arg2->expr);
+      gcc_assert (corank > 0);
+      gcc_assert (se->loop->dimen == 1);
+      gcc_assert (se->ss->info->expr == expr);
+
+      bound = se->loop->loopvar[0];
+      bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			       bound, gfc_rank_cst[arg->expr->rank]);
+      gfc_advance_se_ss_chain (se);
+    }
+  else
+    {
+      /* use the passed argument.  */
+      gcc_assert (arg2->expr);
+      gfc_init_se (&argse, NULL);
+      gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
+      gfc_add_block_to_block (&se->pre, &argse.pre);
+      bound = argse.expr;
+
+      if (INTEGER_CST_P (bound))
+	{
+	  int hi, low;
+
+	  hi = TREE_INT_CST_HIGH (bound);
+	  low = TREE_INT_CST_LOW (bound);
+	  if (hi || low < 1 || low > GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc)))
+	    gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
+		       "dimension index", expr->value.function.isym->name,
+		       &expr->where);
+	}
+      else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+        {
+	  bound = gfc_evaluate_now (bound, &se->pre);
+	  cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+				  bound, build_int_cst (TREE_TYPE (bound), 1));
+	  tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
+	  tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+				 bound, tmp);
+	  cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
+				  boolean_type_node, cond, tmp);
+	  gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
+				   gfc_msg_fault);
+	}
+
+
+      /* Subtract 1 to get to zero based and add dimensions.  */
+      switch (arg->expr->rank)
+	{
+	case 0:
+	  bound = fold_build2_loc (input_location, MINUS_EXPR,
+				   gfc_array_index_type, bound,
+				   gfc_index_one_node);
+	case 1:
+	  break;
+	default:
+	  bound = fold_build2_loc (input_location, PLUS_EXPR,
+				   gfc_array_index_type, bound,
+				   gfc_rank_cst[arg->expr->rank - 1]);
+	}
+    }
+
+  resbound = gfc_conv_descriptor_lbound_get (desc, bound);
+
+  /* Handle UCOBOUND with special handling of the last codimension.  */
+  if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND)
+    {
+      /* Last codimension: For -fcoarray=single just return
+	 the lcobound - otherwise add
+	   ceiling (real (num_images ()) / real (size)) - 1
+	 = (num_images () + size - 1) / size - 1
+	 = (num_images - 1) / size(),
+         where size is the product of the extent of all but the last
+	 codimension.  */
+
+      if (gfc_option.coarray != GFC_FCOARRAY_SINGLE && corank > 1)
+	{
+          tree cosize;
+
+	  gfc_init_coarray_decl (false);
+	  cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank);
+
+	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				 gfc_array_index_type,
+				 fold_convert (gfc_array_index_type,
+					       gfort_gvar_caf_num_images),
+				 build_int_cst (gfc_array_index_type, 1));
+	  tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+				 gfc_array_index_type, tmp,
+				 fold_convert (gfc_array_index_type, cosize));
+	  resbound = fold_build2_loc (input_location, PLUS_EXPR,
+				      gfc_array_index_type, resbound, tmp);
+	}
+      else if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
+	{
+	  /* ubound = lbound + num_images() - 1.  */
+	  gfc_init_coarray_decl (false);
+	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				 gfc_array_index_type,
+				 fold_convert (gfc_array_index_type,
+					       gfort_gvar_caf_num_images),
+				 build_int_cst (gfc_array_index_type, 1));
+	  resbound = fold_build2_loc (input_location, PLUS_EXPR,
+				      gfc_array_index_type, resbound, tmp);
+	}
+
+      if (corank > 1)
+	{
+	  cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+				  bound,
+				  build_int_cst (TREE_TYPE (bound),
+						 arg->expr->rank + corank - 1));
+
+	  resbound2 = gfc_conv_descriptor_ubound_get (desc, bound);
+	  se->expr = fold_build3_loc (input_location, COND_EXPR,
+				      gfc_array_index_type, cond,
+				      resbound, resbound2);
+	}
+      else
+	se->expr = resbound;
+    }
+  else
+    se->expr = resbound;
+
+  type = gfc_typenode_for_spec (&expr->ts);
+  se->expr = convert (type, se->expr);
+}
+
+
+static void
+conv_intrinsic_stride (gfc_se * se, gfc_expr * expr)
+{
+  gfc_actual_arglist *array_arg;
+  gfc_actual_arglist *dim_arg;
+  gfc_se argse;
+  tree desc, tmp;
+
+  array_arg = expr->value.function.actual;
+  dim_arg = array_arg->next;
+
+  gcc_assert (array_arg->expr->expr_type == EXPR_VARIABLE);
+
+  gfc_init_se (&argse, NULL);
+  gfc_conv_expr_descriptor (&argse, array_arg->expr);
+  gfc_add_block_to_block (&se->pre, &argse.pre);
+  gfc_add_block_to_block (&se->post, &argse.post);
+  desc = argse.expr;
+
+  gcc_assert (dim_arg->expr);
+  gfc_init_se (&argse, NULL);
+  gfc_conv_expr_type (&argse, dim_arg->expr, gfc_array_index_type);
+  gfc_add_block_to_block (&se->pre, &argse.pre);
+  tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			 argse.expr, gfc_index_one_node);
+  se->expr = gfc_conv_descriptor_stride_get (desc, tmp);
+}
+
+
+static void
+gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
+{
+  tree arg, cabs;
+
+  gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+
+  switch (expr->value.function.actual->expr->ts.type)
+    {
+    case BT_INTEGER:
+    case BT_REAL:
+      se->expr = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (arg),
+				  arg);
+      break;
+
+    case BT_COMPLEX:
+      cabs = gfc_builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind);
+      se->expr = build_call_expr_loc (input_location, cabs, 1, arg);
+      break;
+
+    default:
+      gcc_unreachable ();
+    }
+}
+
+
+/* Create a complex value from one or two real components.  */
+
+static void
+gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
+{
+  tree real;
+  tree imag;
+  tree type;
+  tree *args;
+  unsigned int num_args;
+
+  num_args = gfc_intrinsic_argument_list_length (expr);
+  args = XALLOCAVEC (tree, num_args);
+
+  type = gfc_typenode_for_spec (&expr->ts);
+  gfc_conv_intrinsic_function_args (se, expr, args, num_args);
+  real = convert (TREE_TYPE (type), args[0]);
+  if (both)
+    imag = convert (TREE_TYPE (type), args[1]);
+  else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
+    {
+      imag = fold_build1_loc (input_location, IMAGPART_EXPR,
+			      TREE_TYPE (TREE_TYPE (args[0])), args[0]);
+      imag = convert (TREE_TYPE (type), imag);
+    }
+  else
+    imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
+
+  se->expr = fold_build2_loc (input_location, COMPLEX_EXPR, type, real, imag);
+}
+
+
+/* Remainder function MOD(A, P) = A - INT(A / P) * P
+                      MODULO(A, P) = A - FLOOR (A / P) * P  
+
+   The obvious algorithms above are numerically instable for large
+   arguments, hence these intrinsics are instead implemented via calls
+   to the fmod family of functions.  It is the responsibility of the
+   user to ensure that the second argument is non-zero.  */
+
+static void
+gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
+{
+  tree type;
+  tree tmp;
+  tree test;
+  tree test2;
+  tree fmod;
+  tree zero;
+  tree args[2];
+
+  gfc_conv_intrinsic_function_args (se, expr, args, 2);
+
+  switch (expr->ts.type)
+    {
+    case BT_INTEGER:
+      /* Integer case is easy, we've got a builtin op.  */
+      type = TREE_TYPE (args[0]);
+
+      if (modulo)
+       se->expr = fold_build2_loc (input_location, FLOOR_MOD_EXPR, type,
+				   args[0], args[1]);
+      else
+       se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
+				   args[0], args[1]);
+      break;
+
+    case BT_REAL:
+      fmod = NULL_TREE;
+      /* Check if we have a builtin fmod.  */
+      fmod = gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind);
+
+      /* The builtin should always be available.  */
+      gcc_assert (fmod != NULL_TREE);
+
+      tmp = build_addr (fmod, current_function_decl);
+      se->expr = build_call_array_loc (input_location,
+				       TREE_TYPE (TREE_TYPE (fmod)),
+                                       tmp, 2, args);
+      if (modulo == 0)
+	return;
+
+      type = TREE_TYPE (args[0]);
+
+      args[0] = gfc_evaluate_now (args[0], &se->pre);
+      args[1] = gfc_evaluate_now (args[1], &se->pre);
+
+      /* Definition:
+	 modulo = arg - floor (arg/arg2) * arg2
+
+	 In order to calculate the result accurately, we use the fmod
+	 function as follows.
+	 
+	 res = fmod (arg, arg2);
+	 if (res)
+	   {
+	     if ((arg < 0) xor (arg2 < 0))
+	       res += arg2;
+	   }
+	 else
+	   res = copysign (0., arg2);
+
+	 => As two nested ternary exprs:
+
+	 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res) 
+	       : copysign (0., arg2);
+
+      */
+
+      zero = gfc_build_const (type, integer_zero_node);
+      tmp = gfc_evaluate_now (se->expr, &se->pre);
+      if (!flag_signed_zeros)
+	{
+	  test = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+				  args[0], zero);
+	  test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+				   args[1], zero);
+	  test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
+				   boolean_type_node, test, test2);
+	  test = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+				  tmp, zero);
+	  test = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+				  boolean_type_node, test, test2);
+	  test = gfc_evaluate_now (test, &se->pre);
+	  se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
+				      fold_build2_loc (input_location, 
+						       PLUS_EXPR,
+						       type, tmp, args[1]), 
+				      tmp);
+	}
+      else
+	{
+	  tree expr1, copysign, cscall;
+	  copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, 
+						      expr->ts.kind);
+	  test = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+				  args[0], zero);
+	  test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+				   args[1], zero);
+	  test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
+				   boolean_type_node, test, test2);
+	  expr1 = fold_build3_loc (input_location, COND_EXPR, type, test2,
+				   fold_build2_loc (input_location, 
+						    PLUS_EXPR,
+						    type, tmp, args[1]), 
+				   tmp);
+	  test = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+				  tmp, zero);
+	  cscall = build_call_expr_loc (input_location, copysign, 2, zero, 
+					args[1]);
+	  se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
+				      expr1, cscall);
+	}
+      return;
+
+    default:
+      gcc_unreachable ();
+    }
+}
+
+/* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
+   DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
+   where the right shifts are logical (i.e. 0's are shifted in).
+   Because SHIFT_EXPR's want shifts strictly smaller than the integral
+   type width, we have to special-case both S == 0 and S == BITSIZE(J):
+     DSHIFTL(I,J,0) = I
+     DSHIFTL(I,J,BITSIZE) = J
+     DSHIFTR(I,J,0) = J
+     DSHIFTR(I,J,BITSIZE) = I.  */
+
+static void
+gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl)
+{
+  tree type, utype, stype, arg1, arg2, shift, res, left, right;
+  tree args[3], cond, tmp;
+  int bitsize;
+
+  gfc_conv_intrinsic_function_args (se, expr, args, 3);
+
+  gcc_assert (TREE_TYPE (args[0]) == TREE_TYPE (args[1]));
+  type = TREE_TYPE (args[0]);
+  bitsize = TYPE_PRECISION (type);
+  utype = unsigned_type_for (type);
+  stype = TREE_TYPE (args[2]);
+
+  arg1 = gfc_evaluate_now (args[0], &se->pre);
+  arg2 = gfc_evaluate_now (args[1], &se->pre);
+  shift = gfc_evaluate_now (args[2], &se->pre);
+
+  /* The generic case.  */
+  tmp = fold_build2_loc (input_location, MINUS_EXPR, stype,
+			 build_int_cst (stype, bitsize), shift);
+  left = fold_build2_loc (input_location, LSHIFT_EXPR, type,
+			  arg1, dshiftl ? shift : tmp);
+
+  right = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
+			   fold_convert (utype, arg2), dshiftl ? tmp : shift);
+  right = fold_convert (type, right);
+
+  res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right);
+
+  /* Special cases.  */
+  cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, shift,
+			  build_int_cst (stype, 0));
+  res = fold_build3_loc (input_location, COND_EXPR, type, cond,
+			 dshiftl ? arg1 : arg2, res);
+
+  cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, shift,
+			  build_int_cst (stype, bitsize));
+  res = fold_build3_loc (input_location, COND_EXPR, type, cond,
+			 dshiftl ? arg2 : arg1, res);
+
+  se->expr = res;
+}
+
+
+/* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y.  */
+
+static void
+gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
+{
+  tree val;
+  tree tmp;
+  tree type;
+  tree zero;
+  tree args[2];
+
+  gfc_conv_intrinsic_function_args (se, expr, args, 2);
+  type = TREE_TYPE (args[0]);
+
+  val = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], args[1]);
+  val = gfc_evaluate_now (val, &se->pre);
+
+  zero = gfc_build_const (type, integer_zero_node);
+  tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, val, zero);
+  se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, zero, val);
+}
+
+
+/* SIGN(A, B) is absolute value of A times sign of B.
+   The real value versions use library functions to ensure the correct
+   handling of negative zero.  Integer case implemented as:
+   SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
+  */
+
+static void
+gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
+{
+  tree tmp;
+  tree type;
+  tree args[2];
+
+  gfc_conv_intrinsic_function_args (se, expr, args, 2);
+  if (expr->ts.type == BT_REAL)
+    {
+      tree abs;
+
+      tmp = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
+      abs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
+
+      /* We explicitly have to ignore the minus sign. We do so by using
+	 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1).  */
+      if (!gfc_option.flag_sign_zero
+	  && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
+	{
+	  tree cond, zero;
+	  zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
+	  cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+				  args[1], zero);
+	  se->expr = fold_build3_loc (input_location, COND_EXPR,
+				  TREE_TYPE (args[0]), cond,
+				  build_call_expr_loc (input_location, abs, 1,
+						       args[0]),
+				  build_call_expr_loc (input_location, tmp, 2,
+						       args[0], args[1]));
+	}
+      else
+        se->expr = build_call_expr_loc (input_location, tmp, 2,
+					args[0], args[1]);
+      return;
+    }
+
+  /* Having excluded floating point types, we know we are now dealing
+     with signed integer types.  */
+  type = TREE_TYPE (args[0]);
+
+  /* Args[0] is used multiple times below.  */
+  args[0] = gfc_evaluate_now (args[0], &se->pre);
+
+  /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
+     the signs of A and B are the same, and of all ones if they differ.  */
+  tmp = fold_build2_loc (input_location, BIT_XOR_EXPR, type, args[0], args[1]);
+  tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, tmp,
+			 build_int_cst (type, TYPE_PRECISION (type) - 1));
+  tmp = gfc_evaluate_now (tmp, &se->pre);
+
+  /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
+     is all ones (i.e. -1).  */
+  se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, type,
+			      fold_build2_loc (input_location, PLUS_EXPR,
+					       type, args[0], tmp), tmp);
+}
+
+
+/* Test for the presence of an optional argument.  */
+
+static void
+gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
+{
+  gfc_expr *arg;
+
+  arg = expr->value.function.actual->expr;
+  gcc_assert (arg->expr_type == EXPR_VARIABLE);
+  se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
+  se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
+}
+
+
+/* Calculate the double precision product of two single precision values.  */
+
+static void
+gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
+{
+  tree type;
+  tree args[2];
+
+  gfc_conv_intrinsic_function_args (se, expr, args, 2);
+
+  /* Convert the args to double precision before multiplying.  */
+  type = gfc_typenode_for_spec (&expr->ts);
+  args[0] = convert (type, args[0]);
+  args[1] = convert (type, args[1]);
+  se->expr = fold_build2_loc (input_location, MULT_EXPR, type, args[0],
+			      args[1]);
+}
+
+
+/* Return a length one character string containing an ascii character.  */
+
+static void
+gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
+{
+  tree arg[2];
+  tree var;
+  tree type;
+  unsigned int num_args;
+
+  num_args = gfc_intrinsic_argument_list_length (expr);
+  gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
+
+  type = gfc_get_char_type (expr->ts.kind);
+  var = gfc_create_var (type, "char");
+
+  arg[0] = fold_build1_loc (input_location, NOP_EXPR, type, arg[0]);
+  gfc_add_modify (&se->pre, var, arg[0]);
+  se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
+  se->string_length = build_int_cst (gfc_charlen_type_node, 1);
+}
+
+
+static void
+gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
+{
+  tree var;
+  tree len;
+  tree tmp;
+  tree cond;
+  tree fndecl;
+  tree *args;
+  unsigned int num_args;
+
+  num_args = gfc_intrinsic_argument_list_length (expr) + 2;
+  args = XALLOCAVEC (tree, num_args);
+
+  var = gfc_create_var (pchar_type_node, "pstr");
+  len = gfc_create_var (gfc_charlen_type_node, "len");
+
+  gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
+  args[0] = gfc_build_addr_expr (NULL_TREE, var);
+  args[1] = gfc_build_addr_expr (NULL_TREE, len);
+
+  fndecl = build_addr (gfor_fndecl_ctime, current_function_decl);
+  tmp = build_call_array_loc (input_location,
+			  TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
+			  fndecl, num_args, args);
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  /* Free the temporary afterwards, if necessary.  */
+  cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+			  len, build_int_cst (TREE_TYPE (len), 0));
+  tmp = gfc_call_free (var);
+  tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
+  gfc_add_expr_to_block (&se->post, tmp);
+
+  se->expr = var;
+  se->string_length = len;
+}
+
+
+static void
+gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
+{
+  tree var;
+  tree len;
+  tree tmp;
+  tree cond;
+  tree fndecl;
+  tree *args;
+  unsigned int num_args;
+
+  num_args = gfc_intrinsic_argument_list_length (expr) + 2;
+  args = XALLOCAVEC (tree, num_args);
+
+  var = gfc_create_var (pchar_type_node, "pstr");
+  len = gfc_create_var (gfc_charlen_type_node, "len");
+
+  gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
+  args[0] = gfc_build_addr_expr (NULL_TREE, var);
+  args[1] = gfc_build_addr_expr (NULL_TREE, len);
+
+  fndecl = build_addr (gfor_fndecl_fdate, current_function_decl);
+  tmp = build_call_array_loc (input_location,
+			  TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
+			  fndecl, num_args, args);
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  /* Free the temporary afterwards, if necessary.  */
+  cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+			  len, build_int_cst (TREE_TYPE (len), 0));
+  tmp = gfc_call_free (var);
+  tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
+  gfc_add_expr_to_block (&se->post, tmp);
+
+  se->expr = var;
+  se->string_length = len;
+}
+
+
+/* Return a character string containing the tty name.  */
+
+static void
+gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
+{
+  tree var;
+  tree len;
+  tree tmp;
+  tree cond;
+  tree fndecl;
+  tree *args;
+  unsigned int num_args;
+
+  num_args = gfc_intrinsic_argument_list_length (expr) + 2;
+  args = XALLOCAVEC (tree, num_args);
+
+  var = gfc_create_var (pchar_type_node, "pstr");
+  len = gfc_create_var (gfc_charlen_type_node, "len");
+
+  gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
+  args[0] = gfc_build_addr_expr (NULL_TREE, var);
+  args[1] = gfc_build_addr_expr (NULL_TREE, len);
+
+  fndecl = build_addr (gfor_fndecl_ttynam, current_function_decl);
+  tmp = build_call_array_loc (input_location,
+			  TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
+			  fndecl, num_args, args);
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  /* Free the temporary afterwards, if necessary.  */
+  cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+			  len, build_int_cst (TREE_TYPE (len), 0));
+  tmp = gfc_call_free (var);
+  tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
+  gfc_add_expr_to_block (&se->post, tmp);
+
+  se->expr = var;
+  se->string_length = len;
+}
+
+
+/* Get the minimum/maximum value of all the parameters.
+    minmax (a1, a2, a3, ...)
+    {
+      mvar = a1;
+      if (a2 .op. mvar || isnan (mvar))
+        mvar = a2;
+      if (a3 .op. mvar || isnan (mvar))
+        mvar = a3;
+      ...
+      return mvar
+    }
+ */
+
+/* TODO: Mismatching types can occur when specific names are used.
+   These should be handled during resolution.  */
+static void
+gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
+{
+  tree tmp;
+  tree mvar;
+  tree val;
+  tree thencase;
+  tree *args;
+  tree type;
+  gfc_actual_arglist *argexpr;
+  unsigned int i, nargs;
+
+  nargs = gfc_intrinsic_argument_list_length (expr);
+  args = XALLOCAVEC (tree, nargs);
+
+  gfc_conv_intrinsic_function_args (se, expr, args, nargs);
+  type = gfc_typenode_for_spec (&expr->ts);
+
+  argexpr = expr->value.function.actual;
+  if (TREE_TYPE (args[0]) != type)
+    args[0] = convert (type, args[0]);
+  /* Only evaluate the argument once.  */
+  if (TREE_CODE (args[0]) != VAR_DECL && !TREE_CONSTANT (args[0]))
+    args[0] = gfc_evaluate_now (args[0], &se->pre);
+
+  mvar = gfc_create_var (type, "M");
+  gfc_add_modify (&se->pre, mvar, args[0]);
+  for (i = 1, argexpr = argexpr->next; i < nargs; i++)
+    {
+      tree cond, isnan;
+
+      val = args[i]; 
+
+      /* Handle absent optional arguments by ignoring the comparison.  */
+      if (argexpr->expr->expr_type == EXPR_VARIABLE
+	  && argexpr->expr->symtree->n.sym->attr.optional
+	  && TREE_CODE (val) == INDIRECT_REF)
+	cond = fold_build2_loc (input_location,
+				NE_EXPR, boolean_type_node,
+				TREE_OPERAND (val, 0), 
+			build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
+      else
+      {
+	cond = NULL_TREE;
+
+	/* Only evaluate the argument once.  */
+	if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
+	  val = gfc_evaluate_now (val, &se->pre);
+      }
+
+      thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
+
+      tmp = fold_build2_loc (input_location, op, boolean_type_node,
+			     convert (type, val), mvar);
+
+      /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
+	 __builtin_isnan might be made dependent on that module being loaded,
+	 to help performance of programs that don't rely on IEEE semantics.  */
+      if (FLOAT_TYPE_P (TREE_TYPE (mvar)))
+	{
+	  isnan = build_call_expr_loc (input_location,
+				       builtin_decl_explicit (BUILT_IN_ISNAN),
+				       1, mvar);
+	  tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+				 boolean_type_node, tmp,
+				 fold_convert (boolean_type_node, isnan));
+	}
+      tmp = build3_v (COND_EXPR, tmp, thencase,
+		      build_empty_stmt (input_location));
+
+      if (cond != NULL_TREE)
+	tmp = build3_v (COND_EXPR, cond, tmp,
+			build_empty_stmt (input_location));
+
+      gfc_add_expr_to_block (&se->pre, tmp);
+      argexpr = argexpr->next;
+    }
+  se->expr = mvar;
+}
+
+
+/* Generate library calls for MIN and MAX intrinsics for character
+   variables.  */
+static void
+gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
+{
+  tree *args;
+  tree var, len, fndecl, tmp, cond, function;
+  unsigned int nargs;
+
+  nargs = gfc_intrinsic_argument_list_length (expr);
+  args = XALLOCAVEC (tree, nargs + 4);
+  gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
+
+  /* Create the result variables.  */
+  len = gfc_create_var (gfc_charlen_type_node, "len");
+  args[0] = gfc_build_addr_expr (NULL_TREE, len);
+  var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
+  args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
+  args[2] = build_int_cst (integer_type_node, op);
+  args[3] = build_int_cst (integer_type_node, nargs / 2);
+
+  if (expr->ts.kind == 1)
+    function = gfor_fndecl_string_minmax;
+  else if (expr->ts.kind == 4)
+    function = gfor_fndecl_string_minmax_char4;
+  else
+    gcc_unreachable ();
+
+  /* Make the function call.  */
+  fndecl = build_addr (function, current_function_decl);
+  tmp = build_call_array_loc (input_location,
+			  TREE_TYPE (TREE_TYPE (function)), fndecl,
+			  nargs + 4, args);
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  /* Free the temporary afterwards, if necessary.  */
+  cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+			  len, build_int_cst (TREE_TYPE (len), 0));
+  tmp = gfc_call_free (var);
+  tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
+  gfc_add_expr_to_block (&se->post, tmp);
+
+  se->expr = var;
+  se->string_length = len;
+}
+
+
+/* Create a symbol node for this intrinsic.  The symbol from the frontend
+   has the generic name.  */
+
+static gfc_symbol *
+gfc_get_symbol_for_expr (gfc_expr * expr)
+{
+  gfc_symbol *sym;
+
+  /* TODO: Add symbols for intrinsic function to the global namespace.  */
+  gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
+  sym = gfc_new_symbol (expr->value.function.name, NULL);
+
+  sym->ts = expr->ts;
+  sym->attr.external = 1;
+  sym->attr.function = 1;
+  sym->attr.always_explicit = 1;
+  sym->attr.proc = PROC_INTRINSIC;
+  sym->attr.flavor = FL_PROCEDURE;
+  sym->result = sym;
+  if (expr->rank > 0)
+    {
+      sym->attr.dimension = 1;
+      sym->as = gfc_get_array_spec ();
+      sym->as->type = AS_ASSUMED_SHAPE;
+      sym->as->rank = expr->rank;
+    }
+
+  gfc_copy_formal_args_intr (sym, expr->value.function.isym);
+
+  return sym;
+}
+
+/* Generate a call to an external intrinsic function.  */
+static void
+gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
+{
+  gfc_symbol *sym;
+  vec<tree, va_gc> *append_args;
+
+  gcc_assert (!se->ss || se->ss->info->expr == expr);
+
+  if (se->ss)
+    gcc_assert (expr->rank > 0);
+  else
+    gcc_assert (expr->rank == 0);
+
+  sym = gfc_get_symbol_for_expr (expr);
+
+  /* Calls to libgfortran_matmul need to be appended special arguments,
+     to be able to call the BLAS ?gemm functions if required and possible.  */
+  append_args = NULL;
+  if (expr->value.function.isym->id == GFC_ISYM_MATMUL
+      && sym->ts.type != BT_LOGICAL)
+    {
+      tree cint = gfc_get_int_type (gfc_c_int_kind);
+
+      if (gfc_option.flag_external_blas
+	  && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
+	  && (sym->ts.kind == 4 || sym->ts.kind == 8))
+	{
+	  tree gemm_fndecl;
+
+	  if (sym->ts.type == BT_REAL)
+	    {
+	      if (sym->ts.kind == 4)
+		gemm_fndecl = gfor_fndecl_sgemm;
+	      else
+		gemm_fndecl = gfor_fndecl_dgemm;
+	    }
+	  else
+	    {
+	      if (sym->ts.kind == 4)
+		gemm_fndecl = gfor_fndecl_cgemm;
+	      else
+		gemm_fndecl = gfor_fndecl_zgemm;
+	    }
+
+	  vec_alloc (append_args, 3);
+	  append_args->quick_push (build_int_cst (cint, 1));
+	  append_args->quick_push (build_int_cst (cint,
+		                                 gfc_option.blas_matmul_limit));
+	  append_args->quick_push (gfc_build_addr_expr (NULL_TREE,
+							gemm_fndecl));
+	}
+      else
+	{
+	  vec_alloc (append_args, 3);
+	  append_args->quick_push (build_int_cst (cint, 0));
+	  append_args->quick_push (build_int_cst (cint, 0));
+	  append_args->quick_push (null_pointer_node);
+	}
+    }
+
+  gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
+			  append_args);
+  gfc_free_symbol (sym);
+}
+
+/* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
+   Implemented as
+    any(a)
+    {
+      forall (i=...)
+        if (a[i] != 0)
+          return 1
+      end forall
+      return 0
+    }
+    all(a)
+    {
+      forall (i=...)
+        if (a[i] == 0)
+          return 0
+      end forall
+      return 1
+    }
+ */
+static void
+gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
+{
+  tree resvar;
+  stmtblock_t block;
+  stmtblock_t body;
+  tree type;
+  tree tmp;
+  tree found;
+  gfc_loopinfo loop;
+  gfc_actual_arglist *actual;
+  gfc_ss *arrayss;
+  gfc_se arrayse;
+  tree exit_label;
+
+  if (se->ss)
+    {
+      gfc_conv_intrinsic_funcall (se, expr);
+      return;
+    }
+
+  actual = expr->value.function.actual;
+  type = gfc_typenode_for_spec (&expr->ts);
+  /* Initialize the result.  */
+  resvar = gfc_create_var (type, "test");
+  if (op == EQ_EXPR)
+    tmp = convert (type, boolean_true_node);
+  else
+    tmp = convert (type, boolean_false_node);
+  gfc_add_modify (&se->pre, resvar, tmp);
+
+  /* Walk the arguments.  */
+  arrayss = gfc_walk_expr (actual->expr);
+  gcc_assert (arrayss != gfc_ss_terminator);
+
+  /* Initialize the scalarizer.  */
+  gfc_init_loopinfo (&loop);
+  exit_label = gfc_build_label_decl (NULL_TREE);
+  TREE_USED (exit_label) = 1;
+  gfc_add_ss_to_loop (&loop, arrayss);
+
+  /* Initialize the loop.  */
+  gfc_conv_ss_startstride (&loop);
+  gfc_conv_loop_setup (&loop, &expr->where);
+
+  gfc_mark_ss_chain_used (arrayss, 1);
+  /* Generate the loop body.  */
+  gfc_start_scalarized_body (&loop, &body);
+
+  /* If the condition matches then set the return value.  */
+  gfc_start_block (&block);
+  if (op == EQ_EXPR)
+    tmp = convert (type, boolean_false_node);
+  else
+    tmp = convert (type, boolean_true_node);
+  gfc_add_modify (&block, resvar, tmp);
+
+  /* And break out of the loop.  */
+  tmp = build1_v (GOTO_EXPR, exit_label);
+  gfc_add_expr_to_block (&block, tmp);
+
+  found = gfc_finish_block (&block);
+
+  /* Check this element.  */
+  gfc_init_se (&arrayse, NULL);
+  gfc_copy_loopinfo_to_se (&arrayse, &loop);
+  arrayse.ss = arrayss;
+  gfc_conv_expr_val (&arrayse, actual->expr);
+
+  gfc_add_block_to_block (&body, &arrayse.pre);
+  tmp = fold_build2_loc (input_location, op, boolean_type_node, arrayse.expr,
+			 build_int_cst (TREE_TYPE (arrayse.expr), 0));
+  tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
+  gfc_add_expr_to_block (&body, tmp);
+  gfc_add_block_to_block (&body, &arrayse.post);
+
+  gfc_trans_scalarizing_loops (&loop, &body);
+
+  /* Add the exit label.  */
+  tmp = build1_v (LABEL_EXPR, exit_label);
+  gfc_add_expr_to_block (&loop.pre, tmp);
+
+  gfc_add_block_to_block (&se->pre, &loop.pre);
+  gfc_add_block_to_block (&se->pre, &loop.post);
+  gfc_cleanup_loop (&loop);
+
+  se->expr = resvar;
+}
+
+/* COUNT(A) = Number of true elements in A.  */
+static void
+gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
+{
+  tree resvar;
+  tree type;
+  stmtblock_t body;
+  tree tmp;
+  gfc_loopinfo loop;
+  gfc_actual_arglist *actual;
+  gfc_ss *arrayss;
+  gfc_se arrayse;
+
+  if (se->ss)
+    {
+      gfc_conv_intrinsic_funcall (se, expr);
+      return;
+    }
+
+  actual = expr->value.function.actual;
+
+  type = gfc_typenode_for_spec (&expr->ts);
+  /* Initialize the result.  */
+  resvar = gfc_create_var (type, "count");
+  gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
+
+  /* Walk the arguments.  */
+  arrayss = gfc_walk_expr (actual->expr);
+  gcc_assert (arrayss != gfc_ss_terminator);
+
+  /* Initialize the scalarizer.  */
+  gfc_init_loopinfo (&loop);
+  gfc_add_ss_to_loop (&loop, arrayss);
+
+  /* Initialize the loop.  */
+  gfc_conv_ss_startstride (&loop);
+  gfc_conv_loop_setup (&loop, &expr->where);
+
+  gfc_mark_ss_chain_used (arrayss, 1);
+  /* Generate the loop body.  */
+  gfc_start_scalarized_body (&loop, &body);
+
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (resvar),
+			 resvar, build_int_cst (TREE_TYPE (resvar), 1));
+  tmp = build2_v (MODIFY_EXPR, resvar, tmp);
+
+  gfc_init_se (&arrayse, NULL);
+  gfc_copy_loopinfo_to_se (&arrayse, &loop);
+  arrayse.ss = arrayss;
+  gfc_conv_expr_val (&arrayse, actual->expr);
+  tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
+		  build_empty_stmt (input_location));
+
+  gfc_add_block_to_block (&body, &arrayse.pre);
+  gfc_add_expr_to_block (&body, tmp);
+  gfc_add_block_to_block (&body, &arrayse.post);
+
+  gfc_trans_scalarizing_loops (&loop, &body);
+
+  gfc_add_block_to_block (&se->pre, &loop.pre);
+  gfc_add_block_to_block (&se->pre, &loop.post);
+  gfc_cleanup_loop (&loop);
+
+  se->expr = resvar;
+}
+
+
+/* Update given gfc_se to have ss component pointing to the nested gfc_ss
+   struct and return the corresponding loopinfo.  */
+
+static gfc_loopinfo *
+enter_nested_loop (gfc_se *se)
+{
+  se->ss = se->ss->nested_ss;
+  gcc_assert (se->ss == se->ss->loop->ss);
+
+  return se->ss->loop;
+}
+
+
+/* Inline implementation of the sum and product intrinsics.  */
+static void
+gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
+			  bool norm2)
+{
+  tree resvar;
+  tree scale = NULL_TREE;
+  tree type;
+  stmtblock_t body;
+  stmtblock_t block;
+  tree tmp;
+  gfc_loopinfo loop, *ploop;
+  gfc_actual_arglist *arg_array, *arg_mask;
+  gfc_ss *arrayss = NULL;
+  gfc_ss *maskss = NULL;
+  gfc_se arrayse;
+  gfc_se maskse;
+  gfc_se *parent_se;
+  gfc_expr *arrayexpr;
+  gfc_expr *maskexpr;
+
+  if (expr->rank > 0)
+    {
+      gcc_assert (gfc_inline_intrinsic_function_p (expr));
+      parent_se = se;
+    }
+  else
+    parent_se = NULL;
+
+  type = gfc_typenode_for_spec (&expr->ts);
+  /* Initialize the result.  */
+  resvar = gfc_create_var (type, "val");
+  if (norm2)
+    {
+      /* result = 0.0;
+	 scale = 1.0.  */
+      scale = gfc_create_var (type, "scale");
+      gfc_add_modify (&se->pre, scale,
+		      gfc_build_const (type, integer_one_node));
+      tmp = gfc_build_const (type, integer_zero_node);
+    }
+  else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR)
+    tmp = gfc_build_const (type, integer_zero_node);
+  else if (op == NE_EXPR)
+    /* PARITY.  */
+    tmp = convert (type, boolean_false_node);
+  else if (op == BIT_AND_EXPR)
+    tmp = gfc_build_const (type, fold_build1_loc (input_location, NEGATE_EXPR,
+						  type, integer_one_node));
+  else
+    tmp = gfc_build_const (type, integer_one_node);
+
+  gfc_add_modify (&se->pre, resvar, tmp);
+
+  arg_array = expr->value.function.actual;
+
+  arrayexpr = arg_array->expr;
+
+  if (op == NE_EXPR || norm2)
+    /* PARITY and NORM2.  */
+    maskexpr = NULL;
+  else
+    {
+      arg_mask  = arg_array->next->next;
+      gcc_assert (arg_mask != NULL);
+      maskexpr = arg_mask->expr;
+    }
+
+  if (expr->rank == 0)
+    {
+      /* Walk the arguments.  */
+      arrayss = gfc_walk_expr (arrayexpr);
+      gcc_assert (arrayss != gfc_ss_terminator);
+
+      if (maskexpr && maskexpr->rank > 0)
+	{
+	  maskss = gfc_walk_expr (maskexpr);
+	  gcc_assert (maskss != gfc_ss_terminator);
+	}
+      else
+	maskss = NULL;
+
+      /* Initialize the scalarizer.  */
+      gfc_init_loopinfo (&loop);
+      gfc_add_ss_to_loop (&loop, arrayss);
+      if (maskexpr && maskexpr->rank > 0)
+	gfc_add_ss_to_loop (&loop, maskss);
+
+      /* Initialize the loop.  */
+      gfc_conv_ss_startstride (&loop);
+      gfc_conv_loop_setup (&loop, &expr->where);
+
+      gfc_mark_ss_chain_used (arrayss, 1);
+      if (maskexpr && maskexpr->rank > 0)
+	gfc_mark_ss_chain_used (maskss, 1);
+
+      ploop = &loop;
+    }
+  else
+    /* All the work has been done in the parent loops.  */
+    ploop = enter_nested_loop (se);
+
+  gcc_assert (ploop);
+
+  /* Generate the loop body.  */
+  gfc_start_scalarized_body (ploop, &body);
+
+  /* If we have a mask, only add this element if the mask is set.  */
+  if (maskexpr && maskexpr->rank > 0)
+    {
+      gfc_init_se (&maskse, parent_se);
+      gfc_copy_loopinfo_to_se (&maskse, ploop);
+      if (expr->rank == 0)
+	maskse.ss = maskss;
+      gfc_conv_expr_val (&maskse, maskexpr);
+      gfc_add_block_to_block (&body, &maskse.pre);
+
+      gfc_start_block (&block);
+    }
+  else
+    gfc_init_block (&block);
+
+  /* Do the actual summation/product.  */
+  gfc_init_se (&arrayse, parent_se);
+  gfc_copy_loopinfo_to_se (&arrayse, ploop);
+  if (expr->rank == 0)
+    arrayse.ss = arrayss;
+  gfc_conv_expr_val (&arrayse, arrayexpr);
+  gfc_add_block_to_block (&block, &arrayse.pre);
+
+  if (norm2)
+    {
+      /* if (x (i) != 0.0)
+	   {
+	     absX = abs(x(i))
+	     if (absX > scale)
+	       {
+                 val = scale/absX;
+		 result = 1.0 + result * val * val;
+		 scale = absX;
+	       }
+	     else
+	       {
+                 val = absX/scale;
+	         result += val * val;
+	       }
+	   }  */
+      tree res1, res2, cond, absX, val;
+      stmtblock_t ifblock1, ifblock2, ifblock3;
+
+      gfc_init_block (&ifblock1);
+
+      absX = gfc_create_var (type, "absX");
+      gfc_add_modify (&ifblock1, absX,
+		      fold_build1_loc (input_location, ABS_EXPR, type,
+				       arrayse.expr));
+      val = gfc_create_var (type, "val");
+      gfc_add_expr_to_block (&ifblock1, val);
+
+      gfc_init_block (&ifblock2);
+      gfc_add_modify (&ifblock2, val,
+		      fold_build2_loc (input_location, RDIV_EXPR, type, scale,
+				       absX));
+      res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val); 
+      res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1);
+      res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1,
+			      gfc_build_const (type, integer_one_node));
+      gfc_add_modify (&ifblock2, resvar, res1);
+      gfc_add_modify (&ifblock2, scale, absX);
+      res1 = gfc_finish_block (&ifblock2); 
+
+      gfc_init_block (&ifblock3);
+      gfc_add_modify (&ifblock3, val,
+		      fold_build2_loc (input_location, RDIV_EXPR, type, absX,
+				       scale));
+      res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val); 
+      res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2);
+      gfc_add_modify (&ifblock3, resvar, res2);
+      res2 = gfc_finish_block (&ifblock3);
+
+      cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+			      absX, scale);
+      tmp = build3_v (COND_EXPR, cond, res1, res2);
+      gfc_add_expr_to_block (&ifblock1, tmp);  
+      tmp = gfc_finish_block (&ifblock1);
+
+      cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			      arrayse.expr,
+			      gfc_build_const (type, integer_zero_node));
+
+      tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&block, tmp);  
+    }
+  else
+    {
+      tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr);
+      gfc_add_modify (&block, resvar, tmp);
+    }
+
+  gfc_add_block_to_block (&block, &arrayse.post);
+
+  if (maskexpr && maskexpr->rank > 0)
+    {
+      /* We enclose the above in if (mask) {...} .  */
+
+      tmp = gfc_finish_block (&block);
+      tmp = build3_v (COND_EXPR, maskse.expr, tmp,
+		      build_empty_stmt (input_location));
+    }
+  else
+    tmp = gfc_finish_block (&block);
+  gfc_add_expr_to_block (&body, tmp);
+
+  gfc_trans_scalarizing_loops (ploop, &body);
+
+  /* For a scalar mask, enclose the loop in an if statement.  */
+  if (maskexpr && maskexpr->rank == 0)
+    {
+      gfc_init_block (&block);
+      gfc_add_block_to_block (&block, &ploop->pre);
+      gfc_add_block_to_block (&block, &ploop->post);
+      tmp = gfc_finish_block (&block);
+
+      if (expr->rank > 0)
+	{
+	  tmp = build3_v (COND_EXPR, se->ss->info->data.scalar.value, tmp,
+			  build_empty_stmt (input_location));
+	  gfc_advance_se_ss_chain (se);
+	}
+      else
+	{
+	  gcc_assert (expr->rank == 0);
+	  gfc_init_se (&maskse, NULL);
+	  gfc_conv_expr_val (&maskse, maskexpr);
+	  tmp = build3_v (COND_EXPR, maskse.expr, tmp,
+			  build_empty_stmt (input_location));
+	}
+
+      gfc_add_expr_to_block (&block, tmp);
+      gfc_add_block_to_block (&se->pre, &block);
+      gcc_assert (se->post.head == NULL);
+    }
+  else
+    {
+      gfc_add_block_to_block (&se->pre, &ploop->pre);
+      gfc_add_block_to_block (&se->pre, &ploop->post);
+    }
+
+  if (expr->rank == 0)
+    gfc_cleanup_loop (ploop);
+
+  if (norm2)
+    {
+      /* result = scale * sqrt(result).  */
+      tree sqrt;
+      sqrt = gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind);
+      resvar = build_call_expr_loc (input_location,
+				    sqrt, 1, resvar);
+      resvar = fold_build2_loc (input_location, MULT_EXPR, type, scale, resvar);
+    }
+
+  se->expr = resvar;
+}
+
+
+/* Inline implementation of the dot_product intrinsic. This function
+   is based on gfc_conv_intrinsic_arith (the previous function).  */
+static void
+gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
+{
+  tree resvar;
+  tree type;
+  stmtblock_t body;
+  stmtblock_t block;
+  tree tmp;
+  gfc_loopinfo loop;
+  gfc_actual_arglist *actual;
+  gfc_ss *arrayss1, *arrayss2;
+  gfc_se arrayse1, arrayse2;
+  gfc_expr *arrayexpr1, *arrayexpr2;
+
+  type = gfc_typenode_for_spec (&expr->ts);
+
+  /* Initialize the result.  */
+  resvar = gfc_create_var (type, "val");
+  if (expr->ts.type == BT_LOGICAL)
+    tmp = build_int_cst (type, 0);
+  else
+    tmp = gfc_build_const (type, integer_zero_node);
+
+  gfc_add_modify (&se->pre, resvar, tmp);
+
+  /* Walk argument #1.  */
+  actual = expr->value.function.actual;
+  arrayexpr1 = actual->expr;
+  arrayss1 = gfc_walk_expr (arrayexpr1);
+  gcc_assert (arrayss1 != gfc_ss_terminator);
+
+  /* Walk argument #2.  */
+  actual = actual->next;
+  arrayexpr2 = actual->expr;
+  arrayss2 = gfc_walk_expr (arrayexpr2);
+  gcc_assert (arrayss2 != gfc_ss_terminator);
+
+  /* Initialize the scalarizer.  */
+  gfc_init_loopinfo (&loop);
+  gfc_add_ss_to_loop (&loop, arrayss1);
+  gfc_add_ss_to_loop (&loop, arrayss2);
+
+  /* Initialize the loop.  */
+  gfc_conv_ss_startstride (&loop);
+  gfc_conv_loop_setup (&loop, &expr->where);
+
+  gfc_mark_ss_chain_used (arrayss1, 1);
+  gfc_mark_ss_chain_used (arrayss2, 1);
+
+  /* Generate the loop body.  */
+  gfc_start_scalarized_body (&loop, &body);
+  gfc_init_block (&block);
+
+  /* Make the tree expression for [conjg(]array1[)].  */
+  gfc_init_se (&arrayse1, NULL);
+  gfc_copy_loopinfo_to_se (&arrayse1, &loop);
+  arrayse1.ss = arrayss1;
+  gfc_conv_expr_val (&arrayse1, arrayexpr1);
+  if (expr->ts.type == BT_COMPLEX)
+    arrayse1.expr = fold_build1_loc (input_location, CONJ_EXPR, type,
+				     arrayse1.expr);
+  gfc_add_block_to_block (&block, &arrayse1.pre);
+
+  /* Make the tree expression for array2.  */
+  gfc_init_se (&arrayse2, NULL);
+  gfc_copy_loopinfo_to_se (&arrayse2, &loop);
+  arrayse2.ss = arrayss2;
+  gfc_conv_expr_val (&arrayse2, arrayexpr2);
+  gfc_add_block_to_block (&block, &arrayse2.pre);
+
+  /* Do the actual product and sum.  */
+  if (expr->ts.type == BT_LOGICAL)
+    {
+      tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, type,
+			     arrayse1.expr, arrayse2.expr);
+      tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, type, resvar, tmp);
+    }
+  else
+    {
+      tmp = fold_build2_loc (input_location, MULT_EXPR, type, arrayse1.expr,
+			     arrayse2.expr);
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, tmp);
+    }
+  gfc_add_modify (&block, resvar, tmp);
+
+  /* Finish up the loop block and the loop.  */
+  tmp = gfc_finish_block (&block);
+  gfc_add_expr_to_block (&body, tmp);
+
+  gfc_trans_scalarizing_loops (&loop, &body);
+  gfc_add_block_to_block (&se->pre, &loop.pre);
+  gfc_add_block_to_block (&se->pre, &loop.post);
+  gfc_cleanup_loop (&loop);
+
+  se->expr = resvar;
+}
+
+
+/* Emit code for minloc or maxloc intrinsic.  There are many different cases
+   we need to handle.  For performance reasons we sometimes create two
+   loops instead of one, where the second one is much simpler.
+   Examples for minloc intrinsic:
+   1) Result is an array, a call is generated
+   2) Array mask is used and NaNs need to be supported:
+      limit = Infinity;
+      pos = 0;
+      S = from;
+      while (S <= to) {
+	if (mask[S]) {
+	  if (pos == 0) pos = S + (1 - from);
+	  if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
+	}
+	S++;
+      }
+      goto lab2;
+      lab1:;
+      while (S <= to) {
+	if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
+	S++;
+      }
+      lab2:;
+   3) NaNs need to be supported, but it is known at compile time or cheaply
+      at runtime whether array is nonempty or not:
+      limit = Infinity;
+      pos = 0;
+      S = from;
+      while (S <= to) {
+	if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
+	S++;
+      }
+      if (from <= to) pos = 1;
+      goto lab2;
+      lab1:;
+      while (S <= to) {
+	if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
+	S++;
+      }
+      lab2:;
+   4) NaNs aren't supported, array mask is used:
+      limit = infinities_supported ? Infinity : huge (limit);
+      pos = 0;
+      S = from;
+      while (S <= to) {
+	if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
+	S++;
+      }
+      goto lab2;
+      lab1:;
+      while (S <= to) {
+	if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
+	S++;
+      }
+      lab2:;
+   5) Same without array mask:
+      limit = infinities_supported ? Infinity : huge (limit);
+      pos = (from <= to) ? 1 : 0;
+      S = from;
+      while (S <= to) {
+	if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
+	S++;
+      }
+   For 3) and 5), if mask is scalar, this all goes into a conditional,
+   setting pos = 0; in the else branch.  */
+
+static void
+gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
+{
+  stmtblock_t body;
+  stmtblock_t block;
+  stmtblock_t ifblock;
+  stmtblock_t elseblock;
+  tree limit;
+  tree type;
+  tree tmp;
+  tree cond;
+  tree elsetmp;
+  tree ifbody;
+  tree offset;
+  tree nonempty;
+  tree lab1, lab2;
+  gfc_loopinfo loop;
+  gfc_actual_arglist *actual;
+  gfc_ss *arrayss;
+  gfc_ss *maskss;
+  gfc_se arrayse;
+  gfc_se maskse;
+  gfc_expr *arrayexpr;
+  gfc_expr *maskexpr;
+  tree pos;
+  int n;
+
+  if (se->ss)
+    {
+      gfc_conv_intrinsic_funcall (se, expr);
+      return;
+    }
+
+  /* Initialize the result.  */
+  pos = gfc_create_var (gfc_array_index_type, "pos");
+  offset = gfc_create_var (gfc_array_index_type, "offset");
+  type = gfc_typenode_for_spec (&expr->ts);
+
+  /* Walk the arguments.  */
+  actual = expr->value.function.actual;
+  arrayexpr = actual->expr;
+  arrayss = gfc_walk_expr (arrayexpr);
+  gcc_assert (arrayss != gfc_ss_terminator);
+
+  actual = actual->next->next;
+  gcc_assert (actual);
+  maskexpr = actual->expr;
+  nonempty = NULL;
+  if (maskexpr && maskexpr->rank != 0)
+    {
+      maskss = gfc_walk_expr (maskexpr);
+      gcc_assert (maskss != gfc_ss_terminator);
+    }
+  else
+    {
+      mpz_t asize;
+      if (gfc_array_size (arrayexpr, &asize))
+	{
+	  nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
+	  mpz_clear (asize);
+	  nonempty = fold_build2_loc (input_location, GT_EXPR,
+				      boolean_type_node, nonempty,
+				      gfc_index_zero_node);
+	}
+      maskss = NULL;
+    }
+
+  limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
+  switch (arrayexpr->ts.type)
+    {
+    case BT_REAL:
+      tmp = gfc_build_inf_or_huge (TREE_TYPE (limit), arrayexpr->ts.kind);
+      break;
+
+    case BT_INTEGER:
+      n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
+      tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
+				  arrayexpr->ts.kind);
+      break;
+
+    default:
+      gcc_unreachable ();
+    }
+
+  /* We start with the most negative possible value for MAXLOC, and the most
+     positive possible value for MINLOC. The most negative possible value is
+     -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
+     possible value is HUGE in both cases.  */
+  if (op == GT_EXPR)
+    tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
+  if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
+    tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp,
+			   build_int_cst (type, 1));
+
+  gfc_add_modify (&se->pre, limit, tmp);
+
+  /* Initialize the scalarizer.  */
+  gfc_init_loopinfo (&loop);
+  gfc_add_ss_to_loop (&loop, arrayss);
+  if (maskss)
+    gfc_add_ss_to_loop (&loop, maskss);
+
+  /* Initialize the loop.  */
+  gfc_conv_ss_startstride (&loop);
+
+  /* The code generated can have more than one loop in sequence (see the
+     comment at the function header).  This doesn't work well with the
+     scalarizer, which changes arrays' offset when the scalarization loops
+     are generated (see gfc_trans_preloop_setup).  Fortunately, {min,max}loc
+     are  currently inlined in the scalar case only (for which loop is of rank
+     one).  As there is no dependency to care about in that case, there is no
+     temporary, so that we can use the scalarizer temporary code to handle
+     multiple loops.  Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
+     with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
+     to restore offset.
+     TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
+     should eventually go away.  We could either create two loops properly,
+     or find another way to save/restore the array offsets between the two
+     loops (without conflicting with temporary management), or use a single
+     loop minmaxloc implementation.  See PR 31067.  */
+  loop.temp_dim = loop.dimen;
+  gfc_conv_loop_setup (&loop, &expr->where);
+
+  gcc_assert (loop.dimen == 1);
+  if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0])
+    nonempty = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
+				loop.from[0], loop.to[0]);
+
+  lab1 = NULL;
+  lab2 = NULL;
+  /* Initialize the position to zero, following Fortran 2003.  We are free
+     to do this because Fortran 95 allows the result of an entirely false
+     mask to be processor dependent.  If we know at compile time the array
+     is non-empty and no MASK is used, we can initialize to 1 to simplify
+     the inner loop.  */
+  if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
+    gfc_add_modify (&loop.pre, pos,
+		    fold_build3_loc (input_location, COND_EXPR,
+				     gfc_array_index_type,
+				     nonempty, gfc_index_one_node,
+				     gfc_index_zero_node));
+  else
+    {
+      gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
+      lab1 = gfc_build_label_decl (NULL_TREE);
+      TREE_USED (lab1) = 1;
+      lab2 = gfc_build_label_decl (NULL_TREE);
+      TREE_USED (lab2) = 1;
+    }
+
+  /* An offset must be added to the loop
+     counter to obtain the required position.  */
+  gcc_assert (loop.from[0]);
+
+  tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			 gfc_index_one_node, loop.from[0]);
+  gfc_add_modify (&loop.pre, offset, tmp);
+
+  gfc_mark_ss_chain_used (arrayss, lab1 ? 3 : 1);
+  if (maskss)
+    gfc_mark_ss_chain_used (maskss, lab1 ? 3 : 1);
+  /* Generate the loop body.  */
+  gfc_start_scalarized_body (&loop, &body);
+
+  /* If we have a mask, only check this element if the mask is set.  */
+  if (maskss)
+    {
+      gfc_init_se (&maskse, NULL);
+      gfc_copy_loopinfo_to_se (&maskse, &loop);
+      maskse.ss = maskss;
+      gfc_conv_expr_val (&maskse, maskexpr);
+      gfc_add_block_to_block (&body, &maskse.pre);
+
+      gfc_start_block (&block);
+    }
+  else
+    gfc_init_block (&block);
+
+  /* Compare with the current limit.  */
+  gfc_init_se (&arrayse, NULL);
+  gfc_copy_loopinfo_to_se (&arrayse, &loop);
+  arrayse.ss = arrayss;
+  gfc_conv_expr_val (&arrayse, arrayexpr);
+  gfc_add_block_to_block (&block, &arrayse.pre);
+
+  /* We do the following if this is a more extreme value.  */
+  gfc_start_block (&ifblock);
+
+  /* Assign the value to the limit...  */
+  gfc_add_modify (&ifblock, limit, arrayse.expr);
+
+  if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
+    {
+      stmtblock_t ifblock2;
+      tree ifbody2;
+
+      gfc_start_block (&ifblock2);
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
+			     loop.loopvar[0], offset);
+      gfc_add_modify (&ifblock2, pos, tmp);
+      ifbody2 = gfc_finish_block (&ifblock2);
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pos,
+			      gfc_index_zero_node);
+      tmp = build3_v (COND_EXPR, cond, ifbody2,
+		      build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&block, tmp);
+    }
+
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
+			 loop.loopvar[0], offset);
+  gfc_add_modify (&ifblock, pos, tmp);
+
+  if (lab1)
+    gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
+
+  ifbody = gfc_finish_block (&ifblock);
+
+  if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
+    {
+      if (lab1)
+	cond = fold_build2_loc (input_location,
+				op == GT_EXPR ? GE_EXPR : LE_EXPR,
+				boolean_type_node, arrayse.expr, limit);
+      else
+	cond = fold_build2_loc (input_location, op, boolean_type_node,
+				arrayse.expr, limit);
+
+      ifbody = build3_v (COND_EXPR, cond, ifbody,
+			 build_empty_stmt (input_location));
+    }
+  gfc_add_expr_to_block (&block, ifbody);
+
+  if (maskss)
+    {
+      /* We enclose the above in if (mask) {...}.  */
+      tmp = gfc_finish_block (&block);
+
+      tmp = build3_v (COND_EXPR, maskse.expr, tmp,
+		      build_empty_stmt (input_location));
+    }
+  else
+    tmp = gfc_finish_block (&block);
+  gfc_add_expr_to_block (&body, tmp);
+
+  if (lab1)
+    {
+      gfc_trans_scalarized_loop_boundary (&loop, &body);
+
+      if (HONOR_NANS (DECL_MODE (limit)))
+	{
+	  if (nonempty != NULL)
+	    {
+	      ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node);
+	      tmp = build3_v (COND_EXPR, nonempty, ifbody,
+			      build_empty_stmt (input_location));
+	      gfc_add_expr_to_block (&loop.code[0], tmp);
+	    }
+	}
+
+      gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2));
+      gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1));
+
+      /* If we have a mask, only check this element if the mask is set.  */
+      if (maskss)
+	{
+	  gfc_init_se (&maskse, NULL);
+	  gfc_copy_loopinfo_to_se (&maskse, &loop);
+	  maskse.ss = maskss;
+	  gfc_conv_expr_val (&maskse, maskexpr);
+	  gfc_add_block_to_block (&body, &maskse.pre);
+
+	  gfc_start_block (&block);
+	}
+      else
+	gfc_init_block (&block);
+
+      /* Compare with the current limit.  */
+      gfc_init_se (&arrayse, NULL);
+      gfc_copy_loopinfo_to_se (&arrayse, &loop);
+      arrayse.ss = arrayss;
+      gfc_conv_expr_val (&arrayse, arrayexpr);
+      gfc_add_block_to_block (&block, &arrayse.pre);
+
+      /* We do the following if this is a more extreme value.  */
+      gfc_start_block (&ifblock);
+
+      /* Assign the value to the limit...  */
+      gfc_add_modify (&ifblock, limit, arrayse.expr);
+
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
+			     loop.loopvar[0], offset);
+      gfc_add_modify (&ifblock, pos, tmp);
+
+      ifbody = gfc_finish_block (&ifblock);
+
+      cond = fold_build2_loc (input_location, op, boolean_type_node,
+			      arrayse.expr, limit);
+
+      tmp = build3_v (COND_EXPR, cond, ifbody,
+		      build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&block, tmp);
+
+      if (maskss)
+	{
+	  /* We enclose the above in if (mask) {...}.  */
+	  tmp = gfc_finish_block (&block);
+
+	  tmp = build3_v (COND_EXPR, maskse.expr, tmp,
+			  build_empty_stmt (input_location));
+	}
+      else
+	tmp = gfc_finish_block (&block);
+      gfc_add_expr_to_block (&body, tmp);
+      /* Avoid initializing loopvar[0] again, it should be left where
+	 it finished by the first loop.  */
+      loop.from[0] = loop.loopvar[0];
+    }
+
+  gfc_trans_scalarizing_loops (&loop, &body);
+
+  if (lab2)
+    gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2));
+
+  /* For a scalar mask, enclose the loop in an if statement.  */
+  if (maskexpr && maskss == NULL)
+    {
+      gfc_init_se (&maskse, NULL);
+      gfc_conv_expr_val (&maskse, maskexpr);
+      gfc_init_block (&block);
+      gfc_add_block_to_block (&block, &loop.pre);
+      gfc_add_block_to_block (&block, &loop.post);
+      tmp = gfc_finish_block (&block);
+
+      /* For the else part of the scalar mask, just initialize
+	 the pos variable the same way as above.  */
+
+      gfc_init_block (&elseblock);
+      gfc_add_modify (&elseblock, pos, gfc_index_zero_node);
+      elsetmp = gfc_finish_block (&elseblock);
+
+      tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
+      gfc_add_expr_to_block (&block, tmp);
+      gfc_add_block_to_block (&se->pre, &block);
+    }
+  else
+    {
+      gfc_add_block_to_block (&se->pre, &loop.pre);
+      gfc_add_block_to_block (&se->pre, &loop.post);
+    }
+  gfc_cleanup_loop (&loop);
+
+  se->expr = convert (type, pos);
+}
+
+/* Emit code for minval or maxval intrinsic.  There are many different cases
+   we need to handle.  For performance reasons we sometimes create two
+   loops instead of one, where the second one is much simpler.
+   Examples for minval intrinsic:
+   1) Result is an array, a call is generated
+   2) Array mask is used and NaNs need to be supported, rank 1:
+      limit = Infinity;
+      nonempty = false;
+      S = from;
+      while (S <= to) {
+	if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
+	S++;
+      }
+      limit = nonempty ? NaN : huge (limit);
+      lab:
+      while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
+   3) NaNs need to be supported, but it is known at compile time or cheaply
+      at runtime whether array is nonempty or not, rank 1:
+      limit = Infinity;
+      S = from;
+      while (S <= to) { if (a[S] <= limit) goto lab; S++; }
+      limit = (from <= to) ? NaN : huge (limit);
+      lab:
+      while (S <= to) { limit = min (a[S], limit); S++; }
+   4) Array mask is used and NaNs need to be supported, rank > 1:
+      limit = Infinity;
+      nonempty = false;
+      fast = false;
+      S1 = from1;
+      while (S1 <= to1) {
+	S2 = from2;
+	while (S2 <= to2) {
+	  if (mask[S1][S2]) {
+	    if (fast) limit = min (a[S1][S2], limit);
+	    else {
+	      nonempty = true;
+	      if (a[S1][S2] <= limit) {
+		limit = a[S1][S2];
+		fast = true;
+	      }
+	    }
+	  }
+	  S2++;
+	}
+	S1++;
+      }
+      if (!fast)
+	limit = nonempty ? NaN : huge (limit);
+   5) NaNs need to be supported, but it is known at compile time or cheaply
+      at runtime whether array is nonempty or not, rank > 1:
+      limit = Infinity;
+      fast = false;
+      S1 = from1;
+      while (S1 <= to1) {
+	S2 = from2;
+	while (S2 <= to2) {
+	  if (fast) limit = min (a[S1][S2], limit);
+	  else {
+	    if (a[S1][S2] <= limit) {
+	      limit = a[S1][S2];
+	      fast = true;
+	    }
+	  }
+	  S2++;
+	}
+	S1++;
+      }
+      if (!fast)
+	limit = (nonempty_array) ? NaN : huge (limit);
+   6) NaNs aren't supported, but infinities are.  Array mask is used:
+      limit = Infinity;
+      nonempty = false;
+      S = from;
+      while (S <= to) {
+	if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
+	S++;
+      }
+      limit = nonempty ? limit : huge (limit);
+   7) Same without array mask:
+      limit = Infinity;
+      S = from;
+      while (S <= to) { limit = min (a[S], limit); S++; }
+      limit = (from <= to) ? limit : huge (limit);
+   8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
+      limit = huge (limit);
+      S = from;
+      while (S <= to) { limit = min (a[S], limit); S++); }
+      (or
+      while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
+      with array mask instead).
+   For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
+   setting limit = huge (limit); in the else branch.  */
+
+static void
+gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
+{
+  tree limit;
+  tree type;
+  tree tmp;
+  tree ifbody;
+  tree nonempty;
+  tree nonempty_var;
+  tree lab;
+  tree fast;
+  tree huge_cst = NULL, nan_cst = NULL;
+  stmtblock_t body;
+  stmtblock_t block, block2;
+  gfc_loopinfo loop;
+  gfc_actual_arglist *actual;
+  gfc_ss *arrayss;
+  gfc_ss *maskss;
+  gfc_se arrayse;
+  gfc_se maskse;
+  gfc_expr *arrayexpr;
+  gfc_expr *maskexpr;
+  int n;
+
+  if (se->ss)
+    {
+      gfc_conv_intrinsic_funcall (se, expr);
+      return;
+    }
+
+  type = gfc_typenode_for_spec (&expr->ts);
+  /* Initialize the result.  */
+  limit = gfc_create_var (type, "limit");
+  n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
+  switch (expr->ts.type)
+    {
+    case BT_REAL:
+      huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
+					expr->ts.kind, 0);
+      if (HONOR_INFINITIES (DECL_MODE (limit)))
+	{
+	  REAL_VALUE_TYPE real;
+	  real_inf (&real);
+	  tmp = build_real (type, real);
+	}
+      else
+	tmp = huge_cst;
+      if (HONOR_NANS (DECL_MODE (limit)))
+	{
+	  REAL_VALUE_TYPE real;
+	  real_nan (&real, "", 1, DECL_MODE (limit));
+	  nan_cst = build_real (type, real);
+	}
+      break;
+
+    case BT_INTEGER:
+      tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
+      break;
+
+    default:
+      gcc_unreachable ();
+    }
+
+  /* We start with the most negative possible value for MAXVAL, and the most
+     positive possible value for MINVAL. The most negative possible value is
+     -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
+     possible value is HUGE in both cases.  */
+  if (op == GT_EXPR)
+    {
+      tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
+      if (huge_cst)
+	huge_cst = fold_build1_loc (input_location, NEGATE_EXPR,
+				    TREE_TYPE (huge_cst), huge_cst);
+    }
+
+  if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
+    tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
+			   tmp, build_int_cst (type, 1));
+
+  gfc_add_modify (&se->pre, limit, tmp);
+
+  /* Walk the arguments.  */
+  actual = expr->value.function.actual;
+  arrayexpr = actual->expr;
+  arrayss = gfc_walk_expr (arrayexpr);
+  gcc_assert (arrayss != gfc_ss_terminator);
+
+  actual = actual->next->next;
+  gcc_assert (actual);
+  maskexpr = actual->expr;
+  nonempty = NULL;
+  if (maskexpr && maskexpr->rank != 0)
+    {
+      maskss = gfc_walk_expr (maskexpr);
+      gcc_assert (maskss != gfc_ss_terminator);
+    }
+  else
+    {
+      mpz_t asize;
+      if (gfc_array_size (arrayexpr, &asize))
+	{
+	  nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
+	  mpz_clear (asize);
+	  nonempty = fold_build2_loc (input_location, GT_EXPR,
+				      boolean_type_node, nonempty,
+				      gfc_index_zero_node);
+	}
+      maskss = NULL;
+    }
+
+  /* Initialize the scalarizer.  */
+  gfc_init_loopinfo (&loop);
+  gfc_add_ss_to_loop (&loop, arrayss);
+  if (maskss)
+    gfc_add_ss_to_loop (&loop, maskss);
+
+  /* Initialize the loop.  */
+  gfc_conv_ss_startstride (&loop);
+
+  /* The code generated can have more than one loop in sequence (see the
+     comment at the function header).  This doesn't work well with the
+     scalarizer, which changes arrays' offset when the scalarization loops
+     are generated (see gfc_trans_preloop_setup).  Fortunately, {min,max}val
+     are  currently inlined in the scalar case only.  As there is no dependency
+     to care about in that case, there is no temporary, so that we can use the
+     scalarizer temporary code to handle multiple loops.  Thus, we set temp_dim
+     here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
+     gfc_trans_scalarized_loop_boundary even later to restore offset.
+     TODO: this prevents inlining of rank > 0 minmaxval calls, so this
+     should eventually go away.  We could either create two loops properly,
+     or find another way to save/restore the array offsets between the two
+     loops (without conflicting with temporary management), or use a single
+     loop minmaxval implementation.  See PR 31067.  */
+  loop.temp_dim = loop.dimen;
+  gfc_conv_loop_setup (&loop, &expr->where);
+
+  if (nonempty == NULL && maskss == NULL
+      && loop.dimen == 1 && loop.from[0] && loop.to[0])
+    nonempty = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
+				loop.from[0], loop.to[0]);
+  nonempty_var = NULL;
+  if (nonempty == NULL
+      && (HONOR_INFINITIES (DECL_MODE (limit))
+	  || HONOR_NANS (DECL_MODE (limit))))
+    {
+      nonempty_var = gfc_create_var (boolean_type_node, "nonempty");
+      gfc_add_modify (&se->pre, nonempty_var, boolean_false_node);
+      nonempty = nonempty_var;
+    }
+  lab = NULL;
+  fast = NULL;
+  if (HONOR_NANS (DECL_MODE (limit)))
+    {
+      if (loop.dimen == 1)
+	{
+	  lab = gfc_build_label_decl (NULL_TREE);
+	  TREE_USED (lab) = 1;
+	}
+      else
+	{
+	  fast = gfc_create_var (boolean_type_node, "fast");
+	  gfc_add_modify (&se->pre, fast, boolean_false_node);
+	}
+    }
+
+  gfc_mark_ss_chain_used (arrayss, lab ? 3 : 1);
+  if (maskss)
+    gfc_mark_ss_chain_used (maskss, lab ? 3 : 1);
+  /* Generate the loop body.  */
+  gfc_start_scalarized_body (&loop, &body);
+
+  /* If we have a mask, only add this element if the mask is set.  */
+  if (maskss)
+    {
+      gfc_init_se (&maskse, NULL);
+      gfc_copy_loopinfo_to_se (&maskse, &loop);
+      maskse.ss = maskss;
+      gfc_conv_expr_val (&maskse, maskexpr);
+      gfc_add_block_to_block (&body, &maskse.pre);
+
+      gfc_start_block (&block);
+    }
+  else
+    gfc_init_block (&block);
+
+  /* Compare with the current limit.  */
+  gfc_init_se (&arrayse, NULL);
+  gfc_copy_loopinfo_to_se (&arrayse, &loop);
+  arrayse.ss = arrayss;
+  gfc_conv_expr_val (&arrayse, arrayexpr);
+  gfc_add_block_to_block (&block, &arrayse.pre);
+
+  gfc_init_block (&block2);
+
+  if (nonempty_var)
+    gfc_add_modify (&block2, nonempty_var, boolean_true_node);
+
+  if (HONOR_NANS (DECL_MODE (limit)))
+    {
+      tmp = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
+			     boolean_type_node, arrayse.expr, limit);
+      if (lab)
+	ifbody = build1_v (GOTO_EXPR, lab);
+      else
+	{
+	  stmtblock_t ifblock;
+
+	  gfc_init_block (&ifblock);
+	  gfc_add_modify (&ifblock, limit, arrayse.expr);
+	  gfc_add_modify (&ifblock, fast, boolean_true_node);
+	  ifbody = gfc_finish_block (&ifblock);
+	}
+      tmp = build3_v (COND_EXPR, tmp, ifbody,
+		      build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&block2, tmp);
+    }
+  else
+    {
+      /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
+	 signed zeros.  */
+      if (HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
+	{
+	  tmp = fold_build2_loc (input_location, op, boolean_type_node,
+				 arrayse.expr, limit);
+	  ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
+	  tmp = build3_v (COND_EXPR, tmp, ifbody,
+			  build_empty_stmt (input_location));
+	  gfc_add_expr_to_block (&block2, tmp);
+	}
+      else
+	{
+	  tmp = fold_build2_loc (input_location,
+				 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
+				 type, arrayse.expr, limit);
+	  gfc_add_modify (&block2, limit, tmp);
+	}
+    }
+
+  if (fast)
+    {
+      tree elsebody = gfc_finish_block (&block2);
+
+      /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
+	 signed zeros.  */
+      if (HONOR_NANS (DECL_MODE (limit))
+	  || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
+	{
+	  tmp = fold_build2_loc (input_location, op, boolean_type_node,
+				 arrayse.expr, limit);
+	  ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
+	  ifbody = build3_v (COND_EXPR, tmp, ifbody,
+			     build_empty_stmt (input_location));
+	}
+      else
+	{
+	  tmp = fold_build2_loc (input_location,
+				 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
+				 type, arrayse.expr, limit);
+	  ifbody = build2_v (MODIFY_EXPR, limit, tmp);
+	}
+      tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
+      gfc_add_expr_to_block (&block, tmp);
+    }
+  else
+    gfc_add_block_to_block (&block, &block2);
+
+  gfc_add_block_to_block (&block, &arrayse.post);
+
+  tmp = gfc_finish_block (&block);
+  if (maskss)
+    /* We enclose the above in if (mask) {...}.  */
+    tmp = build3_v (COND_EXPR, maskse.expr, tmp,
+		    build_empty_stmt (input_location));
+  gfc_add_expr_to_block (&body, tmp);
+
+  if (lab)
+    {
+      gfc_trans_scalarized_loop_boundary (&loop, &body);
+
+      tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
+			     nan_cst, huge_cst);
+      gfc_add_modify (&loop.code[0], limit, tmp);
+      gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
+
+      /* If we have a mask, only add this element if the mask is set.  */
+      if (maskss)
+	{
+	  gfc_init_se (&maskse, NULL);
+	  gfc_copy_loopinfo_to_se (&maskse, &loop);
+	  maskse.ss = maskss;
+	  gfc_conv_expr_val (&maskse, maskexpr);
+	  gfc_add_block_to_block (&body, &maskse.pre);
+
+	  gfc_start_block (&block);
+	}
+      else
+	gfc_init_block (&block);
+
+      /* Compare with the current limit.  */
+      gfc_init_se (&arrayse, NULL);
+      gfc_copy_loopinfo_to_se (&arrayse, &loop);
+      arrayse.ss = arrayss;
+      gfc_conv_expr_val (&arrayse, arrayexpr);
+      gfc_add_block_to_block (&block, &arrayse.pre);
+
+      /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
+	 signed zeros.  */
+      if (HONOR_NANS (DECL_MODE (limit))
+	  || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
+	{
+	  tmp = fold_build2_loc (input_location, op, boolean_type_node,
+				 arrayse.expr, limit);
+	  ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
+	  tmp = build3_v (COND_EXPR, tmp, ifbody,
+			  build_empty_stmt (input_location));
+	  gfc_add_expr_to_block (&block, tmp);
+	}
+      else
+	{
+	  tmp = fold_build2_loc (input_location,
+				 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
+				 type, arrayse.expr, limit);
+	  gfc_add_modify (&block, limit, tmp);
+	}
+
+      gfc_add_block_to_block (&block, &arrayse.post);
+
+      tmp = gfc_finish_block (&block);
+      if (maskss)
+	/* We enclose the above in if (mask) {...}.  */
+	tmp = build3_v (COND_EXPR, maskse.expr, tmp,
+			build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&body, tmp);
+      /* Avoid initializing loopvar[0] again, it should be left where
+	 it finished by the first loop.  */
+      loop.from[0] = loop.loopvar[0];
+    }
+  gfc_trans_scalarizing_loops (&loop, &body);
+
+  if (fast)
+    {
+      tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
+			     nan_cst, huge_cst);
+      ifbody = build2_v (MODIFY_EXPR, limit, tmp);
+      tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
+		      ifbody);
+      gfc_add_expr_to_block (&loop.pre, tmp);
+    }
+  else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
+    {
+      tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, limit,
+			     huge_cst);
+      gfc_add_modify (&loop.pre, limit, tmp);
+    }
+
+  /* For a scalar mask, enclose the loop in an if statement.  */
+  if (maskexpr && maskss == NULL)
+    {
+      tree else_stmt;
+
+      gfc_init_se (&maskse, NULL);
+      gfc_conv_expr_val (&maskse, maskexpr);
+      gfc_init_block (&block);
+      gfc_add_block_to_block (&block, &loop.pre);
+      gfc_add_block_to_block (&block, &loop.post);
+      tmp = gfc_finish_block (&block);
+
+      if (HONOR_INFINITIES (DECL_MODE (limit)))
+	else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
+      else
+	else_stmt = build_empty_stmt (input_location);
+      tmp = build3_v (COND_EXPR, maskse.expr, tmp, else_stmt);
+      gfc_add_expr_to_block (&block, tmp);
+      gfc_add_block_to_block (&se->pre, &block);
+    }
+  else
+    {
+      gfc_add_block_to_block (&se->pre, &loop.pre);
+      gfc_add_block_to_block (&se->pre, &loop.post);
+    }
+
+  gfc_cleanup_loop (&loop);
+
+  se->expr = limit;
+}
+
+/* BTEST (i, pos) = (i & (1 << pos)) != 0.  */
+static void
+gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
+{
+  tree args[2];
+  tree type;
+  tree tmp;
+
+  gfc_conv_intrinsic_function_args (se, expr, args, 2);
+  type = TREE_TYPE (args[0]);
+
+  tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
+			 build_int_cst (type, 1), args[1]);
+  tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], tmp);
+  tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
+			 build_int_cst (type, 0));
+  type = gfc_typenode_for_spec (&expr->ts);
+  se->expr = convert (type, tmp);
+}
+
+
+/* Generate code for BGE, BGT, BLE and BLT intrinsics.  */
+static void
+gfc_conv_intrinsic_bitcomp (gfc_se * se, gfc_expr * expr, enum tree_code op)
+{
+  tree args[2];
+
+  gfc_conv_intrinsic_function_args (se, expr, args, 2);
+
+  /* Convert both arguments to the unsigned type of the same size.  */
+  args[0] = fold_convert (unsigned_type_for (TREE_TYPE (args[0])), args[0]);
+  args[1] = fold_convert (unsigned_type_for (TREE_TYPE (args[1])), args[1]);
+
+  /* If they have unequal type size, convert to the larger one.  */
+  if (TYPE_PRECISION (TREE_TYPE (args[0]))
+      > TYPE_PRECISION (TREE_TYPE (args[1])))
+    args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
+  else if (TYPE_PRECISION (TREE_TYPE (args[1]))
+	   > TYPE_PRECISION (TREE_TYPE (args[0])))
+    args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
+
+  /* Now, we compare them.  */
+  se->expr = fold_build2_loc (input_location, op, boolean_type_node,
+			      args[0], args[1]);
+}
+
+
+/* Generate code to perform the specified operation.  */
+static void
+gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
+{
+  tree args[2];
+
+  gfc_conv_intrinsic_function_args (se, expr, args, 2);
+  se->expr = fold_build2_loc (input_location, op, TREE_TYPE (args[0]),
+			      args[0], args[1]);
+}
+
+/* Bitwise not.  */
+static void
+gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
+{
+  tree arg;
+
+  gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+  se->expr = fold_build1_loc (input_location, BIT_NOT_EXPR,
+			      TREE_TYPE (arg), arg);
+}
+
+/* Set or clear a single bit.  */
+static void
+gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
+{
+  tree args[2];
+  tree type;
+  tree tmp;
+  enum tree_code op;
+
+  gfc_conv_intrinsic_function_args (se, expr, args, 2);
+  type = TREE_TYPE (args[0]);
+
+  tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
+			 build_int_cst (type, 1), args[1]);
+  if (set)
+    op = BIT_IOR_EXPR;
+  else
+    {
+      op = BIT_AND_EXPR;
+      tmp = fold_build1_loc (input_location, BIT_NOT_EXPR, type, tmp);
+    }
+  se->expr = fold_build2_loc (input_location, op, type, args[0], tmp);
+}
+
+/* Extract a sequence of bits.
+    IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN).  */
+static void
+gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
+{
+  tree args[3];
+  tree type;
+  tree tmp;
+  tree mask;
+
+  gfc_conv_intrinsic_function_args (se, expr, args, 3);
+  type = TREE_TYPE (args[0]);
+
+  mask = build_int_cst (type, -1);
+  mask = fold_build2_loc (input_location, LSHIFT_EXPR, type, mask, args[2]);
+  mask = fold_build1_loc (input_location, BIT_NOT_EXPR, type, mask);
+
+  tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, args[0], args[1]);
+
+  se->expr = fold_build2_loc (input_location, BIT_AND_EXPR, type, tmp, mask);
+}
+
+static void
+gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift,
+			  bool arithmetic)
+{
+  tree args[2], type, num_bits, cond;
+
+  gfc_conv_intrinsic_function_args (se, expr, args, 2);
+
+  args[0] = gfc_evaluate_now (args[0], &se->pre);
+  args[1] = gfc_evaluate_now (args[1], &se->pre);
+  type = TREE_TYPE (args[0]);
+
+  if (!arithmetic)
+    args[0] = fold_convert (unsigned_type_for (type), args[0]);
+  else
+    gcc_assert (right_shift);
+
+  se->expr = fold_build2_loc (input_location,
+			      right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
+			      TREE_TYPE (args[0]), args[0], args[1]);
+
+  if (!arithmetic)
+    se->expr = fold_convert (type, se->expr);
+
+  /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
+     gcc requires a shift width < BIT_SIZE(I), so we have to catch this
+     special case.  */
+  num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
+  cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
+			  args[1], num_bits);
+
+  se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
+			      build_int_cst (type, 0), se->expr);
+}
+
+/* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
+                        ? 0
+	 	        : ((shift >= 0) ? i << shift : i >> -shift)
+   where all shifts are logical shifts.  */
+static void
+gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
+{
+  tree args[2];
+  tree type;
+  tree utype;
+  tree tmp;
+  tree width;
+  tree num_bits;
+  tree cond;
+  tree lshift;
+  tree rshift;
+
+  gfc_conv_intrinsic_function_args (se, expr, args, 2);
+
+  args[0] = gfc_evaluate_now (args[0], &se->pre);
+  args[1] = gfc_evaluate_now (args[1], &se->pre);
+
+  type = TREE_TYPE (args[0]);
+  utype = unsigned_type_for (type);
+
+  width = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (args[1]),
+			   args[1]);
+
+  /* Left shift if positive.  */
+  lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type, args[0], width);
+
+  /* Right shift if negative.
+     We convert to an unsigned type because we want a logical shift.
+     The standard doesn't define the case of shifting negative
+     numbers, and we try to be compatible with other compilers, most
+     notably g77, here.  */
+  rshift = fold_convert (type, fold_build2_loc (input_location, RSHIFT_EXPR,
+				    utype, convert (utype, args[0]), width));
+
+  tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, args[1],
+			 build_int_cst (TREE_TYPE (args[1]), 0));
+  tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, lshift, rshift);
+
+  /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
+     gcc requires a shift width < BIT_SIZE(I), so we have to catch this
+     special case.  */
+  num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
+  cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, width,
+			  num_bits);
+  se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
+			      build_int_cst (type, 0), tmp);
+}
+
+
+/* Circular shift.  AKA rotate or barrel shift.  */
+
+static void
+gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
+{
+  tree *args;
+  tree type;
+  tree tmp;
+  tree lrot;
+  tree rrot;
+  tree zero;
+  unsigned int num_args;
+
+  num_args = gfc_intrinsic_argument_list_length (expr);
+  args = XALLOCAVEC (tree, num_args);
+
+  gfc_conv_intrinsic_function_args (se, expr, args, num_args);
+
+  if (num_args == 3)
+    {
+      /* Use a library function for the 3 parameter version.  */
+      tree int4type = gfc_get_int_type (4);
+
+      type = TREE_TYPE (args[0]);
+      /* We convert the first argument to at least 4 bytes, and
+	 convert back afterwards.  This removes the need for library
+	 functions for all argument sizes, and function will be
+	 aligned to at least 32 bits, so there's no loss.  */
+      if (expr->ts.kind < 4)
+	args[0] = convert (int4type, args[0]);
+
+      /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
+         need loads of library  functions.  They cannot have values >
+	 BIT_SIZE (I) so the conversion is safe.  */
+      args[1] = convert (int4type, args[1]);
+      args[2] = convert (int4type, args[2]);
+
+      switch (expr->ts.kind)
+	{
+	case 1:
+	case 2:
+	case 4:
+	  tmp = gfor_fndecl_math_ishftc4;
+	  break;
+	case 8:
+	  tmp = gfor_fndecl_math_ishftc8;
+	  break;
+	case 16:
+	  tmp = gfor_fndecl_math_ishftc16;
+	  break;
+	default:
+	  gcc_unreachable ();
+	}
+      se->expr = build_call_expr_loc (input_location,
+				      tmp, 3, args[0], args[1], args[2]);
+      /* Convert the result back to the original type, if we extended
+	 the first argument's width above.  */
+      if (expr->ts.kind < 4)
+	se->expr = convert (type, se->expr);
+
+      return;
+    }
+  type = TREE_TYPE (args[0]);
+
+  /* Evaluate arguments only once.  */
+  args[0] = gfc_evaluate_now (args[0], &se->pre);
+  args[1] = gfc_evaluate_now (args[1], &se->pre);
+
+  /* Rotate left if positive.  */
+  lrot = fold_build2_loc (input_location, LROTATE_EXPR, type, args[0], args[1]);
+
+  /* Rotate right if negative.  */
+  tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (args[1]),
+			 args[1]);
+  rrot = fold_build2_loc (input_location,RROTATE_EXPR, type, args[0], tmp);
+
+  zero = build_int_cst (TREE_TYPE (args[1]), 0);
+  tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, args[1],
+			 zero);
+  rrot = fold_build3_loc (input_location, COND_EXPR, type, tmp, lrot, rrot);
+
+  /* Do nothing if shift == 0.  */
+  tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, args[1],
+			 zero);
+  se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, args[0],
+			      rrot);
+}
+
+
+/* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
+			: __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
+
+   The conditional expression is necessary because the result of LEADZ(0)
+   is defined, but the result of __builtin_clz(0) is undefined for most
+   targets.
+
+   For INTEGER kinds smaller than the C 'int' type, we have to subtract the
+   difference in bit size between the argument of LEADZ and the C int.  */
+ 
+static void
+gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
+{
+  tree arg;
+  tree arg_type;
+  tree cond;
+  tree result_type;
+  tree leadz;
+  tree bit_size;
+  tree tmp;
+  tree func;
+  int s, argsize;
+
+  gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+  argsize = TYPE_PRECISION (TREE_TYPE (arg));
+
+  /* Which variant of __builtin_clz* should we call?  */
+  if (argsize <= INT_TYPE_SIZE)
+    {
+      arg_type = unsigned_type_node;
+      func = builtin_decl_explicit (BUILT_IN_CLZ);
+    }
+  else if (argsize <= LONG_TYPE_SIZE)
+    {
+      arg_type = long_unsigned_type_node;
+      func = builtin_decl_explicit (BUILT_IN_CLZL);
+    }
+  else if (argsize <= LONG_LONG_TYPE_SIZE)
+    {
+      arg_type = long_long_unsigned_type_node;
+      func = builtin_decl_explicit (BUILT_IN_CLZLL);
+    }
+  else
+    {
+      gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
+      arg_type = gfc_build_uint_type (argsize);
+      func = NULL_TREE;
+    }
+
+  /* Convert the actual argument twice: first, to the unsigned type of the
+     same size; then, to the proper argument type for the built-in
+     function.  But the return type is of the default INTEGER kind.  */
+  arg = fold_convert (gfc_build_uint_type (argsize), arg);
+  arg = fold_convert (arg_type, arg);
+  arg = gfc_evaluate_now (arg, &se->pre);
+  result_type = gfc_get_int_type (gfc_default_integer_kind);
+
+  /* Compute LEADZ for the case i .ne. 0.  */
+  if (func)
+    {
+      s = TYPE_PRECISION (arg_type) - argsize;
+      tmp = fold_convert (result_type,
+			  build_call_expr_loc (input_location, func,
+					       1, arg));
+      leadz = fold_build2_loc (input_location, MINUS_EXPR, result_type,
+			       tmp, build_int_cst (result_type, s));
+    }
+  else
+    {
+      /* We end up here if the argument type is larger than 'long long'.
+	 We generate this code:
+  
+	    if (x & (ULL_MAX << ULL_SIZE) != 0)
+	      return clzll ((unsigned long long) (x >> ULLSIZE));
+	    else
+	      return ULL_SIZE + clzll ((unsigned long long) x);
+	 where ULL_MAX is the largest value that a ULL_MAX can hold
+	 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
+	 is the bit-size of the long long type (64 in this example).  */
+      tree ullsize, ullmax, tmp1, tmp2, btmp;
+
+      ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
+      ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
+				long_long_unsigned_type_node,
+				build_int_cst (long_long_unsigned_type_node,
+					       0));
+
+      cond = fold_build2_loc (input_location, LSHIFT_EXPR, arg_type,
+			      fold_convert (arg_type, ullmax), ullsize);
+      cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type,
+			      arg, cond);
+      cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			      cond, build_int_cst (arg_type, 0));
+
+      tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
+			      arg, ullsize);
+      tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
+      btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
+      tmp1 = fold_convert (result_type,
+			   build_call_expr_loc (input_location, btmp, 1, tmp1));
+
+      tmp2 = fold_convert (long_long_unsigned_type_node, arg);
+      btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
+      tmp2 = fold_convert (result_type,
+			   build_call_expr_loc (input_location, btmp, 1, tmp2));
+      tmp2 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
+			      tmp2, ullsize);
+
+      leadz = fold_build3_loc (input_location, COND_EXPR, result_type,
+			       cond, tmp1, tmp2);
+    }
+
+  /* Build BIT_SIZE.  */
+  bit_size = build_int_cst (result_type, argsize);
+
+  cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+			  arg, build_int_cst (arg_type, 0));
+  se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
+			      bit_size, leadz);
+}
+
+
+/* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
+
+   The conditional expression is necessary because the result of TRAILZ(0)
+   is defined, but the result of __builtin_ctz(0) is undefined for most
+   targets.  */
+ 
+static void
+gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
+{
+  tree arg;
+  tree arg_type;
+  tree cond;
+  tree result_type;
+  tree trailz;
+  tree bit_size;
+  tree func;
+  int argsize;
+
+  gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+  argsize = TYPE_PRECISION (TREE_TYPE (arg));
+
+  /* Which variant of __builtin_ctz* should we call?  */
+  if (argsize <= INT_TYPE_SIZE)
+    {
+      arg_type = unsigned_type_node;
+      func = builtin_decl_explicit (BUILT_IN_CTZ);
+    }
+  else if (argsize <= LONG_TYPE_SIZE)
+    {
+      arg_type = long_unsigned_type_node;
+      func = builtin_decl_explicit (BUILT_IN_CTZL);
+    }
+  else if (argsize <= LONG_LONG_TYPE_SIZE)
+    {
+      arg_type = long_long_unsigned_type_node;
+      func = builtin_decl_explicit (BUILT_IN_CTZLL);
+    }
+  else
+    {
+      gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
+      arg_type = gfc_build_uint_type (argsize);
+      func = NULL_TREE;
+    }
+
+  /* Convert the actual argument twice: first, to the unsigned type of the
+     same size; then, to the proper argument type for the built-in
+     function.  But the return type is of the default INTEGER kind.  */
+  arg = fold_convert (gfc_build_uint_type (argsize), arg);
+  arg = fold_convert (arg_type, arg);
+  arg = gfc_evaluate_now (arg, &se->pre);
+  result_type = gfc_get_int_type (gfc_default_integer_kind);
+
+  /* Compute TRAILZ for the case i .ne. 0.  */
+  if (func)
+    trailz = fold_convert (result_type, build_call_expr_loc (input_location,
+							     func, 1, arg));
+  else
+    {
+      /* We end up here if the argument type is larger than 'long long'.
+	 We generate this code:
+  
+	    if ((x & ULL_MAX) == 0)
+	      return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
+	    else
+	      return ctzll ((unsigned long long) x);
+
+	 where ULL_MAX is the largest value that a ULL_MAX can hold
+	 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
+	 is the bit-size of the long long type (64 in this example).  */
+      tree ullsize, ullmax, tmp1, tmp2, btmp;
+
+      ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
+      ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
+				long_long_unsigned_type_node,
+				build_int_cst (long_long_unsigned_type_node, 0));
+
+      cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, arg,
+			      fold_convert (arg_type, ullmax));
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, cond,
+			      build_int_cst (arg_type, 0));
+
+      tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
+			      arg, ullsize);
+      tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
+      btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
+      tmp1 = fold_convert (result_type,
+			   build_call_expr_loc (input_location, btmp, 1, tmp1));
+      tmp1 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
+			      tmp1, ullsize);
+
+      tmp2 = fold_convert (long_long_unsigned_type_node, arg);
+      btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
+      tmp2 = fold_convert (result_type,
+			   build_call_expr_loc (input_location, btmp, 1, tmp2));
+
+      trailz = fold_build3_loc (input_location, COND_EXPR, result_type,
+				cond, tmp1, tmp2);
+    }
+
+  /* Build BIT_SIZE.  */
+  bit_size = build_int_cst (result_type, argsize);
+
+  cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+			  arg, build_int_cst (arg_type, 0));
+  se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
+			      bit_size, trailz);
+}
+
+/* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
+   for types larger than "long long", we call the long long built-in for
+   the lower and higher bits and combine the result.  */
+ 
+static void
+gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity)
+{
+  tree arg;
+  tree arg_type;
+  tree result_type;
+  tree func;
+  int argsize;
+
+  gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+  argsize = TYPE_PRECISION (TREE_TYPE (arg));
+  result_type = gfc_get_int_type (gfc_default_integer_kind);
+
+  /* Which variant of the builtin should we call?  */
+  if (argsize <= INT_TYPE_SIZE)
+    {
+      arg_type = unsigned_type_node;
+      func = builtin_decl_explicit (parity
+				    ? BUILT_IN_PARITY
+				    : BUILT_IN_POPCOUNT);
+    }
+  else if (argsize <= LONG_TYPE_SIZE)
+    {
+      arg_type = long_unsigned_type_node;
+      func = builtin_decl_explicit (parity
+				    ? BUILT_IN_PARITYL
+				    : BUILT_IN_POPCOUNTL);
+    }
+  else if (argsize <= LONG_LONG_TYPE_SIZE)
+    {
+      arg_type = long_long_unsigned_type_node;
+      func = builtin_decl_explicit (parity
+				    ? BUILT_IN_PARITYLL
+				    : BUILT_IN_POPCOUNTLL);
+    }
+  else
+    {
+      /* Our argument type is larger than 'long long', which mean none
+	 of the POPCOUNT builtins covers it.  We thus call the 'long long'
+	 variant multiple times, and add the results.  */
+      tree utype, arg2, call1, call2;
+
+      /* For now, we only cover the case where argsize is twice as large
+	 as 'long long'.  */
+      gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
+
+      func = builtin_decl_explicit (parity
+				    ? BUILT_IN_PARITYLL
+				    : BUILT_IN_POPCOUNTLL);
+
+      /* Convert it to an integer, and store into a variable.  */
+      utype = gfc_build_uint_type (argsize);
+      arg = fold_convert (utype, arg);
+      arg = gfc_evaluate_now (arg, &se->pre);
+
+      /* Call the builtin twice.  */
+      call1 = build_call_expr_loc (input_location, func, 1,
+				   fold_convert (long_long_unsigned_type_node,
+						 arg));
+
+      arg2 = fold_build2_loc (input_location, RSHIFT_EXPR, utype, arg,
+			      build_int_cst (utype, LONG_LONG_TYPE_SIZE));
+      call2 = build_call_expr_loc (input_location, func, 1,
+				   fold_convert (long_long_unsigned_type_node,
+						 arg2));
+			  
+      /* Combine the results.  */
+      if (parity)
+	se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, result_type,
+				    call1, call2);
+      else
+	se->expr = fold_build2_loc (input_location, PLUS_EXPR, result_type,
+				    call1, call2);
+
+      return;
+    }
+
+  /* Convert the actual argument twice: first, to the unsigned type of the
+     same size; then, to the proper argument type for the built-in
+     function.  */
+  arg = fold_convert (gfc_build_uint_type (argsize), arg);
+  arg = fold_convert (arg_type, arg);
+
+  se->expr = fold_convert (result_type,
+			   build_call_expr_loc (input_location, func, 1, arg));
+}
+
+
+/* Process an intrinsic with unspecified argument-types that has an optional
+   argument (which could be of type character), e.g. EOSHIFT.  For those, we
+   need to append the string length of the optional argument if it is not
+   present and the type is really character.
+   primary specifies the position (starting at 1) of the non-optional argument
+   specifying the type and optional gives the position of the optional
+   argument in the arglist.  */
+
+static void
+conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
+				     unsigned primary, unsigned optional)
+{
+  gfc_actual_arglist* prim_arg;
+  gfc_actual_arglist* opt_arg;
+  unsigned cur_pos;
+  gfc_actual_arglist* arg;
+  gfc_symbol* sym;
+  vec<tree, va_gc> *append_args;
+
+  /* Find the two arguments given as position.  */
+  cur_pos = 0;
+  prim_arg = NULL;
+  opt_arg = NULL;
+  for (arg = expr->value.function.actual; arg; arg = arg->next)
+    {
+      ++cur_pos;
+
+      if (cur_pos == primary)
+	prim_arg = arg;
+      if (cur_pos == optional)
+	opt_arg = arg;
+
+      if (cur_pos >= primary && cur_pos >= optional)
+	break;
+    }
+  gcc_assert (prim_arg);
+  gcc_assert (prim_arg->expr);
+  gcc_assert (opt_arg);
+
+  /* If we do have type CHARACTER and the optional argument is really absent,
+     append a dummy 0 as string length.  */
+  append_args = NULL;
+  if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
+    {
+      tree dummy;
+
+      dummy = build_int_cst (gfc_charlen_type_node, 0);
+      vec_alloc (append_args, 1);
+      append_args->quick_push (dummy);
+    }
+
+  /* Build the call itself.  */
+  sym = gfc_get_symbol_for_expr (expr);
+  gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
+			  append_args);
+  gfc_free_symbol (sym);
+}
+
+
+/* The length of a character string.  */
+static void
+gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
+{
+  tree len;
+  tree type;
+  tree decl;
+  gfc_symbol *sym;
+  gfc_se argse;
+  gfc_expr *arg;
+
+  gcc_assert (!se->ss);
+
+  arg = expr->value.function.actual->expr;
+
+  type = gfc_typenode_for_spec (&expr->ts);
+  switch (arg->expr_type)
+    {
+    case EXPR_CONSTANT:
+      len = build_int_cst (gfc_charlen_type_node, arg->value.character.length);
+      break;
+
+    case EXPR_ARRAY:
+      /* Obtain the string length from the function used by
+         trans-array.c(gfc_trans_array_constructor).  */
+      len = NULL_TREE;
+      get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
+      break;
+
+    case EXPR_VARIABLE:
+      if (arg->ref == NULL
+	    || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
+	{
+	  /* This doesn't catch all cases.
+	     See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
+	     and the surrounding thread.  */
+	  sym = arg->symtree->n.sym;
+	  decl = gfc_get_symbol_decl (sym);
+	  if (decl == current_function_decl && sym->attr.function
+		&& (sym->result == sym))
+	    decl = gfc_get_fake_result_decl (sym, 0);
+
+	  len = sym->ts.u.cl->backend_decl;
+	  gcc_assert (len);
+	  break;
+	}
+
+      /* Otherwise fall through.  */
+
+    default:
+      /* Anybody stupid enough to do this deserves inefficient code.  */
+      gfc_init_se (&argse, se);
+      if (arg->rank == 0)
+	gfc_conv_expr (&argse, arg);
+      else
+	gfc_conv_expr_descriptor (&argse, arg);
+      gfc_add_block_to_block (&se->pre, &argse.pre);
+      gfc_add_block_to_block (&se->post, &argse.post);
+      len = argse.string_length;
+      break;
+    }
+  se->expr = convert (type, len);
+}
+
+/* The length of a character string not including trailing blanks.  */
+static void
+gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
+{
+  int kind = expr->value.function.actual->expr->ts.kind;
+  tree args[2], type, fndecl;
+
+  gfc_conv_intrinsic_function_args (se, expr, args, 2);
+  type = gfc_typenode_for_spec (&expr->ts);
+
+  if (kind == 1)
+    fndecl = gfor_fndecl_string_len_trim;
+  else if (kind == 4)
+    fndecl = gfor_fndecl_string_len_trim_char4;
+  else
+    gcc_unreachable ();
+
+  se->expr = build_call_expr_loc (input_location,
+			      fndecl, 2, args[0], args[1]);
+  se->expr = convert (type, se->expr);
+}
+
+
+/* Returns the starting position of a substring within a string.  */
+
+static void
+gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
+				      tree function)
+{
+  tree logical4_type_node = gfc_get_logical_type (4);
+  tree type;
+  tree fndecl;
+  tree *args;
+  unsigned int num_args;
+
+  args = XALLOCAVEC (tree, 5);
+
+  /* Get number of arguments; characters count double due to the
+     string length argument. Kind= is not passed to the library
+     and thus ignored.  */
+  if (expr->value.function.actual->next->next->expr == NULL)
+    num_args = 4;
+  else
+    num_args = 5;
+
+  gfc_conv_intrinsic_function_args (se, expr, args, num_args);
+  type = gfc_typenode_for_spec (&expr->ts);
+
+  if (num_args == 4)
+    args[4] = build_int_cst (logical4_type_node, 0);
+  else
+    args[4] = convert (logical4_type_node, args[4]);
+
+  fndecl = build_addr (function, current_function_decl);
+  se->expr = build_call_array_loc (input_location,
+			       TREE_TYPE (TREE_TYPE (function)), fndecl,
+			       5, args);
+  se->expr = convert (type, se->expr);
+
+}
+
+/* The ascii value for a single character.  */
+static void
+gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
+{
+  tree args[2], type, pchartype;
+  int nargs;
+
+  nargs = gfc_intrinsic_argument_list_length (expr);
+  gfc_conv_intrinsic_function_args (se, expr, args, nargs);
+  gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
+  pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
+  args[1] = fold_build1_loc (input_location, NOP_EXPR, pchartype, args[1]);
+  type = gfc_typenode_for_spec (&expr->ts);
+
+  se->expr = build_fold_indirect_ref_loc (input_location,
+				      args[1]);
+  se->expr = convert (type, se->expr);
+}
+
+
+/* Intrinsic ISNAN calls __builtin_isnan.  */
+
+static void
+gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
+{
+  tree arg;
+
+  gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+  se->expr = build_call_expr_loc (input_location,
+				  builtin_decl_explicit (BUILT_IN_ISNAN),
+				  1, arg);
+  STRIP_TYPE_NOPS (se->expr);
+  se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
+}
+
+
+/* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
+   their argument against a constant integer value.  */
+
+static void
+gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
+{
+  tree arg;
+
+  gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+  se->expr = fold_build2_loc (input_location, EQ_EXPR,
+			      gfc_typenode_for_spec (&expr->ts),
+			      arg, build_int_cst (TREE_TYPE (arg), value));
+}
+
+
+
+/* MERGE (tsource, fsource, mask) = mask ? tsource : fsource.  */
+
+static void
+gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
+{
+  tree tsource;
+  tree fsource;
+  tree mask;
+  tree type;
+  tree len, len2;
+  tree *args;
+  unsigned int num_args;
+
+  num_args = gfc_intrinsic_argument_list_length (expr);
+  args = XALLOCAVEC (tree, num_args);
+
+  gfc_conv_intrinsic_function_args (se, expr, args, num_args);
+  if (expr->ts.type != BT_CHARACTER)
+    {
+      tsource = args[0];
+      fsource = args[1];
+      mask = args[2];
+    }
+  else
+    {
+      /* We do the same as in the non-character case, but the argument
+	 list is different because of the string length arguments. We
+	 also have to set the string length for the result.  */
+      len = args[0];
+      tsource = args[1];
+      len2 = args[2];
+      fsource = args[3];
+      mask = args[4];
+
+      gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
+				   &se->pre);
+      se->string_length = len;
+    }
+  type = TREE_TYPE (tsource);
+  se->expr = fold_build3_loc (input_location, COND_EXPR, type, mask, tsource,
+			      fold_convert (type, fsource));
+}
+
+
+/* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)).  */
+
+static void
+gfc_conv_intrinsic_merge_bits (gfc_se * se, gfc_expr * expr)
+{
+  tree args[3], mask, type;
+
+  gfc_conv_intrinsic_function_args (se, expr, args, 3);
+  mask = gfc_evaluate_now (args[2], &se->pre);
+
+  type = TREE_TYPE (args[0]);
+  gcc_assert (TREE_TYPE (args[1]) == type);
+  gcc_assert (TREE_TYPE (mask) == type);
+
+  args[0] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], mask);
+  args[1] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[1],
+			     fold_build1_loc (input_location, BIT_NOT_EXPR,
+					      type, mask));
+  se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
+			      args[0], args[1]);
+}
+
+
+/* MASKL(n)  =  n == 0 ? 0 : (~0) << (BIT_SIZE - n)
+   MASKR(n)  =  n == BIT_SIZE ? ~0 : ~((~0) << n)  */
+
+static void
+gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left)
+{
+  tree arg, allones, type, utype, res, cond, bitsize;
+  int i;
+ 
+  gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+  arg = gfc_evaluate_now (arg, &se->pre);
+
+  type = gfc_get_int_type (expr->ts.kind);
+  utype = unsigned_type_for (type);
+
+  i = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
+  bitsize = build_int_cst (TREE_TYPE (arg), gfc_integer_kinds[i].bit_size);
+
+  allones = fold_build1_loc (input_location, BIT_NOT_EXPR, utype,
+			     build_int_cst (utype, 0));
+
+  if (left)
+    {
+      /* Left-justified mask.  */
+      res = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (arg),
+			     bitsize, arg);
+      res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
+			     fold_convert (utype, res));
+
+      /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
+	 smaller than type width.  */
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg,
+			      build_int_cst (TREE_TYPE (arg), 0));
+      res = fold_build3_loc (input_location, COND_EXPR, utype, cond,
+			     build_int_cst (utype, 0), res);
+    }
+  else
+    {
+      /* Right-justified mask.  */
+      res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
+			     fold_convert (utype, arg));
+      res = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, res);
+
+      /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
+	 strictly smaller than type width.  */
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+			      arg, bitsize);
+      res = fold_build3_loc (input_location, COND_EXPR, utype,
+			     cond, allones, res);
+    }
+
+  se->expr = fold_convert (type, res);
+}
+
+
+/* FRACTION (s) is translated into frexp (s, &dummy_int).  */
+static void
+gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
+{
+  tree arg, type, tmp, frexp;
+
+  frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
+
+  type = gfc_typenode_for_spec (&expr->ts);
+  gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+  tmp = gfc_create_var (integer_type_node, NULL);
+  se->expr = build_call_expr_loc (input_location, frexp, 2,
+				  fold_convert (type, arg),
+				  gfc_build_addr_expr (NULL_TREE, tmp));
+  se->expr = fold_convert (type, se->expr);
+}
+
+
+/* NEAREST (s, dir) is translated into
+     tmp = copysign (HUGE_VAL, dir);
+     return nextafter (s, tmp);
+ */
+static void
+gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
+{
+  tree args[2], type, tmp, nextafter, copysign, huge_val;
+
+  nextafter = gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind);
+  copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
+
+  type = gfc_typenode_for_spec (&expr->ts);
+  gfc_conv_intrinsic_function_args (se, expr, args, 2);
+
+  huge_val = gfc_build_inf_or_huge (type, expr->ts.kind);
+  tmp = build_call_expr_loc (input_location, copysign, 2, huge_val,
+			     fold_convert (type, args[1]));
+  se->expr = build_call_expr_loc (input_location, nextafter, 2,
+				  fold_convert (type, args[0]), tmp);
+  se->expr = fold_convert (type, se->expr);
+}
+
+
+/* SPACING (s) is translated into
+    int e;
+    if (s == 0)
+      res = tiny;
+    else
+    {
+      frexp (s, &e);
+      e = e - prec;
+      e = MAX_EXPR (e, emin);
+      res = scalbn (1., e);
+    }
+    return res;
+
+ where prec is the precision of s, gfc_real_kinds[k].digits,
+       emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
+   and tiny is tiny(s), gfc_real_kinds[k].tiny.  */
+
+static void
+gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
+{
+  tree arg, type, prec, emin, tiny, res, e;
+  tree cond, tmp, frexp, scalbn;
+  int k;
+  stmtblock_t block;
+
+  k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
+  prec = build_int_cst (integer_type_node, gfc_real_kinds[k].digits);
+  emin = build_int_cst (integer_type_node, gfc_real_kinds[k].min_exponent - 1);
+  tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
+
+  frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
+  scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
+
+  gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+  arg = gfc_evaluate_now (arg, &se->pre);
+
+  type = gfc_typenode_for_spec (&expr->ts);
+  e = gfc_create_var (integer_type_node, NULL);
+  res = gfc_create_var (type, NULL);
+
+
+  /* Build the block for s /= 0.  */
+  gfc_start_block (&block);
+  tmp = build_call_expr_loc (input_location, frexp, 2, arg,
+			     gfc_build_addr_expr (NULL_TREE, e));
+  gfc_add_expr_to_block (&block, tmp);
+
+  tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, e,
+			 prec);
+  gfc_add_modify (&block, e, fold_build2_loc (input_location, MAX_EXPR,
+					      integer_type_node, tmp, emin));
+
+  tmp = build_call_expr_loc (input_location, scalbn, 2,
+			 build_real_from_int_cst (type, integer_one_node), e);
+  gfc_add_modify (&block, res, tmp);
+
+  /* Finish by building the IF statement.  */
+  cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg,
+			  build_real_from_int_cst (type, integer_zero_node));
+  tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
+		  gfc_finish_block (&block));
+
+  gfc_add_expr_to_block (&se->pre, tmp);
+  se->expr = res;
+}
+
+
+/* RRSPACING (s) is translated into
+      int e;
+      real x;
+      x = fabs (s);
+      if (x != 0)
+      {
+	frexp (s, &e);
+	x = scalbn (x, precision - e);
+      }
+      return x;
+
+ where precision is gfc_real_kinds[k].digits.  */
+
+static void
+gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
+{
+  tree arg, type, e, x, cond, stmt, tmp, frexp, scalbn, fabs;
+  int prec, k;
+  stmtblock_t block;
+
+  k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
+  prec = gfc_real_kinds[k].digits;
+
+  frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
+  scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
+  fabs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
+
+  type = gfc_typenode_for_spec (&expr->ts);
+  gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+  arg = gfc_evaluate_now (arg, &se->pre);
+
+  e = gfc_create_var (integer_type_node, NULL);
+  x = gfc_create_var (type, NULL);
+  gfc_add_modify (&se->pre, x,
+		  build_call_expr_loc (input_location, fabs, 1, arg));
+
+
+  gfc_start_block (&block);
+  tmp = build_call_expr_loc (input_location, frexp, 2, arg,
+			     gfc_build_addr_expr (NULL_TREE, e));
+  gfc_add_expr_to_block (&block, tmp);
+
+  tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
+			 build_int_cst (integer_type_node, prec), e);
+  tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp);
+  gfc_add_modify (&block, x, tmp);
+  stmt = gfc_finish_block (&block);
+
+  cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, x,
+			  build_real_from_int_cst (type, integer_zero_node));
+  tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  se->expr = fold_convert (type, x);
+}
+
+
+/* SCALE (s, i) is translated into scalbn (s, i).  */
+static void
+gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
+{
+  tree args[2], type, scalbn;
+
+  scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
+
+  type = gfc_typenode_for_spec (&expr->ts);
+  gfc_conv_intrinsic_function_args (se, expr, args, 2);
+  se->expr = build_call_expr_loc (input_location, scalbn, 2,
+				  fold_convert (type, args[0]),
+				  fold_convert (integer_type_node, args[1]));
+  se->expr = fold_convert (type, se->expr);
+}
+
+
+/* SET_EXPONENT (s, i) is translated into
+   scalbn (frexp (s, &dummy_int), i).  */
+static void
+gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
+{
+  tree args[2], type, tmp, frexp, scalbn;
+
+  frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
+  scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
+
+  type = gfc_typenode_for_spec (&expr->ts);
+  gfc_conv_intrinsic_function_args (se, expr, args, 2);
+
+  tmp = gfc_create_var (integer_type_node, NULL);
+  tmp = build_call_expr_loc (input_location, frexp, 2,
+			     fold_convert (type, args[0]),
+			     gfc_build_addr_expr (NULL_TREE, tmp));
+  se->expr = build_call_expr_loc (input_location, scalbn, 2, tmp,
+				  fold_convert (integer_type_node, args[1]));
+  se->expr = fold_convert (type, se->expr);
+}
+
+
+static void
+gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
+{
+  gfc_actual_arglist *actual;
+  tree arg1;
+  tree type;
+  tree fncall0;
+  tree fncall1;
+  gfc_se argse;
+
+  gfc_init_se (&argse, NULL);
+  actual = expr->value.function.actual;
+
+  if (actual->expr->ts.type == BT_CLASS)
+    gfc_add_class_array_ref (actual->expr);
+
+  argse.want_pointer = 1;
+  argse.data_not_needed = 1;
+  gfc_conv_expr_descriptor (&argse, actual->expr);
+  gfc_add_block_to_block (&se->pre, &argse.pre);
+  gfc_add_block_to_block (&se->post, &argse.post);
+  arg1 = gfc_evaluate_now (argse.expr, &se->pre);
+
+  /* Build the call to size0.  */
+  fncall0 = build_call_expr_loc (input_location,
+			     gfor_fndecl_size0, 1, arg1);
+
+  actual = actual->next;
+
+  if (actual->expr)
+    {
+      gfc_init_se (&argse, NULL);
+      gfc_conv_expr_type (&argse, actual->expr,
+			  gfc_array_index_type);
+      gfc_add_block_to_block (&se->pre, &argse.pre);
+
+      /* Unusually, for an intrinsic, size does not exclude
+	 an optional arg2, so we must test for it.  */  
+      if (actual->expr->expr_type == EXPR_VARIABLE
+	    && actual->expr->symtree->n.sym->attr.dummy
+	    && actual->expr->symtree->n.sym->attr.optional)
+	{
+	  tree tmp;
+	  /* Build the call to size1.  */
+	  fncall1 = build_call_expr_loc (input_location,
+				     gfor_fndecl_size1, 2,
+				     arg1, argse.expr);
+
+	  gfc_init_se (&argse, NULL);
+	  argse.want_pointer = 1;
+	  argse.data_not_needed = 1;
+	  gfc_conv_expr (&argse, actual->expr);
+	  gfc_add_block_to_block (&se->pre, &argse.pre);
+	  tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+				 argse.expr, null_pointer_node);
+	  tmp = gfc_evaluate_now (tmp, &se->pre);
+	  se->expr = fold_build3_loc (input_location, COND_EXPR,
+				      pvoid_type_node, tmp, fncall1, fncall0);
+	}
+      else
+	{
+	  se->expr = NULL_TREE;
+	  argse.expr = fold_build2_loc (input_location, MINUS_EXPR,
+					gfc_array_index_type,
+					argse.expr, gfc_index_one_node);
+	}
+    }
+  else if (expr->value.function.actual->expr->rank == 1)
+    {
+      argse.expr = gfc_index_zero_node;
+      se->expr = NULL_TREE;
+    }
+  else
+    se->expr = fncall0;
+
+  if (se->expr == NULL_TREE)
+    {
+      tree ubound, lbound;
+
+      arg1 = build_fold_indirect_ref_loc (input_location,
+				      arg1);
+      ubound = gfc_conv_descriptor_ubound_get (arg1, argse.expr);
+      lbound = gfc_conv_descriptor_lbound_get (arg1, argse.expr);
+      se->expr = fold_build2_loc (input_location, MINUS_EXPR,
+				  gfc_array_index_type, ubound, lbound);
+      se->expr = fold_build2_loc (input_location, PLUS_EXPR,
+				  gfc_array_index_type,
+				  se->expr, gfc_index_one_node);
+      se->expr = fold_build2_loc (input_location, MAX_EXPR,
+				  gfc_array_index_type, se->expr,
+				  gfc_index_zero_node);
+    }
+
+  type = gfc_typenode_for_spec (&expr->ts);
+  se->expr = convert (type, se->expr);
+}
+
+
+/* Helper function to compute the size of a character variable,
+   excluding the terminating null characters.  The result has
+   gfc_array_index_type type.  */
+
+tree
+size_of_string_in_bytes (int kind, tree string_length)
+{
+  tree bytesize;
+  int i = gfc_validate_kind (BT_CHARACTER, kind, false);
+ 
+  bytesize = build_int_cst (gfc_array_index_type,
+			    gfc_character_kinds[i].bit_size / 8);
+
+  return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			  bytesize,
+			  fold_convert (gfc_array_index_type, string_length));
+}
+
+
+static void
+gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
+{
+  gfc_expr *arg;
+  gfc_se argse;
+  tree source_bytes;
+  tree type;
+  tree tmp;
+  tree lower;
+  tree upper;
+  int n;
+
+  arg = expr->value.function.actual->expr;
+
+  gfc_init_se (&argse, NULL);
+
+  if (arg->rank == 0)
+    {
+      if (arg->ts.type == BT_CLASS)
+	gfc_add_data_component (arg);
+
+      gfc_conv_expr_reference (&argse, arg);
+
+      type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
+						 argse.expr));
+
+      /* Obtain the source word length.  */
+      if (arg->ts.type == BT_CHARACTER)
+	se->expr = size_of_string_in_bytes (arg->ts.kind,
+					    argse.string_length);
+      else
+	se->expr = fold_convert (gfc_array_index_type, size_in_bytes (type)); 
+    }
+  else
+    {
+      source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
+      argse.want_pointer = 0;
+      gfc_conv_expr_descriptor (&argse, arg);
+      type = gfc_get_element_type (TREE_TYPE (argse.expr));
+
+      /* Obtain the argument's word length.  */
+      if (arg->ts.type == BT_CHARACTER)
+	tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
+      else
+	tmp = fold_convert (gfc_array_index_type,
+			    size_in_bytes (type)); 
+      gfc_add_modify (&argse.pre, source_bytes, tmp);
+
+      /* Obtain the size of the array in bytes.  */
+      for (n = 0; n < arg->rank; n++)
+	{
+	  tree idx;
+	  idx = gfc_rank_cst[n];
+	  lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
+	  upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
+	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				 gfc_array_index_type, upper, lower);
+	  tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type, tmp, gfc_index_one_node);
+	  tmp = fold_build2_loc (input_location, MULT_EXPR,
+				 gfc_array_index_type, tmp, source_bytes);
+	  gfc_add_modify (&argse.pre, source_bytes, tmp);
+	}
+      se->expr = source_bytes;
+    }
+
+  gfc_add_block_to_block (&se->pre, &argse.pre);
+}
+
+
+static void
+gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
+{
+  gfc_expr *arg;
+  gfc_se argse;
+  tree type, result_type, tmp;
+
+  arg = expr->value.function.actual->expr;
+  
+  gfc_init_se (&argse, NULL);
+  result_type = gfc_get_int_type (expr->ts.kind);
+
+  if (arg->rank == 0)
+    {
+      if (arg->ts.type == BT_CLASS)
+      {
+	gfc_add_vptr_component (arg);
+	gfc_add_size_component (arg);
+	gfc_conv_expr (&argse, arg);
+	tmp = fold_convert (result_type, argse.expr);
+	goto done;
+      }
+
+      gfc_conv_expr_reference (&argse, arg);
+      type = TREE_TYPE (build_fold_indirect_ref_loc (input_location, 
+						     argse.expr));
+    }
+  else
+    {
+      argse.want_pointer = 0;
+      gfc_conv_expr_descriptor (&argse, arg);
+      type = gfc_get_element_type (TREE_TYPE (argse.expr));
+    }
+    
+  /* Obtain the argument's word length.  */
+  if (arg->ts.type == BT_CHARACTER)
+    tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
+  else
+    tmp = size_in_bytes (type); 
+  tmp = fold_convert (result_type, tmp);
+
+done:
+  se->expr = fold_build2_loc (input_location, MULT_EXPR, result_type, tmp,
+			      build_int_cst (result_type, BITS_PER_UNIT));
+  gfc_add_block_to_block (&se->pre, &argse.pre);
+}
+
+
+/* Intrinsic string comparison functions.  */
+
+static void
+gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
+{
+  tree args[4];
+
+  gfc_conv_intrinsic_function_args (se, expr, args, 4);
+
+  se->expr
+    = gfc_build_compare_string (args[0], args[1], args[2], args[3],
+				expr->value.function.actual->expr->ts.kind,
+				op);
+  se->expr = fold_build2_loc (input_location, op,
+			      gfc_typenode_for_spec (&expr->ts), se->expr,
+			      build_int_cst (TREE_TYPE (se->expr), 0));
+}
+
+/* Generate a call to the adjustl/adjustr library function.  */
+static void
+gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
+{
+  tree args[3];
+  tree len;
+  tree type;
+  tree var;
+  tree tmp;
+
+  gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
+  len = args[1];
+
+  type = TREE_TYPE (args[2]);
+  var = gfc_conv_string_tmp (se, type, len);
+  args[0] = var;
+
+  tmp = build_call_expr_loc (input_location,
+			 fndecl, 3, args[0], args[1], args[2]);
+  gfc_add_expr_to_block (&se->pre, tmp);
+  se->expr = var;
+  se->string_length = len;
+}
+
+
+/* Generate code for the TRANSFER intrinsic:
+	For scalar results:
+	  DEST = TRANSFER (SOURCE, MOLD)
+	where:
+	  typeof<DEST> = typeof<MOLD>
+	and:
+	  MOLD is scalar.
+
+	For array results:
+	  DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
+	where:
+	  typeof<DEST> = typeof<MOLD>
+	and:
+	  N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
+	      sizeof (DEST(0) * SIZE).  */
+static void
+gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
+{
+  tree tmp;
+  tree tmpdecl;
+  tree ptr;
+  tree extent;
+  tree source;
+  tree source_type;
+  tree source_bytes;
+  tree mold_type;
+  tree dest_word_len;
+  tree size_words;
+  tree size_bytes;
+  tree upper;
+  tree lower;
+  tree stmt;
+  gfc_actual_arglist *arg;
+  gfc_se argse;
+  gfc_array_info *info;
+  stmtblock_t block;
+  int n;
+  bool scalar_mold;
+  gfc_expr *source_expr, *mold_expr;
+
+  info = NULL;
+  if (se->loop)
+    info = &se->ss->info->data.array;
+
+  /* Convert SOURCE.  The output from this stage is:-
+	source_bytes = length of the source in bytes
+	source = pointer to the source data.  */
+  arg = expr->value.function.actual;
+  source_expr = arg->expr;
+
+  /* Ensure double transfer through LOGICAL preserves all
+     the needed bits.  */
+  if (arg->expr->expr_type == EXPR_FUNCTION
+	&& arg->expr->value.function.esym == NULL
+	&& arg->expr->value.function.isym != NULL
+	&& arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
+	&& arg->expr->ts.type == BT_LOGICAL
+	&& expr->ts.type != arg->expr->ts.type)
+    arg->expr->value.function.name = "__transfer_in_transfer";
+
+  gfc_init_se (&argse, NULL);
+
+  source_bytes = gfc_create_var (gfc_array_index_type, NULL);
+
+  /* Obtain the pointer to source and the length of source in bytes.  */
+  if (arg->expr->rank == 0)
+    {
+      gfc_conv_expr_reference (&argse, arg->expr);
+      if (arg->expr->ts.type == BT_CLASS)
+	source = gfc_class_data_get (argse.expr);
+      else
+	source = argse.expr;
+
+      /* Obtain the source word length.  */
+      switch (arg->expr->ts.type)
+	{
+	case BT_CHARACTER:
+	  tmp = size_of_string_in_bytes (arg->expr->ts.kind,
+					 argse.string_length);
+	  break;
+	case BT_CLASS:
+	  tmp = gfc_vtable_size_get (argse.expr);
+	  break;
+	default:
+	  source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
+								source));
+	  tmp = fold_convert (gfc_array_index_type,
+			      size_in_bytes (source_type));
+	  break;
+	}
+    }
+  else
+    {
+      argse.want_pointer = 0;
+      gfc_conv_expr_descriptor (&argse, arg->expr);
+      source = gfc_conv_descriptor_data_get (argse.expr);
+      source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
+
+      /* Repack the source if not simply contiguous.  */
+      if (!gfc_is_simply_contiguous (arg->expr, false))
+	{
+	  tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
+
+	  if (gfc_option.warn_array_temp)
+	    gfc_warning ("Creating array temporary at %L", &expr->where);
+
+	  source = build_call_expr_loc (input_location,
+				    gfor_fndecl_in_pack, 1, tmp);
+	  source = gfc_evaluate_now (source, &argse.pre);
+
+	  /* Free the temporary.  */
+	  gfc_start_block (&block);
+	  tmp = gfc_call_free (convert (pvoid_type_node, source));
+	  gfc_add_expr_to_block (&block, tmp);
+	  stmt = gfc_finish_block (&block);
+
+	  /* Clean up if it was repacked.  */
+	  gfc_init_block (&block);
+	  tmp = gfc_conv_array_data (argse.expr);
+	  tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+				 source, tmp);
+	  tmp = build3_v (COND_EXPR, tmp, stmt,
+			  build_empty_stmt (input_location));
+	  gfc_add_expr_to_block (&block, tmp);
+	  gfc_add_block_to_block (&block, &se->post);
+	  gfc_init_block (&se->post);
+	  gfc_add_block_to_block (&se->post, &block);
+	}
+
+      /* Obtain the source word length.  */
+      if (arg->expr->ts.type == BT_CHARACTER)
+	tmp = size_of_string_in_bytes (arg->expr->ts.kind,
+				       argse.string_length);
+      else
+	tmp = fold_convert (gfc_array_index_type,
+			    size_in_bytes (source_type)); 
+
+      /* Obtain the size of the array in bytes.  */
+      extent = gfc_create_var (gfc_array_index_type, NULL);
+      for (n = 0; n < arg->expr->rank; n++)
+	{
+	  tree idx;
+	  idx = gfc_rank_cst[n];
+	  gfc_add_modify (&argse.pre, source_bytes, tmp);
+	  lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
+	  upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
+	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				 gfc_array_index_type, upper, lower);
+	  gfc_add_modify (&argse.pre, extent, tmp);
+	  tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type, extent,
+				 gfc_index_one_node);
+	  tmp = fold_build2_loc (input_location, MULT_EXPR,
+				 gfc_array_index_type, tmp, source_bytes);
+	}
+    }
+
+  gfc_add_modify (&argse.pre, source_bytes, tmp);
+  gfc_add_block_to_block (&se->pre, &argse.pre);
+  gfc_add_block_to_block (&se->post, &argse.post);
+
+  /* Now convert MOLD.  The outputs are:
+	mold_type = the TREE type of MOLD
+	dest_word_len = destination word length in bytes.  */
+  arg = arg->next;
+  mold_expr = arg->expr;
+
+  gfc_init_se (&argse, NULL);
+
+  scalar_mold = arg->expr->rank == 0;
+
+  if (arg->expr->rank == 0)
+    {
+      gfc_conv_expr_reference (&argse, arg->expr);
+      mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
+							  argse.expr));
+    }
+  else
+    {
+      gfc_init_se (&argse, NULL);
+      argse.want_pointer = 0;
+      gfc_conv_expr_descriptor (&argse, arg->expr);
+      mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
+    }
+
+  gfc_add_block_to_block (&se->pre, &argse.pre);
+  gfc_add_block_to_block (&se->post, &argse.post);
+
+  if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
+    {
+      /* If this TRANSFER is nested in another TRANSFER, use a type
+	 that preserves all bits.  */
+      if (arg->expr->ts.type == BT_LOGICAL)
+	mold_type = gfc_get_int_type (arg->expr->ts.kind);
+    }
+
+  /* Obtain the destination word length.  */
+  switch (arg->expr->ts.type)
+    {
+    case BT_CHARACTER:
+      tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
+      mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
+      break;
+    case BT_CLASS:
+      tmp = gfc_vtable_size_get (argse.expr);
+      break;
+    default:
+      tmp = fold_convert (gfc_array_index_type, size_in_bytes (mold_type));
+      break;
+    }
+  dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
+  gfc_add_modify (&se->pre, dest_word_len, tmp);
+
+  /* Finally convert SIZE, if it is present.  */
+  arg = arg->next;
+  size_words = gfc_create_var (gfc_array_index_type, NULL);
+
+  if (arg->expr)
+    {
+      gfc_init_se (&argse, NULL);
+      gfc_conv_expr_reference (&argse, arg->expr);
+      tmp = convert (gfc_array_index_type,
+		     build_fold_indirect_ref_loc (input_location,
+					      argse.expr));
+      gfc_add_block_to_block (&se->pre, &argse.pre);
+      gfc_add_block_to_block (&se->post, &argse.post);
+    }
+  else
+    tmp = NULL_TREE;
+
+  /* Separate array and scalar results.  */
+  if (scalar_mold && tmp == NULL_TREE)
+    goto scalar_transfer;
+
+  size_bytes = gfc_create_var (gfc_array_index_type, NULL);
+  if (tmp != NULL_TREE)
+    tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			   tmp, dest_word_len);
+  else
+    tmp = source_bytes;
+
+  gfc_add_modify (&se->pre, size_bytes, tmp);
+  gfc_add_modify (&se->pre, size_words,
+		       fold_build2_loc (input_location, CEIL_DIV_EXPR,
+					gfc_array_index_type,
+					size_bytes, dest_word_len));
+
+  /* Evaluate the bounds of the result.  If the loop range exists, we have
+     to check if it is too large.  If so, we modify loop->to be consistent
+     with min(size, size(source)).  Otherwise, size is made consistent with
+     the loop range, so that the right number of bytes is transferred.*/
+  n = se->loop->order[0];
+  if (se->loop->to[n] != NULL_TREE)
+    {
+      tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			     se->loop->to[n], se->loop->from[n]);
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			     tmp, gfc_index_one_node);
+      tmp = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
+			 tmp, size_words);
+      gfc_add_modify (&se->pre, size_words, tmp);
+      gfc_add_modify (&se->pre, size_bytes,
+			   fold_build2_loc (input_location, MULT_EXPR,
+					    gfc_array_index_type,
+					    size_words, dest_word_len));
+      upper = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			       size_words, se->loop->from[n]);
+      upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			       upper, gfc_index_one_node);
+    }
+  else
+    {
+      upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			       size_words, gfc_index_one_node);
+      se->loop->from[n] = gfc_index_zero_node;
+    }
+
+  se->loop->to[n] = upper;
+
+  /* Build a destination descriptor, using the pointer, source, as the
+     data field.  */
+  gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, mold_type,
+			       NULL_TREE, false, true, false, &expr->where);
+
+  /* Cast the pointer to the result.  */
+  tmp = gfc_conv_descriptor_data_get (info->descriptor);
+  tmp = fold_convert (pvoid_type_node, tmp);
+
+  /* Use memcpy to do the transfer.  */
+  tmp
+    = build_call_expr_loc (input_location,
+			   builtin_decl_explicit (BUILT_IN_MEMCPY), 3, tmp,
+			   fold_convert (pvoid_type_node, source),
+			   fold_convert (size_type_node,
+					 fold_build2_loc (input_location,
+							  MIN_EXPR,
+							  gfc_array_index_type,
+							  size_bytes,
+							  source_bytes)));
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  se->expr = info->descriptor;
+  if (expr->ts.type == BT_CHARACTER)
+    se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len);
+
+  return;
+
+/* Deal with scalar results.  */
+scalar_transfer:
+  extent = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
+			    dest_word_len, source_bytes);
+  extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
+			    extent, gfc_index_zero_node);
+
+  if (expr->ts.type == BT_CHARACTER)
+    {
+      tree direct, indirect, free;
+
+      ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
+      tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
+				"transfer");
+
+      /* If source is longer than the destination, use a pointer to
+	 the source directly.  */
+      gfc_init_block (&block);
+      gfc_add_modify (&block, tmpdecl, ptr);
+      direct = gfc_finish_block (&block);
+
+      /* Otherwise, allocate a string with the length of the destination
+	 and copy the source into it.  */
+      gfc_init_block (&block);
+      tmp = gfc_get_pchar_type (expr->ts.kind);
+      tmp = gfc_call_malloc (&block, tmp, dest_word_len);
+      gfc_add_modify (&block, tmpdecl,
+		      fold_convert (TREE_TYPE (ptr), tmp));
+      tmp = build_call_expr_loc (input_location,
+			     builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
+			     fold_convert (pvoid_type_node, tmpdecl),
+			     fold_convert (pvoid_type_node, ptr),
+			     fold_convert (size_type_node, extent));
+      gfc_add_expr_to_block (&block, tmp);
+      indirect = gfc_finish_block (&block);
+
+      /* Wrap it up with the condition.  */
+      tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
+			     dest_word_len, source_bytes);
+      tmp = build3_v (COND_EXPR, tmp, direct, indirect);
+      gfc_add_expr_to_block (&se->pre, tmp);
+
+      /* Free the temporary string, if necessary.  */
+      free = gfc_call_free (tmpdecl);
+      tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+			     dest_word_len, source_bytes);
+      tmp = build3_v (COND_EXPR, tmp, free, build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&se->post, tmp);
+
+      se->expr = tmpdecl;
+      se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len);
+    }
+  else
+    {
+      tmpdecl = gfc_create_var (mold_type, "transfer");
+
+      ptr = convert (build_pointer_type (mold_type), source);
+
+      /* For CLASS results, allocate the needed memory first.  */
+      if (mold_expr->ts.type == BT_CLASS)
+	{
+	  tree cdata;
+	  cdata = gfc_class_data_get (tmpdecl);
+	  tmp = gfc_call_malloc (&se->pre, TREE_TYPE (cdata), dest_word_len);
+	  gfc_add_modify (&se->pre, cdata, tmp);
+	}
+
+      /* Use memcpy to do the transfer.  */
+      if (mold_expr->ts.type == BT_CLASS)
+	tmp = gfc_class_data_get (tmpdecl);
+      else
+	tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
+
+      tmp = build_call_expr_loc (input_location,
+			     builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
+			     fold_convert (pvoid_type_node, tmp),
+			     fold_convert (pvoid_type_node, ptr),
+			     fold_convert (size_type_node, extent));
+      gfc_add_expr_to_block (&se->pre, tmp);
+
+      /* For CLASS results, set the _vptr.  */
+      if (mold_expr->ts.type == BT_CLASS)
+	{
+	  tree vptr;
+	  gfc_symbol *vtab;
+	  vptr = gfc_class_vptr_get (tmpdecl);
+	  vtab = gfc_find_derived_vtab (source_expr->ts.u.derived);
+	  gcc_assert (vtab);
+	  tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+	  gfc_add_modify (&se->pre, vptr, fold_convert (TREE_TYPE (vptr), tmp));
+	}
+
+      se->expr = tmpdecl;
+    }
+}
+
+
+/* Generate code for the ALLOCATED intrinsic.
+   Generate inline code that directly check the address of the argument.  */
+
+static void
+gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
+{
+  gfc_actual_arglist *arg1;
+  gfc_se arg1se;
+  tree tmp;
+
+  gfc_init_se (&arg1se, NULL);
+  arg1 = expr->value.function.actual;
+
+  if (arg1->expr->ts.type == BT_CLASS)
+    {
+      /* Make sure that class array expressions have both a _data
+	 component reference and an array reference....  */
+      if (CLASS_DATA (arg1->expr)->attr.dimension)
+	gfc_add_class_array_ref (arg1->expr);
+      /* .... whilst scalars only need the _data component.  */
+      else
+	gfc_add_data_component (arg1->expr);
+    }
+
+  if (arg1->expr->rank == 0)
+    {
+      /* Allocatable scalar.  */
+      arg1se.want_pointer = 1;
+      gfc_conv_expr (&arg1se, arg1->expr);
+      tmp = arg1se.expr;
+    }
+  else
+    {
+      /* Allocatable array.  */
+      arg1se.descriptor_only = 1;
+      gfc_conv_expr_descriptor (&arg1se, arg1->expr);
+      tmp = gfc_conv_descriptor_data_get (arg1se.expr);
+    }
+
+  tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
+			 fold_convert (TREE_TYPE (tmp), null_pointer_node));
+  se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
+}
+
+
+/* Generate code for the ASSOCIATED intrinsic.
+   If both POINTER and TARGET are arrays, generate a call to library function
+   _gfor_associated, and pass descriptors of POINTER and TARGET to it.
+   In other cases, generate inline code that directly compare the address of
+   POINTER with the address of TARGET.  */
+
+static void
+gfc_conv_associated (gfc_se *se, gfc_expr *expr)
+{
+  gfc_actual_arglist *arg1;
+  gfc_actual_arglist *arg2;
+  gfc_se arg1se;
+  gfc_se arg2se;
+  tree tmp2;
+  tree tmp;
+  tree nonzero_charlen;
+  tree nonzero_arraylen;
+  gfc_ss *ss;
+  bool scalar;
+
+  gfc_init_se (&arg1se, NULL);
+  gfc_init_se (&arg2se, NULL);
+  arg1 = expr->value.function.actual;
+  arg2 = arg1->next;
+
+  /* Check whether the expression is a scalar or not; we cannot use
+     arg1->expr->rank as it can be nonzero for proc pointers.  */
+  ss = gfc_walk_expr (arg1->expr);
+  scalar = ss == gfc_ss_terminator;
+  if (!scalar)
+    gfc_free_ss_chain (ss);
+
+  if (!arg2->expr)
+    {
+      /* No optional target.  */
+      if (scalar)
+        {
+	  /* A pointer to a scalar.  */
+	  arg1se.want_pointer = 1;
+	  gfc_conv_expr (&arg1se, arg1->expr);
+	  if (arg1->expr->symtree->n.sym->attr.proc_pointer
+	      && arg1->expr->symtree->n.sym->attr.dummy)
+	    arg1se.expr = build_fold_indirect_ref_loc (input_location,
+						       arg1se.expr);
+	  if (arg1->expr->ts.type == BT_CLASS)
+	      tmp2 = gfc_class_data_get (arg1se.expr);
+	  else
+	    tmp2 = arg1se.expr;
+        }
+      else
+        {
+          /* A pointer to an array.  */
+          gfc_conv_expr_descriptor (&arg1se, arg1->expr);
+          tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
+        }
+      gfc_add_block_to_block (&se->pre, &arg1se.pre);
+      gfc_add_block_to_block (&se->post, &arg1se.post);
+      tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp2,
+			     fold_convert (TREE_TYPE (tmp2), null_pointer_node));
+      se->expr = tmp;
+    }
+  else
+    {
+      /* An optional target.  */
+      if (arg2->expr->ts.type == BT_CLASS)
+	gfc_add_data_component (arg2->expr);
+
+      nonzero_charlen = NULL_TREE;
+      if (arg1->expr->ts.type == BT_CHARACTER)
+	nonzero_charlen = fold_build2_loc (input_location, NE_EXPR,
+					   boolean_type_node,
+					   arg1->expr->ts.u.cl->backend_decl,
+					   integer_zero_node);
+      if (scalar)
+        {
+	  /* A pointer to a scalar.  */
+	  arg1se.want_pointer = 1;
+	  gfc_conv_expr (&arg1se, arg1->expr);
+	  if (arg1->expr->symtree->n.sym->attr.proc_pointer
+	      && arg1->expr->symtree->n.sym->attr.dummy)
+	    arg1se.expr = build_fold_indirect_ref_loc (input_location,
+						       arg1se.expr);
+	  if (arg1->expr->ts.type == BT_CLASS)
+	    arg1se.expr = gfc_class_data_get (arg1se.expr);
+
+	  arg2se.want_pointer = 1;
+	  gfc_conv_expr (&arg2se, arg2->expr);
+	  if (arg2->expr->symtree->n.sym->attr.proc_pointer
+	      && arg2->expr->symtree->n.sym->attr.dummy)
+	    arg2se.expr = build_fold_indirect_ref_loc (input_location,
+						       arg2se.expr);
+	  gfc_add_block_to_block (&se->pre, &arg1se.pre);
+	  gfc_add_block_to_block (&se->post, &arg1se.post);
+          tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+				 arg1se.expr, arg2se.expr);
+          tmp2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+				  arg1se.expr, null_pointer_node);
+          se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+				      boolean_type_node, tmp, tmp2);
+        }
+      else
+        {
+	  /* An array pointer of zero length is not associated if target is
+	     present.  */
+	  arg1se.descriptor_only = 1;
+	  gfc_conv_expr_lhs (&arg1se, arg1->expr);
+	  if (arg1->expr->rank == -1)
+	    {
+	      tmp = gfc_conv_descriptor_rank (arg1se.expr);
+	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				     TREE_TYPE (tmp), tmp, gfc_index_one_node);
+	    }
+	  else
+	    tmp = gfc_rank_cst[arg1->expr->rank - 1];
+	  tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp);
+	  nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
+					      boolean_type_node, tmp,
+					      build_int_cst (TREE_TYPE (tmp), 0));
+
+          /* A pointer to an array, call library function _gfor_associated.  */
+          arg1se.want_pointer = 1;
+          gfc_conv_expr_descriptor (&arg1se, arg1->expr);
+
+          arg2se.want_pointer = 1;
+          gfc_conv_expr_descriptor (&arg2se, arg2->expr);
+          gfc_add_block_to_block (&se->pre, &arg2se.pre);
+          gfc_add_block_to_block (&se->post, &arg2se.post);
+          se->expr = build_call_expr_loc (input_location,
+				      gfor_fndecl_associated, 2,
+				      arg1se.expr, arg2se.expr);
+	  se->expr = convert (boolean_type_node, se->expr);
+	  se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+				      boolean_type_node, se->expr,
+				      nonzero_arraylen);
+        }
+
+      /* If target is present zero character length pointers cannot
+	 be associated.  */
+      if (nonzero_charlen != NULL_TREE)
+	se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+				    boolean_type_node,
+				    se->expr, nonzero_charlen);
+    }
+
+  se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
+}
+
+
+/* Generate code for the SAME_TYPE_AS intrinsic.
+   Generate inline code that directly checks the vindices.  */
+
+static void
+gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
+{
+  gfc_expr *a, *b;
+  gfc_se se1, se2;
+  tree tmp;
+  tree conda = NULL_TREE, condb = NULL_TREE;
+
+  gfc_init_se (&se1, NULL);
+  gfc_init_se (&se2, NULL);
+
+  a = expr->value.function.actual->expr;
+  b = expr->value.function.actual->next->expr;
+
+  if (UNLIMITED_POLY (a))
+    {
+      tmp = gfc_class_vptr_get (a->symtree->n.sym->backend_decl);
+      conda = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			       tmp, build_int_cst (TREE_TYPE (tmp), 0));
+    }
+
+  if (UNLIMITED_POLY (b))
+    {
+      tmp = gfc_class_vptr_get (b->symtree->n.sym->backend_decl);
+      condb = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			       tmp, build_int_cst (TREE_TYPE (tmp), 0));
+    }
+
+  if (a->ts.type == BT_CLASS)
+    {
+      gfc_add_vptr_component (a);
+      gfc_add_hash_component (a);
+    }
+  else if (a->ts.type == BT_DERIVED)
+    a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+			  a->ts.u.derived->hash_value);
+
+  if (b->ts.type == BT_CLASS)
+    {
+      gfc_add_vptr_component (b);
+      gfc_add_hash_component (b);
+    }
+  else if (b->ts.type == BT_DERIVED)
+    b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+			  b->ts.u.derived->hash_value);
+
+  gfc_conv_expr (&se1, a);
+  gfc_conv_expr (&se2, b);
+
+  tmp = fold_build2_loc (input_location, EQ_EXPR,
+			 boolean_type_node, se1.expr,
+			 fold_convert (TREE_TYPE (se1.expr), se2.expr));
+
+  if (conda)
+    tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
+			   boolean_type_node, conda, tmp);
+
+  if (condb)
+    tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
+			   boolean_type_node, condb, tmp);
+
+  se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
+}
+
+
+/* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function.  */
+
+static void
+gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
+{
+  tree args[2];
+
+  gfc_conv_intrinsic_function_args (se, expr, args, 2);
+  se->expr = build_call_expr_loc (input_location,
+			      gfor_fndecl_sc_kind, 2, args[0], args[1]);
+  se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
+}
+
+
+/* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */
+
+static void
+gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
+{
+  tree arg, type;
+
+  gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+
+  /* The argument to SELECTED_INT_KIND is INTEGER(4).  */
+  type = gfc_get_int_type (4); 
+  arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
+
+  /* Convert it to the required type.  */
+  type = gfc_typenode_for_spec (&expr->ts);
+  se->expr = build_call_expr_loc (input_location,
+			      gfor_fndecl_si_kind, 1, arg);
+  se->expr = fold_convert (type, se->expr);
+}
+
+
+/* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function.  */
+
+static void
+gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
+{
+  gfc_actual_arglist *actual;
+  tree type;
+  gfc_se argse;
+  vec<tree, va_gc> *args = NULL;
+
+  for (actual = expr->value.function.actual; actual; actual = actual->next)
+    {
+      gfc_init_se (&argse, se);
+
+      /* Pass a NULL pointer for an absent arg.  */
+      if (actual->expr == NULL)
+        argse.expr = null_pointer_node;
+      else
+	{
+	  gfc_typespec ts;
+          gfc_clear_ts (&ts);
+
+	  if (actual->expr->ts.kind != gfc_c_int_kind)
+	    {
+  	      /* The arguments to SELECTED_REAL_KIND are INTEGER(4).  */
+	      ts.type = BT_INTEGER;
+	      ts.kind = gfc_c_int_kind;
+	      gfc_convert_type (actual->expr, &ts, 2);
+	    }
+	  gfc_conv_expr_reference (&argse, actual->expr);
+	} 
+
+      gfc_add_block_to_block (&se->pre, &argse.pre);
+      gfc_add_block_to_block (&se->post, &argse.post);
+      vec_safe_push (args, argse.expr);
+    }
+
+  /* Convert it to the required type.  */
+  type = gfc_typenode_for_spec (&expr->ts);
+  se->expr = build_call_expr_loc_vec (input_location,
+				      gfor_fndecl_sr_kind, args);
+  se->expr = fold_convert (type, se->expr);
+}
+
+
+/* Generate code for TRIM (A) intrinsic function.  */
+
+static void
+gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
+{
+  tree var;
+  tree len;
+  tree addr;
+  tree tmp;
+  tree cond;
+  tree fndecl;
+  tree function;
+  tree *args;
+  unsigned int num_args;
+
+  num_args = gfc_intrinsic_argument_list_length (expr) + 2;
+  args = XALLOCAVEC (tree, num_args);
+
+  var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
+  addr = gfc_build_addr_expr (ppvoid_type_node, var);
+  len = gfc_create_var (gfc_charlen_type_node, "len");
+
+  gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
+  args[0] = gfc_build_addr_expr (NULL_TREE, len);
+  args[1] = addr;
+
+  if (expr->ts.kind == 1)
+    function = gfor_fndecl_string_trim;
+  else if (expr->ts.kind == 4)
+    function = gfor_fndecl_string_trim_char4;
+  else
+    gcc_unreachable ();
+
+  fndecl = build_addr (function, current_function_decl);
+  tmp = build_call_array_loc (input_location,
+			  TREE_TYPE (TREE_TYPE (function)), fndecl,
+			  num_args, args);
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  /* Free the temporary afterwards, if necessary.  */
+  cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+			  len, build_int_cst (TREE_TYPE (len), 0));
+  tmp = gfc_call_free (var);
+  tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
+  gfc_add_expr_to_block (&se->post, tmp);
+
+  se->expr = var;
+  se->string_length = len;
+}
+
+
+/* Generate code for REPEAT (STRING, NCOPIES) intrinsic function.  */
+
+static void
+gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
+{
+  tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
+  tree type, cond, tmp, count, exit_label, n, max, largest;
+  tree size;
+  stmtblock_t block, body;
+  int i;
+
+  /* We store in charsize the size of a character.  */
+  i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
+  size = build_int_cst (size_type_node, gfc_character_kinds[i].bit_size / 8);
+
+  /* Get the arguments.  */
+  gfc_conv_intrinsic_function_args (se, expr, args, 3);
+  slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
+  src = args[1];
+  ncopies = gfc_evaluate_now (args[2], &se->pre);
+  ncopies_type = TREE_TYPE (ncopies);
+
+  /* Check that NCOPIES is not negative.  */
+  cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, ncopies,
+			  build_int_cst (ncopies_type, 0));
+  gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
+			   "Argument NCOPIES of REPEAT intrinsic is negative "
+			   "(its value is %ld)",
+			   fold_convert (long_integer_type_node, ncopies));
+
+  /* If the source length is zero, any non negative value of NCOPIES
+     is valid, and nothing happens.  */
+  n = gfc_create_var (ncopies_type, "ncopies");
+  cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen,
+			  build_int_cst (size_type_node, 0));
+  tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond,
+			 build_int_cst (ncopies_type, 0), ncopies);
+  gfc_add_modify (&se->pre, n, tmp);
+  ncopies = n;
+
+  /* Check that ncopies is not too large: ncopies should be less than
+     (or equal to) MAX / slen, where MAX is the maximal integer of
+     the gfc_charlen_type_node type.  If slen == 0, we need a special
+     case to avoid the division by zero.  */
+  i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
+  max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
+  max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, size_type_node,
+			  fold_convert (size_type_node, max), slen);
+  largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
+	      ? size_type_node : ncopies_type;
+  cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+			  fold_convert (largest, ncopies),
+			  fold_convert (largest, max));
+  tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen,
+			 build_int_cst (size_type_node, 0));
+  cond = fold_build3_loc (input_location, COND_EXPR, boolean_type_node, tmp,
+			  boolean_false_node, cond);
+  gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
+			   "Argument NCOPIES of REPEAT intrinsic is too large");
+
+  /* Compute the destination length.  */
+  dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
+			  fold_convert (gfc_charlen_type_node, slen),
+			  fold_convert (gfc_charlen_type_node, ncopies));
+  type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
+  dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
+
+  /* Generate the code to do the repeat operation:
+       for (i = 0; i < ncopies; i++)
+         memmove (dest + (i * slen * size), src, slen*size);  */
+  gfc_start_block (&block);
+  count = gfc_create_var (ncopies_type, "count");
+  gfc_add_modify (&block, count, build_int_cst (ncopies_type, 0));
+  exit_label = gfc_build_label_decl (NULL_TREE);
+
+  /* Start the loop body.  */
+  gfc_start_block (&body);
+
+  /* Exit the loop if count >= ncopies.  */
+  cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, count,
+			  ncopies);
+  tmp = build1_v (GOTO_EXPR, exit_label);
+  TREE_USED (exit_label) = 1;
+  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
+			 build_empty_stmt (input_location));
+  gfc_add_expr_to_block (&body, tmp);
+
+  /* Call memmove (dest + (i*slen*size), src, slen*size).  */
+  tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
+			 fold_convert (gfc_charlen_type_node, slen),
+			 fold_convert (gfc_charlen_type_node, count));
+  tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
+			 tmp, fold_convert (gfc_charlen_type_node, size));
+  tmp = fold_build_pointer_plus_loc (input_location,
+				     fold_convert (pvoid_type_node, dest), tmp);
+  tmp = build_call_expr_loc (input_location,
+			     builtin_decl_explicit (BUILT_IN_MEMMOVE),
+			     3, tmp, src,
+			     fold_build2_loc (input_location, MULT_EXPR,
+					      size_type_node, slen,
+					      fold_convert (size_type_node,
+							    size)));
+  gfc_add_expr_to_block (&body, tmp);
+
+  /* Increment count.  */
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, ncopies_type,
+			 count, build_int_cst (TREE_TYPE (count), 1));
+  gfc_add_modify (&body, count, tmp);
+
+  /* Build the loop.  */
+  tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
+  gfc_add_expr_to_block (&block, tmp);
+
+  /* Add the exit label.  */
+  tmp = build1_v (LABEL_EXPR, exit_label);
+  gfc_add_expr_to_block (&block, tmp);
+
+  /* Finish the block.  */
+  tmp = gfc_finish_block (&block);
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  /* Set the result value.  */
+  se->expr = dest;
+  se->string_length = dlen;
+}
+
+
+/* Generate code for the IARGC intrinsic.  */
+
+static void
+gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
+{
+  tree tmp;
+  tree fndecl;
+  tree type;
+
+  /* Call the library function.  This always returns an INTEGER(4).  */
+  fndecl = gfor_fndecl_iargc;
+  tmp = build_call_expr_loc (input_location,
+			 fndecl, 0);
+
+  /* Convert it to the required type.  */
+  type = gfc_typenode_for_spec (&expr->ts);
+  tmp = fold_convert (type, tmp);
+
+  se->expr = tmp;
+}
+
+
+/* The loc intrinsic returns the address of its argument as
+   gfc_index_integer_kind integer.  */
+
+static void
+gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
+{
+  tree temp_var;
+  gfc_expr *arg_expr;
+
+  gcc_assert (!se->ss);
+
+  arg_expr = expr->value.function.actual->expr;
+  if (arg_expr->rank == 0)
+    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);
+   
+  /* Create a temporary variable for loc return value.  Without this, 
+     we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1).  */
+  temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
+  gfc_add_modify (&se->pre, temp_var, se->expr);
+  se->expr = temp_var;
+}
+
+
+/* The following routine generates code for the intrinsic
+   functions from the ISO_C_BINDING module:
+    * C_LOC
+    * C_FUNLOC
+    * C_ASSOCIATED  */
+
+static void
+conv_isocbinding_function (gfc_se *se, gfc_expr *expr)
+{
+  gfc_actual_arglist *arg = expr->value.function.actual;
+
+  if (expr->value.function.isym->id == GFC_ISYM_C_LOC)
+    {
+      if (arg->expr->rank == 0)
+	gfc_conv_expr_reference (se, arg->expr);
+      else if (gfc_is_simply_contiguous (arg->expr, false))
+	gfc_conv_array_parameter (se, arg->expr, true, NULL, NULL, NULL);
+      else
+	{
+	  gfc_conv_expr_descriptor (se, arg->expr);
+	  se->expr = gfc_conv_descriptor_data_get (se->expr);
+	}
+
+      /* TODO -- the following two lines shouldn't be necessary, but if
+	 they're removed, a bug is exposed later in the code path.
+	 This workaround was thus introduced, but will have to be
+	 removed; please see PR 35150 for details about the issue.  */
+      se->expr = convert (pvoid_type_node, se->expr);
+      se->expr = gfc_evaluate_now (se->expr, &se->pre);
+    }
+  else if (expr->value.function.isym->id == GFC_ISYM_C_FUNLOC)
+    gfc_conv_expr_reference (se, arg->expr);
+  else if (expr->value.function.isym->id == GFC_ISYM_C_ASSOCIATED)
+    {
+      gfc_se arg1se;
+      gfc_se arg2se;
+
+      /* Build the addr_expr for the first argument.  The argument is
+	 already an *address* so we don't need to set want_pointer in
+	 the gfc_se.  */
+      gfc_init_se (&arg1se, NULL);
+      gfc_conv_expr (&arg1se, arg->expr);
+      gfc_add_block_to_block (&se->pre, &arg1se.pre);
+      gfc_add_block_to_block (&se->post, &arg1se.post);
+
+      /* See if we were given two arguments.  */
+      if (arg->next->expr == NULL)
+	/* Only given one arg so generate a null and do a
+	   not-equal comparison against the first arg.  */
+	se->expr = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+				    arg1se.expr,
+				    fold_convert (TREE_TYPE (arg1se.expr),
+						  null_pointer_node));
+      else
+	{
+	  tree eq_expr;
+	  tree not_null_expr;
+
+	  /* Given two arguments so build the arg2se from second arg.  */
+	  gfc_init_se (&arg2se, NULL);
+	  gfc_conv_expr (&arg2se, arg->next->expr);
+	  gfc_add_block_to_block (&se->pre, &arg2se.pre);
+	  gfc_add_block_to_block (&se->post, &arg2se.post);
+
+	  /* Generate test to compare that the two args are equal.  */
+	  eq_expr = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+				     arg1se.expr, arg2se.expr);
+	  /* Generate test to ensure that the first arg is not null.  */
+	  not_null_expr = fold_build2_loc (input_location, NE_EXPR,
+					   boolean_type_node,
+					   arg1se.expr, null_pointer_node);
+
+	  /* Finally, the generated test must check that both arg1 is not
+	     NULL and that it is equal to the second arg.  */
+	  se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+				      boolean_type_node,
+				      not_null_expr, eq_expr);
+	}
+    }
+  else
+    gcc_unreachable ();
+}
+
+
+/* The following routine generates code for the intrinsic
+   subroutines from the ISO_C_BINDING module:
+    * C_F_POINTER
+    * C_F_PROCPOINTER.  */
+
+static tree
+conv_isocbinding_subroutine (gfc_code *code)
+{
+  gfc_se se;
+  gfc_se cptrse;
+  gfc_se fptrse;
+  gfc_se shapese;
+  gfc_ss *shape_ss;
+  tree desc, dim, tmp, stride, offset;
+  stmtblock_t body, block;
+  gfc_loopinfo loop;
+  gfc_actual_arglist *arg = code->ext.actual;
+
+  gfc_init_se (&se, NULL);
+  gfc_init_se (&cptrse, NULL);
+  gfc_conv_expr (&cptrse, arg->expr);
+  gfc_add_block_to_block (&se.pre, &cptrse.pre);
+  gfc_add_block_to_block (&se.post, &cptrse.post);
+
+  gfc_init_se (&fptrse, NULL);
+  if (arg->next->expr->rank == 0)
+    {
+      fptrse.want_pointer = 1;
+      gfc_conv_expr (&fptrse, arg->next->expr);
+      gfc_add_block_to_block (&se.pre, &fptrse.pre);
+      gfc_add_block_to_block (&se.post, &fptrse.post);
+      if (arg->next->expr->symtree->n.sym->attr.proc_pointer
+	  && arg->next->expr->symtree->n.sym->attr.dummy)
+	fptrse.expr = build_fold_indirect_ref_loc (input_location,
+						       fptrse.expr);
+      se.expr = fold_build2_loc (input_location, MODIFY_EXPR,
+				 TREE_TYPE (fptrse.expr),
+				 fptrse.expr,
+				 fold_convert (TREE_TYPE (fptrse.expr),
+					       cptrse.expr));
+      gfc_add_expr_to_block (&se.pre, se.expr);
+      gfc_add_block_to_block (&se.pre, &se.post);
+      return gfc_finish_block (&se.pre);
+    }
+
+  gfc_start_block (&block);
+
+  /* Get the descriptor of the Fortran pointer.  */
+  fptrse.descriptor_only = 1;
+  gfc_conv_expr_descriptor (&fptrse, arg->next->expr);
+  gfc_add_block_to_block (&block, &fptrse.pre);
+  desc = fptrse.expr;
+
+  /* Set data value, dtype, and offset.  */
+  tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
+  gfc_conv_descriptor_data_set (&block, desc, fold_convert (tmp, cptrse.expr));
+  gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc),
+		  gfc_get_dtype (TREE_TYPE (desc)));
+
+  /* Start scalarization of the bounds, using the shape argument.  */
+
+  shape_ss = gfc_walk_expr (arg->next->next->expr);
+  gcc_assert (shape_ss != gfc_ss_terminator);
+  gfc_init_se (&shapese, NULL);
+
+  gfc_init_loopinfo (&loop);
+  gfc_add_ss_to_loop (&loop, shape_ss);
+  gfc_conv_ss_startstride (&loop);
+  gfc_conv_loop_setup (&loop, &arg->next->expr->where);
+  gfc_mark_ss_chain_used (shape_ss, 1);
+
+  gfc_copy_loopinfo_to_se (&shapese, &loop);
+  shapese.ss = shape_ss;
+
+  stride = gfc_create_var (gfc_array_index_type, "stride");
+  offset = gfc_create_var (gfc_array_index_type, "offset");
+  gfc_add_modify (&block, stride, gfc_index_one_node);
+  gfc_add_modify (&block, offset, gfc_index_zero_node);
+
+  /* Loop body.  */
+  gfc_start_scalarized_body (&loop, &body);
+
+  dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			     loop.loopvar[0], loop.from[0]);
+
+  /* Set bounds and stride. */
+  gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node);
+  gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
+
+  gfc_conv_expr (&shapese, arg->next->next->expr);
+  gfc_add_block_to_block (&body, &shapese.pre);
+  gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr);
+  gfc_add_block_to_block (&body, &shapese.post);
+
+  /* Calculate offset. */
+  gfc_add_modify (&body, offset,
+		  fold_build2_loc (input_location, PLUS_EXPR,
+				   gfc_array_index_type, offset, stride));
+  /* Update stride.  */
+  gfc_add_modify (&body, stride,
+		  fold_build2_loc (input_location, MULT_EXPR,
+				   gfc_array_index_type, stride,
+				   fold_convert (gfc_array_index_type,
+						 shapese.expr)));
+  /* Finish scalarization loop.  */
+  gfc_trans_scalarizing_loops (&loop, &body);
+  gfc_add_block_to_block (&block, &loop.pre);
+  gfc_add_block_to_block (&block, &loop.post);
+  gfc_add_block_to_block (&block, &fptrse.post);
+  gfc_cleanup_loop (&loop);
+
+  gfc_add_modify (&block, offset,
+		  fold_build1_loc (input_location, NEGATE_EXPR,
+				   gfc_array_index_type, offset));
+  gfc_conv_descriptor_offset_set (&block, desc, offset);
+
+  gfc_add_expr_to_block (&se.pre, gfc_finish_block (&block));
+  gfc_add_block_to_block (&se.pre, &se.post);
+  return gfc_finish_block (&se.pre);
+}
+
+
+/* Generate code for an intrinsic function.  Some map directly to library
+   calls, others get special handling.  In some cases the name of the function
+   used depends on the type specifiers.  */
+
+void
+gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
+{
+  const char *name;
+  int lib, kind;
+  tree fndecl;
+
+  name = &expr->value.function.name[2];
+
+  if (expr->rank > 0)
+    {
+      lib = gfc_is_intrinsic_libcall (expr);
+      if (lib != 0)
+	{
+	  if (lib == 1)
+	    se->ignore_optional = 1;
+
+	  switch (expr->value.function.isym->id)
+	    {
+	    case GFC_ISYM_EOSHIFT:
+	    case GFC_ISYM_PACK:
+	    case GFC_ISYM_RESHAPE:
+	      /* For all of those the first argument specifies the type and the
+		 third is optional.  */
+	      conv_generic_with_optional_char_arg (se, expr, 1, 3);
+	      break;
+
+	    default:
+	      gfc_conv_intrinsic_funcall (se, expr);
+	      break;
+	    }
+
+	  return;
+	}
+    }
+
+  switch (expr->value.function.isym->id)
+    {
+    case GFC_ISYM_NONE:
+      gcc_unreachable ();
+
+    case GFC_ISYM_REPEAT:
+      gfc_conv_intrinsic_repeat (se, expr);
+      break;
+
+    case GFC_ISYM_TRIM:
+      gfc_conv_intrinsic_trim (se, expr);
+      break;
+
+    case GFC_ISYM_SC_KIND:
+      gfc_conv_intrinsic_sc_kind (se, expr);
+      break;
+
+    case GFC_ISYM_SI_KIND:
+      gfc_conv_intrinsic_si_kind (se, expr);
+      break;
+
+    case GFC_ISYM_SR_KIND:
+      gfc_conv_intrinsic_sr_kind (se, expr);
+      break;
+
+    case GFC_ISYM_EXPONENT:
+      gfc_conv_intrinsic_exponent (se, expr);
+      break;
+
+    case GFC_ISYM_SCAN:
+      kind = expr->value.function.actual->expr->ts.kind;
+      if (kind == 1)
+       fndecl = gfor_fndecl_string_scan;
+      else if (kind == 4)
+       fndecl = gfor_fndecl_string_scan_char4;
+      else
+       gcc_unreachable ();
+
+      gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
+      break;
+
+    case GFC_ISYM_VERIFY:
+      kind = expr->value.function.actual->expr->ts.kind;
+      if (kind == 1)
+       fndecl = gfor_fndecl_string_verify;
+      else if (kind == 4)
+       fndecl = gfor_fndecl_string_verify_char4;
+      else
+       gcc_unreachable ();
+
+      gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
+      break;
+
+    case GFC_ISYM_ALLOCATED:
+      gfc_conv_allocated (se, expr);
+      break;
+
+    case GFC_ISYM_ASSOCIATED:
+      gfc_conv_associated(se, expr);
+      break;
+
+    case GFC_ISYM_SAME_TYPE_AS:
+      gfc_conv_same_type_as (se, expr);
+      break;
+
+    case GFC_ISYM_ABS:
+      gfc_conv_intrinsic_abs (se, expr);
+      break;
+
+    case GFC_ISYM_ADJUSTL:
+      if (expr->ts.kind == 1)
+       fndecl = gfor_fndecl_adjustl;
+      else if (expr->ts.kind == 4)
+       fndecl = gfor_fndecl_adjustl_char4;
+      else
+       gcc_unreachable ();
+
+      gfc_conv_intrinsic_adjust (se, expr, fndecl);
+      break;
+
+    case GFC_ISYM_ADJUSTR:
+      if (expr->ts.kind == 1)
+       fndecl = gfor_fndecl_adjustr;
+      else if (expr->ts.kind == 4)
+       fndecl = gfor_fndecl_adjustr_char4;
+      else
+       gcc_unreachable ();
+
+      gfc_conv_intrinsic_adjust (se, expr, fndecl);
+      break;
+
+    case GFC_ISYM_AIMAG:
+      gfc_conv_intrinsic_imagpart (se, expr);
+      break;
+
+    case GFC_ISYM_AINT:
+      gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
+      break;
+
+    case GFC_ISYM_ALL:
+      gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
+      break;
+
+    case GFC_ISYM_ANINT:
+      gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
+      break;
+
+    case GFC_ISYM_AND:
+      gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
+      break;
+
+    case GFC_ISYM_ANY:
+      gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
+      break;
+
+    case GFC_ISYM_BTEST:
+      gfc_conv_intrinsic_btest (se, expr);
+      break;
+
+    case GFC_ISYM_BGE:
+      gfc_conv_intrinsic_bitcomp (se, expr, GE_EXPR);
+      break;
+
+    case GFC_ISYM_BGT:
+      gfc_conv_intrinsic_bitcomp (se, expr, GT_EXPR);
+      break;
+
+    case GFC_ISYM_BLE:
+      gfc_conv_intrinsic_bitcomp (se, expr, LE_EXPR);
+      break;
+
+    case GFC_ISYM_BLT:
+      gfc_conv_intrinsic_bitcomp (se, expr, LT_EXPR);
+      break;
+
+    case GFC_ISYM_C_ASSOCIATED:
+    case GFC_ISYM_C_FUNLOC:
+    case GFC_ISYM_C_LOC:
+      conv_isocbinding_function (se, expr);
+      break;
+
+    case GFC_ISYM_ACHAR:
+    case GFC_ISYM_CHAR:
+      gfc_conv_intrinsic_char (se, expr);
+      break;
+
+    case GFC_ISYM_CONVERSION:
+    case GFC_ISYM_REAL:
+    case GFC_ISYM_LOGICAL:
+    case GFC_ISYM_DBLE:
+      gfc_conv_intrinsic_conversion (se, expr);
+      break;
+
+      /* Integer conversions are handled separately to make sure we get the
+         correct rounding mode.  */
+    case GFC_ISYM_INT:
+    case GFC_ISYM_INT2:
+    case GFC_ISYM_INT8:
+    case GFC_ISYM_LONG:
+      gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
+      break;
+
+    case GFC_ISYM_NINT:
+      gfc_conv_intrinsic_int (se, expr, RND_ROUND);
+      break;
+
+    case GFC_ISYM_CEILING:
+      gfc_conv_intrinsic_int (se, expr, RND_CEIL);
+      break;
+
+    case GFC_ISYM_FLOOR:
+      gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
+      break;
+
+    case GFC_ISYM_MOD:
+      gfc_conv_intrinsic_mod (se, expr, 0);
+      break;
+
+    case GFC_ISYM_MODULO:
+      gfc_conv_intrinsic_mod (se, expr, 1);
+      break;
+
+    case GFC_ISYM_CMPLX:
+      gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
+      break;
+
+    case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
+      gfc_conv_intrinsic_iargc (se, expr);
+      break;
+
+    case GFC_ISYM_COMPLEX:
+      gfc_conv_intrinsic_cmplx (se, expr, 1);
+      break;
+
+    case GFC_ISYM_CONJG:
+      gfc_conv_intrinsic_conjg (se, expr);
+      break;
+
+    case GFC_ISYM_COUNT:
+      gfc_conv_intrinsic_count (se, expr);
+      break;
+
+    case GFC_ISYM_CTIME:
+      gfc_conv_intrinsic_ctime (se, expr);
+      break;
+
+    case GFC_ISYM_DIM:
+      gfc_conv_intrinsic_dim (se, expr);
+      break;
+
+    case GFC_ISYM_DOT_PRODUCT:
+      gfc_conv_intrinsic_dot_product (se, expr);
+      break;
+
+    case GFC_ISYM_DPROD:
+      gfc_conv_intrinsic_dprod (se, expr);
+      break;
+
+    case GFC_ISYM_DSHIFTL:
+      gfc_conv_intrinsic_dshift (se, expr, true);
+      break;
+
+    case GFC_ISYM_DSHIFTR:
+      gfc_conv_intrinsic_dshift (se, expr, false);
+      break;
+
+    case GFC_ISYM_FDATE:
+      gfc_conv_intrinsic_fdate (se, expr);
+      break;
+
+    case GFC_ISYM_FRACTION:
+      gfc_conv_intrinsic_fraction (se, expr);
+      break;
+
+    case GFC_ISYM_IALL:
+      gfc_conv_intrinsic_arith (se, expr, BIT_AND_EXPR, false);
+      break;
+
+    case GFC_ISYM_IAND:
+      gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
+      break;
+
+    case GFC_ISYM_IANY:
+      gfc_conv_intrinsic_arith (se, expr, BIT_IOR_EXPR, false);
+      break;
+
+    case GFC_ISYM_IBCLR:
+      gfc_conv_intrinsic_singlebitop (se, expr, 0);
+      break;
+
+    case GFC_ISYM_IBITS:
+      gfc_conv_intrinsic_ibits (se, expr);
+      break;
+
+    case GFC_ISYM_IBSET:
+      gfc_conv_intrinsic_singlebitop (se, expr, 1);
+      break;
+
+    case GFC_ISYM_IACHAR:
+    case GFC_ISYM_ICHAR:
+      /* We assume ASCII character sequence.  */
+      gfc_conv_intrinsic_ichar (se, expr);
+      break;
+
+    case GFC_ISYM_IARGC:
+      gfc_conv_intrinsic_iargc (se, expr);
+      break;
+
+    case GFC_ISYM_IEOR:
+      gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
+      break;
+
+    case GFC_ISYM_INDEX:
+      kind = expr->value.function.actual->expr->ts.kind;
+      if (kind == 1)
+       fndecl = gfor_fndecl_string_index;
+      else if (kind == 4)
+       fndecl = gfor_fndecl_string_index_char4;
+      else
+       gcc_unreachable ();
+
+      gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
+      break;
+
+    case GFC_ISYM_IOR:
+      gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
+      break;
+
+    case GFC_ISYM_IPARITY:
+      gfc_conv_intrinsic_arith (se, expr, BIT_XOR_EXPR, false);
+      break;
+
+    case GFC_ISYM_IS_IOSTAT_END:
+      gfc_conv_has_intvalue (se, expr, LIBERROR_END);
+      break;
+
+    case GFC_ISYM_IS_IOSTAT_EOR:
+      gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
+      break;
+
+    case GFC_ISYM_ISNAN:
+      gfc_conv_intrinsic_isnan (se, expr);
+      break;
+
+    case GFC_ISYM_LSHIFT:
+      gfc_conv_intrinsic_shift (se, expr, false, false);
+      break;
+
+    case GFC_ISYM_RSHIFT:
+      gfc_conv_intrinsic_shift (se, expr, true, true);
+      break;
+
+    case GFC_ISYM_SHIFTA:
+      gfc_conv_intrinsic_shift (se, expr, true, true);
+      break;
+
+    case GFC_ISYM_SHIFTL:
+      gfc_conv_intrinsic_shift (se, expr, false, false);
+      break;
+
+    case GFC_ISYM_SHIFTR:
+      gfc_conv_intrinsic_shift (se, expr, true, false);
+      break;
+
+    case GFC_ISYM_ISHFT:
+      gfc_conv_intrinsic_ishft (se, expr);
+      break;
+
+    case GFC_ISYM_ISHFTC:
+      gfc_conv_intrinsic_ishftc (se, expr);
+      break;
+
+    case GFC_ISYM_LEADZ:
+      gfc_conv_intrinsic_leadz (se, expr);
+      break;
+
+    case GFC_ISYM_TRAILZ:
+      gfc_conv_intrinsic_trailz (se, expr);
+      break;
+
+    case GFC_ISYM_POPCNT:
+      gfc_conv_intrinsic_popcnt_poppar (se, expr, 0);
+      break;
+
+    case GFC_ISYM_POPPAR:
+      gfc_conv_intrinsic_popcnt_poppar (se, expr, 1);
+      break;
+
+    case GFC_ISYM_LBOUND:
+      gfc_conv_intrinsic_bound (se, expr, 0);
+      break;
+
+    case GFC_ISYM_LCOBOUND:
+      conv_intrinsic_cobound (se, expr);
+      break;
+
+    case GFC_ISYM_TRANSPOSE:
+      /* The scalarizer has already been set up for reversed dimension access
+	 order ; now we just get the argument value normally.  */
+      gfc_conv_expr (se, expr->value.function.actual->expr);
+      break;
+
+    case GFC_ISYM_LEN:
+      gfc_conv_intrinsic_len (se, expr);
+      break;
+
+    case GFC_ISYM_LEN_TRIM:
+      gfc_conv_intrinsic_len_trim (se, expr);
+      break;
+
+    case GFC_ISYM_LGE:
+      gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
+      break;
+
+    case GFC_ISYM_LGT:
+      gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
+      break;
+
+    case GFC_ISYM_LLE:
+      gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
+      break;
+
+    case GFC_ISYM_LLT:
+      gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
+      break;
+
+    case GFC_ISYM_MASKL:
+      gfc_conv_intrinsic_mask (se, expr, 1);
+      break;
+
+    case GFC_ISYM_MASKR:
+      gfc_conv_intrinsic_mask (se, expr, 0);
+      break;
+
+    case GFC_ISYM_MAX:
+      if (expr->ts.type == BT_CHARACTER)
+	gfc_conv_intrinsic_minmax_char (se, expr, 1);
+      else
+	gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
+      break;
+
+    case GFC_ISYM_MAXLOC:
+      gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
+      break;
+
+    case GFC_ISYM_MAXVAL:
+      gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
+      break;
+
+    case GFC_ISYM_MERGE:
+      gfc_conv_intrinsic_merge (se, expr);
+      break;
+
+    case GFC_ISYM_MERGE_BITS:
+      gfc_conv_intrinsic_merge_bits (se, expr);
+      break;
+
+    case GFC_ISYM_MIN:
+      if (expr->ts.type == BT_CHARACTER)
+	gfc_conv_intrinsic_minmax_char (se, expr, -1);
+      else
+	gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
+      break;
+
+    case GFC_ISYM_MINLOC:
+      gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
+      break;
+
+    case GFC_ISYM_MINVAL:
+      gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
+      break;
+
+    case GFC_ISYM_NEAREST:
+      gfc_conv_intrinsic_nearest (se, expr);
+      break;
+
+    case GFC_ISYM_NORM2:
+      gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, true);
+      break;
+
+    case GFC_ISYM_NOT:
+      gfc_conv_intrinsic_not (se, expr);
+      break;
+
+    case GFC_ISYM_OR:
+      gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
+      break;
+
+    case GFC_ISYM_PARITY:
+      gfc_conv_intrinsic_arith (se, expr, NE_EXPR, false);
+      break;
+
+    case GFC_ISYM_PRESENT:
+      gfc_conv_intrinsic_present (se, expr);
+      break;
+
+    case GFC_ISYM_PRODUCT:
+      gfc_conv_intrinsic_arith (se, expr, MULT_EXPR, false);
+      break;
+
+    case GFC_ISYM_RANK:
+      gfc_conv_intrinsic_rank (se, expr);
+      break;
+
+    case GFC_ISYM_RRSPACING:
+      gfc_conv_intrinsic_rrspacing (se, expr);
+      break;
+
+    case GFC_ISYM_SET_EXPONENT:
+      gfc_conv_intrinsic_set_exponent (se, expr);
+      break;
+
+    case GFC_ISYM_SCALE:
+      gfc_conv_intrinsic_scale (se, expr);
+      break;
+
+    case GFC_ISYM_SIGN:
+      gfc_conv_intrinsic_sign (se, expr);
+      break;
+
+    case GFC_ISYM_SIZE:
+      gfc_conv_intrinsic_size (se, expr);
+      break;
+
+    case GFC_ISYM_SIZEOF:
+    case GFC_ISYM_C_SIZEOF:
+      gfc_conv_intrinsic_sizeof (se, expr);
+      break;
+
+    case GFC_ISYM_STORAGE_SIZE:
+      gfc_conv_intrinsic_storage_size (se, expr);
+      break;
+
+    case GFC_ISYM_SPACING:
+      gfc_conv_intrinsic_spacing (se, expr);
+      break;
+
+    case GFC_ISYM_STRIDE:
+      conv_intrinsic_stride (se, expr);
+      break;
+
+    case GFC_ISYM_SUM:
+      gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false);
+      break;
+
+    case GFC_ISYM_TRANSFER:
+      if (se->ss && se->ss->info->useflags)
+	/* Access the previously obtained result.  */
+	gfc_conv_tmp_array_ref (se);
+      else
+	gfc_conv_intrinsic_transfer (se, expr);
+      break;
+
+    case GFC_ISYM_TTYNAM:
+      gfc_conv_intrinsic_ttynam (se, expr);
+      break;
+
+    case GFC_ISYM_UBOUND:
+      gfc_conv_intrinsic_bound (se, expr, 1);
+      break;
+
+    case GFC_ISYM_UCOBOUND:
+      conv_intrinsic_cobound (se, expr);
+      break;
+
+    case GFC_ISYM_XOR:
+      gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
+      break;
+
+    case GFC_ISYM_LOC:
+      gfc_conv_intrinsic_loc (se, expr);
+      break;
+
+    case GFC_ISYM_THIS_IMAGE:
+      /* For num_images() == 1, handle as LCOBOUND.  */
+      if (expr->value.function.actual->expr
+	  && gfc_option.coarray == GFC_FCOARRAY_SINGLE)
+	conv_intrinsic_cobound (se, expr);
+      else
+	trans_this_image (se, expr);
+      break;
+
+    case GFC_ISYM_IMAGE_INDEX:
+      trans_image_index (se, expr);
+      break;
+
+    case GFC_ISYM_NUM_IMAGES:
+      trans_num_images (se);
+      break;
+
+    case GFC_ISYM_ACCESS:
+    case GFC_ISYM_CHDIR:
+    case GFC_ISYM_CHMOD:
+    case GFC_ISYM_DTIME:
+    case GFC_ISYM_ETIME:
+    case GFC_ISYM_EXTENDS_TYPE_OF:
+    case GFC_ISYM_FGET:
+    case GFC_ISYM_FGETC:
+    case GFC_ISYM_FNUM:
+    case GFC_ISYM_FPUT:
+    case GFC_ISYM_FPUTC:
+    case GFC_ISYM_FSTAT:
+    case GFC_ISYM_FTELL:
+    case GFC_ISYM_GETCWD:
+    case GFC_ISYM_GETGID:
+    case GFC_ISYM_GETPID:
+    case GFC_ISYM_GETUID:
+    case GFC_ISYM_HOSTNM:
+    case GFC_ISYM_KILL:
+    case GFC_ISYM_IERRNO:
+    case GFC_ISYM_IRAND:
+    case GFC_ISYM_ISATTY:
+    case GFC_ISYM_JN2:
+    case GFC_ISYM_LINK:
+    case GFC_ISYM_LSTAT:
+    case GFC_ISYM_MALLOC:
+    case GFC_ISYM_MATMUL:
+    case GFC_ISYM_MCLOCK:
+    case GFC_ISYM_MCLOCK8:
+    case GFC_ISYM_RAND:
+    case GFC_ISYM_RENAME:
+    case GFC_ISYM_SECOND:
+    case GFC_ISYM_SECNDS:
+    case GFC_ISYM_SIGNAL:
+    case GFC_ISYM_STAT:
+    case GFC_ISYM_SYMLNK:
+    case GFC_ISYM_SYSTEM:
+    case GFC_ISYM_TIME:
+    case GFC_ISYM_TIME8:
+    case GFC_ISYM_UMASK:
+    case GFC_ISYM_UNLINK:
+    case GFC_ISYM_YN2:
+      gfc_conv_intrinsic_funcall (se, expr);
+      break;
+
+    case GFC_ISYM_EOSHIFT:
+    case GFC_ISYM_PACK:
+    case GFC_ISYM_RESHAPE:
+      /* For those, expr->rank should always be >0 and thus the if above the
+	 switch should have matched.  */
+      gcc_unreachable ();
+      break;
+
+    default:
+      gfc_conv_intrinsic_lib_function (se, expr);
+      break;
+    }
+}
+
+
+static gfc_ss *
+walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr)
+{
+  gfc_ss *arg_ss, *tmp_ss;
+  gfc_actual_arglist *arg;
+
+  arg = expr->value.function.actual;
+
+  gcc_assert (arg->expr);
+
+  arg_ss = gfc_walk_subexpr (gfc_ss_terminator, arg->expr);
+  gcc_assert (arg_ss != gfc_ss_terminator);
+
+  for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next)
+    {
+      if (tmp_ss->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;
+	}
+
+      /* Stop when tmp_ss points to the last valid element of the chain...  */
+      if (tmp_ss->next == gfc_ss_terminator)
+	break;
+    }
+
+  /* ... so that we can attach the rest of the chain to it.  */
+  tmp_ss->next = ss;
+
+  return arg_ss;
+}
+
+
+/* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
+   This has the side effect of reversing the nested list, so there is no
+   need to call gfc_reverse_ss on it (the given list is assumed not to be
+   reversed yet).   */
+
+static gfc_ss *
+nest_loop_dimension (gfc_ss *ss, int dim)
+{
+  int ss_dim, i;
+  gfc_ss *new_ss, *prev_ss = gfc_ss_terminator;
+  gfc_loopinfo *new_loop;
+
+  gcc_assert (ss != gfc_ss_terminator);
+
+  for (; ss != gfc_ss_terminator; ss = ss->next)
+    {
+      new_ss = gfc_get_ss ();
+      new_ss->next = prev_ss;
+      new_ss->parent = ss;
+      new_ss->info = ss->info;
+      new_ss->info->refcount++;
+      if (ss->dimen != 0)
+	{
+	  gcc_assert (ss->info->type != GFC_SS_SCALAR
+		      && ss->info->type != GFC_SS_REFERENCE);
+
+	  new_ss->dimen = 1;
+	  new_ss->dim[0] = ss->dim[dim];
+
+	  gcc_assert (dim < ss->dimen);
+
+	  ss_dim = --ss->dimen;
+	  for (i = dim; i < ss_dim; i++)
+	    ss->dim[i] = ss->dim[i + 1];
+
+	  ss->dim[ss_dim] = 0;
+	}
+      prev_ss = new_ss;
+
+      if (ss->nested_ss)
+	{
+	  ss->nested_ss->parent = new_ss;
+	  new_ss->nested_ss = ss->nested_ss;
+	}
+      ss->nested_ss = new_ss;
+    }
+
+  new_loop = gfc_get_loopinfo ();
+  gfc_init_loopinfo (new_loop);
+
+  gcc_assert (prev_ss != NULL);
+  gcc_assert (prev_ss != gfc_ss_terminator);
+  gfc_add_ss_to_loop (new_loop, prev_ss);
+  return new_ss->parent;
+}
+
+
+/* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
+   is to be inlined.  */
+
+static gfc_ss *
+walk_inline_intrinsic_arith (gfc_ss *ss, gfc_expr *expr)
+{
+  gfc_ss *tmp_ss, *tail, *array_ss;
+  gfc_actual_arglist *arg1, *arg2, *arg3;
+  int sum_dim;
+  bool scalar_mask = false;
+
+  /* The rank of the result will be determined later.  */
+  arg1 = expr->value.function.actual;
+  arg2 = arg1->next;
+  arg3 = arg2->next;
+  gcc_assert (arg3 != NULL);
+
+  if (expr->rank == 0)
+    return ss;
+
+  tmp_ss = gfc_ss_terminator;
+
+  if (arg3->expr)
+    {
+      gfc_ss *mask_ss;
+
+      mask_ss = gfc_walk_subexpr (tmp_ss, arg3->expr);
+      if (mask_ss == tmp_ss)
+	scalar_mask = 1;
+
+      tmp_ss = mask_ss;
+    }
+
+  array_ss = gfc_walk_subexpr (tmp_ss, arg1->expr);
+  gcc_assert (array_ss != tmp_ss);
+
+  /* Odd thing: If the mask is scalar, it is used by the frontend after
+     the array (to make an if around the nested loop). Thus it shall
+     be after array_ss once the gfc_ss list is reversed.  */
+  if (scalar_mask)
+    tmp_ss = gfc_get_scalar_ss (array_ss, arg3->expr);
+  else
+    tmp_ss = array_ss;
+
+  /* "Hide" the dimension on which we will sum in the first arg's scalarization
+     chain.  */
+  sum_dim = mpz_get_si (arg2->expr->value.integer) - 1;
+  tail = nest_loop_dimension (tmp_ss, sum_dim);
+  tail->next = ss;
+
+  return tmp_ss;
+}
+
+
+static gfc_ss *
+walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr)
+{
+
+  switch (expr->value.function.isym->id)
+    {
+      case GFC_ISYM_PRODUCT:
+      case GFC_ISYM_SUM:
+	return walk_inline_intrinsic_arith (ss, expr);
+
+      case GFC_ISYM_TRANSPOSE:
+	return walk_inline_intrinsic_transpose (ss, expr);
+
+      default:
+	gcc_unreachable ();
+    }
+  gcc_unreachable ();
+}
+
+
+/* This generates code to execute before entering the scalarization loop.
+   Currently does nothing.  */
+
+void
+gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
+{
+  switch (ss->info->expr->value.function.isym->id)
+    {
+    case GFC_ISYM_UBOUND:
+    case GFC_ISYM_LBOUND:
+    case GFC_ISYM_UCOBOUND:
+    case GFC_ISYM_LCOBOUND:
+    case GFC_ISYM_THIS_IMAGE:
+      break;
+
+    default:
+      gcc_unreachable ();
+    }
+}
+
+
+/* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
+   are expanded into code inside the scalarization loop.  */
+
+static gfc_ss *
+gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
+{
+  if (expr->value.function.actual->expr->ts.type == BT_CLASS)
+    gfc_add_class_array_ref (expr->value.function.actual->expr);
+
+  /* The two argument version returns a scalar.  */
+  if (expr->value.function.actual->next->expr)
+    return ss;
+
+  return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
+}
+
+
+/* Walk an intrinsic array libcall.  */
+
+static gfc_ss *
+gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
+{
+  gcc_assert (expr->rank > 0);
+  return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
+}
+
+
+/* Return whether the function call expression EXPR will be expanded
+   inline by gfc_conv_intrinsic_function.  */
+
+bool
+gfc_inline_intrinsic_function_p (gfc_expr *expr)
+{
+  gfc_actual_arglist *args;
+
+  if (!expr->value.function.isym)
+    return false;
+
+  switch (expr->value.function.isym->id)
+    {
+    case GFC_ISYM_PRODUCT:
+    case GFC_ISYM_SUM:
+      /* Disable inline expansion if code size matters.  */
+      if (optimize_size)
+	return false;
+
+      args = expr->value.function.actual;
+      /* We need to be able to subset the SUM argument at compile-time.  */
+      if (args->next->expr && args->next->expr->expr_type != EXPR_CONSTANT)
+	return false;
+
+      return true;
+
+    case GFC_ISYM_TRANSPOSE:
+      return true;
+
+    default:
+      return false;
+    }
+}
+
+
+/* Returns nonzero if the specified intrinsic function call maps directly to
+   an external library call.  Should only be used for functions that return
+   arrays.  */
+
+int
+gfc_is_intrinsic_libcall (gfc_expr * expr)
+{
+  gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
+  gcc_assert (expr->rank > 0);
+
+  if (gfc_inline_intrinsic_function_p (expr))
+    return 0;
+
+  switch (expr->value.function.isym->id)
+    {
+    case GFC_ISYM_ALL:
+    case GFC_ISYM_ANY:
+    case GFC_ISYM_COUNT:
+    case GFC_ISYM_JN2:
+    case GFC_ISYM_IANY:
+    case GFC_ISYM_IALL:
+    case GFC_ISYM_IPARITY:
+    case GFC_ISYM_MATMUL:
+    case GFC_ISYM_MAXLOC:
+    case GFC_ISYM_MAXVAL:
+    case GFC_ISYM_MINLOC:
+    case GFC_ISYM_MINVAL:
+    case GFC_ISYM_NORM2:
+    case GFC_ISYM_PARITY:
+    case GFC_ISYM_PRODUCT:
+    case GFC_ISYM_SUM:
+    case GFC_ISYM_SHAPE:
+    case GFC_ISYM_SPREAD:
+    case GFC_ISYM_YN2:
+      /* Ignore absent optional parameters.  */
+      return 1;
+
+    case GFC_ISYM_RESHAPE:
+    case GFC_ISYM_CSHIFT:
+    case GFC_ISYM_EOSHIFT:
+    case GFC_ISYM_PACK:
+    case GFC_ISYM_UNPACK:
+      /* Pass absent optional parameters.  */
+      return 2;
+
+    default:
+      return 0;
+    }
+}
+
+/* Walk an intrinsic function.  */
+gfc_ss *
+gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
+			     gfc_intrinsic_sym * isym)
+{
+  gcc_assert (isym);
+
+  if (isym->elemental)
+    return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
+					     NULL, GFC_SS_SCALAR);
+
+  if (expr->rank == 0)
+    return ss;
+
+  if (gfc_inline_intrinsic_function_p (expr))
+    return walk_inline_intrinsic_function (ss, expr);
+
+  if (gfc_is_intrinsic_libcall (expr))
+    return gfc_walk_intrinsic_libfunc (ss, expr);
+
+  /* Special cases.  */
+  switch (isym->id)
+    {
+    case GFC_ISYM_LBOUND:
+    case GFC_ISYM_LCOBOUND:
+    case GFC_ISYM_UBOUND:
+    case GFC_ISYM_UCOBOUND:
+    case GFC_ISYM_THIS_IMAGE:
+      return gfc_walk_intrinsic_bound (ss, expr);
+
+    case GFC_ISYM_TRANSFER:
+      return gfc_walk_intrinsic_libfunc (ss, expr);
+
+    default:
+      /* This probably meant someone forgot to add an intrinsic to the above
+         list(s) when they implemented it, or something's gone horribly
+	 wrong.  */
+      gcc_unreachable ();
+    }
+}
+
+
+static tree
+conv_intrinsic_atomic_def (gfc_code *code)
+{
+  gfc_se atom, value;
+  stmtblock_t block;
+
+  gfc_init_se (&atom, NULL);
+  gfc_init_se (&value, NULL);
+  gfc_conv_expr (&atom, code->ext.actual->expr);
+  gfc_conv_expr (&value, code->ext.actual->next->expr);
+
+  gfc_init_block (&block);
+  gfc_add_modify (&block, atom.expr,
+		  fold_convert (TREE_TYPE (atom.expr), value.expr));
+  return gfc_finish_block (&block);
+}
+
+
+static tree
+conv_intrinsic_atomic_ref (gfc_code *code)
+{
+  gfc_se atom, value;
+  stmtblock_t block;
+
+  gfc_init_se (&atom, NULL);
+  gfc_init_se (&value, NULL);
+  gfc_conv_expr (&value, code->ext.actual->expr);
+  gfc_conv_expr (&atom, code->ext.actual->next->expr);
+
+  gfc_init_block (&block);
+  gfc_add_modify (&block, value.expr,
+		  fold_convert (TREE_TYPE (value.expr), atom.expr));
+  return gfc_finish_block (&block);
+}
+
+
+static tree
+conv_intrinsic_move_alloc (gfc_code *code)
+{
+  stmtblock_t block;
+  gfc_expr *from_expr, *to_expr;
+  gfc_expr *to_expr2, *from_expr2 = NULL;
+  gfc_se from_se, to_se;
+  tree tmp;
+  bool coarray;
+
+  gfc_start_block (&block);
+
+  from_expr = code->ext.actual->expr;
+  to_expr = code->ext.actual->next->expr;
+
+  gfc_init_se (&from_se, NULL);
+  gfc_init_se (&to_se, NULL);
+
+  gcc_assert (from_expr->ts.type != BT_CLASS
+	      || to_expr->ts.type == BT_CLASS);
+  coarray = gfc_get_corank (from_expr) != 0;
+
+  if (from_expr->rank == 0 && !coarray)
+    {
+      if (from_expr->ts.type != BT_CLASS)
+	from_expr2 = from_expr;
+      else
+	{
+	  from_expr2 = gfc_copy_expr (from_expr);
+	  gfc_add_data_component (from_expr2);
+	}
+
+      if (to_expr->ts.type != BT_CLASS)
+	to_expr2 = to_expr;
+      else
+	{
+	  to_expr2 = gfc_copy_expr (to_expr);
+	  gfc_add_data_component (to_expr2);
+	}
+
+      from_se.want_pointer = 1;
+      to_se.want_pointer = 1;
+      gfc_conv_expr (&from_se, from_expr2);
+      gfc_conv_expr (&to_se, to_expr2);
+      gfc_add_block_to_block (&block, &from_se.pre);
+      gfc_add_block_to_block (&block, &to_se.pre);
+
+      /* Deallocate "to".  */
+      tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, true,
+					       to_expr, to_expr->ts);
+      gfc_add_expr_to_block (&block, tmp);
+
+      /* Assign (_data) pointers.  */
+      gfc_add_modify_loc (input_location, &block, to_se.expr,
+			  fold_convert (TREE_TYPE (to_se.expr), from_se.expr));
+
+      /* Set "from" to NULL.  */
+      gfc_add_modify_loc (input_location, &block, from_se.expr,
+			  fold_convert (TREE_TYPE (from_se.expr), null_pointer_node));
+
+      gfc_add_block_to_block (&block, &from_se.post);
+      gfc_add_block_to_block (&block, &to_se.post);
+
+      /* Set _vptr.  */
+      if (to_expr->ts.type == BT_CLASS)
+	{
+	  gfc_symbol *vtab;
+
+	  gfc_free_expr (to_expr2);
+	  gfc_init_se (&to_se, NULL);
+	  to_se.want_pointer = 1;
+	  gfc_add_vptr_component (to_expr);
+	  gfc_conv_expr (&to_se, to_expr);
+
+	  if (from_expr->ts.type == BT_CLASS)
+	    {
+	      if (UNLIMITED_POLY (from_expr))
+		vtab = NULL;
+	      else
+		{
+		  vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
+		  gcc_assert (vtab);
+		}
+
+	      gfc_free_expr (from_expr2);
+	      gfc_init_se (&from_se, NULL);
+	      from_se.want_pointer = 1;
+	      gfc_add_vptr_component (from_expr);
+	      gfc_conv_expr (&from_se, from_expr);
+	      gfc_add_modify_loc (input_location, &block, to_se.expr,
+				  fold_convert (TREE_TYPE (to_se.expr),
+				  from_se.expr));
+
+              /* Reset _vptr component to declared type.  */
+	      if (vtab == NULL)
+		/* Unlimited polymorphic.  */
+		gfc_add_modify_loc (input_location, &block, from_se.expr,
+				    fold_convert (TREE_TYPE (from_se.expr),
+						  null_pointer_node));
+	      else
+		{
+		  tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+		  gfc_add_modify_loc (input_location, &block, from_se.expr,
+				      fold_convert (TREE_TYPE (from_se.expr), tmp));
+		}
+	    }
+	  else
+	    {
+	      vtab = gfc_find_vtab (&from_expr->ts);
+	      gcc_assert (vtab);
+	      tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+	      gfc_add_modify_loc (input_location, &block, to_se.expr,
+				  fold_convert (TREE_TYPE (to_se.expr), tmp));
+	    }
+	}
+
+      return gfc_finish_block (&block);
+    }
+
+  /* Update _vptr component.  */
+  if (to_expr->ts.type == BT_CLASS)
+    {
+      gfc_symbol *vtab;
+
+      to_se.want_pointer = 1;
+      to_expr2 = gfc_copy_expr (to_expr);
+      gfc_add_vptr_component (to_expr2);
+      gfc_conv_expr (&to_se, to_expr2);
+
+      if (from_expr->ts.type == BT_CLASS)
+	{
+	  if (UNLIMITED_POLY (from_expr))
+	    vtab = NULL;
+	  else
+	    {
+	      vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
+	      gcc_assert (vtab);
+	    }
+
+	  from_se.want_pointer = 1;
+	  from_expr2 = gfc_copy_expr (from_expr);
+	  gfc_add_vptr_component (from_expr2);
+	  gfc_conv_expr (&from_se, from_expr2);
+	  gfc_add_modify_loc (input_location, &block, to_se.expr,
+			      fold_convert (TREE_TYPE (to_se.expr),
+			      from_se.expr));
+
+	  /* Reset _vptr component to declared type.  */
+	  if (vtab == NULL)
+	    /* Unlimited polymorphic.  */
+	    gfc_add_modify_loc (input_location, &block, from_se.expr,
+				fold_convert (TREE_TYPE (from_se.expr),
+					      null_pointer_node));
+	  else
+	    {
+	      tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+	      gfc_add_modify_loc (input_location, &block, from_se.expr,
+				  fold_convert (TREE_TYPE (from_se.expr), tmp));
+	    }
+	}
+      else
+	{
+	  vtab = gfc_find_vtab (&from_expr->ts);
+	  gcc_assert (vtab);
+	  tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+	  gfc_add_modify_loc (input_location, &block, to_se.expr,
+			      fold_convert (TREE_TYPE (to_se.expr), tmp));
+	}
+
+      gfc_free_expr (to_expr2);
+      gfc_init_se (&to_se, NULL);
+
+      if (from_expr->ts.type == BT_CLASS)
+	{
+	  gfc_free_expr (from_expr2);
+	  gfc_init_se (&from_se, NULL);
+	}
+    }
+
+
+  /* Deallocate "to".  */
+  if (from_expr->rank == 0)
+    {
+      to_se.want_coarray = 1;
+      from_se.want_coarray = 1;
+    }
+  gfc_conv_expr_descriptor (&to_se, to_expr);
+  gfc_conv_expr_descriptor (&from_se, from_expr);
+
+  /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
+     is an image control "statement", cf. IR F08/0040 in 12-006A.  */
+  if (coarray && gfc_option.coarray == GFC_FCOARRAY_LIB)
+    {
+      tree cond;
+
+      tmp = gfc_deallocate_with_status (to_se.expr, NULL_TREE, NULL_TREE,
+					NULL_TREE, NULL_TREE, true, to_expr,
+					true);
+      gfc_add_expr_to_block (&block, tmp);
+
+      tmp = gfc_conv_descriptor_data_get (to_se.expr);
+      cond = fold_build2_loc (input_location, EQ_EXPR,
+			      boolean_type_node, tmp,
+			      fold_convert (TREE_TYPE (tmp),
+					    null_pointer_node));
+      tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
+				 3, null_pointer_node, null_pointer_node,
+				 build_int_cst (integer_type_node, 0));
+
+      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+			     tmp, build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&block, tmp);
+    }
+  else
+    {
+      tmp = gfc_conv_descriptor_data_get (to_se.expr);
+      tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, NULL_TREE,
+					NULL_TREE, true, to_expr, false);
+      gfc_add_expr_to_block (&block, tmp);
+    }
+
+  /* Move the pointer and update the array descriptor data.  */
+  gfc_add_modify_loc (input_location, &block, to_se.expr, from_se.expr);
+
+  /* Set "from" to NULL.  */
+  tmp = gfc_conv_descriptor_data_get (from_se.expr);
+  gfc_add_modify_loc (input_location, &block, tmp,
+		      fold_convert (TREE_TYPE (tmp), null_pointer_node));
+
+  return gfc_finish_block (&block);
+}
+
+
+tree
+gfc_conv_intrinsic_subroutine (gfc_code *code)
+{
+  tree res;
+
+  gcc_assert (code->resolved_isym);
+
+  switch (code->resolved_isym->id)
+    {
+    case GFC_ISYM_MOVE_ALLOC:
+      res = conv_intrinsic_move_alloc (code);
+      break;
+
+    case GFC_ISYM_ATOMIC_DEF:
+      res = conv_intrinsic_atomic_def (code);
+      break;
+
+    case GFC_ISYM_ATOMIC_REF:
+      res = conv_intrinsic_atomic_ref (code);
+      break;
+
+    case GFC_ISYM_C_F_POINTER:
+    case GFC_ISYM_C_F_PROCPOINTER:
+      res = conv_isocbinding_subroutine (code);
+      break;
+
+
+    default:
+      res = NULL_TREE;
+      break;
+    }
+
+  return res;
+}
+
+#include "gt-fortran-trans-intrinsic.h"
diff --git a/gcc-4.9/gcc/fortran/trans-io.c b/gcc-4.9/gcc/fortran/trans-io.c
new file mode 100644
index 000000000..d15159857
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/trans-io.c
@@ -0,0 +1,2348 @@
+/* IO Code translation/library interface
+   Copyright (C) 2002-2014 Free Software Foundation, Inc.
+   Contributed by Paul Brook
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "tree.h"
+#include "stringpool.h"
+#include "stor-layout.h"
+#include "ggc.h"
+#include "diagnostic-core.h"	/* For internal_error.  */
+#include "gfortran.h"
+#include "trans.h"
+#include "trans-stmt.h"
+#include "trans-array.h"
+#include "trans-types.h"
+#include "trans-const.h"
+
+/* Members of the ioparm structure.  */
+
+enum ioparam_type
+{
+  IOPARM_ptype_common,
+  IOPARM_ptype_open,
+  IOPARM_ptype_close,
+  IOPARM_ptype_filepos,
+  IOPARM_ptype_inquire,
+  IOPARM_ptype_dt,
+  IOPARM_ptype_wait,
+  IOPARM_ptype_num
+};
+
+enum iofield_type
+{
+  IOPARM_type_int4,
+  IOPARM_type_intio,
+  IOPARM_type_pint4,
+  IOPARM_type_pintio,
+  IOPARM_type_pchar,
+  IOPARM_type_parray,
+  IOPARM_type_pad,
+  IOPARM_type_char1,
+  IOPARM_type_char2,
+  IOPARM_type_common,
+  IOPARM_type_num
+};
+
+typedef struct GTY(()) gfc_st_parameter_field {
+  const char *name;
+  unsigned int mask;
+  enum ioparam_type param_type;
+  enum iofield_type type;
+  tree field;
+  tree field_len;
+}
+gfc_st_parameter_field;
+
+typedef struct GTY(()) gfc_st_parameter {
+  const char *name;
+  tree type;
+}
+gfc_st_parameter;
+
+enum iofield
+{
+#define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name,
+#include "ioparm.def"
+#undef IOPARM
+  IOPARM_field_num
+};
+
+static GTY(()) gfc_st_parameter st_parameter[] =
+{
+  { "common", NULL },
+  { "open", NULL },
+  { "close", NULL },
+  { "filepos", NULL },
+  { "inquire", NULL },
+  { "dt", NULL },
+  { "wait", NULL }
+};
+
+static GTY(()) gfc_st_parameter_field st_parameter_field[] =
+{
+#define IOPARM(param_type, name, mask, type) \
+  { #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL },
+#include "ioparm.def"
+#undef IOPARM
+  { NULL, 0, (enum ioparam_type) 0, (enum iofield_type) 0, NULL, NULL }
+};
+
+/* Library I/O subroutines */
+
+enum iocall
+{
+  IOCALL_READ,
+  IOCALL_READ_DONE,
+  IOCALL_WRITE,
+  IOCALL_WRITE_DONE,
+  IOCALL_X_INTEGER,
+  IOCALL_X_INTEGER_WRITE,
+  IOCALL_X_LOGICAL,
+  IOCALL_X_LOGICAL_WRITE,
+  IOCALL_X_CHARACTER,
+  IOCALL_X_CHARACTER_WRITE,
+  IOCALL_X_CHARACTER_WIDE,
+  IOCALL_X_CHARACTER_WIDE_WRITE,
+  IOCALL_X_REAL,
+  IOCALL_X_REAL_WRITE,
+  IOCALL_X_COMPLEX,
+  IOCALL_X_COMPLEX_WRITE,
+  IOCALL_X_REAL128,
+  IOCALL_X_REAL128_WRITE,
+  IOCALL_X_COMPLEX128,
+  IOCALL_X_COMPLEX128_WRITE,
+  IOCALL_X_ARRAY,
+  IOCALL_X_ARRAY_WRITE,
+  IOCALL_OPEN,
+  IOCALL_CLOSE,
+  IOCALL_INQUIRE,
+  IOCALL_IOLENGTH,
+  IOCALL_IOLENGTH_DONE,
+  IOCALL_REWIND,
+  IOCALL_BACKSPACE,
+  IOCALL_ENDFILE,
+  IOCALL_FLUSH,
+  IOCALL_SET_NML_VAL,
+  IOCALL_SET_NML_VAL_DIM,
+  IOCALL_WAIT,
+  IOCALL_NUM
+};
+
+static GTY(()) tree iocall[IOCALL_NUM];
+
+/* Variable for keeping track of what the last data transfer statement
+   was.  Used for deciding which subroutine to call when the data
+   transfer is complete.  */
+static enum { READ, WRITE, IOLENGTH } last_dt;
+
+/* The data transfer parameter block that should be shared by all
+   data transfer calls belonging to the same read/write/iolength.  */
+static GTY(()) tree dt_parm;
+static stmtblock_t *dt_post_end_block;
+
+static void
+gfc_build_st_parameter (enum ioparam_type ptype, tree *types)
+{
+  unsigned int type;
+  gfc_st_parameter_field *p;
+  char name[64];
+  size_t len;
+  tree t = make_node (RECORD_TYPE);
+  tree *chain = NULL;
+
+  len = strlen (st_parameter[ptype].name);
+  gcc_assert (len <= sizeof (name) - sizeof ("__st_parameter_"));
+  memcpy (name, "__st_parameter_", sizeof ("__st_parameter_"));
+  memcpy (name + sizeof ("__st_parameter_") - 1, st_parameter[ptype].name,
+	  len + 1);
+  TYPE_NAME (t) = get_identifier (name);
+
+  for (type = 0, p = st_parameter_field; type < IOPARM_field_num; type++, p++)
+    if (p->param_type == ptype)
+      switch (p->type)
+	{
+	case IOPARM_type_int4:
+	case IOPARM_type_intio:
+	case IOPARM_type_pint4:
+	case IOPARM_type_pintio:
+	case IOPARM_type_parray:
+	case IOPARM_type_pchar:
+	case IOPARM_type_pad:
+	  p->field = gfc_add_field_to_struct (t, get_identifier (p->name),
+					      types[p->type], &chain);
+	  break;
+	case IOPARM_type_char1:
+	  p->field = gfc_add_field_to_struct (t, get_identifier (p->name),
+					      pchar_type_node, &chain);
+	  /* FALLTHROUGH */
+	case IOPARM_type_char2:
+	  len = strlen (p->name);
+	  gcc_assert (len <= sizeof (name) - sizeof ("_len"));
+	  memcpy (name, p->name, len);
+	  memcpy (name + len, "_len", sizeof ("_len"));
+	  p->field_len = gfc_add_field_to_struct (t, get_identifier (name),
+						  gfc_charlen_type_node,
+						  &chain);
+	  if (p->type == IOPARM_type_char2)
+	    p->field = gfc_add_field_to_struct (t, get_identifier (p->name),
+						pchar_type_node, &chain);
+	  break;
+	case IOPARM_type_common:
+	  p->field
+	    = gfc_add_field_to_struct (t,
+				       get_identifier (p->name),
+				       st_parameter[IOPARM_ptype_common].type,
+				       &chain);
+	  break;
+	case IOPARM_type_num:
+	  gcc_unreachable ();
+	}
+
+  gfc_finish_type (t);
+  st_parameter[ptype].type = t;
+}
+
+
+/* Build code to test an error condition and call generate_error if needed.
+   Note: This builds calls to generate_error in the runtime library function.
+   The function generate_error is dependent on certain parameters in the
+   st_parameter_common flags to be set. (See libgfortran/runtime/error.c)
+   Therefore, the code to set these flags must be generated before
+   this function is used.  */
+
+static void
+gfc_trans_io_runtime_check (bool has_iostat, tree cond, tree var,
+			    int error_code, const char * msgid,
+			    stmtblock_t * pblock)
+{
+  stmtblock_t block;
+  tree body;
+  tree tmp;
+  tree arg1, arg2, arg3;
+  char *message;
+
+  if (integer_zerop (cond))
+    return;
+
+  /* The code to generate the error.  */
+  gfc_start_block (&block);
+
+  if (has_iostat)
+    gfc_add_expr_to_block (&block, build_predict_expr (PRED_FORTRAN_FAIL_IO,
+						       NOT_TAKEN));
+  else
+    gfc_add_expr_to_block (&block, build_predict_expr (PRED_NORETURN,
+						       NOT_TAKEN));
+
+  arg1 = gfc_build_addr_expr (NULL_TREE, var);
+
+  arg2 = build_int_cst (integer_type_node, error_code),
+
+  asprintf (&message, "%s", _(msgid));
+  arg3 = gfc_build_addr_expr (pchar_type_node,
+			      gfc_build_localized_cstring_const (message));
+  free (message);
+
+  tmp = build_call_expr_loc (input_location,
+			 gfor_fndecl_generate_error, 3, arg1, arg2, arg3);
+
+  gfc_add_expr_to_block (&block, tmp);
+
+  body = gfc_finish_block (&block);
+
+  if (integer_onep (cond))
+    {
+      gfc_add_expr_to_block (pblock, body);
+    }
+  else
+    {
+      tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt (input_location));
+      gfc_add_expr_to_block (pblock, tmp);
+    }
+}
+
+
+/* Create function decls for IO library functions.  */
+
+void
+gfc_build_io_library_fndecls (void)
+{
+  tree types[IOPARM_type_num], pad_idx, gfc_int4_type_node;
+  tree gfc_intio_type_node;
+  tree parm_type, dt_parm_type;
+  HOST_WIDE_INT pad_size;
+  unsigned int ptype;
+
+  types[IOPARM_type_int4] = gfc_int4_type_node = gfc_get_int_type (4);
+  types[IOPARM_type_intio] = gfc_intio_type_node
+			    = gfc_get_int_type (gfc_intio_kind);
+  types[IOPARM_type_pint4] = build_pointer_type (gfc_int4_type_node);
+  types[IOPARM_type_pintio]
+			    = build_pointer_type (gfc_intio_type_node);
+  types[IOPARM_type_parray] = pchar_type_node;
+  types[IOPARM_type_pchar] = pchar_type_node;
+  pad_size = 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node));
+  pad_size += 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node));
+  pad_idx = build_index_type (size_int (pad_size - 1));
+  types[IOPARM_type_pad] = build_array_type (char_type_node, pad_idx);
+
+  /* pad actually contains pointers and integers so it needs to have an
+     alignment that is at least as large as the needed alignment for those
+     types.  See the st_parameter_dt structure in libgfortran/io/io.h for
+     what really goes into this space.  */
+  TYPE_ALIGN (types[IOPARM_type_pad]) = MAX (TYPE_ALIGN (pchar_type_node),
+		     TYPE_ALIGN (gfc_get_int_type (gfc_intio_kind)));
+
+  for (ptype = IOPARM_ptype_common; ptype < IOPARM_ptype_num; ptype++)
+    gfc_build_st_parameter ((enum ioparam_type) ptype, types);
+
+  /* Define the transfer functions.  */
+
+  dt_parm_type = build_pointer_type (st_parameter[IOPARM_ptype_dt].type);
+
+  iocall[IOCALL_X_INTEGER] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("transfer_integer")), ".wW",
+	void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
+
+  iocall[IOCALL_X_INTEGER_WRITE] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("transfer_integer_write")), ".wR",
+	void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
+
+  iocall[IOCALL_X_LOGICAL] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("transfer_logical")), ".wW",
+	void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
+
+  iocall[IOCALL_X_LOGICAL_WRITE] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("transfer_logical_write")), ".wR",
+	void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
+
+  iocall[IOCALL_X_CHARACTER] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("transfer_character")), ".wW",
+	void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
+
+  iocall[IOCALL_X_CHARACTER_WRITE] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("transfer_character_write")), ".wR",
+	void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
+
+  iocall[IOCALL_X_CHARACTER_WIDE] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("transfer_character_wide")), ".wW",
+	void_type_node, 4, dt_parm_type, pvoid_type_node,
+	gfc_charlen_type_node, gfc_int4_type_node);
+
+  iocall[IOCALL_X_CHARACTER_WIDE_WRITE] =
+    gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("transfer_character_wide_write")), ".wR",
+	void_type_node, 4, dt_parm_type, pvoid_type_node,
+	gfc_charlen_type_node, gfc_int4_type_node);
+
+  iocall[IOCALL_X_REAL] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("transfer_real")), ".wW",
+	void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
+
+  iocall[IOCALL_X_REAL_WRITE] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("transfer_real_write")), ".wR",
+	void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
+
+  iocall[IOCALL_X_COMPLEX] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("transfer_complex")), ".wW",
+	void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
+
+  iocall[IOCALL_X_COMPLEX_WRITE] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("transfer_complex_write")), ".wR",
+	void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
+
+  /* Version for __float128.  */
+  iocall[IOCALL_X_REAL128] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("transfer_real128")), ".wW",
+	void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
+
+  iocall[IOCALL_X_REAL128_WRITE] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("transfer_real128_write")), ".wR",
+	void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
+
+  iocall[IOCALL_X_COMPLEX128] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("transfer_complex128")), ".wW",
+	void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
+
+  iocall[IOCALL_X_COMPLEX128_WRITE] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("transfer_complex128_write")), ".wR",
+	void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
+
+  iocall[IOCALL_X_ARRAY] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("transfer_array")), ".ww",
+	void_type_node, 4, dt_parm_type, pvoid_type_node,
+	integer_type_node, gfc_charlen_type_node);
+
+  iocall[IOCALL_X_ARRAY_WRITE] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("transfer_array_write")), ".wr",
+	void_type_node, 4, dt_parm_type, pvoid_type_node,
+	integer_type_node, gfc_charlen_type_node);
+
+  /* Library entry points */
+
+  iocall[IOCALL_READ] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("st_read")), ".w",
+	void_type_node, 1, dt_parm_type);
+
+  iocall[IOCALL_WRITE] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("st_write")), ".w",
+	void_type_node, 1, dt_parm_type);
+
+  parm_type = build_pointer_type (st_parameter[IOPARM_ptype_open].type);
+  iocall[IOCALL_OPEN] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("st_open")), ".w",
+	void_type_node, 1, parm_type);
+
+  parm_type = build_pointer_type (st_parameter[IOPARM_ptype_close].type);
+  iocall[IOCALL_CLOSE] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("st_close")), ".w",
+	void_type_node, 1, parm_type);
+
+  parm_type = build_pointer_type (st_parameter[IOPARM_ptype_inquire].type);
+  iocall[IOCALL_INQUIRE] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("st_inquire")), ".w",
+	void_type_node, 1, parm_type);
+
+  iocall[IOCALL_IOLENGTH] = gfc_build_library_function_decl_with_spec(
+	get_identifier (PREFIX("st_iolength")), ".w",
+	void_type_node, 1, dt_parm_type);
+
+  /* TODO: Change when asynchronous I/O is implemented.  */
+  parm_type = build_pointer_type (st_parameter[IOPARM_ptype_wait].type);
+  iocall[IOCALL_WAIT] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("st_wait")), ".X",
+	void_type_node, 1, parm_type);
+
+  parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type);
+  iocall[IOCALL_REWIND] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("st_rewind")), ".w",
+	void_type_node, 1, parm_type);
+
+  iocall[IOCALL_BACKSPACE] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("st_backspace")), ".w",
+	void_type_node, 1, parm_type);
+
+  iocall[IOCALL_ENDFILE] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("st_endfile")), ".w",
+	void_type_node, 1, parm_type);
+
+  iocall[IOCALL_FLUSH] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("st_flush")), ".w",
+	void_type_node, 1, parm_type);
+
+  /* Library helpers */
+
+  iocall[IOCALL_READ_DONE] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("st_read_done")), ".w",
+	void_type_node, 1, dt_parm_type);
+
+  iocall[IOCALL_WRITE_DONE] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("st_write_done")), ".w",
+	void_type_node, 1, dt_parm_type);
+
+  iocall[IOCALL_IOLENGTH_DONE] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("st_iolength_done")), ".w",
+	void_type_node, 1, dt_parm_type);
+
+  iocall[IOCALL_SET_NML_VAL] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("st_set_nml_var")), ".w.R",
+	void_type_node, 6, dt_parm_type, pvoid_type_node, pvoid_type_node,
+	void_type_node, gfc_charlen_type_node, gfc_int4_type_node);
+
+  iocall[IOCALL_SET_NML_VAL_DIM] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("st_set_nml_var_dim")), ".w",
+	void_type_node, 5, dt_parm_type, gfc_int4_type_node,
+	gfc_array_index_type, gfc_array_index_type, gfc_array_index_type);
+}
+
+
+/* Generate code to store an integer constant into the
+   st_parameter_XXX structure.  */
+
+static unsigned int
+set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
+		     unsigned int val)
+{
+  tree tmp;
+  gfc_st_parameter_field *p = &st_parameter_field[type];
+
+  if (p->param_type == IOPARM_ptype_common)
+    var = fold_build3_loc (input_location, COMPONENT_REF,
+			   st_parameter[IOPARM_ptype_common].type,
+			   var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
+  tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
+			 var, p->field, NULL_TREE);
+  gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (p->field), val));
+  return p->mask;
+}
+
+
+/* Generate code to store a non-string I/O parameter into the
+   st_parameter_XXX structure.  This is a pass by value.  */
+
+static unsigned int
+set_parameter_value (stmtblock_t *block, bool has_iostat, tree var,
+		     enum iofield type, gfc_expr *e)
+{
+  gfc_se se;
+  tree tmp;
+  gfc_st_parameter_field *p = &st_parameter_field[type];
+  tree dest_type = TREE_TYPE (p->field);
+
+  gfc_init_se (&se, NULL);
+  gfc_conv_expr_val (&se, e);
+
+  /* If we're storing a UNIT number, we need to check it first.  */
+  if (type == IOPARM_common_unit && e->ts.kind > 4)
+    {
+      tree cond, val;
+      int i;
+
+      /* Don't evaluate the UNIT number multiple times.  */
+      se.expr = gfc_evaluate_now (se.expr, &se.pre);
+
+      /* UNIT numbers should be greater than the min.  */
+      i = gfc_validate_kind (BT_INTEGER, 4, false);
+      val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].pedantic_min_int, 4);
+      cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+			      se.expr,
+			      fold_convert (TREE_TYPE (se.expr), val));
+      gfc_trans_io_runtime_check (has_iostat, cond, var, LIBERROR_BAD_UNIT,
+				  "Unit number in I/O statement too small",
+				  &se.pre);
+
+      /* UNIT numbers should be less than the max.  */
+      val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4);
+      cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+			      se.expr,
+			      fold_convert (TREE_TYPE (se.expr), val));
+      gfc_trans_io_runtime_check (has_iostat, cond, var, LIBERROR_BAD_UNIT,
+				  "Unit number in I/O statement too large",
+				  &se.pre);
+
+    }
+
+  se.expr = convert (dest_type, se.expr);
+  gfc_add_block_to_block (block, &se.pre);
+
+  if (p->param_type == IOPARM_ptype_common)
+    var = fold_build3_loc (input_location, COMPONENT_REF,
+			   st_parameter[IOPARM_ptype_common].type,
+			   var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
+
+  tmp = fold_build3_loc (input_location, COMPONENT_REF, dest_type, var,
+			 p->field, NULL_TREE);
+  gfc_add_modify (block, tmp, se.expr);
+  return p->mask;
+}
+
+
+/* Generate code to store a non-string I/O parameter into the
+   st_parameter_XXX structure.  This is pass by reference.  */
+
+static unsigned int
+set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock,
+		   tree var, enum iofield type, gfc_expr *e)
+{
+  gfc_se se;
+  tree tmp, addr;
+  gfc_st_parameter_field *p = &st_parameter_field[type];
+
+  gcc_assert (e->ts.type == BT_INTEGER || e->ts.type == BT_LOGICAL);
+  gfc_init_se (&se, NULL);
+  gfc_conv_expr_lhs (&se, e);
+
+  gfc_add_block_to_block (block, &se.pre);
+
+  if (TYPE_MODE (TREE_TYPE (se.expr))
+      == TYPE_MODE (TREE_TYPE (TREE_TYPE (p->field))))
+    {
+      addr = convert (TREE_TYPE (p->field), gfc_build_addr_expr (NULL_TREE, se.expr));
+
+      /* If this is for the iostat variable initialize the
+	 user variable to LIBERROR_OK which is zero.  */
+      if (type == IOPARM_common_iostat)
+	gfc_add_modify (block, se.expr,
+			     build_int_cst (TREE_TYPE (se.expr), LIBERROR_OK));
+    }
+  else
+    {
+      /* The type used by the library has different size
+	from the type of the variable supplied by the user.
+	Need to use a temporary.  */
+      tree tmpvar = gfc_create_var (TREE_TYPE (TREE_TYPE (p->field)),
+				    st_parameter_field[type].name);
+
+      /* If this is for the iostat variable, initialize the
+	 user variable to LIBERROR_OK which is zero.  */
+      if (type == IOPARM_common_iostat)
+	gfc_add_modify (block, tmpvar,
+			     build_int_cst (TREE_TYPE (tmpvar), LIBERROR_OK));
+
+      addr = gfc_build_addr_expr (NULL_TREE, tmpvar);
+	/* After the I/O operation, we set the variable from the temporary.  */
+      tmp = convert (TREE_TYPE (se.expr), tmpvar);
+      gfc_add_modify (postblock, se.expr, tmp);
+     }
+
+  if (p->param_type == IOPARM_ptype_common)
+    var = fold_build3_loc (input_location, COMPONENT_REF,
+			   st_parameter[IOPARM_ptype_common].type,
+			   var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
+  tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
+			 var, p->field, NULL_TREE);
+  gfc_add_modify (block, tmp, addr);
+  return p->mask;
+}
+
+/* Given an array expr, find its address and length to get a string. If the
+   array is full, the string's address is the address of array's first element
+   and the length is the size of the whole array.  If it is an element, the
+   string's address is the element's address and the length is the rest size of
+   the array.  */
+
+static void
+gfc_convert_array_to_string (gfc_se * se, gfc_expr * e)
+{
+  tree size;
+
+  if (e->rank == 0)
+    {
+      tree type, array, tmp;
+      gfc_symbol *sym;
+      int rank;
+
+      /* If it is an element, we need its address and size of the rest.  */
+      gcc_assert (e->expr_type == EXPR_VARIABLE);
+      gcc_assert (e->ref->u.ar.type == AR_ELEMENT);
+      sym = e->symtree->n.sym;
+      rank = sym->as->rank - 1;
+      gfc_conv_expr (se, e);
+
+      array = sym->backend_decl;
+      type = TREE_TYPE (array);
+
+      if (GFC_ARRAY_TYPE_P (type))
+	size = GFC_TYPE_ARRAY_SIZE (type);
+      else
+	{
+	  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+	  size = gfc_conv_array_stride (array, rank);
+	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				 gfc_array_index_type,
+				 gfc_conv_array_ubound (array, rank),
+				 gfc_conv_array_lbound (array, rank));
+	  tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type, tmp,
+				 gfc_index_one_node);
+	  size = fold_build2_loc (input_location, MULT_EXPR,
+				  gfc_array_index_type, tmp, size);
+	}
+      gcc_assert (size);
+
+      size = fold_build2_loc (input_location, MINUS_EXPR,
+			      gfc_array_index_type, size,
+			      TREE_OPERAND (se->expr, 1));
+      se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
+      tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
+      size = fold_build2_loc (input_location, MULT_EXPR,
+			      gfc_array_index_type, size,
+			      fold_convert (gfc_array_index_type, tmp));
+      se->string_length = fold_convert (gfc_charlen_type_node, size);
+      return;
+    }
+
+  gfc_conv_array_parameter (se, e, true, NULL, NULL, &size);
+  se->string_length = fold_convert (gfc_charlen_type_node, size);
+}
+
+
+/* Generate code to store a string and its length into the
+   st_parameter_XXX structure.  */
+
+static unsigned int
+set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
+	    enum iofield type, gfc_expr * e)
+{
+  gfc_se se;
+  tree tmp;
+  tree io;
+  tree len;
+  gfc_st_parameter_field *p = &st_parameter_field[type];
+
+  gfc_init_se (&se, NULL);
+
+  if (p->param_type == IOPARM_ptype_common)
+    var = fold_build3_loc (input_location, COMPONENT_REF,
+			   st_parameter[IOPARM_ptype_common].type,
+			   var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
+  io = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
+		    var, p->field, NULL_TREE);
+  len = fold_build3_loc (input_location, COMPONENT_REF,
+			 TREE_TYPE (p->field_len),
+			 var, p->field_len, NULL_TREE);
+
+  /* Integer variable assigned a format label.  */
+  if (e->ts.type == BT_INTEGER
+      && e->rank == 0
+      && e->symtree->n.sym->attr.assign == 1)
+    {
+      char * msg;
+      tree cond;
+
+      gfc_conv_label_variable (&se, e);
+      tmp = GFC_DECL_STRING_LEN (se.expr);
+      cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+			      tmp, build_int_cst (TREE_TYPE (tmp), 0));
+
+      asprintf(&msg, "Label assigned to variable '%s' (%%ld) is not a format "
+	       "label", e->symtree->name);
+      gfc_trans_runtime_check (true, false, cond, &se.pre, &e->where, msg,
+			       fold_convert (long_integer_type_node, tmp));
+      free (msg);
+
+      gfc_add_modify (&se.pre, io,
+		 fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr)));
+      gfc_add_modify (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
+    }
+  else
+    {
+      /* General character.  */
+      if (e->ts.type == BT_CHARACTER && e->rank == 0)
+	gfc_conv_expr (&se, e);
+      /* Array assigned Hollerith constant or character array.  */
+      else if (e->rank > 0 || (e->symtree && e->symtree->n.sym->as->rank > 0))
+	gfc_convert_array_to_string (&se, e);
+      else
+	gcc_unreachable ();
+
+      gfc_conv_string_parameter (&se);
+      gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
+      gfc_add_modify (&se.pre, len, se.string_length);
+    }
+
+  gfc_add_block_to_block (block, &se.pre);
+  gfc_add_block_to_block (postblock, &se.post);
+  return p->mask;
+}
+
+
+/* Generate code to store the character (array) and the character length
+   for an internal unit.  */
+
+static unsigned int
+set_internal_unit (stmtblock_t * block, stmtblock_t * post_block,
+		   tree var, gfc_expr * e)
+{
+  gfc_se se;
+  tree io;
+  tree len;
+  tree desc;
+  tree tmp;
+  gfc_st_parameter_field *p;
+  unsigned int mask;
+
+  gfc_init_se (&se, NULL);
+
+  p = &st_parameter_field[IOPARM_dt_internal_unit];
+  mask = p->mask;
+  io = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
+			var, p->field, NULL_TREE);
+  len = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field_len),
+			 var, p->field_len,	NULL_TREE);
+  p = &st_parameter_field[IOPARM_dt_internal_unit_desc];
+  desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
+			  var, p->field, NULL_TREE);
+
+  gcc_assert (e->ts.type == BT_CHARACTER);
+
+  /* Character scalars.  */
+  if (e->rank == 0)
+    {
+      gfc_conv_expr (&se, e);
+      gfc_conv_string_parameter (&se);
+      tmp = se.expr;
+      se.expr = build_int_cst (pchar_type_node, 0);
+    }
+
+  /* Character array.  */
+  else if (e->rank > 0)
+    {
+      if (is_subref_array (e))
+	{
+	  /* Use a temporary for components of arrays of derived types
+	     or substring array references.  */
+	  gfc_conv_subref_array_arg (&se, e, 0,
+		last_dt == READ ? INTENT_IN : INTENT_OUT, false);
+	  tmp = build_fold_indirect_ref_loc (input_location,
+					 se.expr);
+	  se.expr = gfc_build_addr_expr (pchar_type_node, tmp);
+	  tmp = gfc_conv_descriptor_data_get (tmp);
+	}
+      else
+	{
+	  /* Return the data pointer and rank from the descriptor.  */
+	  gfc_conv_expr_descriptor (&se, e);
+	  tmp = gfc_conv_descriptor_data_get (se.expr);
+	  se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
+	}
+    }
+  else
+    gcc_unreachable ();
+
+  /* The cast is needed for character substrings and the descriptor
+     data.  */
+  gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), tmp));
+  gfc_add_modify (&se.pre, len,
+		       fold_convert (TREE_TYPE (len), se.string_length));
+  gfc_add_modify (&se.pre, desc, se.expr);
+
+  gfc_add_block_to_block (block, &se.pre);
+  gfc_add_block_to_block (post_block, &se.post);
+  return mask;
+}
+
+/* Add a case to a IO-result switch.  */
+
+static void
+add_case (int label_value, gfc_st_label * label, stmtblock_t * body)
+{
+  tree tmp, value;
+
+  if (label == NULL)
+    return;			/* No label, no case */
+
+  value = build_int_cst (integer_type_node, label_value);
+
+  /* Make a backend label for this case.  */
+  tmp = gfc_build_label_decl (NULL_TREE);
+
+  /* And the case itself.  */
+  tmp = build_case_label (value, NULL_TREE, tmp);
+  gfc_add_expr_to_block (body, tmp);
+
+  /* Jump to the label.  */
+  tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label));
+  gfc_add_expr_to_block (body, tmp);
+}
+
+
+/* Generate a switch statement that branches to the correct I/O
+   result label.  The last statement of an I/O call stores the
+   result into a variable because there is often cleanup that
+   must be done before the switch, so a temporary would have to
+   be created anyway.  */
+
+static void
+io_result (stmtblock_t * block, tree var, gfc_st_label * err_label,
+	   gfc_st_label * end_label, gfc_st_label * eor_label)
+{
+  stmtblock_t body;
+  tree tmp, rc;
+  gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
+
+  /* If no labels are specified, ignore the result instead
+     of building an empty switch.  */
+  if (err_label == NULL
+      && end_label == NULL
+      && eor_label == NULL)
+    return;
+
+  /* Build a switch statement.  */
+  gfc_start_block (&body);
+
+  /* The label values here must be the same as the values
+     in the library_return enum in the runtime library */
+  add_case (1, err_label, &body);
+  add_case (2, end_label, &body);
+  add_case (3, eor_label, &body);
+
+  tmp = gfc_finish_block (&body);
+
+  var = fold_build3_loc (input_location, COMPONENT_REF,
+			 st_parameter[IOPARM_ptype_common].type,
+			 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
+  rc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
+			var, p->field, NULL_TREE);
+  rc = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (rc),
+			rc, build_int_cst (TREE_TYPE (rc),
+					   IOPARM_common_libreturn_mask));
+
+  tmp = fold_build3_loc (input_location, SWITCH_EXPR, NULL_TREE,
+			 rc, tmp, NULL_TREE);
+
+  gfc_add_expr_to_block (block, tmp);
+}
+
+
+/* Store the current file and line number to variables so that if a
+   library call goes awry, we can tell the user where the problem is.  */
+
+static void
+set_error_locus (stmtblock_t * block, tree var, locus * where)
+{
+  gfc_file *f;
+  tree str, locus_file;
+  int line;
+  gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename];
+
+  locus_file = fold_build3_loc (input_location, COMPONENT_REF,
+				st_parameter[IOPARM_ptype_common].type,
+				var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
+  locus_file = fold_build3_loc (input_location, COMPONENT_REF,
+				TREE_TYPE (p->field), locus_file,
+				p->field, NULL_TREE);
+  f = where->lb->file;
+  str = gfc_build_cstring_const (f->filename);
+
+  str = gfc_build_addr_expr (pchar_type_node, str);
+  gfc_add_modify (block, locus_file, str);
+
+  line = LOCATION_LINE (where->lb->location);
+  set_parameter_const (block, var, IOPARM_common_line, line);
+}
+
+
+/* Translate an OPEN statement.  */
+
+tree
+gfc_trans_open (gfc_code * code)
+{
+  stmtblock_t block, post_block;
+  gfc_open *p;
+  tree tmp, var;
+  unsigned int mask = 0;
+
+  gfc_start_block (&block);
+  gfc_init_block (&post_block);
+
+  var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm");
+
+  set_error_locus (&block, var, &code->loc);
+  p = code->ext.open;
+
+  if (p->iomsg)
+    mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
+			p->iomsg);
+
+  if (p->iostat)
+    mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
+			       p->iostat);
+
+  if (p->err)
+    mask |= IOPARM_common_err;
+
+  if (p->file)
+    mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file);
+
+  if (p->status)
+    mask |= set_string (&block, &post_block, var, IOPARM_open_status,
+			p->status);
+
+  if (p->access)
+    mask |= set_string (&block, &post_block, var, IOPARM_open_access,
+			p->access);
+
+  if (p->form)
+    mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form);
+
+  if (p->recl)
+    mask |= set_parameter_value (&block, p->iostat, var, IOPARM_open_recl_in,
+				 p->recl);
+
+  if (p->blank)
+    mask |= set_string (&block, &post_block, var, IOPARM_open_blank,
+			p->blank);
+
+  if (p->position)
+    mask |= set_string (&block, &post_block, var, IOPARM_open_position,
+			p->position);
+
+  if (p->action)
+    mask |= set_string (&block, &post_block, var, IOPARM_open_action,
+			p->action);
+
+  if (p->delim)
+    mask |= set_string (&block, &post_block, var, IOPARM_open_delim,
+			p->delim);
+
+  if (p->pad)
+    mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad);
+
+  if (p->decimal)
+    mask |= set_string (&block, &post_block, var, IOPARM_open_decimal,
+			p->decimal);
+
+  if (p->encoding)
+    mask |= set_string (&block, &post_block, var, IOPARM_open_encoding,
+			p->encoding);
+
+  if (p->round)
+    mask |= set_string (&block, &post_block, var, IOPARM_open_round, p->round);
+
+  if (p->sign)
+    mask |= set_string (&block, &post_block, var, IOPARM_open_sign, p->sign);
+
+  if (p->asynchronous)
+    mask |= set_string (&block, &post_block, var, IOPARM_open_asynchronous,
+			p->asynchronous);
+
+  if (p->convert)
+    mask |= set_string (&block, &post_block, var, IOPARM_open_convert,
+			p->convert);
+
+  if (p->newunit)
+    mask |= set_parameter_ref (&block, &post_block, var, IOPARM_open_newunit,
+			       p->newunit);
+
+  set_parameter_const (&block, var, IOPARM_common_flags, mask);
+
+  if (p->unit)
+    set_parameter_value (&block, p->iostat, var, IOPARM_common_unit, p->unit);
+  else
+    set_parameter_const (&block, var, IOPARM_common_unit, 0);
+
+  tmp = gfc_build_addr_expr (NULL_TREE, var);
+  tmp = build_call_expr_loc (input_location,
+			 iocall[IOCALL_OPEN], 1, tmp);
+  gfc_add_expr_to_block (&block, tmp);
+
+  gfc_add_block_to_block (&block, &post_block);
+
+  io_result (&block, var, p->err, NULL, NULL);
+
+  return gfc_finish_block (&block);
+}
+
+
+/* Translate a CLOSE statement.  */
+
+tree
+gfc_trans_close (gfc_code * code)
+{
+  stmtblock_t block, post_block;
+  gfc_close *p;
+  tree tmp, var;
+  unsigned int mask = 0;
+
+  gfc_start_block (&block);
+  gfc_init_block (&post_block);
+
+  var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm");
+
+  set_error_locus (&block, var, &code->loc);
+  p = code->ext.close;
+
+  if (p->iomsg)
+    mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
+			p->iomsg);
+
+  if (p->iostat)
+    mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
+			       p->iostat);
+
+  if (p->err)
+    mask |= IOPARM_common_err;
+
+  if (p->status)
+    mask |= set_string (&block, &post_block, var, IOPARM_close_status,
+			p->status);
+
+  set_parameter_const (&block, var, IOPARM_common_flags, mask);
+
+  if (p->unit)
+    set_parameter_value (&block, p->iostat, var, IOPARM_common_unit, p->unit);
+  else
+    set_parameter_const (&block, var, IOPARM_common_unit, 0);
+
+  tmp = gfc_build_addr_expr (NULL_TREE, var);
+  tmp = build_call_expr_loc (input_location,
+			 iocall[IOCALL_CLOSE], 1, tmp);
+  gfc_add_expr_to_block (&block, tmp);
+
+  gfc_add_block_to_block (&block, &post_block);
+
+  io_result (&block, var, p->err, NULL, NULL);
+
+  return gfc_finish_block (&block);
+}
+
+
+/* Common subroutine for building a file positioning statement.  */
+
+static tree
+build_filepos (tree function, gfc_code * code)
+{
+  stmtblock_t block, post_block;
+  gfc_filepos *p;
+  tree tmp, var;
+  unsigned int mask = 0;
+
+  p = code->ext.filepos;
+
+  gfc_start_block (&block);
+  gfc_init_block (&post_block);
+
+  var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type,
+			"filepos_parm");
+
+  set_error_locus (&block, var, &code->loc);
+
+  if (p->iomsg)
+    mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
+			p->iomsg);
+
+  if (p->iostat)
+    mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
+			       p->iostat);
+
+  if (p->err)
+    mask |= IOPARM_common_err;
+
+  set_parameter_const (&block, var, IOPARM_common_flags, mask);
+
+  if (p->unit)
+    set_parameter_value (&block, p->iostat, var, IOPARM_common_unit, p->unit);
+  else
+    set_parameter_const (&block, var, IOPARM_common_unit, 0);
+
+  tmp = gfc_build_addr_expr (NULL_TREE, var);
+  tmp = build_call_expr_loc (input_location,
+			 function, 1, tmp);
+  gfc_add_expr_to_block (&block, tmp);
+
+  gfc_add_block_to_block (&block, &post_block);
+
+  io_result (&block, var, p->err, NULL, NULL);
+
+  return gfc_finish_block (&block);
+}
+
+
+/* Translate a BACKSPACE statement.  */
+
+tree
+gfc_trans_backspace (gfc_code * code)
+{
+  return build_filepos (iocall[IOCALL_BACKSPACE], code);
+}
+
+
+/* Translate an ENDFILE statement.  */
+
+tree
+gfc_trans_endfile (gfc_code * code)
+{
+  return build_filepos (iocall[IOCALL_ENDFILE], code);
+}
+
+
+/* Translate a REWIND statement.  */
+
+tree
+gfc_trans_rewind (gfc_code * code)
+{
+  return build_filepos (iocall[IOCALL_REWIND], code);
+}
+
+
+/* Translate a FLUSH statement.  */
+
+tree
+gfc_trans_flush (gfc_code * code)
+{
+  return build_filepos (iocall[IOCALL_FLUSH], code);
+}
+
+
+/* Create a dummy iostat variable to catch any error due to bad unit.  */
+
+static gfc_expr *
+create_dummy_iostat (void)
+{
+  gfc_symtree *st;
+  gfc_expr *e;
+
+  gfc_get_ha_sym_tree ("@iostat", &st);
+  st->n.sym->ts.type = BT_INTEGER;
+  st->n.sym->ts.kind = gfc_default_integer_kind;
+  gfc_set_sym_referenced (st->n.sym);
+  gfc_commit_symbol (st->n.sym);
+  st->n.sym->backend_decl
+	= gfc_create_var (gfc_get_int_type (st->n.sym->ts.kind),
+			  st->n.sym->name);
+
+  e = gfc_get_expr ();
+  e->expr_type = EXPR_VARIABLE;
+  e->symtree = st;
+  e->ts.type = BT_INTEGER;
+  e->ts.kind = st->n.sym->ts.kind;
+
+  return e;
+}
+
+
+/* Translate the non-IOLENGTH form of an INQUIRE statement.  */
+
+tree
+gfc_trans_inquire (gfc_code * code)
+{
+  stmtblock_t block, post_block;
+  gfc_inquire *p;
+  tree tmp, var;
+  unsigned int mask = 0, mask2 = 0;
+
+  gfc_start_block (&block);
+  gfc_init_block (&post_block);
+
+  var = gfc_create_var (st_parameter[IOPARM_ptype_inquire].type,
+			"inquire_parm");
+
+  set_error_locus (&block, var, &code->loc);
+  p = code->ext.inquire;
+
+  if (p->iomsg)
+    mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
+			p->iomsg);
+
+  if (p->iostat)
+    mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
+			       p->iostat);
+
+  if (p->err)
+    mask |= IOPARM_common_err;
+
+  /* Sanity check.  */
+  if (p->unit && p->file)
+    gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code->loc);
+
+  if (p->file)
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_file,
+			p->file);
+
+  if (p->exist)
+    {
+      mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist,
+				 p->exist);
+
+      if (p->unit && !p->iostat)
+	{
+	  p->iostat = create_dummy_iostat ();
+	  mask |= set_parameter_ref (&block, &post_block, var,
+				     IOPARM_common_iostat, p->iostat);
+	}
+    }
+
+  if (p->opened)
+    mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened,
+			       p->opened);
+
+  if (p->number)
+    mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_number,
+			       p->number);
+
+  if (p->named)
+    mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_named,
+			       p->named);
+
+  if (p->name)
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_name,
+			p->name);
+
+  if (p->access)
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_access,
+			p->access);
+
+  if (p->sequential)
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_sequential,
+			p->sequential);
+
+  if (p->direct)
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_direct,
+			p->direct);
+
+  if (p->form)
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_form,
+			p->form);
+
+  if (p->formatted)
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_formatted,
+			p->formatted);
+
+  if (p->unformatted)
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_unformatted,
+			p->unformatted);
+
+  if (p->recl)
+    mask |= set_parameter_ref (&block, &post_block, var,
+			       IOPARM_inquire_recl_out, p->recl);
+
+  if (p->nextrec)
+    mask |= set_parameter_ref (&block, &post_block, var,
+			       IOPARM_inquire_nextrec, p->nextrec);
+
+  if (p->blank)
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank,
+			p->blank);
+
+  if (p->delim)
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim,
+			p->delim);
+
+  if (p->position)
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_position,
+			p->position);
+
+  if (p->action)
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_action,
+			p->action);
+
+  if (p->read)
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_read,
+			p->read);
+
+  if (p->write)
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_write,
+			p->write);
+
+  if (p->readwrite)
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite,
+			p->readwrite);
+
+  if (p->pad)
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad,
+			p->pad);
+
+  if (p->convert)
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert,
+			p->convert);
+
+  if (p->strm_pos)
+    mask |= set_parameter_ref (&block, &post_block, var,
+			       IOPARM_inquire_strm_pos_out, p->strm_pos);
+
+  /* The second series of flags.  */
+  if (p->asynchronous)
+    mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_asynchronous,
+			 p->asynchronous);
+
+  if (p->decimal)
+    mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_decimal,
+			 p->decimal);
+
+  if (p->encoding)
+    mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_encoding,
+			 p->encoding);
+
+  if (p->round)
+    mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_round,
+			 p->round);
+
+  if (p->sign)
+    mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_sign,
+			 p->sign);
+
+  if (p->pending)
+    mask2 |= set_parameter_ref (&block, &post_block, var,
+				IOPARM_inquire_pending, p->pending);
+
+  if (p->size)
+    mask2 |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_size,
+				p->size);
+
+  if (p->id)
+    mask2 |= set_parameter_ref (&block, &post_block,var, IOPARM_inquire_id,
+				p->id);
+  if (p->iqstream)
+    mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_iqstream,
+			 p->iqstream);
+
+  if (mask2)
+    mask |= set_parameter_const (&block, var, IOPARM_inquire_flags2, mask2);
+
+  set_parameter_const (&block, var, IOPARM_common_flags, mask);
+
+  if (p->unit)
+    set_parameter_value (&block, p->iostat, var, IOPARM_common_unit, p->unit);
+  else
+    set_parameter_const (&block, var, IOPARM_common_unit, 0);
+
+  tmp = gfc_build_addr_expr (NULL_TREE, var);
+  tmp = build_call_expr_loc (input_location,
+			 iocall[IOCALL_INQUIRE], 1, tmp);
+  gfc_add_expr_to_block (&block, tmp);
+
+  gfc_add_block_to_block (&block, &post_block);
+
+  io_result (&block, var, p->err, NULL, NULL);
+
+  return gfc_finish_block (&block);
+}
+
+
+tree
+gfc_trans_wait (gfc_code * code)
+{
+  stmtblock_t block, post_block;
+  gfc_wait *p;
+  tree tmp, var;
+  unsigned int mask = 0;
+
+  gfc_start_block (&block);
+  gfc_init_block (&post_block);
+
+  var = gfc_create_var (st_parameter[IOPARM_ptype_wait].type,
+			"wait_parm");
+
+  set_error_locus (&block, var, &code->loc);
+  p = code->ext.wait;
+
+  /* Set parameters here.  */
+  if (p->iomsg)
+    mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
+			p->iomsg);
+
+  if (p->iostat)
+    mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
+			       p->iostat);
+
+  if (p->err)
+    mask |= IOPARM_common_err;
+
+  if (p->id)
+    mask |= set_parameter_value (&block, p->iostat, var, IOPARM_wait_id, p->id);
+
+  set_parameter_const (&block, var, IOPARM_common_flags, mask);
+
+  if (p->unit)
+    set_parameter_value (&block, p->iostat, var, IOPARM_common_unit, p->unit);
+
+  tmp = gfc_build_addr_expr (NULL_TREE, var);
+  tmp = build_call_expr_loc (input_location,
+			 iocall[IOCALL_WAIT], 1, tmp);
+  gfc_add_expr_to_block (&block, tmp);
+
+  gfc_add_block_to_block (&block, &post_block);
+
+  io_result (&block, var, p->err, NULL, NULL);
+
+  return gfc_finish_block (&block);
+
+}
+
+
+/* nml_full_name builds up the fully qualified name of a
+   derived type component.  */
+
+static char*
+nml_full_name (const char* var_name, const char* cmp_name)
+{
+  int full_name_length;
+  char * full_name;
+
+  full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
+  full_name = XCNEWVEC (char, full_name_length + 1);
+  strcpy (full_name, var_name);
+  full_name = strcat (full_name, "%");
+  full_name = strcat (full_name, cmp_name);
+  return full_name;
+}
+
+
+/* nml_get_addr_expr builds an address expression from the
+   gfc_symbol or gfc_component backend_decl's. An offset is
+   provided so that the address of an element of an array of
+   derived types is returned. This is used in the runtime to
+   determine that span of the derived type.  */
+
+static tree
+nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
+		   tree base_addr)
+{
+  tree decl = NULL_TREE;
+  tree tmp;
+
+  if (sym)
+    {
+      sym->attr.referenced = 1;
+      decl = gfc_get_symbol_decl (sym);
+
+      /* If this is the enclosing function declaration, use
+	 the fake result instead.  */
+      if (decl == current_function_decl)
+	decl = gfc_get_fake_result_decl (sym, 0);
+      else if (decl == DECL_CONTEXT (current_function_decl))
+	decl =  gfc_get_fake_result_decl (sym, 1);
+    }
+  else
+    decl = c->backend_decl;
+
+  gcc_assert (decl && ((TREE_CODE (decl) == FIELD_DECL
+		     || TREE_CODE (decl) == VAR_DECL
+		     || TREE_CODE (decl) == PARM_DECL)
+		     || TREE_CODE (decl) == COMPONENT_REF));
+
+  tmp = decl;
+
+  /* Build indirect reference, if dummy argument.  */
+
+  if (POINTER_TYPE_P (TREE_TYPE(tmp)))
+    tmp = build_fold_indirect_ref_loc (input_location, tmp);
+
+  /* Treat the component of a derived type, using base_addr for
+     the derived type.  */
+
+  if (TREE_CODE (decl) == FIELD_DECL)
+    tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
+			   base_addr, tmp, NULL_TREE);
+
+  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+    tmp = gfc_conv_array_data (tmp);
+  else
+    {
+      if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+	tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+
+      if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
+         tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL);
+
+      if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+	tmp = build_fold_indirect_ref_loc (input_location,
+				   tmp);
+    }
+
+  gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
+
+  return tmp;
+}
+
+
+/* For an object VAR_NAME whose base address is BASE_ADDR, generate a
+   call to iocall[IOCALL_SET_NML_VAL].  For derived type variable, recursively
+   generate calls to iocall[IOCALL_SET_NML_VAL] for each component.  */
+
+#define IARG(i) build_int_cst (gfc_array_index_type, i)
+
+static void
+transfer_namelist_element (stmtblock_t * block, const char * var_name,
+			   gfc_symbol * sym, gfc_component * c,
+			   tree base_addr)
+{
+  gfc_typespec * ts = NULL;
+  gfc_array_spec * as = NULL;
+  tree addr_expr = NULL;
+  tree dt = NULL;
+  tree string;
+  tree tmp;
+  tree dtype;
+  tree dt_parm_addr;
+  tree decl = NULL_TREE;
+  int n_dim;
+  int itype;
+  int rank = 0;
+
+  gcc_assert (sym || c);
+
+  /* Build the namelist object name.  */
+
+  string = gfc_build_cstring_const (var_name);
+  string = gfc_build_addr_expr (pchar_type_node, string);
+
+  /* Build ts, as and data address using symbol or component.  */
+
+  ts = (sym) ? &sym->ts : &c->ts;
+  as = (sym) ? sym->as : c->as;
+
+  addr_expr = nml_get_addr_expr (sym, c, base_addr);
+
+  if (as)
+    rank = as->rank;
+
+  if (rank)
+    {
+      decl = (sym) ? sym->backend_decl : c->backend_decl;
+      if (sym && sym->attr.dummy)
+        decl = build_fold_indirect_ref_loc (input_location, decl);
+      dt =  TREE_TYPE (decl);
+      dtype = gfc_get_dtype (dt);
+    }
+  else
+    {
+      itype = ts->type;
+      dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT);
+    }
+
+  /* Build up the arguments for the transfer call.
+     The call for the scalar part transfers:
+     (address, name, type, kind or string_length, dtype)  */
+
+  dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
+
+  if (ts->type == BT_CHARACTER)
+    tmp = ts->u.cl->backend_decl;
+  else
+    tmp = build_int_cst (gfc_charlen_type_node, 0);
+  tmp = build_call_expr_loc (input_location,
+			 iocall[IOCALL_SET_NML_VAL], 6,
+			 dt_parm_addr, addr_expr, string,
+			 IARG (ts->kind), tmp, dtype);
+  gfc_add_expr_to_block (block, tmp);
+
+  /* If the object is an array, transfer rank times:
+     (null pointer, name, stride, lbound, ubound)  */
+
+  for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
+    {
+      tmp = build_call_expr_loc (input_location,
+			     iocall[IOCALL_SET_NML_VAL_DIM], 5,
+			     dt_parm_addr,
+			     IARG (n_dim),
+			     gfc_conv_array_stride (decl, n_dim),
+			     gfc_conv_array_lbound (decl, n_dim),
+			     gfc_conv_array_ubound (decl, n_dim));
+      gfc_add_expr_to_block (block, tmp);
+    }
+
+  if (ts->type == BT_DERIVED && ts->u.derived->components)
+    {
+      gfc_component *cmp;
+
+      /* Provide the RECORD_TYPE to build component references.  */
+
+      tree expr = build_fold_indirect_ref_loc (input_location,
+					   addr_expr);
+
+      for (cmp = ts->u.derived->components; cmp; cmp = cmp->next)
+	{
+	  char *full_name = nml_full_name (var_name, cmp->name);
+	  transfer_namelist_element (block,
+				     full_name,
+				     NULL, cmp, expr);
+	  free (full_name);
+	}
+    }
+}
+
+#undef IARG
+
+/* Create a data transfer statement.  Not all of the fields are valid
+   for both reading and writing, but improper use has been filtered
+   out by now.  */
+
+static tree
+build_dt (tree function, gfc_code * code)
+{
+  stmtblock_t block, post_block, post_end_block, post_iu_block;
+  gfc_dt *dt;
+  tree tmp, var;
+  gfc_expr *nmlname;
+  gfc_namelist *nml;
+  unsigned int mask = 0;
+
+  gfc_start_block (&block);
+  gfc_init_block (&post_block);
+  gfc_init_block (&post_end_block);
+  gfc_init_block (&post_iu_block);
+
+  var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm");
+
+  set_error_locus (&block, var, &code->loc);
+
+  if (last_dt == IOLENGTH)
+    {
+      gfc_inquire *inq;
+
+      inq = code->ext.inquire;
+
+      /* First check that preconditions are met.  */
+      gcc_assert (inq != NULL);
+      gcc_assert (inq->iolength != NULL);
+
+      /* Connect to the iolength variable.  */
+      mask |= set_parameter_ref (&block, &post_end_block, var,
+				 IOPARM_dt_iolength, inq->iolength);
+      dt = NULL;
+    }
+  else
+    {
+      dt = code->ext.dt;
+      gcc_assert (dt != NULL);
+    }
+
+  if (dt && dt->io_unit)
+    {
+      if (dt->io_unit->ts.type == BT_CHARACTER)
+	{
+	  mask |= set_internal_unit (&block, &post_iu_block,
+				     var, dt->io_unit);
+	  set_parameter_const (&block, var, IOPARM_common_unit,
+			       dt->io_unit->ts.kind == 1 ? 0 : -1);
+	}
+    }
+  else
+    set_parameter_const (&block, var, IOPARM_common_unit, 0);
+
+  if (dt)
+    {
+      if (dt->iomsg)
+	mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
+			    dt->iomsg);
+
+      if (dt->iostat)
+	mask |= set_parameter_ref (&block, &post_end_block, var,
+				   IOPARM_common_iostat, dt->iostat);
+
+      if (dt->err)
+	mask |= IOPARM_common_err;
+
+      if (dt->eor)
+	mask |= IOPARM_common_eor;
+
+      if (dt->end)
+	mask |= IOPARM_common_end;
+
+      if (dt->id)
+	mask |= set_parameter_ref (&block, &post_end_block, var,
+				   IOPARM_dt_id, dt->id);
+
+      if (dt->pos)
+	mask |= set_parameter_value (&block, dt->iostat, var, IOPARM_dt_pos,
+				     dt->pos);
+
+      if (dt->asynchronous)
+	mask |= set_string (&block, &post_block, var, IOPARM_dt_asynchronous,
+			    dt->asynchronous);
+
+      if (dt->blank)
+	mask |= set_string (&block, &post_block, var, IOPARM_dt_blank,
+			    dt->blank);
+
+      if (dt->decimal)
+	mask |= set_string (&block, &post_block, var, IOPARM_dt_decimal,
+			    dt->decimal);
+
+      if (dt->delim)
+	mask |= set_string (&block, &post_block, var, IOPARM_dt_delim,
+			    dt->delim);
+
+      if (dt->pad)
+	mask |= set_string (&block, &post_block, var, IOPARM_dt_pad,
+			    dt->pad);
+
+      if (dt->round)
+	mask |= set_string (&block, &post_block, var, IOPARM_dt_round,
+			    dt->round);
+
+      if (dt->sign)
+	mask |= set_string (&block, &post_block, var, IOPARM_dt_sign,
+			    dt->sign);
+
+      if (dt->rec)
+	mask |= set_parameter_value (&block, dt->iostat, var, IOPARM_dt_rec,
+				     dt->rec);
+
+      if (dt->advance)
+	mask |= set_string (&block, &post_block, var, IOPARM_dt_advance,
+			    dt->advance);
+
+      if (dt->format_expr)
+	mask |= set_string (&block, &post_end_block, var, IOPARM_dt_format,
+			    dt->format_expr);
+
+      if (dt->format_label)
+	{
+	  if (dt->format_label == &format_asterisk)
+	    mask |= IOPARM_dt_list_format;
+	  else
+	    mask |= set_string (&block, &post_block, var, IOPARM_dt_format,
+				dt->format_label->format);
+	}
+
+      if (dt->size)
+	mask |= set_parameter_ref (&block, &post_end_block, var,
+				   IOPARM_dt_size, dt->size);
+
+      if (dt->namelist)
+	{
+	  if (dt->format_expr || dt->format_label)
+	    gfc_internal_error ("build_dt: format with namelist");
+
+          nmlname = gfc_get_character_expr (gfc_default_character_kind, NULL,
+					    dt->namelist->name,
+					    strlen (dt->namelist->name));
+
+	  mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
+			      nmlname);
+
+	  gfc_free_expr (nmlname);
+
+	  if (last_dt == READ)
+	    mask |= IOPARM_dt_namelist_read_mode;
+
+	  set_parameter_const (&block, var, IOPARM_common_flags, mask);
+
+	  dt_parm = var;
+
+	  for (nml = dt->namelist->namelist; nml; nml = nml->next)
+	    transfer_namelist_element (&block, nml->sym->name, nml->sym,
+				       NULL, NULL_TREE);
+	}
+      else
+	set_parameter_const (&block, var, IOPARM_common_flags, mask);
+
+      if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER)
+	set_parameter_value (&block, dt->iostat, var, IOPARM_common_unit,
+			     dt->io_unit);
+    }
+  else
+    set_parameter_const (&block, var, IOPARM_common_flags, mask);
+
+  tmp = gfc_build_addr_expr (NULL_TREE, var);
+  tmp = build_call_expr_loc (UNKNOWN_LOCATION,
+			 function, 1, tmp);
+  gfc_add_expr_to_block (&block, tmp);
+
+  gfc_add_block_to_block (&block, &post_block);
+
+  dt_parm = var;
+  dt_post_end_block = &post_end_block;
+
+  /* Set implied do loop exit condition.  */
+  if (last_dt == READ || last_dt == WRITE)
+    {
+      gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
+
+      tmp = fold_build3_loc (input_location, COMPONENT_REF,
+			     st_parameter[IOPARM_ptype_common].type,
+			     dt_parm, TYPE_FIELDS (TREE_TYPE (dt_parm)),
+			     NULL_TREE);
+      tmp = fold_build3_loc (input_location, COMPONENT_REF,
+			     TREE_TYPE (p->field), tmp, p->field, NULL_TREE);
+      tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (tmp),
+			     tmp, build_int_cst (TREE_TYPE (tmp),
+			     IOPARM_common_libreturn_mask));
+    }
+  else /* IOLENGTH */
+    tmp = NULL_TREE;
+
+  gfc_add_expr_to_block (&block, gfc_trans_code_cond (code->block->next, tmp));
+
+  gfc_add_block_to_block (&block, &post_iu_block);
+
+  dt_parm = NULL;
+  dt_post_end_block = NULL;
+
+  return gfc_finish_block (&block);
+}
+
+
+/* Translate the IOLENGTH form of an INQUIRE statement.  We treat
+   this as a third sort of data transfer statement, except that
+   lengths are summed instead of actually transferring any data.  */
+
+tree
+gfc_trans_iolength (gfc_code * code)
+{
+  last_dt = IOLENGTH;
+  return build_dt (iocall[IOCALL_IOLENGTH], code);
+}
+
+
+/* Translate a READ statement.  */
+
+tree
+gfc_trans_read (gfc_code * code)
+{
+  last_dt = READ;
+  return build_dt (iocall[IOCALL_READ], code);
+}
+
+
+/* Translate a WRITE statement */
+
+tree
+gfc_trans_write (gfc_code * code)
+{
+  last_dt = WRITE;
+  return build_dt (iocall[IOCALL_WRITE], code);
+}
+
+
+/* Finish a data transfer statement.  */
+
+tree
+gfc_trans_dt_end (gfc_code * code)
+{
+  tree function, tmp;
+  stmtblock_t block;
+
+  gfc_init_block (&block);
+
+  switch (last_dt)
+    {
+    case READ:
+      function = iocall[IOCALL_READ_DONE];
+      break;
+
+    case WRITE:
+      function = iocall[IOCALL_WRITE_DONE];
+      break;
+
+    case IOLENGTH:
+      function = iocall[IOCALL_IOLENGTH_DONE];
+      break;
+
+    default:
+      gcc_unreachable ();
+    }
+
+  tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
+  tmp = build_call_expr_loc (input_location,
+			 function, 1, tmp);
+  gfc_add_expr_to_block (&block, tmp);
+  gfc_add_block_to_block (&block, dt_post_end_block);
+  gfc_init_block (dt_post_end_block);
+
+  if (last_dt != IOLENGTH)
+    {
+      gcc_assert (code->ext.dt != NULL);
+      io_result (&block, dt_parm, code->ext.dt->err,
+		 code->ext.dt->end, code->ext.dt->eor);
+    }
+
+  return gfc_finish_block (&block);
+}
+
+static void
+transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code);
+
+/* Given an array field in a derived type variable, generate the code
+   for the loop that iterates over array elements, and the code that
+   accesses those array elements.  Use transfer_expr to generate code
+   for transferring that element.  Because elements may also be
+   derived types, transfer_expr and transfer_array_component are mutually
+   recursive.  */
+
+static tree
+transfer_array_component (tree expr, gfc_component * cm, locus * where)
+{
+  tree tmp;
+  stmtblock_t body;
+  stmtblock_t block;
+  gfc_loopinfo loop;
+  int n;
+  gfc_ss *ss;
+  gfc_se se;
+  gfc_array_info *ss_array;
+
+  gfc_start_block (&block);
+  gfc_init_se (&se, NULL);
+
+  /* Create and initialize Scalarization Status.  Unlike in
+     gfc_trans_transfer, we can't simply use gfc_walk_expr to take
+     care of this task, because we don't have a gfc_expr at hand.
+     Build one manually, as in gfc_trans_subarray_assign.  */
+
+  ss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
+			 GFC_SS_COMPONENT);
+  ss_array = &ss->info->data.array;
+  ss_array->shape = gfc_get_shape (cm->as->rank);
+  ss_array->descriptor = expr;
+  ss_array->data = gfc_conv_array_data (expr);
+  ss_array->offset = gfc_conv_array_offset (expr);
+  for (n = 0; n < cm->as->rank; n++)
+    {
+      ss_array->start[n] = gfc_conv_array_lbound (expr, n);
+      ss_array->stride[n] = gfc_index_one_node;
+
+      mpz_init (ss_array->shape[n]);
+      mpz_sub (ss_array->shape[n], cm->as->upper[n]->value.integer,
+               cm->as->lower[n]->value.integer);
+      mpz_add_ui (ss_array->shape[n], ss_array->shape[n], 1);
+    }
+
+  /* Once we got ss, we use scalarizer to create the loop.  */
+
+  gfc_init_loopinfo (&loop);
+  gfc_add_ss_to_loop (&loop, ss);
+  gfc_conv_ss_startstride (&loop);
+  gfc_conv_loop_setup (&loop, where);
+  gfc_mark_ss_chain_used (ss, 1);
+  gfc_start_scalarized_body (&loop, &body);
+
+  gfc_copy_loopinfo_to_se (&se, &loop);
+  se.ss = ss;
+
+  /* gfc_conv_tmp_array_ref assumes that se.expr contains the array.  */
+  se.expr = expr;
+  gfc_conv_tmp_array_ref (&se);
+
+  /* Now se.expr contains an element of the array.  Take the address and pass
+     it to the IO routines.  */
+  tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
+  transfer_expr (&se, &cm->ts, tmp, NULL);
+
+  /* We are done now with the loop body.  Wrap up the scalarizer and
+     return.  */
+
+  gfc_add_block_to_block (&body, &se.pre);
+  gfc_add_block_to_block (&body, &se.post);
+
+  gfc_trans_scalarizing_loops (&loop, &body);
+
+  gfc_add_block_to_block (&block, &loop.pre);
+  gfc_add_block_to_block (&block, &loop.post);
+
+  gcc_assert (ss_array->shape != NULL);
+  gfc_free_shape (&ss_array->shape, cm->as->rank);
+  gfc_cleanup_loop (&loop);
+
+  return gfc_finish_block (&block);
+}
+
+/* Generate the call for a scalar transfer node.  */
+
+static void
+transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
+{
+  tree tmp, function, arg2, arg3, field, expr;
+  gfc_component *c;
+  int kind;
+
+  /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
+     the user says something like: print *, 'c_null_ptr: ', c_null_ptr
+     We need to translate the expression to a constant if it's either
+     C_NULL_PTR or C_NULL_FUNPTR.  We could also get a user variable of
+     type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
+     BT_DERIVED (could have been changed by gfc_conv_expr).  */
+  if ((ts->type == BT_DERIVED || ts->type == BT_INTEGER)
+      && ts->u.derived != NULL
+      && (ts->is_iso_c == 1 || ts->u.derived->ts.is_iso_c == 1))
+    {
+      ts->type = BT_INTEGER;
+      ts->kind = gfc_index_integer_kind;
+    }
+
+  kind = ts->kind;
+  function = NULL;
+  arg2 = NULL;
+  arg3 = NULL;
+
+  switch (ts->type)
+    {
+    case BT_INTEGER:
+      arg2 = build_int_cst (integer_type_node, kind);
+      if (last_dt == READ)
+	function = iocall[IOCALL_X_INTEGER];
+      else
+	function = iocall[IOCALL_X_INTEGER_WRITE];
+
+      break;
+
+    case BT_REAL:
+      arg2 = build_int_cst (integer_type_node, kind);
+      if (last_dt == READ)
+	{
+	  if (gfc_real16_is_float128 && ts->kind == 16)
+	    function = iocall[IOCALL_X_REAL128];
+	  else
+	    function = iocall[IOCALL_X_REAL];
+	}
+      else
+	{
+	  if (gfc_real16_is_float128 && ts->kind == 16)
+	    function = iocall[IOCALL_X_REAL128_WRITE];
+	  else
+	    function = iocall[IOCALL_X_REAL_WRITE];
+	}
+
+      break;
+
+    case BT_COMPLEX:
+      arg2 = build_int_cst (integer_type_node, kind);
+      if (last_dt == READ)
+	{
+	  if (gfc_real16_is_float128 && ts->kind == 16)
+	    function = iocall[IOCALL_X_COMPLEX128];
+	  else
+	    function = iocall[IOCALL_X_COMPLEX];
+	}
+      else
+	{
+	  if (gfc_real16_is_float128 && ts->kind == 16)
+	    function = iocall[IOCALL_X_COMPLEX128_WRITE];
+	  else
+	    function = iocall[IOCALL_X_COMPLEX_WRITE];
+	}
+
+      break;
+
+    case BT_LOGICAL:
+      arg2 = build_int_cst (integer_type_node, kind);
+      if (last_dt == READ)
+	function = iocall[IOCALL_X_LOGICAL];
+      else
+	function = iocall[IOCALL_X_LOGICAL_WRITE];
+
+      break;
+
+    case BT_CHARACTER:
+      if (kind == 4)
+	{
+	  if (se->string_length)
+	    arg2 = se->string_length;
+	  else
+	    {
+	      tmp = build_fold_indirect_ref_loc (input_location,
+					     addr_expr);
+	      gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
+	      arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
+	      arg2 = fold_convert (gfc_charlen_type_node, arg2);
+	    }
+	  arg3 = build_int_cst (integer_type_node, kind);
+	  if (last_dt == READ)
+	    function = iocall[IOCALL_X_CHARACTER_WIDE];
+	  else
+	    function = iocall[IOCALL_X_CHARACTER_WIDE_WRITE];
+
+	  tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
+	  tmp = build_call_expr_loc (input_location,
+				 function, 4, tmp, addr_expr, arg2, arg3);
+	  gfc_add_expr_to_block (&se->pre, tmp);
+	  gfc_add_block_to_block (&se->pre, &se->post);
+	  return;
+	}
+      /* Fall through. */
+    case BT_HOLLERITH:
+      if (se->string_length)
+	arg2 = se->string_length;
+      else
+	{
+	  tmp = build_fold_indirect_ref_loc (input_location,
+					 addr_expr);
+	  gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
+	  arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
+	}
+      if (last_dt == READ)
+	function = iocall[IOCALL_X_CHARACTER];
+      else
+	function = iocall[IOCALL_X_CHARACTER_WRITE];
+
+      break;
+
+    case BT_DERIVED:
+      if (ts->u.derived->components == NULL)
+	return;
+
+      /* Recurse into the elements of the derived type.  */
+      expr = gfc_evaluate_now (addr_expr, &se->pre);
+      expr = build_fold_indirect_ref_loc (input_location,
+				      expr);
+
+      /* Make sure that the derived type has been built.  An external
+	 function, if only referenced in an io statement, requires this
+	 check (see PR58771).  */
+      if (ts->u.derived->backend_decl == NULL_TREE)
+	(void) gfc_typenode_for_spec (ts);
+
+      for (c = ts->u.derived->components; c; c = c->next)
+	{
+	  field = c->backend_decl;
+	  gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
+
+	  tmp = fold_build3_loc (UNKNOWN_LOCATION,
+			     COMPONENT_REF, TREE_TYPE (field),
+			     expr, field, NULL_TREE);
+
+          if (c->attr.dimension)
+            {
+              tmp = transfer_array_component (tmp, c, & code->loc);
+              gfc_add_expr_to_block (&se->pre, tmp);
+            }
+          else
+            {
+              if (!c->attr.pointer)
+                tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+              transfer_expr (se, &c->ts, tmp, code);
+            }
+	}
+      return;
+
+    default:
+      internal_error ("Bad IO basetype (%d)", ts->type);
+    }
+
+  tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
+  tmp = build_call_expr_loc (input_location,
+			 function, 3, tmp, addr_expr, arg2);
+  gfc_add_expr_to_block (&se->pre, tmp);
+  gfc_add_block_to_block (&se->pre, &se->post);
+
+}
+
+
+/* Generate a call to pass an array descriptor to the IO library. The
+   array should be of one of the intrinsic types.  */
+
+static void
+transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
+{
+  tree tmp, charlen_arg, kind_arg, io_call;
+
+  if (ts->type == BT_CHARACTER)
+    charlen_arg = se->string_length;
+  else
+    charlen_arg = build_int_cst (gfc_charlen_type_node, 0);
+
+  kind_arg = build_int_cst (integer_type_node, ts->kind);
+
+  tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
+  if (last_dt == READ)
+    io_call = iocall[IOCALL_X_ARRAY];
+  else
+    io_call = iocall[IOCALL_X_ARRAY_WRITE];
+
+  tmp = build_call_expr_loc (UNKNOWN_LOCATION,
+			 io_call, 4,
+			 tmp, addr_expr, kind_arg, charlen_arg);
+  gfc_add_expr_to_block (&se->pre, tmp);
+  gfc_add_block_to_block (&se->pre, &se->post);
+}
+
+
+/* gfc_trans_transfer()-- Translate a TRANSFER code node */
+
+tree
+gfc_trans_transfer (gfc_code * code)
+{
+  stmtblock_t block, body;
+  gfc_loopinfo loop;
+  gfc_expr *expr;
+  gfc_ref *ref;
+  gfc_ss *ss;
+  gfc_se se;
+  tree tmp;
+  int n;
+
+  gfc_start_block (&block);
+  gfc_init_block (&body);
+
+  expr = code->expr1;
+  ref = NULL;
+  gfc_init_se (&se, NULL);
+
+  if (expr->rank == 0)
+    {
+      /* Transfer a scalar value.  */
+      gfc_conv_expr_reference (&se, expr);
+      transfer_expr (&se, &expr->ts, se.expr, code);
+    }
+  else
+    {
+      /* Transfer an array. If it is an array of an intrinsic
+	 type, pass the descriptor to the library.  Otherwise
+	 scalarize the transfer.  */
+      if (expr->ref && !gfc_is_proc_ptr_comp (expr))
+	{
+	  for (ref = expr->ref; ref && ref->type != REF_ARRAY;
+	    ref = ref->next);
+	  gcc_assert (ref && ref->type == REF_ARRAY);
+	}
+
+      if (expr->ts.type != BT_DERIVED
+	    && ref && ref->next == NULL
+	    && !is_subref_array (expr))
+	{
+	  bool seen_vector = false;
+
+	  if (ref && ref->u.ar.type == AR_SECTION)
+	    {
+	      for (n = 0; n < ref->u.ar.dimen; n++)
+		if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
+		  {
+		    seen_vector = true;
+		    break;
+		  }
+	    }
+
+	  if (seen_vector && last_dt == READ)
+	    {
+	      /* Create a temp, read to that and copy it back.  */
+	      gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT, false);
+	      tmp =  se.expr;
+	    }
+	  else
+	    {
+	      /* Get the descriptor.  */
+	      gfc_conv_expr_descriptor (&se, expr);
+	      tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
+	    }
+
+	  transfer_array_desc (&se, &expr->ts, tmp);
+	  goto finish_block_label;
+	}
+
+      /* Initialize the scalarizer.  */
+      ss = gfc_walk_expr (expr);
+      gfc_init_loopinfo (&loop);
+      gfc_add_ss_to_loop (&loop, ss);
+
+      /* Initialize the loop.  */
+      gfc_conv_ss_startstride (&loop);
+      gfc_conv_loop_setup (&loop, &code->expr1->where);
+
+      /* The main loop body.  */
+      gfc_mark_ss_chain_used (ss, 1);
+      gfc_start_scalarized_body (&loop, &body);
+
+      gfc_copy_loopinfo_to_se (&se, &loop);
+      se.ss = ss;
+
+      gfc_conv_expr_reference (&se, expr);
+      transfer_expr (&se, &expr->ts, se.expr, code);
+    }
+
+ finish_block_label:
+
+  gfc_add_block_to_block (&body, &se.pre);
+  gfc_add_block_to_block (&body, &se.post);
+
+  if (se.ss == NULL)
+    tmp = gfc_finish_block (&body);
+  else
+    {
+      gcc_assert (expr->rank != 0);
+      gcc_assert (se.ss == gfc_ss_terminator);
+      gfc_trans_scalarizing_loops (&loop, &body);
+
+      gfc_add_block_to_block (&loop.pre, &loop.post);
+      tmp = gfc_finish_block (&loop.pre);
+      gfc_cleanup_loop (&loop);
+    }
+
+  gfc_add_expr_to_block (&block, tmp);
+
+  return gfc_finish_block (&block);
+}
+
+#include "gt-fortran-trans-io.h"
diff --git a/gcc-4.9/gcc/fortran/trans-openmp.c b/gcc-4.9/gcc/fortran/trans-openmp.c
new file mode 100644
index 000000000..41020a836
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/trans-openmp.c
@@ -0,0 +1,1959 @@
+/* OpenMP directive translation -- generate GCC trees from gfc_code.
+   Copyright (C) 2005-2014 Free Software Foundation, Inc.
+   Contributed by Jakub Jelinek <jakub@redhat.com>
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "tree.h"
+#include "gimple-expr.h"
+#include "gimplify.h"	/* For create_tmp_var_raw.  */
+#include "stringpool.h"
+#include "diagnostic-core.h"	/* For internal_error.  */
+#include "gfortran.h"
+#include "trans.h"
+#include "trans-stmt.h"
+#include "trans-types.h"
+#include "trans-array.h"
+#include "trans-const.h"
+#include "arith.h"
+#include "omp-low.h"
+
+int ompws_flags;
+
+/* True if OpenMP should privatize what this DECL points to rather
+   than the DECL itself.  */
+
+bool
+gfc_omp_privatize_by_reference (const_tree decl)
+{
+  tree type = TREE_TYPE (decl);
+
+  if (TREE_CODE (type) == REFERENCE_TYPE
+      && (!DECL_ARTIFICIAL (decl) || TREE_CODE (decl) == PARM_DECL))
+    return true;
+
+  if (TREE_CODE (type) == POINTER_TYPE)
+    {
+      /* Array POINTER/ALLOCATABLE have aggregate types, all user variables
+	 that have POINTER_TYPE type and don't have GFC_POINTER_TYPE_P
+	 set are supposed to be privatized by reference.  */
+      if (GFC_POINTER_TYPE_P (type))
+	return false;
+
+      if (!DECL_ARTIFICIAL (decl)
+	  && TREE_CODE (TREE_TYPE (type)) != FUNCTION_TYPE)
+	return true;
+
+      /* Some arrays are expanded as DECL_ARTIFICIAL pointers
+	 by the frontend.  */
+      if (DECL_LANG_SPECIFIC (decl)
+	  && GFC_DECL_SAVED_DESCRIPTOR (decl))
+	return true;
+    }
+
+  return false;
+}
+
+/* True if OpenMP sharing attribute of DECL is predetermined.  */
+
+enum omp_clause_default_kind
+gfc_omp_predetermined_sharing (tree decl)
+{
+  if (DECL_ARTIFICIAL (decl)
+      && ! GFC_DECL_RESULT (decl)
+      && ! (DECL_LANG_SPECIFIC (decl)
+	    && GFC_DECL_SAVED_DESCRIPTOR (decl)))
+    return OMP_CLAUSE_DEFAULT_SHARED;
+
+  /* Cray pointees shouldn't be listed in any clauses and should be
+     gimplified to dereference of the corresponding Cray pointer.
+     Make them all private, so that they are emitted in the debug
+     information.  */
+  if (GFC_DECL_CRAY_POINTEE (decl))
+    return OMP_CLAUSE_DEFAULT_PRIVATE;
+
+  /* Assumed-size arrays are predetermined shared.  */
+  if (TREE_CODE (decl) == PARM_DECL
+      && GFC_ARRAY_TYPE_P (TREE_TYPE (decl))
+      && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_UNKNOWN
+      && GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl),
+				GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)) - 1)
+	 == NULL)
+    return OMP_CLAUSE_DEFAULT_SHARED;
+
+  /* Dummy procedures aren't considered variables by OpenMP, thus are
+     disallowed in OpenMP clauses.  They are represented as PARM_DECLs
+     in the middle-end, so return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE here
+     to avoid complaining about their uses with default(none).  */
+  if (TREE_CODE (decl) == PARM_DECL
+      && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE
+      && TREE_CODE (TREE_TYPE (TREE_TYPE (decl))) == FUNCTION_TYPE)
+    return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
+
+  /* COMMON and EQUIVALENCE decls are shared.  They
+     are only referenced through DECL_VALUE_EXPR of the variables
+     contained in them.  If those are privatized, they will not be
+     gimplified to the COMMON or EQUIVALENCE decls.  */
+  if (GFC_DECL_COMMON_OR_EQUIV (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
+    return OMP_CLAUSE_DEFAULT_SHARED;
+
+  if (GFC_DECL_RESULT (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
+    return OMP_CLAUSE_DEFAULT_SHARED;
+
+  return OMP_CLAUSE_DEFAULT_UNSPECIFIED;
+}
+
+/* Return decl that should be used when reporting DEFAULT(NONE)
+   diagnostics.  */
+
+tree
+gfc_omp_report_decl (tree decl)
+{
+  if (DECL_ARTIFICIAL (decl)
+      && DECL_LANG_SPECIFIC (decl)
+      && GFC_DECL_SAVED_DESCRIPTOR (decl))
+    return GFC_DECL_SAVED_DESCRIPTOR (decl);
+
+  return decl;
+}
+
+/* Return true if DECL in private clause needs
+   OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause.  */
+bool
+gfc_omp_private_outer_ref (tree decl)
+{
+  tree type = TREE_TYPE (decl);
+
+  if (GFC_DESCRIPTOR_TYPE_P (type)
+      && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
+    return true;
+
+  return false;
+}
+
+/* Return code to initialize DECL with its default constructor, or
+   NULL if there's nothing to do.  */
+
+tree
+gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer)
+{
+  tree type = TREE_TYPE (decl), rank, size, esize, ptr, cond, then_b, else_b;
+  stmtblock_t block, cond_block;
+
+  if (! GFC_DESCRIPTOR_TYPE_P (type)
+      || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
+    return NULL;
+
+  if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_REDUCTION)
+    return NULL;
+
+  gcc_assert (outer != NULL);
+  gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_PRIVATE
+	      || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LASTPRIVATE);
+
+  /* Allocatable arrays in PRIVATE clauses need to be set to
+     "not currently allocated" allocation status if outer
+     array is "not currently allocated", otherwise should be allocated.  */
+  gfc_start_block (&block);
+
+  gfc_init_block (&cond_block);
+
+  gfc_add_modify (&cond_block, decl, outer);
+  rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
+  size = gfc_conv_descriptor_ubound_get (decl, rank);
+  size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			  size, gfc_conv_descriptor_lbound_get (decl, rank));
+  size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			  size, gfc_index_one_node);
+  if (GFC_TYPE_ARRAY_RANK (type) > 1)
+    size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			    size, gfc_conv_descriptor_stride_get (decl, rank));
+  esize = fold_convert (gfc_array_index_type,
+			TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+  size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			  size, esize);
+  size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block);
+
+  ptr = gfc_create_var (pvoid_type_node, NULL);
+  gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE);
+  gfc_conv_descriptor_data_set (&cond_block, decl, ptr);
+
+  then_b = gfc_finish_block (&cond_block);
+
+  gfc_init_block (&cond_block);
+  gfc_conv_descriptor_data_set (&cond_block, decl, null_pointer_node);
+  else_b = gfc_finish_block (&cond_block);
+
+  cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			  fold_convert (pvoid_type_node,
+					gfc_conv_descriptor_data_get (outer)),
+			  null_pointer_node);
+  gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR,
+			 void_type_node, cond, then_b, else_b));
+
+  return gfc_finish_block (&block);
+}
+
+/* Build and return code for a copy constructor from SRC to DEST.  */
+
+tree
+gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
+{
+  tree type = TREE_TYPE (dest), ptr, size, esize, rank, call;
+  tree cond, then_b, else_b;
+  stmtblock_t block, cond_block;
+
+  if (! GFC_DESCRIPTOR_TYPE_P (type)
+      || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
+    return build2_v (MODIFY_EXPR, dest, src);
+
+  gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE);
+
+  /* Allocatable arrays in FIRSTPRIVATE clauses need to be allocated
+     and copied from SRC.  */
+  gfc_start_block (&block);
+
+  gfc_init_block (&cond_block);
+
+  gfc_add_modify (&cond_block, dest, src);
+  rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
+  size = gfc_conv_descriptor_ubound_get (dest, rank);
+  size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			  size, gfc_conv_descriptor_lbound_get (dest, rank));
+  size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			  size, gfc_index_one_node);
+  if (GFC_TYPE_ARRAY_RANK (type) > 1)
+    size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			    size, gfc_conv_descriptor_stride_get (dest, rank));
+  esize = fold_convert (gfc_array_index_type,
+			TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+  size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			  size, esize);
+  size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block);
+
+  ptr = gfc_create_var (pvoid_type_node, NULL);
+  gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE);
+  gfc_conv_descriptor_data_set (&cond_block, dest, ptr);
+
+  call = build_call_expr_loc (input_location,
+			  builtin_decl_explicit (BUILT_IN_MEMCPY),
+			  3, ptr,
+			  fold_convert (pvoid_type_node,
+					gfc_conv_descriptor_data_get (src)),
+			  size);
+  gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call));
+  then_b = gfc_finish_block (&cond_block);
+
+  gfc_init_block (&cond_block);
+  gfc_conv_descriptor_data_set (&cond_block, dest, null_pointer_node);
+  else_b = gfc_finish_block (&cond_block);
+
+  cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			  fold_convert (pvoid_type_node,
+					gfc_conv_descriptor_data_get (src)),
+			  null_pointer_node);
+  gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR,
+			 void_type_node, cond, then_b, else_b));
+
+  return gfc_finish_block (&block);
+}
+
+/* Similarly, except use an assignment operator instead.  */
+
+tree
+gfc_omp_clause_assign_op (tree clause ATTRIBUTE_UNUSED, tree dest, tree src)
+{
+  tree type = TREE_TYPE (dest), rank, size, esize, call;
+  stmtblock_t block;
+
+  if (! GFC_DESCRIPTOR_TYPE_P (type)
+      || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
+    return build2_v (MODIFY_EXPR, dest, src);
+
+  /* Handle copying allocatable arrays.  */
+  gfc_start_block (&block);
+
+  rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
+  size = gfc_conv_descriptor_ubound_get (dest, rank);
+  size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			  size, gfc_conv_descriptor_lbound_get (dest, rank));
+  size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			  size, gfc_index_one_node);
+  if (GFC_TYPE_ARRAY_RANK (type) > 1)
+    size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			    size, gfc_conv_descriptor_stride_get (dest, rank));
+  esize = fold_convert (gfc_array_index_type,
+			TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+  size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			  size, esize);
+  size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
+  call = build_call_expr_loc (input_location,
+			  builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
+			  fold_convert (pvoid_type_node,
+					gfc_conv_descriptor_data_get (dest)),
+			  fold_convert (pvoid_type_node,
+					gfc_conv_descriptor_data_get (src)),
+			  size);
+  gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
+
+  return gfc_finish_block (&block);
+}
+
+/* Build and return code destructing DECL.  Return NULL if nothing
+   to be done.  */
+
+tree
+gfc_omp_clause_dtor (tree clause ATTRIBUTE_UNUSED, tree decl)
+{
+  tree type = TREE_TYPE (decl);
+
+  if (! GFC_DESCRIPTOR_TYPE_P (type)
+      || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
+    return NULL;
+
+  if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_REDUCTION)
+    return NULL;
+
+  /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
+     to be deallocated if they were allocated.  */
+  return gfc_trans_dealloc_allocated (decl, false, NULL);
+}
+
+
+/* Return true if DECL's DECL_VALUE_EXPR (if any) should be
+   disregarded in OpenMP construct, because it is going to be
+   remapped during OpenMP lowering.  SHARED is true if DECL
+   is going to be shared, false if it is going to be privatized.  */
+
+bool
+gfc_omp_disregard_value_expr (tree decl, bool shared)
+{
+  if (GFC_DECL_COMMON_OR_EQUIV (decl)
+      && DECL_HAS_VALUE_EXPR_P (decl))
+    {
+      tree value = DECL_VALUE_EXPR (decl);
+
+      if (TREE_CODE (value) == COMPONENT_REF
+	  && TREE_CODE (TREE_OPERAND (value, 0)) == VAR_DECL
+	  && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
+	{
+	  /* If variable in COMMON or EQUIVALENCE is privatized, return
+	     true, as just that variable is supposed to be privatized,
+	     not the whole COMMON or whole EQUIVALENCE.
+	     For shared variables in COMMON or EQUIVALENCE, let them be
+	     gimplified to DECL_VALUE_EXPR, so that for multiple shared vars
+	     from the same COMMON or EQUIVALENCE just one sharing of the
+	     whole COMMON or EQUIVALENCE is enough.  */
+	  return ! shared;
+	}
+    }
+
+  if (GFC_DECL_RESULT (decl) && DECL_HAS_VALUE_EXPR_P (decl))
+    return ! shared;
+
+  return false;
+}
+
+/* Return true if DECL that is shared iff SHARED is true should
+   be put into OMP_CLAUSE_PRIVATE with OMP_CLAUSE_PRIVATE_DEBUG
+   flag set.  */
+
+bool
+gfc_omp_private_debug_clause (tree decl, bool shared)
+{
+  if (GFC_DECL_CRAY_POINTEE (decl))
+    return true;
+
+  if (GFC_DECL_COMMON_OR_EQUIV (decl)
+      && DECL_HAS_VALUE_EXPR_P (decl))
+    {
+      tree value = DECL_VALUE_EXPR (decl);
+
+      if (TREE_CODE (value) == COMPONENT_REF
+	  && TREE_CODE (TREE_OPERAND (value, 0)) == VAR_DECL
+	  && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
+	return shared;
+    }
+
+  return false;
+}
+
+/* Register language specific type size variables as potentially OpenMP
+   firstprivate variables.  */
+
+void
+gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *ctx, tree type)
+{
+  if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
+    {
+      int r;
+
+      gcc_assert (TYPE_LANG_SPECIFIC (type) != NULL);
+      for (r = 0; r < GFC_TYPE_ARRAY_RANK (type); r++)
+	{
+	  omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_LBOUND (type, r));
+	  omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_UBOUND (type, r));
+	  omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_STRIDE (type, r));
+	}
+      omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_SIZE (type));
+      omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_OFFSET (type));
+    }
+}
+
+
+static inline tree
+gfc_trans_add_clause (tree node, tree tail)
+{
+  OMP_CLAUSE_CHAIN (node) = tail;
+  return node;
+}
+
+static tree
+gfc_trans_omp_variable (gfc_symbol *sym)
+{
+  tree t = gfc_get_symbol_decl (sym);
+  tree parent_decl;
+  int parent_flag;
+  bool return_value;
+  bool alternate_entry;
+  bool entry_master;
+
+  return_value = sym->attr.function && sym->result == sym;
+  alternate_entry = sym->attr.function && sym->attr.entry
+		    && sym->result == sym;
+  entry_master = sym->attr.result
+		 && sym->ns->proc_name->attr.entry_master
+		 && !gfc_return_by_reference (sym->ns->proc_name);
+  parent_decl = DECL_CONTEXT (current_function_decl);
+
+  if ((t == parent_decl && return_value)
+       || (sym->ns && sym->ns->proc_name
+	   && sym->ns->proc_name->backend_decl == parent_decl
+	   && (alternate_entry || entry_master)))
+    parent_flag = 1;
+  else
+    parent_flag = 0;
+
+  /* Special case for assigning the return value of a function.
+     Self recursive functions must have an explicit return value.  */
+  if (return_value && (t == current_function_decl || parent_flag))
+    t = gfc_get_fake_result_decl (sym, parent_flag);
+
+  /* Similarly for alternate entry points.  */
+  else if (alternate_entry
+	   && (sym->ns->proc_name->backend_decl == current_function_decl
+	       || parent_flag))
+    {
+      gfc_entry_list *el = NULL;
+
+      for (el = sym->ns->entries; el; el = el->next)
+	if (sym == el->sym)
+	  {
+	    t = gfc_get_fake_result_decl (sym, parent_flag);
+	    break;
+	  }
+    }
+
+  else if (entry_master
+	   && (sym->ns->proc_name->backend_decl == current_function_decl
+	       || parent_flag))
+    t = gfc_get_fake_result_decl (sym, parent_flag);
+
+  return t;
+}
+
+static tree
+gfc_trans_omp_variable_list (enum omp_clause_code code, gfc_namelist *namelist,
+			     tree list)
+{
+  for (; namelist != NULL; namelist = namelist->next)
+    if (namelist->sym->attr.referenced)
+      {
+	tree t = gfc_trans_omp_variable (namelist->sym);
+	if (t != error_mark_node)
+	  {
+	    tree node = build_omp_clause (input_location, code);
+	    OMP_CLAUSE_DECL (node) = t;
+	    list = gfc_trans_add_clause (node, list);
+	  }
+      }
+  return list;
+}
+
+static void
+gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
+{
+  gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL;
+  gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL;
+  gfc_symbol init_val_sym, outer_sym, intrinsic_sym;
+  gfc_expr *e1, *e2, *e3, *e4;
+  gfc_ref *ref;
+  tree decl, backend_decl, stmt, type, outer_decl;
+  locus old_loc = gfc_current_locus;
+  const char *iname;
+  bool t;
+
+  decl = OMP_CLAUSE_DECL (c);
+  gfc_current_locus = where;
+  type = TREE_TYPE (decl);
+  outer_decl = create_tmp_var_raw (type, NULL);
+  if (TREE_CODE (decl) == PARM_DECL
+      && TREE_CODE (type) == REFERENCE_TYPE
+      && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type))
+      && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (type)) == GFC_ARRAY_ALLOCATABLE)
+    {
+      decl = build_fold_indirect_ref (decl);
+      type = TREE_TYPE (type);
+    }
+
+  /* Create a fake symbol for init value.  */
+  memset (&init_val_sym, 0, sizeof (init_val_sym));
+  init_val_sym.ns = sym->ns;
+  init_val_sym.name = sym->name;
+  init_val_sym.ts = sym->ts;
+  init_val_sym.attr.referenced = 1;
+  init_val_sym.declared_at = where;
+  init_val_sym.attr.flavor = FL_VARIABLE;
+  backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym));
+  init_val_sym.backend_decl = backend_decl;
+
+  /* Create a fake symbol for the outer array reference.  */
+  outer_sym = *sym;
+  outer_sym.as = gfc_copy_array_spec (sym->as);
+  outer_sym.attr.dummy = 0;
+  outer_sym.attr.result = 0;
+  outer_sym.attr.flavor = FL_VARIABLE;
+  outer_sym.backend_decl = outer_decl;
+  if (decl != OMP_CLAUSE_DECL (c))
+    outer_sym.backend_decl = build_fold_indirect_ref (outer_decl);
+
+  /* Create fake symtrees for it.  */
+  symtree1 = gfc_new_symtree (&root1, sym->name);
+  symtree1->n.sym = sym;
+  gcc_assert (symtree1 == root1);
+
+  symtree2 = gfc_new_symtree (&root2, sym->name);
+  symtree2->n.sym = &init_val_sym;
+  gcc_assert (symtree2 == root2);
+
+  symtree3 = gfc_new_symtree (&root3, sym->name);
+  symtree3->n.sym = &outer_sym;
+  gcc_assert (symtree3 == root3);
+
+  /* Create expressions.  */
+  e1 = gfc_get_expr ();
+  e1->expr_type = EXPR_VARIABLE;
+  e1->where = where;
+  e1->symtree = symtree1;
+  e1->ts = sym->ts;
+  e1->ref = ref = gfc_get_ref ();
+  ref->type = REF_ARRAY;
+  ref->u.ar.where = where;
+  ref->u.ar.as = sym->as;
+  ref->u.ar.type = AR_FULL;
+  ref->u.ar.dimen = 0;
+  t = gfc_resolve_expr (e1);
+  gcc_assert (t);
+
+  e2 = gfc_get_expr ();
+  e2->expr_type = EXPR_VARIABLE;
+  e2->where = where;
+  e2->symtree = symtree2;
+  e2->ts = sym->ts;
+  t = gfc_resolve_expr (e2);
+  gcc_assert (t);
+
+  e3 = gfc_copy_expr (e1);
+  e3->symtree = symtree3;
+  t = gfc_resolve_expr (e3);
+  gcc_assert (t);
+
+  iname = NULL;
+  switch (OMP_CLAUSE_REDUCTION_CODE (c))
+    {
+    case PLUS_EXPR:
+    case MINUS_EXPR:
+      e4 = gfc_add (e3, e1);
+      break;
+    case MULT_EXPR:
+      e4 = gfc_multiply (e3, e1);
+      break;
+    case TRUTH_ANDIF_EXPR:
+      e4 = gfc_and (e3, e1);
+      break;
+    case TRUTH_ORIF_EXPR:
+      e4 = gfc_or (e3, e1);
+      break;
+    case EQ_EXPR:
+      e4 = gfc_eqv (e3, e1);
+      break;
+    case NE_EXPR:
+      e4 = gfc_neqv (e3, e1);
+      break;
+    case MIN_EXPR:
+      iname = "min";
+      break;
+    case MAX_EXPR:
+      iname = "max";
+      break;
+    case BIT_AND_EXPR:
+      iname = "iand";
+      break;
+    case BIT_IOR_EXPR:
+      iname = "ior";
+      break;
+    case BIT_XOR_EXPR:
+      iname = "ieor";
+      break;
+    default:
+      gcc_unreachable ();
+    }
+  if (iname != NULL)
+    {
+      memset (&intrinsic_sym, 0, sizeof (intrinsic_sym));
+      intrinsic_sym.ns = sym->ns;
+      intrinsic_sym.name = iname;
+      intrinsic_sym.ts = sym->ts;
+      intrinsic_sym.attr.referenced = 1;
+      intrinsic_sym.attr.intrinsic = 1;
+      intrinsic_sym.attr.function = 1;
+      intrinsic_sym.result = &intrinsic_sym;
+      intrinsic_sym.declared_at = where;
+
+      symtree4 = gfc_new_symtree (&root4, iname);
+      symtree4->n.sym = &intrinsic_sym;
+      gcc_assert (symtree4 == root4);
+
+      e4 = gfc_get_expr ();
+      e4->expr_type = EXPR_FUNCTION;
+      e4->where = where;
+      e4->symtree = symtree4;
+      e4->value.function.isym = gfc_find_function (iname);
+      e4->value.function.actual = gfc_get_actual_arglist ();
+      e4->value.function.actual->expr = e3;
+      e4->value.function.actual->next = gfc_get_actual_arglist ();
+      e4->value.function.actual->next->expr = e1;
+    }
+  /* e1 and e3 have been stored as arguments of e4, avoid sharing.  */
+  e1 = gfc_copy_expr (e1);
+  e3 = gfc_copy_expr (e3);
+  t = gfc_resolve_expr (e4);
+  gcc_assert (t);
+
+  /* Create the init statement list.  */
+  pushlevel ();
+  if (GFC_DESCRIPTOR_TYPE_P (type)
+      && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
+    {
+      /* If decl is an allocatable array, it needs to be allocated
+	 with the same bounds as the outer var.  */
+      tree rank, size, esize, ptr;
+      stmtblock_t block;
+
+      gfc_start_block (&block);
+
+      gfc_add_modify (&block, decl, outer_sym.backend_decl);
+      rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
+      size = gfc_conv_descriptor_ubound_get (decl, rank);
+      size = fold_build2_loc (input_location, MINUS_EXPR,
+			      gfc_array_index_type, size,
+			      gfc_conv_descriptor_lbound_get (decl, rank));
+      size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			      size, gfc_index_one_node);
+      if (GFC_TYPE_ARRAY_RANK (type) > 1)
+	size = fold_build2_loc (input_location, MULT_EXPR,
+				gfc_array_index_type, size,
+				gfc_conv_descriptor_stride_get (decl, rank));
+      esize = fold_convert (gfc_array_index_type,
+			    TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+      size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			      size, esize);
+      size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
+
+      ptr = gfc_create_var (pvoid_type_node, NULL);
+      gfc_allocate_using_malloc (&block, ptr, size, NULL_TREE);
+      gfc_conv_descriptor_data_set (&block, decl, ptr);
+
+      gfc_add_expr_to_block (&block, gfc_trans_assignment (e1, e2, false,
+			     false));
+      stmt = gfc_finish_block (&block);
+    }
+  else
+    stmt = gfc_trans_assignment (e1, e2, false, false);
+  if (TREE_CODE (stmt) != BIND_EXPR)
+    stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
+  else
+    poplevel (0, 0);
+  OMP_CLAUSE_REDUCTION_INIT (c) = stmt;
+
+  /* Create the merge statement list.  */
+  pushlevel ();
+  if (GFC_DESCRIPTOR_TYPE_P (type)
+      && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
+    {
+      /* If decl is an allocatable array, it needs to be deallocated
+	 afterwards.  */
+      stmtblock_t block;
+
+      gfc_start_block (&block);
+      gfc_add_expr_to_block (&block, gfc_trans_assignment (e3, e4, false,
+			     true));
+      gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl, false,
+								  NULL));
+      stmt = gfc_finish_block (&block);
+    }
+  else
+    stmt = gfc_trans_assignment (e3, e4, false, true);
+  if (TREE_CODE (stmt) != BIND_EXPR)
+    stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
+  else
+    poplevel (0, 0);
+  OMP_CLAUSE_REDUCTION_MERGE (c) = stmt;
+
+  /* And stick the placeholder VAR_DECL into the clause as well.  */
+  OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_decl;
+
+  gfc_current_locus = old_loc;
+
+  gfc_free_expr (e1);
+  gfc_free_expr (e2);
+  gfc_free_expr (e3);
+  gfc_free_expr (e4);
+  free (symtree1);
+  free (symtree2);
+  free (symtree3);
+  free (symtree4);
+  gfc_free_array_spec (outer_sym.as);
+}
+
+static tree
+gfc_trans_omp_reduction_list (gfc_namelist *namelist, tree list, 
+			      enum tree_code reduction_code, locus where)
+{
+  for (; namelist != NULL; namelist = namelist->next)
+    if (namelist->sym->attr.referenced)
+      {
+	tree t = gfc_trans_omp_variable (namelist->sym);
+	if (t != error_mark_node)
+	  {
+	    tree node = build_omp_clause (where.lb->location,
+					  OMP_CLAUSE_REDUCTION);
+	    OMP_CLAUSE_DECL (node) = t;
+	    OMP_CLAUSE_REDUCTION_CODE (node) = reduction_code;
+	    if (namelist->sym->attr.dimension)
+	      gfc_trans_omp_array_reduction (node, namelist->sym, where);
+	    list = gfc_trans_add_clause (node, list);
+	  }
+      }
+  return list;
+}
+
+static tree
+gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
+		       locus where)
+{
+  tree omp_clauses = NULL_TREE, chunk_size, c;
+  int list;
+  enum omp_clause_code clause_code;
+  gfc_se se;
+
+  if (clauses == NULL)
+    return NULL_TREE;
+
+  for (list = 0; list < OMP_LIST_NUM; list++)
+    {
+      gfc_namelist *n = clauses->lists[list];
+
+      if (n == NULL)
+	continue;
+      if (list >= OMP_LIST_REDUCTION_FIRST
+	  && list <= OMP_LIST_REDUCTION_LAST)
+	{
+	  enum tree_code reduction_code;
+	  switch (list)
+	    {
+	    case OMP_LIST_PLUS:
+	      reduction_code = PLUS_EXPR;
+	      break;
+	    case OMP_LIST_MULT:
+	      reduction_code = MULT_EXPR;
+	      break;
+	    case OMP_LIST_SUB:
+	      reduction_code = MINUS_EXPR;
+	      break;
+	    case OMP_LIST_AND:
+	      reduction_code = TRUTH_ANDIF_EXPR;
+	      break;
+	    case OMP_LIST_OR:
+	      reduction_code = TRUTH_ORIF_EXPR;
+	      break;
+	    case OMP_LIST_EQV:
+	      reduction_code = EQ_EXPR;
+	      break;
+	    case OMP_LIST_NEQV:
+	      reduction_code = NE_EXPR;
+	      break;
+	    case OMP_LIST_MAX:
+	      reduction_code = MAX_EXPR;
+	      break;
+	    case OMP_LIST_MIN:
+	      reduction_code = MIN_EXPR;
+	      break;
+	    case OMP_LIST_IAND:
+	      reduction_code = BIT_AND_EXPR;
+	      break;
+	    case OMP_LIST_IOR:
+	      reduction_code = BIT_IOR_EXPR;
+	      break;
+	    case OMP_LIST_IEOR:
+	      reduction_code = BIT_XOR_EXPR;
+	      break;
+	    default:
+	      gcc_unreachable ();
+	    }
+	  omp_clauses
+	    = gfc_trans_omp_reduction_list (n, omp_clauses, reduction_code,
+					    where);
+	  continue;
+	}
+      switch (list)
+	{
+	case OMP_LIST_PRIVATE:
+	  clause_code = OMP_CLAUSE_PRIVATE;
+	  goto add_clause;
+	case OMP_LIST_SHARED:
+	  clause_code = OMP_CLAUSE_SHARED;
+	  goto add_clause;
+	case OMP_LIST_FIRSTPRIVATE:
+	  clause_code = OMP_CLAUSE_FIRSTPRIVATE;
+	  goto add_clause;
+	case OMP_LIST_LASTPRIVATE:
+	  clause_code = OMP_CLAUSE_LASTPRIVATE;
+	  goto add_clause;
+	case OMP_LIST_COPYIN:
+	  clause_code = OMP_CLAUSE_COPYIN;
+	  goto add_clause;
+	case OMP_LIST_COPYPRIVATE:
+	  clause_code = OMP_CLAUSE_COPYPRIVATE;
+	  /* FALLTHROUGH */
+	add_clause:
+	  omp_clauses
+	    = gfc_trans_omp_variable_list (clause_code, n, omp_clauses);
+	  break;
+	default:
+	  break;
+	}
+    }
+
+  if (clauses->if_expr)
+    {
+      tree if_var;
+
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr (&se, clauses->if_expr);
+      gfc_add_block_to_block (block, &se.pre);
+      if_var = gfc_evaluate_now (se.expr, block);
+      gfc_add_block_to_block (block, &se.post);
+
+      c = build_omp_clause (where.lb->location, OMP_CLAUSE_IF);
+      OMP_CLAUSE_IF_EXPR (c) = if_var;
+      omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+    }
+
+  if (clauses->final_expr)
+    {
+      tree final_var;
+
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr (&se, clauses->final_expr);
+      gfc_add_block_to_block (block, &se.pre);
+      final_var = gfc_evaluate_now (se.expr, block);
+      gfc_add_block_to_block (block, &se.post);
+
+      c = build_omp_clause (where.lb->location, OMP_CLAUSE_FINAL);
+      OMP_CLAUSE_FINAL_EXPR (c) = final_var;
+      omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+    }
+
+  if (clauses->num_threads)
+    {
+      tree num_threads;
+
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr (&se, clauses->num_threads);
+      gfc_add_block_to_block (block, &se.pre);
+      num_threads = gfc_evaluate_now (se.expr, block);
+      gfc_add_block_to_block (block, &se.post);
+
+      c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_THREADS);
+      OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads;
+      omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+    }
+
+  chunk_size = NULL_TREE;
+  if (clauses->chunk_size)
+    {
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr (&se, clauses->chunk_size);
+      gfc_add_block_to_block (block, &se.pre);
+      chunk_size = gfc_evaluate_now (se.expr, block);
+      gfc_add_block_to_block (block, &se.post);
+    }
+
+  if (clauses->sched_kind != OMP_SCHED_NONE)
+    {
+      c = build_omp_clause (where.lb->location, OMP_CLAUSE_SCHEDULE);
+      OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
+      switch (clauses->sched_kind)
+	{
+	case OMP_SCHED_STATIC:
+	  OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_STATIC;
+	  break;
+	case OMP_SCHED_DYNAMIC:
+	  OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_DYNAMIC;
+	  break;
+	case OMP_SCHED_GUIDED:
+	  OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_GUIDED;
+	  break;
+	case OMP_SCHED_RUNTIME:
+	  OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_RUNTIME;
+	  break;
+	case OMP_SCHED_AUTO:
+	  OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_AUTO;
+	  break;
+	default:
+	  gcc_unreachable ();
+	}
+      omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+    }
+
+  if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
+    {
+      c = build_omp_clause (where.lb->location, OMP_CLAUSE_DEFAULT);
+      switch (clauses->default_sharing)
+	{
+	case OMP_DEFAULT_NONE:
+	  OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_NONE;
+	  break;
+	case OMP_DEFAULT_SHARED:
+	  OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_SHARED;
+	  break;
+	case OMP_DEFAULT_PRIVATE:
+	  OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRIVATE;
+	  break;
+	case OMP_DEFAULT_FIRSTPRIVATE:
+	  OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
+	  break;
+	default:
+	  gcc_unreachable ();
+	}
+      omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+    }
+
+  if (clauses->nowait)
+    {
+      c = build_omp_clause (where.lb->location, OMP_CLAUSE_NOWAIT);
+      omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+    }
+
+  if (clauses->ordered)
+    {
+      c = build_omp_clause (where.lb->location, OMP_CLAUSE_ORDERED);
+      omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+    }
+
+  if (clauses->untied)
+    {
+      c = build_omp_clause (where.lb->location, OMP_CLAUSE_UNTIED);
+      omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+    }
+
+  if (clauses->mergeable)
+    {
+      c = build_omp_clause (where.lb->location, OMP_CLAUSE_MERGEABLE);
+      omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+    }
+
+  if (clauses->collapse)
+    {
+      c = build_omp_clause (where.lb->location, OMP_CLAUSE_COLLAPSE);
+      OMP_CLAUSE_COLLAPSE_EXPR (c)
+	= build_int_cst (integer_type_node, clauses->collapse);
+      omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+    }
+
+  return omp_clauses;
+}
+
+/* Like gfc_trans_code, but force creation of a BIND_EXPR around it.  */
+
+static tree
+gfc_trans_omp_code (gfc_code *code, bool force_empty)
+{
+  tree stmt;
+
+  pushlevel ();
+  stmt = gfc_trans_code (code);
+  if (TREE_CODE (stmt) != BIND_EXPR)
+    {
+      if (!IS_EMPTY_STMT (stmt) || force_empty)
+	{
+	  tree block = poplevel (1, 0);
+	  stmt = build3_v (BIND_EXPR, NULL, stmt, block);
+	}
+      else
+	poplevel (0, 0);
+    }
+  else
+    poplevel (0, 0);
+  return stmt;
+}
+
+
+static tree gfc_trans_omp_sections (gfc_code *, gfc_omp_clauses *);
+static tree gfc_trans_omp_workshare (gfc_code *, gfc_omp_clauses *);
+
+static tree
+gfc_trans_omp_atomic (gfc_code *code)
+{
+  gfc_code *atomic_code = code;
+  gfc_se lse;
+  gfc_se rse;
+  gfc_se vse;
+  gfc_expr *expr2, *e;
+  gfc_symbol *var;
+  stmtblock_t block;
+  tree lhsaddr, type, rhs, x;
+  enum tree_code op = ERROR_MARK;
+  enum tree_code aop = OMP_ATOMIC;
+  bool var_on_left = false;
+
+  code = code->block->next;
+  gcc_assert (code->op == EXEC_ASSIGN);
+  var = code->expr1->symtree->n.sym;
+
+  gfc_init_se (&lse, NULL);
+  gfc_init_se (&rse, NULL);
+  gfc_init_se (&vse, NULL);
+  gfc_start_block (&block);
+
+  expr2 = code->expr2;
+  if (expr2->expr_type == EXPR_FUNCTION
+      && expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
+    expr2 = expr2->value.function.actual->expr;
+
+  switch (atomic_code->ext.omp_atomic)
+    {
+    case GFC_OMP_ATOMIC_READ:
+      gfc_conv_expr (&vse, code->expr1);
+      gfc_add_block_to_block (&block, &vse.pre);
+
+      gfc_conv_expr (&lse, expr2);
+      gfc_add_block_to_block (&block, &lse.pre);
+      type = TREE_TYPE (lse.expr);
+      lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
+
+      x = build1 (OMP_ATOMIC_READ, type, lhsaddr);
+      x = convert (TREE_TYPE (vse.expr), x);
+      gfc_add_modify (&block, vse.expr, x);
+
+      gfc_add_block_to_block (&block, &lse.pre);
+      gfc_add_block_to_block (&block, &rse.pre);
+
+      return gfc_finish_block (&block);
+    case GFC_OMP_ATOMIC_CAPTURE:
+      aop = OMP_ATOMIC_CAPTURE_NEW;
+      if (expr2->expr_type == EXPR_VARIABLE)
+	{
+	  aop = OMP_ATOMIC_CAPTURE_OLD;
+	  gfc_conv_expr (&vse, code->expr1);
+	  gfc_add_block_to_block (&block, &vse.pre);
+
+	  gfc_conv_expr (&lse, expr2);
+	  gfc_add_block_to_block (&block, &lse.pre);
+	  gfc_init_se (&lse, NULL);
+	  code = code->next;
+	  var = code->expr1->symtree->n.sym;
+	  expr2 = code->expr2;
+	  if (expr2->expr_type == EXPR_FUNCTION
+	      && expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
+	    expr2 = expr2->value.function.actual->expr;
+	}
+      break;
+    default:
+      break;
+    }
+
+  gfc_conv_expr (&lse, code->expr1);
+  gfc_add_block_to_block (&block, &lse.pre);
+  type = TREE_TYPE (lse.expr);
+  lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
+
+  if (atomic_code->ext.omp_atomic == GFC_OMP_ATOMIC_WRITE)
+    {
+      gfc_conv_expr (&rse, expr2);
+      gfc_add_block_to_block (&block, &rse.pre);
+    }
+  else if (expr2->expr_type == EXPR_OP)
+    {
+      gfc_expr *e;
+      switch (expr2->value.op.op)
+	{
+	case INTRINSIC_PLUS:
+	  op = PLUS_EXPR;
+	  break;
+	case INTRINSIC_TIMES:
+	  op = MULT_EXPR;
+	  break;
+	case INTRINSIC_MINUS:
+	  op = MINUS_EXPR;
+	  break;
+	case INTRINSIC_DIVIDE:
+	  if (expr2->ts.type == BT_INTEGER)
+	    op = TRUNC_DIV_EXPR;
+	  else
+	    op = RDIV_EXPR;
+	  break;
+	case INTRINSIC_AND:
+	  op = TRUTH_ANDIF_EXPR;
+	  break;
+	case INTRINSIC_OR:
+	  op = TRUTH_ORIF_EXPR;
+	  break;
+	case INTRINSIC_EQV:
+	  op = EQ_EXPR;
+	  break;
+	case INTRINSIC_NEQV:
+	  op = NE_EXPR;
+	  break;
+	default:
+	  gcc_unreachable ();
+	}
+      e = expr2->value.op.op1;
+      if (e->expr_type == EXPR_FUNCTION
+	  && e->value.function.isym->id == GFC_ISYM_CONVERSION)
+	e = e->value.function.actual->expr;
+      if (e->expr_type == EXPR_VARIABLE
+	  && e->symtree != NULL
+	  && e->symtree->n.sym == var)
+	{
+	  expr2 = expr2->value.op.op2;
+	  var_on_left = true;
+	}
+      else
+	{
+	  e = expr2->value.op.op2;
+	  if (e->expr_type == EXPR_FUNCTION
+	      && e->value.function.isym->id == GFC_ISYM_CONVERSION)
+	    e = e->value.function.actual->expr;
+	  gcc_assert (e->expr_type == EXPR_VARIABLE
+		      && e->symtree != NULL
+		      && e->symtree->n.sym == var);
+	  expr2 = expr2->value.op.op1;
+	  var_on_left = false;
+	}
+      gfc_conv_expr (&rse, expr2);
+      gfc_add_block_to_block (&block, &rse.pre);
+    }
+  else
+    {
+      gcc_assert (expr2->expr_type == EXPR_FUNCTION);
+      switch (expr2->value.function.isym->id)
+	{
+	case GFC_ISYM_MIN:
+	  op = MIN_EXPR;
+	  break;
+	case GFC_ISYM_MAX:
+	  op = MAX_EXPR;
+	  break;
+	case GFC_ISYM_IAND:
+	  op = BIT_AND_EXPR;
+	  break;
+	case GFC_ISYM_IOR:
+	  op = BIT_IOR_EXPR;
+	  break;
+	case GFC_ISYM_IEOR:
+	  op = BIT_XOR_EXPR;
+	  break;
+	default:
+	  gcc_unreachable ();
+	}
+      e = expr2->value.function.actual->expr;
+      gcc_assert (e->expr_type == EXPR_VARIABLE
+		  && e->symtree != NULL
+		  && e->symtree->n.sym == var);
+
+      gfc_conv_expr (&rse, expr2->value.function.actual->next->expr);
+      gfc_add_block_to_block (&block, &rse.pre);
+      if (expr2->value.function.actual->next->next != NULL)
+	{
+	  tree accum = gfc_create_var (TREE_TYPE (rse.expr), NULL);
+	  gfc_actual_arglist *arg;
+
+	  gfc_add_modify (&block, accum, rse.expr);
+	  for (arg = expr2->value.function.actual->next->next; arg;
+	       arg = arg->next)
+	    {
+	      gfc_init_block (&rse.pre);
+	      gfc_conv_expr (&rse, arg->expr);
+	      gfc_add_block_to_block (&block, &rse.pre);
+	      x = fold_build2_loc (input_location, op, TREE_TYPE (accum),
+				   accum, rse.expr);
+	      gfc_add_modify (&block, accum, x);
+	    }
+
+	  rse.expr = accum;
+	}
+
+      expr2 = expr2->value.function.actual->next->expr;
+    }
+
+  lhsaddr = save_expr (lhsaddr);
+  rhs = gfc_evaluate_now (rse.expr, &block);
+
+  if (atomic_code->ext.omp_atomic == GFC_OMP_ATOMIC_WRITE)
+    x = rhs;
+  else
+    {
+      x = convert (TREE_TYPE (rhs),
+		   build_fold_indirect_ref_loc (input_location, lhsaddr));
+      if (var_on_left)
+	x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), x, rhs);
+      else
+	x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), rhs, x);
+    }
+
+  if (TREE_CODE (TREE_TYPE (rhs)) == COMPLEX_TYPE
+      && TREE_CODE (type) != COMPLEX_TYPE)
+    x = fold_build1_loc (input_location, REALPART_EXPR,
+			 TREE_TYPE (TREE_TYPE (rhs)), x);
+
+  gfc_add_block_to_block (&block, &lse.pre);
+  gfc_add_block_to_block (&block, &rse.pre);
+
+  if (aop == OMP_ATOMIC)
+    {
+      x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x));
+      gfc_add_expr_to_block (&block, x);
+    }
+  else
+    {
+      if (aop == OMP_ATOMIC_CAPTURE_NEW)
+	{
+	  code = code->next;
+	  expr2 = code->expr2;
+	  if (expr2->expr_type == EXPR_FUNCTION
+	      && expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
+	    expr2 = expr2->value.function.actual->expr;
+
+	  gcc_assert (expr2->expr_type == EXPR_VARIABLE);
+	  gfc_conv_expr (&vse, code->expr1);
+	  gfc_add_block_to_block (&block, &vse.pre);
+
+	  gfc_init_se (&lse, NULL);
+	  gfc_conv_expr (&lse, expr2);
+	  gfc_add_block_to_block (&block, &lse.pre);
+	}
+      x = build2 (aop, type, lhsaddr, convert (type, x));
+      x = convert (TREE_TYPE (vse.expr), x);
+      gfc_add_modify (&block, vse.expr, x);
+    }
+
+  return gfc_finish_block (&block);
+}
+
+static tree
+gfc_trans_omp_barrier (void)
+{
+  tree decl = builtin_decl_explicit (BUILT_IN_GOMP_BARRIER);
+  return build_call_expr_loc (input_location, decl, 0);
+}
+
+static tree
+gfc_trans_omp_critical (gfc_code *code)
+{
+  tree name = NULL_TREE, stmt;
+  if (code->ext.omp_name != NULL)
+    name = get_identifier (code->ext.omp_name);
+  stmt = gfc_trans_code (code->block->next);
+  return build2_loc (input_location, OMP_CRITICAL, void_type_node, stmt, name);
+}
+
+typedef struct dovar_init_d {
+  tree var;
+  tree init;
+} dovar_init;
+
+
+static tree
+gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock,
+		  gfc_omp_clauses *do_clauses, tree par_clauses)
+{
+  gfc_se se;
+  tree dovar, stmt, from, to, step, type, init, cond, incr;
+  tree count = NULL_TREE, cycle_label, tmp, omp_clauses;
+  stmtblock_t block;
+  stmtblock_t body;
+  gfc_omp_clauses *clauses = code->ext.omp_clauses;
+  int i, collapse = clauses->collapse;
+  vec<dovar_init> inits = vNULL;
+  dovar_init *di;
+  unsigned ix;
+
+  if (collapse <= 0)
+    collapse = 1;
+
+  code = code->block->next;
+  gcc_assert (code->op == EXEC_DO);
+
+  init = make_tree_vec (collapse);
+  cond = make_tree_vec (collapse);
+  incr = make_tree_vec (collapse);
+
+  if (pblock == NULL)
+    {
+      gfc_start_block (&block);
+      pblock = &block;
+    }
+
+  omp_clauses = gfc_trans_omp_clauses (pblock, do_clauses, code->loc);
+
+  for (i = 0; i < collapse; i++)
+    {
+      int simple = 0;
+      int dovar_found = 0;
+      tree dovar_decl;
+
+      if (clauses)
+	{
+	  gfc_namelist *n;
+	  for (n = clauses->lists[OMP_LIST_LASTPRIVATE]; n != NULL;
+	       n = n->next)
+	    if (code->ext.iterator->var->symtree->n.sym == n->sym)
+	      break;
+	  if (n != NULL)
+	    dovar_found = 1;
+	  else if (n == NULL)
+	    for (n = clauses->lists[OMP_LIST_PRIVATE]; n != NULL; n = n->next)
+	      if (code->ext.iterator->var->symtree->n.sym == n->sym)
+		break;
+	  if (n != NULL)
+	    dovar_found++;
+	}
+
+      /* Evaluate all the expressions in the iterator.  */
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr_lhs (&se, code->ext.iterator->var);
+      gfc_add_block_to_block (pblock, &se.pre);
+      dovar = se.expr;
+      type = TREE_TYPE (dovar);
+      gcc_assert (TREE_CODE (type) == INTEGER_TYPE);
+
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr_val (&se, code->ext.iterator->start);
+      gfc_add_block_to_block (pblock, &se.pre);
+      from = gfc_evaluate_now (se.expr, pblock);
+
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr_val (&se, code->ext.iterator->end);
+      gfc_add_block_to_block (pblock, &se.pre);
+      to = gfc_evaluate_now (se.expr, pblock);
+
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr_val (&se, code->ext.iterator->step);
+      gfc_add_block_to_block (pblock, &se.pre);
+      step = gfc_evaluate_now (se.expr, pblock);
+      dovar_decl = dovar;
+
+      /* Special case simple loops.  */
+      if (TREE_CODE (dovar) == VAR_DECL)
+	{
+	  if (integer_onep (step))
+	    simple = 1;
+	  else if (tree_int_cst_equal (step, integer_minus_one_node))
+	    simple = -1;
+	}
+      else
+	dovar_decl
+	  = gfc_trans_omp_variable (code->ext.iterator->var->symtree->n.sym);
+
+      /* Loop body.  */
+      if (simple)
+	{
+	  TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, dovar, from);
+	  /* The condition should not be folded.  */
+	  TREE_VEC_ELT (cond, i) = build2_loc (input_location, simple > 0
+					       ? LE_EXPR : GE_EXPR,
+					       boolean_type_node, dovar, to);
+	  TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR,
+						    type, dovar, step);
+	  TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location,
+						    MODIFY_EXPR,
+						    type, dovar,
+						    TREE_VEC_ELT (incr, i));
+	}
+      else
+	{
+	  /* STEP is not 1 or -1.  Use:
+	     for (count = 0; count < (to + step - from) / step; count++)
+	       {
+		 dovar = from + count * step;
+		 body;
+	       cycle_label:;
+	       }  */
+	  tmp = fold_build2_loc (input_location, MINUS_EXPR, type, step, from);
+	  tmp = fold_build2_loc (input_location, PLUS_EXPR, type, to, tmp);
+	  tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, type, tmp,
+				 step);
+	  tmp = gfc_evaluate_now (tmp, pblock);
+	  count = gfc_create_var (type, "count");
+	  TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, count,
+					     build_int_cst (type, 0));
+	  /* The condition should not be folded.  */
+	  TREE_VEC_ELT (cond, i) = build2_loc (input_location, LT_EXPR,
+					       boolean_type_node,
+					       count, tmp);
+	  TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR,
+						    type, count,
+						    build_int_cst (type, 1));
+	  TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location,
+						    MODIFY_EXPR, type, count,
+						    TREE_VEC_ELT (incr, i));
+
+	  /* Initialize DOVAR.  */
+	  tmp = fold_build2_loc (input_location, MULT_EXPR, type, count, step);
+	  tmp = fold_build2_loc (input_location, PLUS_EXPR, type, from, tmp);
+	  dovar_init e = {dovar, tmp};
+	  inits.safe_push (e);
+	}
+
+      if (!dovar_found)
+	{
+	  tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
+	  OMP_CLAUSE_DECL (tmp) = dovar_decl;
+	  omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
+	}
+      else if (dovar_found == 2)
+	{
+	  tree c = NULL;
+
+	  tmp = NULL;
+	  if (!simple)
+	    {
+	      /* If dovar is lastprivate, but different counter is used,
+		 dovar += step needs to be added to
+		 OMP_CLAUSE_LASTPRIVATE_STMT, otherwise the copied dovar
+		 will have the value on entry of the last loop, rather
+		 than value after iterator increment.  */
+	      tmp = gfc_evaluate_now (step, pblock);
+	      tmp = fold_build2_loc (input_location, PLUS_EXPR, type, dovar,
+				     tmp);
+	      tmp = fold_build2_loc (input_location, MODIFY_EXPR, type,
+				     dovar, tmp);
+	      for (c = omp_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
+		if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
+		    && OMP_CLAUSE_DECL (c) == dovar_decl)
+		  {
+		    OMP_CLAUSE_LASTPRIVATE_STMT (c) = tmp;
+		    break;
+		  }
+	    }
+	  if (c == NULL && par_clauses != NULL)
+	    {
+	      for (c = par_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
+		if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
+		    && OMP_CLAUSE_DECL (c) == dovar_decl)
+		  {
+		    tree l = build_omp_clause (input_location,
+					       OMP_CLAUSE_LASTPRIVATE);
+		    OMP_CLAUSE_DECL (l) = dovar_decl;
+		    OMP_CLAUSE_CHAIN (l) = omp_clauses;
+		    OMP_CLAUSE_LASTPRIVATE_STMT (l) = tmp;
+		    omp_clauses = l;
+		    OMP_CLAUSE_SET_CODE (c, OMP_CLAUSE_SHARED);
+		    break;
+		  }
+	    }
+	  gcc_assert (simple || c != NULL);
+	}
+      if (!simple)
+	{
+	  tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
+	  OMP_CLAUSE_DECL (tmp) = count;
+	  omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
+	}
+
+      if (i + 1 < collapse)
+	code = code->block->next;
+    }
+
+  if (pblock != &block)
+    {
+      pushlevel ();
+      gfc_start_block (&block);
+    }
+
+  gfc_start_block (&body);
+
+  FOR_EACH_VEC_ELT (inits, ix, di)
+    gfc_add_modify (&body, di->var, di->init);
+  inits.release ();
+
+  /* Cycle statement is implemented with a goto.  Exit statement must not be
+     present for this loop.  */
+  cycle_label = gfc_build_label_decl (NULL_TREE);
+
+  /* Put these labels where they can be found later.  */
+
+  code->cycle_label = cycle_label;
+  code->exit_label = NULL_TREE;
+
+  /* Main loop body.  */
+  tmp = gfc_trans_omp_code (code->block->next, true);
+  gfc_add_expr_to_block (&body, tmp);
+
+  /* Label for cycle statements (if needed).  */
+  if (TREE_USED (cycle_label))
+    {
+      tmp = build1_v (LABEL_EXPR, cycle_label);
+      gfc_add_expr_to_block (&body, tmp);
+    }
+
+  /* End of loop body.  */
+  stmt = make_node (OMP_FOR);
+
+  TREE_TYPE (stmt) = void_type_node;
+  OMP_FOR_BODY (stmt) = gfc_finish_block (&body);
+  OMP_FOR_CLAUSES (stmt) = omp_clauses;
+  OMP_FOR_INIT (stmt) = init;
+  OMP_FOR_COND (stmt) = cond;
+  OMP_FOR_INCR (stmt) = incr;
+  gfc_add_expr_to_block (&block, stmt);
+
+  return gfc_finish_block (&block);
+}
+
+static tree
+gfc_trans_omp_flush (void)
+{
+  tree decl = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
+  return build_call_expr_loc (input_location, decl, 0);
+}
+
+static tree
+gfc_trans_omp_master (gfc_code *code)
+{
+  tree stmt = gfc_trans_code (code->block->next);
+  if (IS_EMPTY_STMT (stmt))
+    return stmt;
+  return build1_v (OMP_MASTER, stmt);
+}
+
+static tree
+gfc_trans_omp_ordered (gfc_code *code)
+{
+  return build1_v (OMP_ORDERED, gfc_trans_code (code->block->next));
+}
+
+static tree
+gfc_trans_omp_parallel (gfc_code *code)
+{
+  stmtblock_t block;
+  tree stmt, omp_clauses;
+
+  gfc_start_block (&block);
+  omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
+				       code->loc);
+  stmt = gfc_trans_omp_code (code->block->next, true);
+  stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
+		     omp_clauses);
+  gfc_add_expr_to_block (&block, stmt);
+  return gfc_finish_block (&block);
+}
+
+static tree
+gfc_trans_omp_parallel_do (gfc_code *code)
+{
+  stmtblock_t block, *pblock = NULL;
+  gfc_omp_clauses parallel_clauses, do_clauses;
+  tree stmt, omp_clauses = NULL_TREE;
+
+  gfc_start_block (&block);
+
+  memset (&do_clauses, 0, sizeof (do_clauses));
+  if (code->ext.omp_clauses != NULL)
+    {
+      memcpy (&parallel_clauses, code->ext.omp_clauses,
+	      sizeof (parallel_clauses));
+      do_clauses.sched_kind = parallel_clauses.sched_kind;
+      do_clauses.chunk_size = parallel_clauses.chunk_size;
+      do_clauses.ordered = parallel_clauses.ordered;
+      do_clauses.collapse = parallel_clauses.collapse;
+      parallel_clauses.sched_kind = OMP_SCHED_NONE;
+      parallel_clauses.chunk_size = NULL;
+      parallel_clauses.ordered = false;
+      parallel_clauses.collapse = 0;
+      omp_clauses = gfc_trans_omp_clauses (&block, &parallel_clauses,
+					   code->loc);
+    }
+  do_clauses.nowait = true;
+  if (!do_clauses.ordered && do_clauses.sched_kind != OMP_SCHED_STATIC)
+    pblock = &block;
+  else
+    pushlevel ();
+  stmt = gfc_trans_omp_do (code, pblock, &do_clauses, omp_clauses);
+  if (TREE_CODE (stmt) != BIND_EXPR)
+    stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
+  else
+    poplevel (0, 0);
+  stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
+		     omp_clauses);
+  OMP_PARALLEL_COMBINED (stmt) = 1;
+  gfc_add_expr_to_block (&block, stmt);
+  return gfc_finish_block (&block);
+}
+
+static tree
+gfc_trans_omp_parallel_sections (gfc_code *code)
+{
+  stmtblock_t block;
+  gfc_omp_clauses section_clauses;
+  tree stmt, omp_clauses;
+
+  memset (&section_clauses, 0, sizeof (section_clauses));
+  section_clauses.nowait = true;
+
+  gfc_start_block (&block);
+  omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
+				       code->loc);
+  pushlevel ();
+  stmt = gfc_trans_omp_sections (code, &section_clauses);
+  if (TREE_CODE (stmt) != BIND_EXPR)
+    stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
+  else
+    poplevel (0, 0);
+  stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
+		     omp_clauses);
+  OMP_PARALLEL_COMBINED (stmt) = 1;
+  gfc_add_expr_to_block (&block, stmt);
+  return gfc_finish_block (&block);
+}
+
+static tree
+gfc_trans_omp_parallel_workshare (gfc_code *code)
+{
+  stmtblock_t block;
+  gfc_omp_clauses workshare_clauses;
+  tree stmt, omp_clauses;
+
+  memset (&workshare_clauses, 0, sizeof (workshare_clauses));
+  workshare_clauses.nowait = true;
+
+  gfc_start_block (&block);
+  omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
+				       code->loc);
+  pushlevel ();
+  stmt = gfc_trans_omp_workshare (code, &workshare_clauses);
+  if (TREE_CODE (stmt) != BIND_EXPR)
+    stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
+  else
+    poplevel (0, 0);
+  stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
+		     omp_clauses);
+  OMP_PARALLEL_COMBINED (stmt) = 1;
+  gfc_add_expr_to_block (&block, stmt);
+  return gfc_finish_block (&block);
+}
+
+static tree
+gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses)
+{
+  stmtblock_t block, body;
+  tree omp_clauses, stmt;
+  bool has_lastprivate = clauses->lists[OMP_LIST_LASTPRIVATE] != NULL;
+
+  gfc_start_block (&block);
+
+  omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
+
+  gfc_init_block (&body);
+  for (code = code->block; code; code = code->block)
+    {
+      /* Last section is special because of lastprivate, so even if it
+	 is empty, chain it in.  */
+      stmt = gfc_trans_omp_code (code->next,
+				 has_lastprivate && code->block == NULL);
+      if (! IS_EMPTY_STMT (stmt))
+	{
+	  stmt = build1_v (OMP_SECTION, stmt);
+	  gfc_add_expr_to_block (&body, stmt);
+	}
+    }
+  stmt = gfc_finish_block (&body);
+
+  stmt = build2_loc (input_location, OMP_SECTIONS, void_type_node, stmt,
+		     omp_clauses);
+  gfc_add_expr_to_block (&block, stmt);
+
+  return gfc_finish_block (&block);
+}
+
+static tree
+gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses)
+{
+  tree omp_clauses = gfc_trans_omp_clauses (NULL, clauses, code->loc);
+  tree stmt = gfc_trans_omp_code (code->block->next, true);
+  stmt = build2_loc (input_location, OMP_SINGLE, void_type_node, stmt,
+		     omp_clauses);
+  return stmt;
+}
+
+static tree
+gfc_trans_omp_task (gfc_code *code)
+{
+  stmtblock_t block;
+  tree stmt, omp_clauses;
+
+  gfc_start_block (&block);
+  omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
+				       code->loc);
+  stmt = gfc_trans_omp_code (code->block->next, true);
+  stmt = build2_loc (input_location, OMP_TASK, void_type_node, stmt,
+		     omp_clauses);
+  gfc_add_expr_to_block (&block, stmt);
+  return gfc_finish_block (&block);
+}
+
+static tree
+gfc_trans_omp_taskwait (void)
+{
+  tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKWAIT);
+  return build_call_expr_loc (input_location, decl, 0);
+}
+
+static tree
+gfc_trans_omp_taskyield (void)
+{
+  tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKYIELD);
+  return build_call_expr_loc (input_location, decl, 0);
+}
+
+static tree
+gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses)
+{
+  tree res, tmp, stmt;
+  stmtblock_t block, *pblock = NULL;
+  stmtblock_t singleblock;
+  int saved_ompws_flags;
+  bool singleblock_in_progress = false;
+  /* True if previous gfc_code in workshare construct is not workshared.  */
+  bool prev_singleunit;
+
+  code = code->block->next;
+
+  pushlevel ();
+
+  gfc_start_block (&block);
+  pblock = &block;
+
+  ompws_flags = OMPWS_WORKSHARE_FLAG;
+  prev_singleunit = false;
+
+  /* Translate statements one by one to trees until we reach
+     the end of the workshare construct.  Adjacent gfc_codes that
+     are a single unit of work are clustered and encapsulated in a
+     single OMP_SINGLE construct.  */
+  for (; code; code = code->next)
+    {
+      if (code->here != 0)
+	{
+	  res = gfc_trans_label_here (code);
+	  gfc_add_expr_to_block (pblock, res);
+	}
+
+      /* No dependence analysis, use for clauses with wait.
+	 If this is the last gfc_code, use default omp_clauses.  */
+      if (code->next == NULL && clauses->nowait)
+	ompws_flags |= OMPWS_NOWAIT;
+
+      /* By default, every gfc_code is a single unit of work.  */
+      ompws_flags |= OMPWS_CURR_SINGLEUNIT;
+      ompws_flags &= ~OMPWS_SCALARIZER_WS;
+
+      switch (code->op)
+	{
+	case EXEC_NOP:
+	  res = NULL_TREE;
+	  break;
+
+	case EXEC_ASSIGN:
+	  res = gfc_trans_assign (code);
+	  break;
+
+	case EXEC_POINTER_ASSIGN:
+	  res = gfc_trans_pointer_assign (code);
+	  break;
+
+	case EXEC_INIT_ASSIGN:
+	  res = gfc_trans_init_assign (code);
+	  break;
+
+	case EXEC_FORALL:
+	  res = gfc_trans_forall (code);
+	  break;
+
+	case EXEC_WHERE:
+	  res = gfc_trans_where (code);
+	  break;
+
+	case EXEC_OMP_ATOMIC:
+	  res = gfc_trans_omp_directive (code);
+	  break;
+
+	case EXEC_OMP_PARALLEL:
+	case EXEC_OMP_PARALLEL_DO:
+	case EXEC_OMP_PARALLEL_SECTIONS:
+	case EXEC_OMP_PARALLEL_WORKSHARE:
+	case EXEC_OMP_CRITICAL:
+	  saved_ompws_flags = ompws_flags;
+	  ompws_flags = 0;
+	  res = gfc_trans_omp_directive (code);
+	  ompws_flags = saved_ompws_flags;
+	  break;
+	
+	default:
+	  internal_error ("gfc_trans_omp_workshare(): Bad statement code");
+	}
+
+      gfc_set_backend_locus (&code->loc);
+
+      if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
+	{
+	  if (prev_singleunit)
+	    {
+	      if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
+		/* Add current gfc_code to single block.  */
+		gfc_add_expr_to_block (&singleblock, res);
+	      else
+		{
+		  /* Finish single block and add it to pblock.  */
+		  tmp = gfc_finish_block (&singleblock);
+		  tmp = build2_loc (input_location, OMP_SINGLE,
+				    void_type_node, tmp, NULL_TREE);
+		  gfc_add_expr_to_block (pblock, tmp);
+		  /* Add current gfc_code to pblock.  */
+		  gfc_add_expr_to_block (pblock, res);
+		  singleblock_in_progress = false;
+		}
+	    }
+	  else
+	    {
+	      if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
+		{
+		  /* Start single block.  */
+		  gfc_init_block (&singleblock);
+		  gfc_add_expr_to_block (&singleblock, res);
+		  singleblock_in_progress = true;
+		}
+	      else
+		/* Add the new statement to the block.  */
+		gfc_add_expr_to_block (pblock, res);
+	    }
+	  prev_singleunit = (ompws_flags & OMPWS_CURR_SINGLEUNIT) != 0;
+	}
+    }
+
+  /* Finish remaining SINGLE block, if we were in the middle of one.  */
+  if (singleblock_in_progress)
+    {
+      /* Finish single block and add it to pblock.  */
+      tmp = gfc_finish_block (&singleblock);
+      tmp = build2_loc (input_location, OMP_SINGLE, void_type_node, tmp,
+			clauses->nowait
+			? build_omp_clause (input_location, OMP_CLAUSE_NOWAIT)
+			: NULL_TREE);
+      gfc_add_expr_to_block (pblock, tmp);
+    }
+
+  stmt = gfc_finish_block (pblock);
+  if (TREE_CODE (stmt) != BIND_EXPR)
+    {
+      if (!IS_EMPTY_STMT (stmt))
+	{
+	  tree bindblock = poplevel (1, 0);
+	  stmt = build3_v (BIND_EXPR, NULL, stmt, bindblock);
+	}
+      else
+	poplevel (0, 0);
+    }
+  else
+    poplevel (0, 0);
+
+  if (IS_EMPTY_STMT (stmt) && !clauses->nowait)
+    stmt = gfc_trans_omp_barrier ();
+
+  ompws_flags = 0;
+  return stmt;
+}
+
+tree
+gfc_trans_omp_directive (gfc_code *code)
+{
+  switch (code->op)
+    {
+    case EXEC_OMP_ATOMIC:
+      return gfc_trans_omp_atomic (code);
+    case EXEC_OMP_BARRIER:
+      return gfc_trans_omp_barrier ();
+    case EXEC_OMP_CRITICAL:
+      return gfc_trans_omp_critical (code);
+    case EXEC_OMP_DO:
+      return gfc_trans_omp_do (code, NULL, code->ext.omp_clauses, NULL);
+    case EXEC_OMP_FLUSH:
+      return gfc_trans_omp_flush ();
+    case EXEC_OMP_MASTER:
+      return gfc_trans_omp_master (code);
+    case EXEC_OMP_ORDERED:
+      return gfc_trans_omp_ordered (code);
+    case EXEC_OMP_PARALLEL:
+      return gfc_trans_omp_parallel (code);
+    case EXEC_OMP_PARALLEL_DO:
+      return gfc_trans_omp_parallel_do (code);
+    case EXEC_OMP_PARALLEL_SECTIONS:
+      return gfc_trans_omp_parallel_sections (code);
+    case EXEC_OMP_PARALLEL_WORKSHARE:
+      return gfc_trans_omp_parallel_workshare (code);
+    case EXEC_OMP_SECTIONS:
+      return gfc_trans_omp_sections (code, code->ext.omp_clauses);
+    case EXEC_OMP_SINGLE:
+      return gfc_trans_omp_single (code, code->ext.omp_clauses);
+    case EXEC_OMP_TASK:
+      return gfc_trans_omp_task (code);
+    case EXEC_OMP_TASKWAIT:
+      return gfc_trans_omp_taskwait ();
+    case EXEC_OMP_TASKYIELD:
+      return gfc_trans_omp_taskyield ();
+    case EXEC_OMP_WORKSHARE:
+      return gfc_trans_omp_workshare (code, code->ext.omp_clauses);
+    default:
+      gcc_unreachable ();
+    }
+}
diff --git a/gcc-4.9/gcc/fortran/trans-stmt.c b/gcc-4.9/gcc/fortran/trans-stmt.c
new file mode 100644
index 000000000..1a9068c0f
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/trans-stmt.c
@@ -0,0 +1,5568 @@
+/* Statement translation -- generate GCC trees from gfc_code.
+   Copyright (C) 2002-2014 Free Software Foundation, Inc.
+   Contributed by Paul Brook <paul@nowt.org>
+   and Steven Bosscher <s.bosscher@student.tudelft.nl>
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "tree.h"
+#include "stringpool.h"
+#include "gfortran.h"
+#include "flags.h"
+#include "trans.h"
+#include "trans-stmt.h"
+#include "trans-types.h"
+#include "trans-array.h"
+#include "trans-const.h"
+#include "arith.h"
+#include "dependency.h"
+#include "ggc.h"
+
+typedef struct iter_info
+{
+  tree var;
+  tree start;
+  tree end;
+  tree step;
+  struct iter_info *next;
+}
+iter_info;
+
+typedef struct forall_info
+{
+  iter_info *this_loop;
+  tree mask;
+  tree maskindex;
+  int nvar;
+  tree size;
+  struct forall_info  *prev_nest;
+  bool do_concurrent;
+}
+forall_info;
+
+static void gfc_trans_where_2 (gfc_code *, tree, bool,
+			       forall_info *, stmtblock_t *);
+
+/* Translate a F95 label number to a LABEL_EXPR.  */
+
+tree
+gfc_trans_label_here (gfc_code * code)
+{
+  return build1_v (LABEL_EXPR, gfc_get_label_decl (code->here));
+}
+
+
+/* Given a variable expression which has been ASSIGNed to, find the decl
+   containing the auxiliary variables.  For variables in common blocks this
+   is a field_decl.  */
+
+void
+gfc_conv_label_variable (gfc_se * se, gfc_expr * expr)
+{
+  gcc_assert (expr->symtree->n.sym->attr.assign == 1);
+  gfc_conv_expr (se, expr);
+  /* Deals with variable in common block. Get the field declaration.  */
+  if (TREE_CODE (se->expr) == COMPONENT_REF)
+    se->expr = TREE_OPERAND (se->expr, 1);
+  /* Deals with dummy argument. Get the parameter declaration.  */
+  else if (TREE_CODE (se->expr) == INDIRECT_REF)
+    se->expr = TREE_OPERAND (se->expr, 0);
+}
+
+/* Translate a label assignment statement.  */
+
+tree
+gfc_trans_label_assign (gfc_code * code)
+{
+  tree label_tree;
+  gfc_se se;
+  tree len;
+  tree addr;
+  tree len_tree;
+  int label_len;
+
+  /* Start a new block.  */
+  gfc_init_se (&se, NULL);
+  gfc_start_block (&se.pre);
+  gfc_conv_label_variable (&se, code->expr1);
+
+  len = GFC_DECL_STRING_LEN (se.expr);
+  addr = GFC_DECL_ASSIGN_ADDR (se.expr);
+
+  label_tree = gfc_get_label_decl (code->label1);
+
+  if (code->label1->defined == ST_LABEL_TARGET
+      || code->label1->defined == ST_LABEL_DO_TARGET)
+    {
+      label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
+      len_tree = integer_minus_one_node;
+    }
+  else
+    {
+      gfc_expr *format = code->label1->format;
+
+      label_len = format->value.character.length;
+      len_tree = build_int_cst (gfc_charlen_type_node, label_len);
+      label_tree = gfc_build_wide_string_const (format->ts.kind, label_len + 1,
+						format->value.character.string);
+      label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
+    }
+
+  gfc_add_modify (&se.pre, len, len_tree);
+  gfc_add_modify (&se.pre, addr, label_tree);
+
+  return gfc_finish_block (&se.pre);
+}
+
+/* Translate a GOTO statement.  */
+
+tree
+gfc_trans_goto (gfc_code * code)
+{
+  locus loc = code->loc;
+  tree assigned_goto;
+  tree target;
+  tree tmp;
+  gfc_se se;
+
+  if (code->label1 != NULL)
+    return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));
+
+  /* ASSIGNED GOTO.  */
+  gfc_init_se (&se, NULL);
+  gfc_start_block (&se.pre);
+  gfc_conv_label_variable (&se, code->expr1);
+  tmp = GFC_DECL_STRING_LEN (se.expr);
+  tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
+			 build_int_cst (TREE_TYPE (tmp), -1));
+  gfc_trans_runtime_check (true, false, tmp, &se.pre, &loc,
+			   "Assigned label is not a target label");
+
+  assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr);
+
+  /* We're going to ignore a label list.  It does not really change the
+     statement's semantics (because it is just a further restriction on
+     what's legal code); before, we were comparing label addresses here, but
+     that's a very fragile business and may break with optimization.  So
+     just ignore it.  */
+
+  target = fold_build1_loc (input_location, GOTO_EXPR, void_type_node,
+			    assigned_goto);
+  gfc_add_expr_to_block (&se.pre, target);
+  return gfc_finish_block (&se.pre);
+}
+
+
+/* Translate an ENTRY statement.  Just adds a label for this entry point.  */
+tree
+gfc_trans_entry (gfc_code * code)
+{
+  return build1_v (LABEL_EXPR, code->ext.entry->label);
+}
+
+
+/* Replace a gfc_ss structure by another both in the gfc_se struct
+   and the gfc_loopinfo struct.  This is used in gfc_conv_elemental_dependencies
+   to replace a variable ss by the corresponding temporary.  */
+
+static void
+replace_ss (gfc_se *se, gfc_ss *old_ss, gfc_ss *new_ss)
+{
+  gfc_ss **sess, **loopss;
+
+  /* The old_ss is a ss for a single variable.  */
+  gcc_assert (old_ss->info->type == GFC_SS_SECTION);
+
+  for (sess = &(se->ss); *sess != gfc_ss_terminator; sess = &((*sess)->next))
+    if (*sess == old_ss)
+      break;
+  gcc_assert (*sess != gfc_ss_terminator);
+
+  *sess = new_ss;
+  new_ss->next = old_ss->next;
+
+
+  for (loopss = &(se->loop->ss); *loopss != gfc_ss_terminator;
+       loopss = &((*loopss)->loop_chain))
+    if (*loopss == old_ss)
+      break;
+  gcc_assert (*loopss != gfc_ss_terminator);
+
+  *loopss = new_ss;
+  new_ss->loop_chain = old_ss->loop_chain;
+  new_ss->loop = old_ss->loop;
+
+  gfc_free_ss (old_ss);
+}
+
+
+/* Check for dependencies between INTENT(IN) and INTENT(OUT) arguments of
+   elemental subroutines.  Make temporaries for output arguments if any such
+   dependencies are found.  Output arguments are chosen because internal_unpack
+   can be used, as is, to copy the result back to the variable.  */
+static void
+gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
+				 gfc_symbol * sym, gfc_actual_arglist * arg,
+				 gfc_dep_check check_variable)
+{
+  gfc_actual_arglist *arg0;
+  gfc_expr *e;
+  gfc_formal_arglist *formal;
+  gfc_se parmse;
+  gfc_ss *ss;
+  gfc_symbol *fsym;
+  tree data;
+  tree size;
+  tree tmp;
+
+  if (loopse->ss == NULL)
+    return;
+
+  ss = loopse->ss;
+  arg0 = arg;
+  formal = gfc_sym_get_dummy_args (sym);
+
+  /* Loop over all the arguments testing for dependencies.  */
+  for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
+    {
+      e = arg->expr;
+      if (e == NULL)
+	continue;
+
+      /* Obtain the info structure for the current argument.  */
+      for (ss = loopse->ss; ss && ss != gfc_ss_terminator; ss = ss->next)
+	if (ss->info->expr == e)
+	  break;
+
+      /* If there is a dependency, create a temporary and use it
+	 instead of the variable.  */
+      fsym = formal ? formal->sym : NULL;
+      if (e->expr_type == EXPR_VARIABLE
+	    && e->rank && fsym
+	    && fsym->attr.intent != INTENT_IN
+	    && gfc_check_fncall_dependency (e, fsym->attr.intent,
+					    sym, arg0, check_variable))
+	{
+	  tree initial, temptype;
+	  stmtblock_t temp_post;
+	  gfc_ss *tmp_ss;
+
+	  tmp_ss = gfc_get_array_ss (gfc_ss_terminator, NULL, ss->dimen,
+				     GFC_SS_SECTION);
+	  gfc_mark_ss_chain_used (tmp_ss, 1);
+	  tmp_ss->info->expr = ss->info->expr;
+	  replace_ss (loopse, ss, tmp_ss);
+
+	  /* Obtain the argument descriptor for unpacking.  */
+	  gfc_init_se (&parmse, NULL);
+	  parmse.want_pointer = 1;
+	  gfc_conv_expr_descriptor (&parmse, e);
+	  gfc_add_block_to_block (&se->pre, &parmse.pre);
+
+	  /* If we've got INTENT(INOUT) or a derived type with INTENT(OUT),
+	     initialize the array temporary with a copy of the values.  */
+	  if (fsym->attr.intent == INTENT_INOUT
+		|| (fsym->ts.type ==BT_DERIVED
+		      && fsym->attr.intent == INTENT_OUT))
+	    initial = parmse.expr;
+	  /* For class expressions, we always initialize with the copy of
+	     the values.  */
+	  else if (e->ts.type == BT_CLASS)
+	    initial = parmse.expr;
+	  else
+	    initial = NULL_TREE;
+
+	  if (e->ts.type != BT_CLASS)
+	    {
+	     /* Find the type of the temporary to create; we don't use the type
+		of e itself as this breaks for subcomponent-references in e
+		(where the type of e is that of the final reference, but
+		parmse.expr's type corresponds to the full derived-type).  */
+	     /* TODO: Fix this somehow so we don't need a temporary of the whole
+		array but instead only the components referenced.  */
+	      temptype = TREE_TYPE (parmse.expr); /* Pointer to descriptor.  */
+	      gcc_assert (TREE_CODE (temptype) == POINTER_TYPE);
+	      temptype = TREE_TYPE (temptype);
+	      temptype = gfc_get_element_type (temptype);
+	    }
+
+	  else
+	    /* For class arrays signal that the size of the dynamic type has to
+	       be obtained from the vtable, using the 'initial' expression.  */
+	    temptype = NULL_TREE;
+
+	  /* Generate the temporary.  Cleaning up the temporary should be the
+	     very last thing done, so we add the code to a new block and add it
+	     to se->post as last instructions.  */
+	  size = gfc_create_var (gfc_array_index_type, NULL);
+	  data = gfc_create_var (pvoid_type_node, NULL);
+	  gfc_init_block (&temp_post);
+	  tmp = gfc_trans_create_temp_array (&se->pre, &temp_post, tmp_ss,
+					     temptype, initial, false, true,
+					     false, &arg->expr->where);
+	  gfc_add_modify (&se->pre, size, tmp);
+	  tmp = fold_convert (pvoid_type_node, tmp_ss->info->data.array.data);
+	  gfc_add_modify (&se->pre, data, tmp);
+
+	  /* Update other ss' delta.  */
+	  gfc_set_delta (loopse->loop);
+
+	  /* Copy the result back using unpack.....  */
+	  if (e->ts.type != BT_CLASS)
+	    tmp = build_call_expr_loc (input_location,
+			gfor_fndecl_in_unpack, 2, parmse.expr, data);
+	  else
+	    {
+	      /* ... except for class results where the copy is
+		 unconditional.  */
+	      tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
+	      tmp = gfc_conv_descriptor_data_get (tmp);
+	      tmp = build_call_expr_loc (input_location,
+					 builtin_decl_explicit (BUILT_IN_MEMCPY),
+					 3, tmp, data,
+					 fold_convert (size_type_node, size));
+	    }
+	  gfc_add_expr_to_block (&se->post, tmp);
+
+	  /* parmse.pre is already added above.  */
+	  gfc_add_block_to_block (&se->post, &parmse.post);
+	  gfc_add_block_to_block (&se->post, &temp_post);
+	}
+    }
+}
+
+
+/* Get the interface symbol for the procedure corresponding to the given call.
+   We can't get the procedure symbol directly as we have to handle the case
+   of (deferred) type-bound procedures.  */
+
+static gfc_symbol *
+get_proc_ifc_for_call (gfc_code *c)
+{
+  gfc_symbol *sym;
+
+  gcc_assert (c->op == EXEC_ASSIGN_CALL || c->op == EXEC_CALL);
+
+  sym = gfc_get_proc_ifc_for_expr (c->expr1);
+
+  /* Fall back/last resort try.  */
+  if (sym == NULL)
+    sym = c->resolved_sym;
+
+  return sym;
+}
+
+
+/* Translate the CALL statement.  Builds a call to an F95 subroutine.  */
+
+tree
+gfc_trans_call (gfc_code * code, bool dependency_check,
+		tree mask, tree count1, bool invert)
+{
+  gfc_se se;
+  gfc_ss * ss;
+  int has_alternate_specifier;
+  gfc_dep_check check_variable;
+  tree index = NULL_TREE;
+  tree maskexpr = NULL_TREE;
+  tree tmp;
+
+  /* A CALL starts a new block because the actual arguments may have to
+     be evaluated first.  */
+  gfc_init_se (&se, NULL);
+  gfc_start_block (&se.pre);
+
+  gcc_assert (code->resolved_sym);
+
+  ss = gfc_ss_terminator;
+  if (code->resolved_sym->attr.elemental)
+    ss = gfc_walk_elemental_function_args (ss, code->ext.actual,
+					   get_proc_ifc_for_call (code),
+					   GFC_SS_REFERENCE);
+
+  /* Is not an elemental subroutine call with array valued arguments.  */
+  if (ss == gfc_ss_terminator)
+    {
+
+      /* Translate the call.  */
+      has_alternate_specifier
+	= gfc_conv_procedure_call (&se, code->resolved_sym, code->ext.actual,
+				  code->expr1, NULL);
+
+      /* A subroutine without side-effect, by definition, does nothing!  */
+      TREE_SIDE_EFFECTS (se.expr) = 1;
+
+      /* Chain the pieces together and return the block.  */
+      if (has_alternate_specifier)
+	{
+	  gfc_code *select_code;
+	  gfc_symbol *sym;
+	  select_code = code->next;
+	  gcc_assert(select_code->op == EXEC_SELECT);
+	  sym = select_code->expr1->symtree->n.sym;
+	  se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr);
+	  if (sym->backend_decl == NULL)
+	    sym->backend_decl = gfc_get_symbol_decl (sym);
+	  gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
+	}
+      else
+	gfc_add_expr_to_block (&se.pre, se.expr);
+
+      gfc_add_block_to_block (&se.pre, &se.post);
+    }
+
+  else
+    {
+      /* An elemental subroutine call with array valued arguments has
+	 to be scalarized.  */
+      gfc_loopinfo loop;
+      stmtblock_t body;
+      stmtblock_t block;
+      gfc_se loopse;
+      gfc_se depse;
+
+      /* gfc_walk_elemental_function_args renders the ss chain in the
+	 reverse order to the actual argument order.  */
+      ss = gfc_reverse_ss (ss);
+
+      /* Initialize the loop.  */
+      gfc_init_se (&loopse, NULL);
+      gfc_init_loopinfo (&loop);
+      gfc_add_ss_to_loop (&loop, ss);
+
+      gfc_conv_ss_startstride (&loop);
+      /* TODO: gfc_conv_loop_setup generates a temporary for vector
+	 subscripts.  This could be prevented in the elemental case
+	 as temporaries are handled separatedly
+	 (below in gfc_conv_elemental_dependencies).  */
+      gfc_conv_loop_setup (&loop, &code->expr1->where);
+      gfc_mark_ss_chain_used (ss, 1);
+
+      /* Convert the arguments, checking for dependencies.  */
+      gfc_copy_loopinfo_to_se (&loopse, &loop);
+      loopse.ss = ss;
+
+      /* For operator assignment, do dependency checking.  */
+      if (dependency_check)
+	check_variable = ELEM_CHECK_VARIABLE;
+      else
+	check_variable = ELEM_DONT_CHECK_VARIABLE;
+
+      gfc_init_se (&depse, NULL);
+      gfc_conv_elemental_dependencies (&depse, &loopse, code->resolved_sym,
+				       code->ext.actual, check_variable);
+
+      gfc_add_block_to_block (&loop.pre,  &depse.pre);
+      gfc_add_block_to_block (&loop.post, &depse.post);
+
+      /* Generate the loop body.  */
+      gfc_start_scalarized_body (&loop, &body);
+      gfc_init_block (&block);
+
+      if (mask && count1)
+	{
+	  /* Form the mask expression according to the mask.  */
+	  index = count1;
+	  maskexpr = gfc_build_array_ref (mask, index, NULL);
+	  if (invert)
+	    maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
+					TREE_TYPE (maskexpr), maskexpr);
+	}
+
+      /* Add the subroutine call to the block.  */
+      gfc_conv_procedure_call (&loopse, code->resolved_sym,
+			       code->ext.actual, code->expr1,
+			       NULL);
+
+      if (mask && count1)
+	{
+	  tmp = build3_v (COND_EXPR, maskexpr, loopse.expr,
+			  build_empty_stmt (input_location));
+	  gfc_add_expr_to_block (&loopse.pre, tmp);
+	  tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type,
+				 count1, gfc_index_one_node);
+	  gfc_add_modify (&loopse.pre, count1, tmp);
+	}
+      else
+	gfc_add_expr_to_block (&loopse.pre, loopse.expr);
+
+      gfc_add_block_to_block (&block, &loopse.pre);
+      gfc_add_block_to_block (&block, &loopse.post);
+
+      /* Finish up the loop block and the loop.  */
+      gfc_add_expr_to_block (&body, gfc_finish_block (&block));
+      gfc_trans_scalarizing_loops (&loop, &body);
+      gfc_add_block_to_block (&se.pre, &loop.pre);
+      gfc_add_block_to_block (&se.pre, &loop.post);
+      gfc_add_block_to_block (&se.pre, &se.post);
+      gfc_cleanup_loop (&loop);
+    }
+
+  return gfc_finish_block (&se.pre);
+}
+
+
+/* Translate the RETURN statement.  */
+
+tree
+gfc_trans_return (gfc_code * code)
+{
+  if (code->expr1)
+    {
+      gfc_se se;
+      tree tmp;
+      tree result;
+
+      /* If code->expr is not NULL, this return statement must appear
+	 in a subroutine and current_fake_result_decl has already
+	 been generated.  */
+
+      result = gfc_get_fake_result_decl (NULL, 0);
+      if (!result)
+	{
+	  gfc_warning ("An alternate return at %L without a * dummy argument",
+			&code->expr1->where);
+	  return gfc_generate_return ();
+	}
+
+      /* Start a new block for this statement.  */
+      gfc_init_se (&se, NULL);
+      gfc_start_block (&se.pre);
+
+      gfc_conv_expr (&se, code->expr1);
+
+      /* Note that the actually returned expression is a simple value and
+	 does not depend on any pointers or such; thus we can clean-up with
+	 se.post before returning.  */
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (result),
+			     result, fold_convert (TREE_TYPE (result),
+			     se.expr));
+      gfc_add_expr_to_block (&se.pre, tmp);
+      gfc_add_block_to_block (&se.pre, &se.post);
+
+      tmp = gfc_generate_return ();
+      gfc_add_expr_to_block (&se.pre, tmp);
+      return gfc_finish_block (&se.pre);
+    }
+
+  return gfc_generate_return ();
+}
+
+
+/* Translate the PAUSE statement.  We have to translate this statement
+   to a runtime library call.  */
+
+tree
+gfc_trans_pause (gfc_code * code)
+{
+  tree gfc_int4_type_node = gfc_get_int_type (4);
+  gfc_se se;
+  tree tmp;
+
+  /* Start a new block for this statement.  */
+  gfc_init_se (&se, NULL);
+  gfc_start_block (&se.pre);
+
+
+  if (code->expr1 == NULL)
+    {
+      tmp = build_int_cst (gfc_int4_type_node, 0);
+      tmp = build_call_expr_loc (input_location,
+				 gfor_fndecl_pause_string, 2,
+				 build_int_cst (pchar_type_node, 0), tmp);
+    }
+  else if (code->expr1->ts.type == BT_INTEGER)
+    {
+      gfc_conv_expr (&se, code->expr1);
+      tmp = build_call_expr_loc (input_location,
+				 gfor_fndecl_pause_numeric, 1,
+				 fold_convert (gfc_int4_type_node, se.expr));
+    }
+  else
+    {
+      gfc_conv_expr_reference (&se, code->expr1);
+      tmp = build_call_expr_loc (input_location,
+			     gfor_fndecl_pause_string, 2,
+			     se.expr, se.string_length);
+    }
+
+  gfc_add_expr_to_block (&se.pre, tmp);
+
+  gfc_add_block_to_block (&se.pre, &se.post);
+
+  return gfc_finish_block (&se.pre);
+}
+
+
+/* Translate the STOP statement.  We have to translate this statement
+   to a runtime library call.  */
+
+tree
+gfc_trans_stop (gfc_code *code, bool error_stop)
+{
+  tree gfc_int4_type_node = gfc_get_int_type (4);
+  gfc_se se;
+  tree tmp;
+
+  /* Start a new block for this statement.  */
+  gfc_init_se (&se, NULL);
+  gfc_start_block (&se.pre);
+
+  if (gfc_option.coarray == GFC_FCOARRAY_LIB && !error_stop)
+    {
+      /* Per F2008, 8.5.1 STOP implies a SYNC MEMORY.  */
+      tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
+      tmp = build_call_expr_loc (input_location, tmp, 0);
+      gfc_add_expr_to_block (&se.pre, tmp);
+
+      tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0);
+      gfc_add_expr_to_block (&se.pre, tmp);
+    }
+
+  if (code->expr1 == NULL)
+    {
+      tmp = build_int_cst (gfc_int4_type_node, 0);
+      tmp = build_call_expr_loc (input_location,
+				 error_stop
+				 ? (gfc_option.coarray == GFC_FCOARRAY_LIB
+				    ? gfor_fndecl_caf_error_stop_str
+				    : gfor_fndecl_error_stop_string)
+				 : gfor_fndecl_stop_string,
+				 2, build_int_cst (pchar_type_node, 0), tmp);
+    }
+  else if (code->expr1->ts.type == BT_INTEGER)
+    {
+      gfc_conv_expr (&se, code->expr1);
+      tmp = build_call_expr_loc (input_location,
+				 error_stop
+				 ? (gfc_option.coarray == GFC_FCOARRAY_LIB
+				    ? gfor_fndecl_caf_error_stop
+				    : gfor_fndecl_error_stop_numeric)
+				 : gfor_fndecl_stop_numeric_f08, 1,
+				 fold_convert (gfc_int4_type_node, se.expr));
+    }
+  else
+    {
+      gfc_conv_expr_reference (&se, code->expr1);
+      tmp = build_call_expr_loc (input_location,
+				 error_stop
+				 ? (gfc_option.coarray == GFC_FCOARRAY_LIB
+				    ? gfor_fndecl_caf_error_stop_str
+				    : gfor_fndecl_error_stop_string)
+				 : gfor_fndecl_stop_string,
+				 2, se.expr, se.string_length);
+    }
+
+  gfc_add_expr_to_block (&se.pre, tmp);
+
+  gfc_add_block_to_block (&se.pre, &se.post);
+
+  return gfc_finish_block (&se.pre);
+}
+
+
+tree
+gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op type ATTRIBUTE_UNUSED)
+{
+  gfc_se se, argse;
+  tree stat = NULL_TREE, lock_acquired = NULL_TREE;
+
+  /* Short cut: For single images without STAT= or LOCK_ACQUIRED
+     return early. (ERRMSG= is always untouched for -fcoarray=single.)  */
+  if (!code->expr2 && !code->expr4 && gfc_option.coarray != GFC_FCOARRAY_LIB)
+    return NULL_TREE;
+
+  gfc_init_se (&se, NULL);
+  gfc_start_block (&se.pre);
+
+  if (code->expr2)
+    {
+      gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
+      gfc_init_se (&argse, NULL);
+      gfc_conv_expr_val (&argse, code->expr2);
+      stat = argse.expr;
+    }
+
+  if (code->expr4)
+    {
+      gcc_assert (code->expr4->expr_type == EXPR_VARIABLE);
+      gfc_init_se (&argse, NULL);
+      gfc_conv_expr_val (&argse, code->expr4);
+      lock_acquired = argse.expr;
+    }
+
+  if (stat != NULL_TREE)
+    gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
+
+  if (lock_acquired != NULL_TREE)
+    gfc_add_modify (&se.pre, lock_acquired,
+		    fold_convert (TREE_TYPE (lock_acquired),
+				  boolean_true_node));
+
+  return gfc_finish_block (&se.pre);
+}
+
+
+tree
+gfc_trans_sync (gfc_code *code, gfc_exec_op type)
+{
+  gfc_se se, argse;
+  tree tmp;
+  tree images = NULL_TREE, stat = NULL_TREE,
+       errmsg = NULL_TREE, errmsglen = NULL_TREE;
+
+  /* Short cut: For single images without bound checking or without STAT=,
+     return early. (ERRMSG= is always untouched for -fcoarray=single.)  */
+  if (!code->expr2 && !(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+      && gfc_option.coarray != GFC_FCOARRAY_LIB)
+    return NULL_TREE;
+
+  gfc_init_se (&se, NULL);
+  gfc_start_block (&se.pre);
+
+  if (code->expr1 && code->expr1->rank == 0)
+    {
+      gfc_init_se (&argse, NULL);
+      gfc_conv_expr_val (&argse, code->expr1);
+      images = argse.expr;
+    }
+
+  if (code->expr2)
+    {
+      gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
+      gfc_init_se (&argse, NULL);
+      gfc_conv_expr_val (&argse, code->expr2);
+      stat = argse.expr;
+    }
+  else
+    stat = null_pointer_node;
+
+  if (code->expr3 && gfc_option.coarray == GFC_FCOARRAY_LIB
+      && type != EXEC_SYNC_MEMORY)
+    {
+      gcc_assert (code->expr3->expr_type == EXPR_VARIABLE);
+      gfc_init_se (&argse, NULL);
+      gfc_conv_expr (&argse, code->expr3);
+      gfc_conv_string_parameter (&argse);
+      errmsg = gfc_build_addr_expr (NULL, argse.expr);
+      errmsglen = argse.string_length;
+    }
+  else if (gfc_option.coarray == GFC_FCOARRAY_LIB && type != EXEC_SYNC_MEMORY)
+    {
+      errmsg = null_pointer_node;
+      errmsglen = build_int_cst (integer_type_node, 0);
+    }
+
+  /* Check SYNC IMAGES(imageset) for valid image index.
+     FIXME: Add a check for image-set arrays. */
+  if (code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+      && code->expr1->rank == 0)
+    {
+      tree cond;
+      if (gfc_option.coarray != GFC_FCOARRAY_LIB)
+	cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+				images, build_int_cst (TREE_TYPE (images), 1));
+      else
+	{
+	  tree cond2;
+	  cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+				  images, gfort_gvar_caf_num_images);
+	  cond2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+				   images,
+				   build_int_cst (TREE_TYPE (images), 1));
+	  cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+				  boolean_type_node, cond, cond2);
+	}
+      gfc_trans_runtime_check (true, false, cond, &se.pre,
+			       &code->expr1->where, "Invalid image number "
+			       "%d in SYNC IMAGES",
+			       fold_convert (integer_type_node, images));
+    }
+
+   /* Per F2008, 8.5.1, a SYNC MEMORY is implied by calling the
+      image control statements SYNC IMAGES and SYNC ALL.  */
+   if (gfc_option.coarray == GFC_FCOARRAY_LIB)
+     {
+       tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
+       tmp = build_call_expr_loc (input_location, tmp, 0);
+       gfc_add_expr_to_block (&se.pre, tmp);
+     }
+
+  if (gfc_option.coarray != GFC_FCOARRAY_LIB || type == EXEC_SYNC_MEMORY)
+    {
+      /* Set STAT to zero.  */
+      if (code->expr2)
+	gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
+    }
+  else if (type == EXEC_SYNC_ALL)
+    {
+      /* SYNC ALL           =>   stat == null_pointer_node
+	 SYNC ALL(stat=s)   =>   stat has an integer type
+
+	 If "stat" has the wrong integer type, use a temp variable of
+	 the right type and later cast the result back into "stat".  */
+      if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node)
+	{
+	  if (TREE_TYPE (stat) == integer_type_node)
+	    stat = gfc_build_addr_expr (NULL, stat);
+
+	  tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
+				     3, stat, errmsg, errmsglen);
+	  gfc_add_expr_to_block (&se.pre, tmp);
+	}
+      else
+	{
+	  tree tmp_stat = gfc_create_var (integer_type_node, "stat");
+
+	  tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
+				     3, gfc_build_addr_expr (NULL, tmp_stat),
+				     errmsg, errmsglen);
+	  gfc_add_expr_to_block (&se.pre, tmp);
+
+	  gfc_add_modify (&se.pre, stat,
+			  fold_convert (TREE_TYPE (stat), tmp_stat));
+	}
+    }
+  else
+    {
+      tree len;
+
+      gcc_assert (type == EXEC_SYNC_IMAGES);
+
+      if (!code->expr1)
+	{
+	  len = build_int_cst (integer_type_node, -1);
+	  images = null_pointer_node;
+	}
+      else if (code->expr1->rank == 0)
+	{
+	  len = build_int_cst (integer_type_node, 1);
+	  images = gfc_build_addr_expr (NULL_TREE, images);
+	}
+      else
+	{
+	  /* FIXME.  */
+	  if (code->expr1->ts.kind != gfc_c_int_kind)
+	    gfc_fatal_error ("Sorry, only support for integer kind %d "
+			     "implemented for image-set at %L",
+			     gfc_c_int_kind, &code->expr1->where);
+
+	  gfc_conv_array_parameter (&se, code->expr1, true, NULL, NULL, &len);
+	  images = se.expr;
+
+	  tmp = gfc_typenode_for_spec (&code->expr1->ts);
+	  if (GFC_ARRAY_TYPE_P (tmp) || GFC_DESCRIPTOR_TYPE_P (tmp))
+	    tmp = gfc_get_element_type (tmp);
+
+	  len = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+				 TREE_TYPE (len), len,
+				 fold_convert (TREE_TYPE (len),
+					       TYPE_SIZE_UNIT (tmp)));
+          len = fold_convert (integer_type_node, len);
+	}
+
+      /* SYNC IMAGES(imgs)        => stat == null_pointer_node
+	 SYNC IMAGES(imgs,stat=s) => stat has an integer type
+
+	 If "stat" has the wrong integer type, use a temp variable of
+	 the right type and later cast the result back into "stat".  */
+      if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node)
+	{
+	  if (TREE_TYPE (stat) == integer_type_node)
+	    stat = gfc_build_addr_expr (NULL, stat);
+
+	  tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images,
+				     5, fold_convert (integer_type_node, len),
+				     images, stat, errmsg, errmsglen);
+	  gfc_add_expr_to_block (&se.pre, tmp);
+	}
+      else
+	{
+	  tree tmp_stat = gfc_create_var (integer_type_node, "stat");
+
+	  tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images,
+				     5, fold_convert (integer_type_node, len),
+				     images, gfc_build_addr_expr (NULL, tmp_stat),
+				     errmsg, errmsglen);
+	  gfc_add_expr_to_block (&se.pre, tmp);
+
+	  gfc_add_modify (&se.pre, stat,
+			  fold_convert (TREE_TYPE (stat), tmp_stat));
+	}
+    }
+
+  return gfc_finish_block (&se.pre);
+}
+
+
+/* Generate GENERIC for the IF construct. This function also deals with
+   the simple IF statement, because the front end translates the IF
+   statement into an IF construct.
+
+   We translate:
+
+        IF (cond) THEN
+           then_clause
+        ELSEIF (cond2)
+           elseif_clause
+        ELSE
+           else_clause
+        ENDIF
+
+   into:
+
+        pre_cond_s;
+        if (cond_s)
+          {
+            then_clause;
+          }
+        else
+          {
+            pre_cond_s
+            if (cond_s)
+              {
+                elseif_clause
+              }
+            else
+              {
+                else_clause;
+              }
+          }
+
+   where COND_S is the simplified version of the predicate. PRE_COND_S
+   are the pre side-effects produced by the translation of the
+   conditional.
+   We need to build the chain recursively otherwise we run into
+   problems with folding incomplete statements.  */
+
+static tree
+gfc_trans_if_1 (gfc_code * code)
+{
+  gfc_se if_se;
+  tree stmt, elsestmt;
+  locus saved_loc;
+  location_t loc;
+
+  /* Check for an unconditional ELSE clause.  */
+  if (!code->expr1)
+    return gfc_trans_code (code->next);
+
+  /* Initialize a statement builder for each block. Puts in NULL_TREEs.  */
+  gfc_init_se (&if_se, NULL);
+  gfc_start_block (&if_se.pre);
+
+  /* Calculate the IF condition expression.  */
+  if (code->expr1->where.lb)
+    {
+      gfc_save_backend_locus (&saved_loc);
+      gfc_set_backend_locus (&code->expr1->where);
+    }
+
+  gfc_conv_expr_val (&if_se, code->expr1);
+
+  if (code->expr1->where.lb)
+    gfc_restore_backend_locus (&saved_loc);
+
+  /* Translate the THEN clause.  */
+  stmt = gfc_trans_code (code->next);
+
+  /* Translate the ELSE clause.  */
+  if (code->block)
+    elsestmt = gfc_trans_if_1 (code->block);
+  else
+    elsestmt = build_empty_stmt (input_location);
+
+  /* Build the condition expression and add it to the condition block.  */
+  loc = code->expr1->where.lb ? code->expr1->where.lb->location : input_location;
+  stmt = fold_build3_loc (loc, COND_EXPR, void_type_node, if_se.expr, stmt,
+			  elsestmt);
+
+  gfc_add_expr_to_block (&if_se.pre, stmt);
+
+  /* Finish off this statement.  */
+  return gfc_finish_block (&if_se.pre);
+}
+
+tree
+gfc_trans_if (gfc_code * code)
+{
+  stmtblock_t body;
+  tree exit_label;
+
+  /* Create exit label so it is available for trans'ing the body code.  */
+  exit_label = gfc_build_label_decl (NULL_TREE);
+  code->exit_label = exit_label;
+
+  /* Translate the actual code in code->block.  */
+  gfc_init_block (&body);
+  gfc_add_expr_to_block (&body, gfc_trans_if_1 (code->block));
+
+  /* Add exit label.  */
+  gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label));
+
+  return gfc_finish_block (&body);
+}
+
+
+/* Translate an arithmetic IF expression.
+
+   IF (cond) label1, label2, label3 translates to
+
+    if (cond <= 0)
+      {
+        if (cond < 0)
+          goto label1;
+        else // cond == 0
+          goto label2;
+      }
+    else // cond > 0
+      goto label3;
+
+   An optimized version can be generated in case of equal labels.
+   E.g., if label1 is equal to label2, we can translate it to
+
+    if (cond <= 0)
+      goto label1;
+    else
+      goto label3;
+*/
+
+tree
+gfc_trans_arithmetic_if (gfc_code * code)
+{
+  gfc_se se;
+  tree tmp;
+  tree branch1;
+  tree branch2;
+  tree zero;
+
+  /* Start a new block.  */
+  gfc_init_se (&se, NULL);
+  gfc_start_block (&se.pre);
+
+  /* Pre-evaluate COND.  */
+  gfc_conv_expr_val (&se, code->expr1);
+  se.expr = gfc_evaluate_now (se.expr, &se.pre);
+
+  /* Build something to compare with.  */
+  zero = gfc_build_const (TREE_TYPE (se.expr), integer_zero_node);
+
+  if (code->label1->value != code->label2->value)
+    {
+      /* If (cond < 0) take branch1 else take branch2.
+         First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases.  */
+      branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));
+      branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2));
+
+      if (code->label1->value != code->label3->value)
+        tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+			       se.expr, zero);
+      else
+        tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			       se.expr, zero);
+
+      branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+				 tmp, branch1, branch2);
+    }
+  else
+    branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));
+
+  if (code->label1->value != code->label3->value
+      && code->label2->value != code->label3->value)
+    {
+      /* if (cond <= 0) take branch1 else take branch2.  */
+      branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3));
+      tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
+			     se.expr, zero);
+      branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+				 tmp, branch1, branch2);
+    }
+
+  /* Append the COND_EXPR to the evaluation of COND, and return.  */
+  gfc_add_expr_to_block (&se.pre, branch1);
+  return gfc_finish_block (&se.pre);
+}
+
+
+/* Translate a CRITICAL block. */
+tree
+gfc_trans_critical (gfc_code *code)
+{
+  stmtblock_t block;
+  tree tmp;
+
+  gfc_start_block (&block);
+
+  if (gfc_option.coarray == GFC_FCOARRAY_LIB)
+    {
+      tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_critical, 0);
+      gfc_add_expr_to_block (&block, tmp);
+    }
+
+  tmp = gfc_trans_code (code->block->next);
+  gfc_add_expr_to_block (&block, tmp);
+
+  if (gfc_option.coarray == GFC_FCOARRAY_LIB)
+    {
+      tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_end_critical,
+				 0);
+      gfc_add_expr_to_block (&block, tmp);
+    }
+
+
+  return gfc_finish_block (&block);
+}
+
+
+/* Do proper initialization for ASSOCIATE names.  */
+
+static void
+trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
+{
+  gfc_expr *e;
+  tree tmp;
+  bool class_target;
+  bool unlimited;
+  tree desc;
+  tree offset;
+  tree dim;
+  int n;
+
+  gcc_assert (sym->assoc);
+  e = sym->assoc->target;
+
+  class_target = (e->expr_type == EXPR_VARIABLE)
+		    && (gfc_is_class_scalar_expr (e)
+			|| gfc_is_class_array_ref (e, NULL));
+
+  unlimited = UNLIMITED_POLY (e);
+
+  /* Do a `pointer assignment' with updated descriptor (or assign descriptor
+     to array temporary) for arrays with either unknown shape or if associating
+     to a variable.  */
+  if (sym->attr.dimension && !class_target
+      && (sym->as->type == AS_DEFERRED || sym->assoc->variable))
+    {
+      gfc_se se;
+      tree desc;
+
+      desc = sym->backend_decl;
+
+      /* If association is to an expression, evaluate it and create temporary.
+	 Otherwise, get descriptor of target for pointer assignment.  */
+      gfc_init_se (&se, NULL);
+      if (sym->assoc->variable)
+	{
+	  se.direct_byref = 1;
+	  se.expr = desc;
+	}
+      gfc_conv_expr_descriptor (&se, e);
+
+      /* If we didn't already do the pointer assignment, set associate-name
+	 descriptor to the one generated for the temporary.  */
+      if (!sym->assoc->variable)
+	{
+	  int dim;
+
+	  gfc_add_modify (&se.pre, desc, se.expr);
+
+	  /* The generated descriptor has lower bound zero (as array
+	     temporary), shift bounds so we get lower bounds of 1.  */
+	  for (dim = 0; dim < e->rank; ++dim)
+	    gfc_conv_shift_descriptor_lbound (&se.pre, desc,
+					      dim, gfc_index_one_node);
+	}
+
+      /* If this is a subreference array pointer associate name use the
+	 associate variable element size for the value of 'span'.  */
+      if (sym->attr.subref_array_pointer)
+	{
+	  gcc_assert (e->expr_type == EXPR_VARIABLE);
+	  tmp = e->symtree->n.sym->backend_decl;
+	  tmp = gfc_get_element_type (TREE_TYPE (tmp));
+	  tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
+	  gfc_add_modify (&se.pre, GFC_DECL_SPAN(desc), tmp);
+	}
+
+      /* Done, register stuff as init / cleanup code.  */
+      gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
+			    gfc_finish_block (&se.post));
+    }
+
+  /* Temporaries, arising from TYPE IS, just need the descriptor of class
+     arrays to be assigned directly.  */
+  else if (class_target && sym->attr.dimension
+	   && (sym->ts.type == BT_DERIVED || unlimited))
+    {
+      gfc_se se;
+
+      gfc_init_se (&se, NULL);
+      se.descriptor_only = 1;
+      gfc_conv_expr (&se, e);
+
+      gcc_assert (GFC_DESCRIPTOR_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 (unlimited)
+	{
+	  /* Recover the dtype, which has been overwritten by the
+	     assignment from an unlimited polymorphic object.  */
+	  tmp = gfc_conv_descriptor_dtype (sym->backend_decl);
+	  gfc_add_modify (&se.pre, tmp,
+			  gfc_get_dtype (TREE_TYPE (sym->backend_decl)));
+	}
+
+      gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
+			    gfc_finish_block (&se.post));
+    }
+
+  /* Do a scalar pointer assignment; this is for scalar variable targets.  */
+  else if (gfc_is_associate_pointer (sym))
+    {
+      gfc_se se;
+
+      gcc_assert (!sym->attr.dimension);
+
+      gfc_init_se (&se, NULL);
+
+      /* Class associate-names come this way because they are
+	 unconditionally associate pointers and the symbol is scalar.  */
+      if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension)
+	{
+	  /* For a class array we need a descriptor for the selector.  */
+	  gfc_conv_expr_descriptor (&se, e);
+
+	  /* Obtain a temporary class container for the result.  */
+	  gfc_conv_class_to_class (&se, e, sym->ts, false, true, false, false);
+	  se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
+
+	  /* Set the offset.  */
+	  desc = gfc_class_data_get (se.expr);
+	  offset = gfc_index_zero_node;
+	  for (n = 0; n < e->rank; n++)
+	    {
+	      dim = gfc_rank_cst[n];
+	      tmp = fold_build2_loc (input_location, MULT_EXPR,
+				     gfc_array_index_type,
+				     gfc_conv_descriptor_stride_get (desc, dim),
+				     gfc_conv_descriptor_lbound_get (desc, dim));
+	      offset = fold_build2_loc (input_location, MINUS_EXPR,
+				        gfc_array_index_type,
+				        offset, tmp);
+	    }
+	  gfc_conv_descriptor_offset_set (&se.pre, desc, offset);
+	}
+      else if (sym->ts.type == BT_CLASS && e->ts.type == BT_CLASS
+	       && CLASS_DATA (e)->attr.dimension)
+	{
+	  /* This is bound to be a class array element.  */
+	  gfc_conv_expr_reference (&se, e);
+	  /* Get the _vptr component of the class object.  */
+	  tmp = gfc_get_vptr_from_expr (se.expr);
+	  /* Obtain a temporary class container for the result.  */
+	  gfc_conv_derived_to_class (&se, e, sym->ts, tmp, false, false);
+	  se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
+	}
+      else
+	gfc_conv_expr (&se, e);
+
+      tmp = TREE_TYPE (sym->backend_decl);
+      tmp = gfc_build_addr_expr (tmp, se.expr);
+      gfc_add_modify (&se.pre, sym->backend_decl, tmp);
+
+      gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
+			    gfc_finish_block (&se.post));
+    }
+
+  /* Do a simple assignment.  This is for scalar expressions, where we
+     can simply use expression assignment.  */
+  else
+    {
+      gfc_expr *lhs;
+
+      lhs = gfc_lval_expr_from_sym (sym);
+      tmp = gfc_trans_assignment (lhs, e, false, true);
+      gfc_add_init_cleanup (block, tmp, NULL_TREE);
+    }
+
+  /* Set the stringlength from the vtable size.  */
+  if (sym->ts.type == BT_CHARACTER && sym->attr.select_type_temporary)
+    {
+      tree charlen;
+      gfc_se se;
+      gfc_init_se (&se, NULL);
+      gcc_assert (UNLIMITED_POLY (e->symtree->n.sym));
+      tmp = gfc_get_symbol_decl (e->symtree->n.sym);
+      tmp = gfc_vtable_size_get (tmp);
+      gfc_get_symbol_decl (sym);
+      charlen = sym->ts.u.cl->backend_decl;
+      gfc_add_modify (&se.pre, charlen,
+		      fold_convert (TREE_TYPE (charlen), tmp));
+      gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
+			    gfc_finish_block (&se.post));
+    }
+}
+
+
+/* Translate a BLOCK construct.  This is basically what we would do for a
+   procedure body.  */
+
+tree
+gfc_trans_block_construct (gfc_code* code)
+{
+  gfc_namespace* ns;
+  gfc_symbol* sym;
+  gfc_wrapped_block block;
+  tree exit_label;
+  stmtblock_t body;
+  gfc_association_list *ass;
+
+  ns = code->ext.block.ns;
+  gcc_assert (ns);
+  sym = ns->proc_name;
+  gcc_assert (sym);
+
+  /* Process local variables.  */
+  gcc_assert (!sym->tlink);
+  sym->tlink = sym;
+  gfc_process_block_locals (ns);
+
+  /* Generate code including exit-label.  */
+  gfc_init_block (&body);
+  exit_label = gfc_build_label_decl (NULL_TREE);
+  code->exit_label = exit_label;
+  gfc_add_expr_to_block (&body, gfc_trans_code (ns->code));
+  gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label));
+
+  /* Finish everything.  */
+  gfc_start_wrapped_block (&block, gfc_finish_block (&body));
+  gfc_trans_deferred_vars (sym, &block);
+  for (ass = code->ext.block.assoc; ass; ass = ass->next)
+    trans_associate_var (ass->st->n.sym, &block);
+
+  return gfc_finish_wrapped_block (&block);
+}
+
+
+/* Translate the simple DO construct.  This is where the loop variable has
+   integer type and step +-1.  We can't use this in the general case
+   because integer overflow and floating point errors could give incorrect
+   results.
+   We translate a do loop from:
+
+   DO dovar = from, to, step
+      body
+   END DO
+
+   to:
+
+   [Evaluate loop bounds and step]
+   dovar = from;
+   if ((step > 0) ? (dovar <= to) : (dovar => to))
+    {
+      for (;;)
+        {
+	  body;
+   cycle_label:
+	  cond = (dovar == to);
+	  dovar += step;
+	  if (cond) goto end_label;
+	}
+      }
+   end_label:
+
+   This helps the optimizers by avoiding the extra induction variable
+   used in the general case.  */
+
+static tree
+gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
+		     tree from, tree to, tree step, tree exit_cond)
+{
+  stmtblock_t body;
+  tree type;
+  tree cond;
+  tree tmp;
+  tree saved_dovar = NULL;
+  tree cycle_label;
+  tree exit_label;
+  location_t loc;
+
+  type = TREE_TYPE (dovar);
+
+  loc = code->ext.iterator->start->where.lb->location;
+
+  /* Initialize the DO variable: dovar = from.  */
+  gfc_add_modify_loc (loc, pblock, dovar,
+		      fold_convert (TREE_TYPE(dovar), from));
+
+  /* Save value for do-tinkering checking. */
+  if (gfc_option.rtcheck & GFC_RTCHECK_DO)
+    {
+      saved_dovar = gfc_create_var (type, ".saved_dovar");
+      gfc_add_modify_loc (loc, pblock, saved_dovar, dovar);
+    }
+
+  /* Cycle and exit statements are implemented with gotos.  */
+  cycle_label = gfc_build_label_decl (NULL_TREE);
+  exit_label = gfc_build_label_decl (NULL_TREE);
+
+  /* Put the labels where they can be found later. See gfc_trans_do().  */
+  code->cycle_label = cycle_label;
+  code->exit_label = exit_label;
+
+  /* Loop body.  */
+  gfc_start_block (&body);
+
+  /* Main loop body.  */
+  tmp = gfc_trans_code_cond (code->block->next, exit_cond);
+  gfc_add_expr_to_block (&body, tmp);
+
+  /* Label for cycle statements (if needed).  */
+  if (TREE_USED (cycle_label))
+    {
+      tmp = build1_v (LABEL_EXPR, cycle_label);
+      gfc_add_expr_to_block (&body, tmp);
+    }
+
+  /* Check whether someone has modified the loop variable. */
+  if (gfc_option.rtcheck & GFC_RTCHECK_DO)
+    {
+      tmp = fold_build2_loc (loc, NE_EXPR, boolean_type_node,
+			     dovar, saved_dovar);
+      gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
+			       "Loop variable has been modified");
+    }
+
+  /* Exit the loop if there is an I/O result condition or error.  */
+  if (exit_cond)
+    {
+      tmp = build1_v (GOTO_EXPR, exit_label);
+      tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
+			     exit_cond, tmp,
+			     build_empty_stmt (loc));
+      gfc_add_expr_to_block (&body, tmp);
+    }
+
+  /* Evaluate the loop condition.  */
+  cond = fold_build2_loc (loc, EQ_EXPR, boolean_type_node, dovar,
+			  to);
+  cond = gfc_evaluate_now_loc (loc, cond, &body);
+
+  /* Increment the loop variable.  */
+  tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step);
+  gfc_add_modify_loc (loc, &body, dovar, tmp);
+
+  if (gfc_option.rtcheck & GFC_RTCHECK_DO)
+    gfc_add_modify_loc (loc, &body, saved_dovar, dovar);
+
+  /* The loop exit.  */
+  tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label);
+  TREE_USED (exit_label) = 1;
+  tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
+			 cond, tmp, build_empty_stmt (loc));
+  gfc_add_expr_to_block (&body, tmp);
+
+  /* Finish the loop body.  */
+  tmp = gfc_finish_block (&body);
+  tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp);
+
+  /* Only execute the loop if the number of iterations is positive.  */
+  if (tree_int_cst_sgn (step) > 0)
+    cond = fold_build2_loc (loc, LE_EXPR, boolean_type_node, dovar,
+			    to);
+  else
+    cond = fold_build2_loc (loc, GE_EXPR, boolean_type_node, dovar,
+			    to);
+  tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, cond, tmp,
+			 build_empty_stmt (loc));
+  gfc_add_expr_to_block (pblock, tmp);
+
+  /* Add the exit label.  */
+  tmp = build1_v (LABEL_EXPR, exit_label);
+  gfc_add_expr_to_block (pblock, tmp);
+
+  return gfc_finish_block (pblock);
+}
+
+/* Translate the DO construct.  This obviously is one of the most
+   important ones to get right with any compiler, but especially
+   so for Fortran.
+
+   We special case some loop forms as described in gfc_trans_simple_do.
+   For other cases we implement them with a separate loop count,
+   as described in the standard.
+
+   We translate a do loop from:
+
+   DO dovar = from, to, step
+      body
+   END DO
+
+   to:
+
+   [evaluate loop bounds and step]
+   empty = (step > 0 ? to < from : to > from);
+   countm1 = (to - from) / step;
+   dovar = from;
+   if (empty) goto exit_label;
+   for (;;)
+     {
+       body;
+cycle_label:
+       dovar += step
+       countm1t = countm1;
+       countm1--;
+       if (countm1t == 0) goto exit_label;
+     }
+exit_label:
+
+   countm1 is an unsigned integer.  It is equal to the loop count minus one,
+   because the loop count itself can overflow.  */
+
+tree
+gfc_trans_do (gfc_code * code, tree exit_cond)
+{
+  gfc_se se;
+  tree dovar;
+  tree saved_dovar = NULL;
+  tree from;
+  tree to;
+  tree step;
+  tree countm1;
+  tree type;
+  tree utype;
+  tree cond;
+  tree cycle_label;
+  tree exit_label;
+  tree tmp;
+  stmtblock_t block;
+  stmtblock_t body;
+  location_t loc;
+
+  gfc_start_block (&block);
+
+  loc = code->ext.iterator->start->where.lb->location;
+
+  /* Evaluate all the expressions in the iterator.  */
+  gfc_init_se (&se, NULL);
+  gfc_conv_expr_lhs (&se, code->ext.iterator->var);
+  gfc_add_block_to_block (&block, &se.pre);
+  dovar = se.expr;
+  type = TREE_TYPE (dovar);
+
+  gfc_init_se (&se, NULL);
+  gfc_conv_expr_val (&se, code->ext.iterator->start);
+  gfc_add_block_to_block (&block, &se.pre);
+  from = gfc_evaluate_now (se.expr, &block);
+
+  gfc_init_se (&se, NULL);
+  gfc_conv_expr_val (&se, code->ext.iterator->end);
+  gfc_add_block_to_block (&block, &se.pre);
+  to = gfc_evaluate_now (se.expr, &block);
+
+  gfc_init_se (&se, NULL);
+  gfc_conv_expr_val (&se, code->ext.iterator->step);
+  gfc_add_block_to_block (&block, &se.pre);
+  step = gfc_evaluate_now (se.expr, &block);
+
+  if (gfc_option.rtcheck & GFC_RTCHECK_DO)
+    {
+      tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, step,
+			     build_zero_cst (type));
+      gfc_trans_runtime_check (true, false, tmp, &block, &code->loc,
+			       "DO step value is zero");
+    }
+
+  /* Special case simple loops.  */
+  if (TREE_CODE (type) == INTEGER_TYPE
+      && (integer_onep (step)
+	|| tree_int_cst_equal (step, integer_minus_one_node)))
+    return gfc_trans_simple_do (code, &block, dovar, from, to, step, exit_cond);
+
+
+  if (TREE_CODE (type) == INTEGER_TYPE)
+    utype = unsigned_type_for (type);
+  else
+    utype = unsigned_type_for (gfc_array_index_type);
+  countm1 = gfc_create_var (utype, "countm1");
+
+  /* Cycle and exit statements are implemented with gotos.  */
+  cycle_label = gfc_build_label_decl (NULL_TREE);
+  exit_label = gfc_build_label_decl (NULL_TREE);
+  TREE_USED (exit_label) = 1;
+
+  /* Put these labels where they can be found later.  */
+  code->cycle_label = cycle_label;
+  code->exit_label = exit_label;
+
+  /* Initialize the DO variable: dovar = from.  */
+  gfc_add_modify (&block, dovar, from);
+
+  /* Save value for do-tinkering checking. */
+  if (gfc_option.rtcheck & GFC_RTCHECK_DO)
+    {
+      saved_dovar = gfc_create_var (type, ".saved_dovar");
+      gfc_add_modify_loc (loc, &block, saved_dovar, dovar);
+    }
+
+  /* Initialize loop count and jump to exit label if the loop is empty.
+     This code is executed before we enter the loop body. We generate:
+     if (step > 0)
+       {
+	 if (to < from)
+	   goto exit_label;
+	 countm1 = (to - from) / step;
+       }
+     else
+       {
+	 if (to > from)
+	   goto exit_label;
+	 countm1 = (from - to) / -step;
+       }
+   */
+
+  if (TREE_CODE (type) == INTEGER_TYPE)
+    {
+      tree pos, neg, tou, fromu, stepu, tmp2;
+
+      /* The distance from FROM to TO cannot always be represented in a signed
+         type, thus use unsigned arithmetic, also to avoid any undefined
+	 overflow issues.  */
+      tou = fold_convert (utype, to);
+      fromu = fold_convert (utype, from);
+      stepu = fold_convert (utype, step);
+
+      /* For a positive step, when to < from, exit, otherwise compute
+         countm1 = ((unsigned)to - (unsigned)from) / (unsigned)step  */
+      tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, to, from);
+      tmp2 = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype,
+			      fold_build2_loc (loc, MINUS_EXPR, utype,
+					       tou, fromu),
+			      stepu);
+      pos = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp,
+			     fold_build1_loc (loc, GOTO_EXPR, void_type_node,
+					      exit_label),
+			     fold_build2 (MODIFY_EXPR, void_type_node,
+					  countm1, tmp2));
+
+      /* For a negative step, when to > from, exit, otherwise compute
+         countm1 = ((unsigned)from - (unsigned)to) / -(unsigned)step  */
+      tmp = fold_build2_loc (loc, GT_EXPR, boolean_type_node, to, from);
+      tmp2 = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype,
+			      fold_build2_loc (loc, MINUS_EXPR, utype,
+					       fromu, tou),
+			      fold_build1_loc (loc, NEGATE_EXPR, utype, stepu));
+      neg = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp,
+			     fold_build1_loc (loc, GOTO_EXPR, void_type_node,
+					      exit_label),
+			     fold_build2 (MODIFY_EXPR, void_type_node,
+					  countm1, tmp2));
+
+      tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, step,
+			     build_int_cst (TREE_TYPE (step), 0));
+      tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp, neg, pos);
+
+      gfc_add_expr_to_block (&block, tmp);
+    }
+  else
+    {
+      tree pos_step;
+
+      /* TODO: We could use the same width as the real type.
+	 This would probably cause more problems that it solves
+	 when we implement "long double" types.  */
+
+      tmp = fold_build2_loc (loc, MINUS_EXPR, type, to, from);
+      tmp = fold_build2_loc (loc, RDIV_EXPR, type, tmp, step);
+      tmp = fold_build1_loc (loc, FIX_TRUNC_EXPR, utype, tmp);
+      gfc_add_modify (&block, countm1, tmp);
+
+      /* We need a special check for empty loops:
+	 empty = (step > 0 ? to < from : to > from);  */
+      pos_step = fold_build2_loc (loc, GT_EXPR, boolean_type_node, step,
+				  build_zero_cst (type));
+      tmp = fold_build3_loc (loc, COND_EXPR, boolean_type_node, pos_step,
+			     fold_build2_loc (loc, LT_EXPR,
+					      boolean_type_node, to, from),
+			     fold_build2_loc (loc, GT_EXPR,
+					      boolean_type_node, to, from));
+      /* If the loop is empty, go directly to the exit label.  */
+      tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp,
+			 build1_v (GOTO_EXPR, exit_label),
+			 build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&block, tmp);
+    }
+
+  /* Loop body.  */
+  gfc_start_block (&body);
+
+  /* Main loop body.  */
+  tmp = gfc_trans_code_cond (code->block->next, exit_cond);
+  gfc_add_expr_to_block (&body, tmp);
+
+  /* Label for cycle statements (if needed).  */
+  if (TREE_USED (cycle_label))
+    {
+      tmp = build1_v (LABEL_EXPR, cycle_label);
+      gfc_add_expr_to_block (&body, tmp);
+    }
+
+  /* Check whether someone has modified the loop variable. */
+  if (gfc_option.rtcheck & GFC_RTCHECK_DO)
+    {
+      tmp = fold_build2_loc (loc, NE_EXPR, boolean_type_node, dovar,
+			     saved_dovar);
+      gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
+			       "Loop variable has been modified");
+    }
+
+  /* Exit the loop if there is an I/O result condition or error.  */
+  if (exit_cond)
+    {
+      tmp = build1_v (GOTO_EXPR, exit_label);
+      tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
+			     exit_cond, tmp,
+			     build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&body, tmp);
+    }
+
+  /* Increment the loop variable.  */
+  tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step);
+  gfc_add_modify_loc (loc, &body, dovar, tmp);
+
+  if (gfc_option.rtcheck & GFC_RTCHECK_DO)
+    gfc_add_modify_loc (loc, &body, saved_dovar, dovar);
+
+  /* Initialize countm1t.  */
+  tree countm1t = gfc_create_var (utype, "countm1t");
+  gfc_add_modify_loc (loc, &body, countm1t, countm1);
+
+  /* Decrement the loop count.  */
+  tmp = fold_build2_loc (loc, MINUS_EXPR, utype, countm1,
+			 build_int_cst (utype, 1));
+  gfc_add_modify_loc (loc, &body, countm1, tmp);
+
+  /* End with the loop condition.  Loop until countm1t == 0.  */
+  cond = fold_build2_loc (loc, EQ_EXPR, boolean_type_node, countm1t,
+			  build_int_cst (utype, 0));
+  tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label);
+  tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
+			 cond, tmp, build_empty_stmt (loc));
+  gfc_add_expr_to_block (&body, tmp);
+
+  /* End of loop body.  */
+  tmp = gfc_finish_block (&body);
+
+  /* The for loop itself.  */
+  tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp);
+  gfc_add_expr_to_block (&block, tmp);
+
+  /* Add the exit label.  */
+  tmp = build1_v (LABEL_EXPR, exit_label);
+  gfc_add_expr_to_block (&block, tmp);
+
+  return gfc_finish_block (&block);
+}
+
+
+/* Translate the DO WHILE construct.
+
+   We translate
+
+   DO WHILE (cond)
+      body
+   END DO
+
+   to:
+
+   for ( ; ; )
+     {
+       pre_cond;
+       if (! cond) goto exit_label;
+       body;
+cycle_label:
+     }
+exit_label:
+
+   Because the evaluation of the exit condition `cond' may have side
+   effects, we can't do much for empty loop bodies.  The backend optimizers
+   should be smart enough to eliminate any dead loops.  */
+
+tree
+gfc_trans_do_while (gfc_code * code)
+{
+  gfc_se cond;
+  tree tmp;
+  tree cycle_label;
+  tree exit_label;
+  stmtblock_t block;
+
+  /* Everything we build here is part of the loop body.  */
+  gfc_start_block (&block);
+
+  /* Cycle and exit statements are implemented with gotos.  */
+  cycle_label = gfc_build_label_decl (NULL_TREE);
+  exit_label = gfc_build_label_decl (NULL_TREE);
+
+  /* Put the labels where they can be found later. See gfc_trans_do().  */
+  code->cycle_label = cycle_label;
+  code->exit_label = exit_label;
+
+  /* Create a GIMPLE version of the exit condition.  */
+  gfc_init_se (&cond, NULL);
+  gfc_conv_expr_val (&cond, code->expr1);
+  gfc_add_block_to_block (&block, &cond.pre);
+  cond.expr = fold_build1_loc (code->expr1->where.lb->location,
+			       TRUTH_NOT_EXPR, TREE_TYPE (cond.expr), cond.expr);
+
+  /* Build "IF (! cond) GOTO exit_label".  */
+  tmp = build1_v (GOTO_EXPR, exit_label);
+  TREE_USED (exit_label) = 1;
+  tmp = fold_build3_loc (code->expr1->where.lb->location, COND_EXPR,
+			 void_type_node, cond.expr, tmp,
+			 build_empty_stmt (code->expr1->where.lb->location));
+  gfc_add_expr_to_block (&block, tmp);
+
+  /* The main body of the loop.  */
+  tmp = gfc_trans_code (code->block->next);
+  gfc_add_expr_to_block (&block, tmp);
+
+  /* Label for cycle statements (if needed).  */
+  if (TREE_USED (cycle_label))
+    {
+      tmp = build1_v (LABEL_EXPR, cycle_label);
+      gfc_add_expr_to_block (&block, tmp);
+    }
+
+  /* End of loop body.  */
+  tmp = gfc_finish_block (&block);
+
+  gfc_init_block (&block);
+  /* Build the loop.  */
+  tmp = fold_build1_loc (code->expr1->where.lb->location, LOOP_EXPR,
+			 void_type_node, tmp);
+  gfc_add_expr_to_block (&block, tmp);
+
+  /* Add the exit label.  */
+  tmp = build1_v (LABEL_EXPR, exit_label);
+  gfc_add_expr_to_block (&block, tmp);
+
+  return gfc_finish_block (&block);
+}
+
+
+/* Translate the SELECT CASE construct for INTEGER case expressions,
+   without killing all potential optimizations.  The problem is that
+   Fortran allows unbounded cases, but the back-end does not, so we
+   need to intercept those before we enter the equivalent SWITCH_EXPR
+   we can build.
+
+   For example, we translate this,
+
+   SELECT CASE (expr)
+      CASE (:100,101,105:115)
+	 block_1
+      CASE (190:199,200:)
+	 block_2
+      CASE (300)
+	 block_3
+      CASE DEFAULT
+	 block_4
+   END SELECT
+
+   to the GENERIC equivalent,
+
+     switch (expr)
+       {
+	 case (minimum value for typeof(expr) ... 100:
+	 case 101:
+	 case 105 ... 114:
+	   block1:
+	   goto end_label;
+
+	 case 200 ... (maximum value for typeof(expr):
+	 case 190 ... 199:
+	   block2;
+	   goto end_label;
+
+	 case 300:
+	   block_3;
+	   goto end_label;
+
+	 default:
+	   block_4;
+	   goto end_label;
+       }
+
+     end_label:  */
+
+static tree
+gfc_trans_integer_select (gfc_code * code)
+{
+  gfc_code *c;
+  gfc_case *cp;
+  tree end_label;
+  tree tmp;
+  gfc_se se;
+  stmtblock_t block;
+  stmtblock_t body;
+
+  gfc_start_block (&block);
+
+  /* Calculate the switch expression.  */
+  gfc_init_se (&se, NULL);
+  gfc_conv_expr_val (&se, code->expr1);
+  gfc_add_block_to_block (&block, &se.pre);
+
+  end_label = gfc_build_label_decl (NULL_TREE);
+
+  gfc_init_block (&body);
+
+  for (c = code->block; c; c = c->block)
+    {
+      for (cp = c->ext.block.case_list; cp; cp = cp->next)
+	{
+	  tree low, high;
+          tree label;
+
+	  /* Assume it's the default case.  */
+	  low = high = NULL_TREE;
+
+	  if (cp->low)
+	    {
+	      low = gfc_conv_mpz_to_tree (cp->low->value.integer,
+					  cp->low->ts.kind);
+
+	      /* If there's only a lower bound, set the high bound to the
+		 maximum value of the case expression.  */
+	      if (!cp->high)
+		high = TYPE_MAX_VALUE (TREE_TYPE (se.expr));
+	    }
+
+	  if (cp->high)
+	    {
+	      /* Three cases are possible here:
+
+		 1) There is no lower bound, e.g. CASE (:N).
+		 2) There is a lower bound .NE. high bound, that is
+		    a case range, e.g. CASE (N:M) where M>N (we make
+		    sure that M>N during type resolution).
+		 3) There is a lower bound, and it has the same value
+		    as the high bound, e.g. CASE (N:N).  This is our
+		    internal representation of CASE(N).
+
+		 In the first and second case, we need to set a value for
+		 high.  In the third case, we don't because the GCC middle
+		 end represents a single case value by just letting high be
+		 a NULL_TREE.  We can't do that because we need to be able
+		 to represent unbounded cases.  */
+
+	      if (!cp->low
+		  || (cp->low
+		      && mpz_cmp (cp->low->value.integer,
+				  cp->high->value.integer) != 0))
+		high = gfc_conv_mpz_to_tree (cp->high->value.integer,
+					     cp->high->ts.kind);
+
+	      /* Unbounded case.  */
+	      if (!cp->low)
+		low = TYPE_MIN_VALUE (TREE_TYPE (se.expr));
+	    }
+
+          /* Build a label.  */
+          label = gfc_build_label_decl (NULL_TREE);
+
+	  /* Add this case label.
+             Add parameter 'label', make it match GCC backend.  */
+	  tmp = build_case_label (low, high, label);
+	  gfc_add_expr_to_block (&body, tmp);
+	}
+
+      /* Add the statements for this case.  */
+      tmp = gfc_trans_code (c->next);
+      gfc_add_expr_to_block (&body, tmp);
+
+      /* Break to the end of the construct.  */
+      tmp = build1_v (GOTO_EXPR, end_label);
+      gfc_add_expr_to_block (&body, tmp);
+    }
+
+  tmp = gfc_finish_block (&body);
+  tmp = fold_build3_loc (input_location, SWITCH_EXPR, NULL_TREE,
+			 se.expr, tmp, NULL_TREE);
+  gfc_add_expr_to_block (&block, tmp);
+
+  tmp = build1_v (LABEL_EXPR, end_label);
+  gfc_add_expr_to_block (&block, tmp);
+
+  return gfc_finish_block (&block);
+}
+
+
+/* Translate the SELECT CASE construct for LOGICAL case expressions.
+
+   There are only two cases possible here, even though the standard
+   does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
+   .FALSE., and DEFAULT.
+
+   We never generate more than two blocks here.  Instead, we always
+   try to eliminate the DEFAULT case.  This way, we can translate this
+   kind of SELECT construct to a simple
+
+   if {} else {};
+
+   expression in GENERIC.  */
+
+static tree
+gfc_trans_logical_select (gfc_code * code)
+{
+  gfc_code *c;
+  gfc_code *t, *f, *d;
+  gfc_case *cp;
+  gfc_se se;
+  stmtblock_t block;
+
+  /* Assume we don't have any cases at all.  */
+  t = f = d = NULL;
+
+  /* Now see which ones we actually do have.  We can have at most two
+     cases in a single case list: one for .TRUE. and one for .FALSE.
+     The default case is always separate.  If the cases for .TRUE. and
+     .FALSE. are in the same case list, the block for that case list
+     always executed, and we don't generate code a COND_EXPR.  */
+  for (c = code->block; c; c = c->block)
+    {
+      for (cp = c->ext.block.case_list; cp; cp = cp->next)
+	{
+	  if (cp->low)
+	    {
+	      if (cp->low->value.logical == 0) /* .FALSE.  */
+		f = c;
+	      else /* if (cp->value.logical != 0), thus .TRUE.  */
+		t = c;
+	    }
+	  else
+	    d = c;
+	}
+    }
+
+  /* Start a new block.  */
+  gfc_start_block (&block);
+
+  /* Calculate the switch expression.  We always need to do this
+     because it may have side effects.  */
+  gfc_init_se (&se, NULL);
+  gfc_conv_expr_val (&se, code->expr1);
+  gfc_add_block_to_block (&block, &se.pre);
+
+  if (t == f && t != NULL)
+    {
+      /* Cases for .TRUE. and .FALSE. are in the same block.  Just
+         translate the code for these cases, append it to the current
+         block.  */
+      gfc_add_expr_to_block (&block, gfc_trans_code (t->next));
+    }
+  else
+    {
+      tree true_tree, false_tree, stmt;
+
+      true_tree = build_empty_stmt (input_location);
+      false_tree = build_empty_stmt (input_location);
+
+      /* If we have a case for .TRUE. and for .FALSE., discard the default case.
+          Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
+          make the missing case the default case.  */
+      if (t != NULL && f != NULL)
+	d = NULL;
+      else if (d != NULL)
+        {
+	  if (t == NULL)
+	    t = d;
+	  else
+	    f = d;
+	}
+
+      /* Translate the code for each of these blocks, and append it to
+         the current block.  */
+      if (t != NULL)
+        true_tree = gfc_trans_code (t->next);
+
+      if (f != NULL)
+	false_tree = gfc_trans_code (f->next);
+
+      stmt = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+			      se.expr, true_tree, false_tree);
+      gfc_add_expr_to_block (&block, stmt);
+    }
+
+  return gfc_finish_block (&block);
+}
+
+
+/* The jump table types are stored in static variables to avoid
+   constructing them from scratch every single time.  */
+static GTY(()) tree select_struct[2];
+
+/* Translate the SELECT CASE construct for CHARACTER case expressions.
+   Instead of generating compares and jumps, it is far simpler to
+   generate a data structure describing the cases in order and call a
+   library subroutine that locates the right case.
+   This is particularly true because this is the only case where we
+   might have to dispose of a temporary.
+   The library subroutine returns a pointer to jump to or NULL if no
+   branches are to be taken.  */
+
+static tree
+gfc_trans_character_select (gfc_code *code)
+{
+  tree init, end_label, tmp, type, case_num, label, fndecl;
+  stmtblock_t block, body;
+  gfc_case *cp, *d;
+  gfc_code *c;
+  gfc_se se, expr1se;
+  int n, k;
+  vec<constructor_elt, va_gc> *inits = NULL;
+
+  tree pchartype = gfc_get_pchar_type (code->expr1->ts.kind);
+
+  /* The jump table types are stored in static variables to avoid
+     constructing them from scratch every single time.  */
+  static tree ss_string1[2], ss_string1_len[2];
+  static tree ss_string2[2], ss_string2_len[2];
+  static tree ss_target[2];
+
+  cp = code->block->ext.block.case_list;
+  while (cp->left != NULL)
+    cp = cp->left;
+
+  /* Generate the body */
+  gfc_start_block (&block);
+  gfc_init_se (&expr1se, NULL);
+  gfc_conv_expr_reference (&expr1se, code->expr1);
+
+  gfc_add_block_to_block (&block, &expr1se.pre);
+
+  end_label = gfc_build_label_decl (NULL_TREE);
+
+  gfc_init_block (&body);
+
+  /* Attempt to optimize length 1 selects.  */
+  if (integer_onep (expr1se.string_length))
+    {
+      for (d = cp; d; d = d->right)
+	{
+	  int i;
+	  if (d->low)
+	    {
+	      gcc_assert (d->low->expr_type == EXPR_CONSTANT
+			  && d->low->ts.type == BT_CHARACTER);
+	      if (d->low->value.character.length > 1)
+		{
+		  for (i = 1; i < d->low->value.character.length; i++)
+		    if (d->low->value.character.string[i] != ' ')
+		      break;
+		  if (i != d->low->value.character.length)
+		    {
+		      if (optimize && d->high && i == 1)
+			{
+			  gcc_assert (d->high->expr_type == EXPR_CONSTANT
+				      && d->high->ts.type == BT_CHARACTER);
+			  if (d->high->value.character.length > 1
+			      && (d->low->value.character.string[0]
+				  == d->high->value.character.string[0])
+			      && d->high->value.character.string[1] != ' '
+			      && ((d->low->value.character.string[1] < ' ')
+				  == (d->high->value.character.string[1]
+				      < ' ')))
+			    continue;
+			}
+		      break;
+		    }
+		}
+	    }
+	  if (d->high)
+	    {
+	      gcc_assert (d->high->expr_type == EXPR_CONSTANT
+			  && d->high->ts.type == BT_CHARACTER);
+	      if (d->high->value.character.length > 1)
+		{
+		  for (i = 1; i < d->high->value.character.length; i++)
+		    if (d->high->value.character.string[i] != ' ')
+		      break;
+		  if (i != d->high->value.character.length)
+		    break;
+		}
+	    }
+	}
+      if (d == NULL)
+	{
+	  tree ctype = gfc_get_char_type (code->expr1->ts.kind);
+
+	  for (c = code->block; c; c = c->block)
+	    {
+	      for (cp = c->ext.block.case_list; cp; cp = cp->next)
+		{
+		  tree low, high;
+		  tree label;
+		  gfc_char_t r;
+
+		  /* Assume it's the default case.  */
+		  low = high = NULL_TREE;
+
+		  if (cp->low)
+		    {
+		      /* CASE ('ab') or CASE ('ab':'az') will never match
+			 any length 1 character.  */
+		      if (cp->low->value.character.length > 1
+			  && cp->low->value.character.string[1] != ' ')
+			continue;
+
+		      if (cp->low->value.character.length > 0)
+			r = cp->low->value.character.string[0];
+		      else
+			r = ' ';
+		      low = build_int_cst (ctype, r);
+
+		      /* If there's only a lower bound, set the high bound
+			 to the maximum value of the case expression.  */
+		      if (!cp->high)
+			high = TYPE_MAX_VALUE (ctype);
+		    }
+
+		  if (cp->high)
+		    {
+		      if (!cp->low
+			  || (cp->low->value.character.string[0]
+			      != cp->high->value.character.string[0]))
+			{
+			  if (cp->high->value.character.length > 0)
+			    r = cp->high->value.character.string[0];
+			  else
+			    r = ' ';
+			  high = build_int_cst (ctype, r);
+			}
+
+		      /* Unbounded case.  */
+		      if (!cp->low)
+			low = TYPE_MIN_VALUE (ctype);
+		    }
+
+		  /* Build a label.  */
+		  label = gfc_build_label_decl (NULL_TREE);
+
+		  /* Add this case label.
+		     Add parameter 'label', make it match GCC backend.  */
+		  tmp = build_case_label (low, high, label);
+		  gfc_add_expr_to_block (&body, tmp);
+		}
+
+	      /* Add the statements for this case.  */
+	      tmp = gfc_trans_code (c->next);
+	      gfc_add_expr_to_block (&body, tmp);
+
+	      /* Break to the end of the construct.  */
+	      tmp = build1_v (GOTO_EXPR, end_label);
+	      gfc_add_expr_to_block (&body, tmp);
+	    }
+
+	  tmp = gfc_string_to_single_character (expr1se.string_length,
+						expr1se.expr,
+						code->expr1->ts.kind);
+	  case_num = gfc_create_var (ctype, "case_num");
+	  gfc_add_modify (&block, case_num, tmp);
+
+	  gfc_add_block_to_block (&block, &expr1se.post);
+
+	  tmp = gfc_finish_block (&body);
+	  tmp = fold_build3_loc (input_location, SWITCH_EXPR, NULL_TREE,
+				 case_num, tmp, NULL_TREE);
+	  gfc_add_expr_to_block (&block, tmp);
+
+	  tmp = build1_v (LABEL_EXPR, end_label);
+	  gfc_add_expr_to_block (&block, tmp);
+
+	  return gfc_finish_block (&block);
+	}
+    }
+
+  if (code->expr1->ts.kind == 1)
+    k = 0;
+  else if (code->expr1->ts.kind == 4)
+    k = 1;
+  else
+    gcc_unreachable ();
+
+  if (select_struct[k] == NULL)
+    {
+      tree *chain = NULL;
+      select_struct[k] = make_node (RECORD_TYPE);
+
+      if (code->expr1->ts.kind == 1)
+	TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char1");
+      else if (code->expr1->ts.kind == 4)
+	TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char4");
+      else
+	gcc_unreachable ();
+
+#undef ADD_FIELD
+#define ADD_FIELD(NAME, TYPE)						    \
+  ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k],		    \
+					  get_identifier (stringize(NAME)), \
+					  TYPE,				    \
+					  &chain)
+
+      ADD_FIELD (string1, pchartype);
+      ADD_FIELD (string1_len, gfc_charlen_type_node);
+
+      ADD_FIELD (string2, pchartype);
+      ADD_FIELD (string2_len, gfc_charlen_type_node);
+
+      ADD_FIELD (target, integer_type_node);
+#undef ADD_FIELD
+
+      gfc_finish_type (select_struct[k]);
+    }
+
+  n = 0;
+  for (d = cp; d; d = d->right)
+    d->n = n++;
+
+  for (c = code->block; c; c = c->block)
+    {
+      for (d = c->ext.block.case_list; d; d = d->next)
+        {
+	  label = gfc_build_label_decl (NULL_TREE);
+	  tmp = build_case_label ((d->low == NULL && d->high == NULL)
+				  ? NULL
+				  : build_int_cst (integer_type_node, d->n),
+				  NULL, label);
+          gfc_add_expr_to_block (&body, tmp);
+        }
+
+      tmp = gfc_trans_code (c->next);
+      gfc_add_expr_to_block (&body, tmp);
+
+      tmp = build1_v (GOTO_EXPR, end_label);
+      gfc_add_expr_to_block (&body, tmp);
+    }
+
+  /* Generate the structure describing the branches */
+  for (d = cp; d; d = d->right)
+    {
+      vec<constructor_elt, va_gc> *node = NULL;
+
+      gfc_init_se (&se, NULL);
+
+      if (d->low == NULL)
+        {
+          CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], null_pointer_node);
+          CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], integer_zero_node);
+        }
+      else
+        {
+          gfc_conv_expr_reference (&se, d->low);
+
+          CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], se.expr);
+          CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], se.string_length);
+        }
+
+      if (d->high == NULL)
+        {
+          CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], null_pointer_node);
+          CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], integer_zero_node);
+        }
+      else
+        {
+          gfc_init_se (&se, NULL);
+          gfc_conv_expr_reference (&se, d->high);
+
+          CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], se.expr);
+          CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], se.string_length);
+        }
+
+      CONSTRUCTOR_APPEND_ELT (node, ss_target[k],
+                              build_int_cst (integer_type_node, d->n));
+
+      tmp = build_constructor (select_struct[k], node);
+      CONSTRUCTOR_APPEND_ELT (inits, NULL_TREE, tmp);
+    }
+
+  type = build_array_type (select_struct[k],
+			   build_index_type (size_int (n-1)));
+
+  init = build_constructor (type, inits);
+  TREE_CONSTANT (init) = 1;
+  TREE_STATIC (init) = 1;
+  /* Create a static variable to hold the jump table.  */
+  tmp = gfc_create_var (type, "jumptable");
+  TREE_CONSTANT (tmp) = 1;
+  TREE_STATIC (tmp) = 1;
+  TREE_READONLY (tmp) = 1;
+  DECL_INITIAL (tmp) = init;
+  init = tmp;
+
+  /* Build the library call */
+  init = gfc_build_addr_expr (pvoid_type_node, init);
+
+  if (code->expr1->ts.kind == 1)
+    fndecl = gfor_fndecl_select_string;
+  else if (code->expr1->ts.kind == 4)
+    fndecl = gfor_fndecl_select_string_char4;
+  else
+    gcc_unreachable ();
+
+  tmp = build_call_expr_loc (input_location,
+			 fndecl, 4, init,
+			 build_int_cst (gfc_charlen_type_node, n),
+			 expr1se.expr, expr1se.string_length);
+  case_num = gfc_create_var (integer_type_node, "case_num");
+  gfc_add_modify (&block, case_num, tmp);
+
+  gfc_add_block_to_block (&block, &expr1se.post);
+
+  tmp = gfc_finish_block (&body);
+  tmp = fold_build3_loc (input_location, SWITCH_EXPR, NULL_TREE,
+			 case_num, tmp, NULL_TREE);
+  gfc_add_expr_to_block (&block, tmp);
+
+  tmp = build1_v (LABEL_EXPR, end_label);
+  gfc_add_expr_to_block (&block, tmp);
+
+  return gfc_finish_block (&block);
+}
+
+
+/* Translate the three variants of the SELECT CASE construct.
+
+   SELECT CASEs with INTEGER case expressions can be translated to an
+   equivalent GENERIC switch statement, and for LOGICAL case
+   expressions we build one or two if-else compares.
+
+   SELECT CASEs with CHARACTER case expressions are a whole different
+   story, because they don't exist in GENERIC.  So we sort them and
+   do a binary search at runtime.
+
+   Fortran has no BREAK statement, and it does not allow jumps from
+   one case block to another.  That makes things a lot easier for
+   the optimizers.  */
+
+tree
+gfc_trans_select (gfc_code * code)
+{
+  stmtblock_t block;
+  tree body;
+  tree exit_label;
+
+  gcc_assert (code && code->expr1);
+  gfc_init_block (&block);
+
+  /* Build the exit label and hang it in.  */
+  exit_label = gfc_build_label_decl (NULL_TREE);
+  code->exit_label = exit_label;
+
+  /* Empty SELECT constructs are legal.  */
+  if (code->block == NULL)
+    body = build_empty_stmt (input_location);
+
+  /* Select the correct translation function.  */
+  else
+    switch (code->expr1->ts.type)
+      {
+      case BT_LOGICAL:
+	body = gfc_trans_logical_select (code);
+	break;
+
+      case BT_INTEGER:
+	body = gfc_trans_integer_select (code);
+	break;
+
+      case BT_CHARACTER:
+	body = gfc_trans_character_select (code);
+	break;
+
+      default:
+	gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
+	/* Not reached */
+      }
+
+  /* Build everything together.  */
+  gfc_add_expr_to_block (&block, body);
+  gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label));
+
+  return gfc_finish_block (&block);
+}
+
+
+/* Traversal function to substitute a replacement symtree if the symbol
+   in the expression is the same as that passed.  f == 2 signals that
+   that variable itself is not to be checked - only the references.
+   This group of functions is used when the variable expression in a
+   FORALL assignment has internal references.  For example:
+		FORALL (i = 1:4) p(p(i)) = i
+   The only recourse here is to store a copy of 'p' for the index
+   expression.  */
+
+static gfc_symtree *new_symtree;
+static gfc_symtree *old_symtree;
+
+static bool
+forall_replace (gfc_expr *expr, gfc_symbol *sym, int *f)
+{
+  if (expr->expr_type != EXPR_VARIABLE)
+    return false;
+
+  if (*f == 2)
+    *f = 1;
+  else if (expr->symtree->n.sym == sym)
+    expr->symtree = new_symtree;
+
+  return false;
+}
+
+static void
+forall_replace_symtree (gfc_expr *e, gfc_symbol *sym, int f)
+{
+  gfc_traverse_expr (e, sym, forall_replace, f);
+}
+
+static bool
+forall_restore (gfc_expr *expr,
+		gfc_symbol *sym ATTRIBUTE_UNUSED,
+		int *f ATTRIBUTE_UNUSED)
+{
+  if (expr->expr_type != EXPR_VARIABLE)
+    return false;
+
+  if (expr->symtree == new_symtree)
+    expr->symtree = old_symtree;
+
+  return false;
+}
+
+static void
+forall_restore_symtree (gfc_expr *e)
+{
+  gfc_traverse_expr (e, NULL, forall_restore, 0);
+}
+
+static void
+forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
+{
+  gfc_se tse;
+  gfc_se rse;
+  gfc_expr *e;
+  gfc_symbol *new_sym;
+  gfc_symbol *old_sym;
+  gfc_symtree *root;
+  tree tmp;
+
+  /* Build a copy of the lvalue.  */
+  old_symtree = c->expr1->symtree;
+  old_sym = old_symtree->n.sym;
+  e = gfc_lval_expr_from_sym (old_sym);
+  if (old_sym->attr.dimension)
+    {
+      gfc_init_se (&tse, NULL);
+      gfc_conv_subref_array_arg (&tse, e, 0, INTENT_IN, false);
+      gfc_add_block_to_block (pre, &tse.pre);
+      gfc_add_block_to_block (post, &tse.post);
+      tse.expr = build_fold_indirect_ref_loc (input_location, tse.expr);
+
+      if (e->ts.type != BT_CHARACTER)
+	{
+	  /* Use the variable offset for the temporary.  */
+	  tmp = gfc_conv_array_offset (old_sym->backend_decl);
+	  gfc_conv_descriptor_offset_set (pre, tse.expr, tmp);
+	}
+    }
+  else
+    {
+      gfc_init_se (&tse, NULL);
+      gfc_init_se (&rse, NULL);
+      gfc_conv_expr (&rse, e);
+      if (e->ts.type == BT_CHARACTER)
+	{
+	  tse.string_length = rse.string_length;
+	  tmp = gfc_get_character_type_len (gfc_default_character_kind,
+					    tse.string_length);
+	  tse.expr = gfc_conv_string_tmp (&tse, build_pointer_type (tmp),
+					  rse.string_length);
+	  gfc_add_block_to_block (pre, &tse.pre);
+	  gfc_add_block_to_block (post, &tse.post);
+	}
+      else
+	{
+	  tmp = gfc_typenode_for_spec (&e->ts);
+	  tse.expr = gfc_create_var (tmp, "temp");
+	}
+
+      tmp = gfc_trans_scalar_assign (&tse, &rse, e->ts, true,
+				     e->expr_type == EXPR_VARIABLE, true);
+      gfc_add_expr_to_block (pre, tmp);
+    }
+  gfc_free_expr (e);
+
+  /* Create a new symbol to represent the lvalue.  */
+  new_sym = gfc_new_symbol (old_sym->name, NULL);
+  new_sym->ts = old_sym->ts;
+  new_sym->attr.referenced = 1;
+  new_sym->attr.temporary = 1;
+  new_sym->attr.dimension = old_sym->attr.dimension;
+  new_sym->attr.flavor = old_sym->attr.flavor;
+
+  /* Use the temporary as the backend_decl.  */
+  new_sym->backend_decl = tse.expr;
+
+  /* Create a fake symtree for it.  */
+  root = NULL;
+  new_symtree = gfc_new_symtree (&root, old_sym->name);
+  new_symtree->n.sym = new_sym;
+  gcc_assert (new_symtree == root);
+
+  /* Go through the expression reference replacing the old_symtree
+     with the new.  */
+  forall_replace_symtree (c->expr1, old_sym, 2);
+
+  /* Now we have made this temporary, we might as well use it for
+  the right hand side.  */
+  forall_replace_symtree (c->expr2, old_sym, 1);
+}
+
+
+/* Handles dependencies in forall assignments.  */
+static int
+check_forall_dependencies (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
+{
+  gfc_ref *lref;
+  gfc_ref *rref;
+  int need_temp;
+  gfc_symbol *lsym;
+
+  lsym = c->expr1->symtree->n.sym;
+  need_temp = gfc_check_dependency (c->expr1, c->expr2, 0);
+
+  /* Now check for dependencies within the 'variable'
+     expression itself.  These are treated by making a complete
+     copy of variable and changing all the references to it
+     point to the copy instead.  Note that the shallow copy of
+     the variable will not suffice for derived types with
+     pointer components.  We therefore leave these to their
+     own devices.  */
+  if (lsym->ts.type == BT_DERIVED
+	&& lsym->ts.u.derived->attr.pointer_comp)
+    return need_temp;
+
+  new_symtree = NULL;
+  if (find_forall_index (c->expr1, lsym, 2))
+    {
+      forall_make_variable_temp (c, pre, post);
+      need_temp = 0;
+    }
+
+  /* Substrings with dependencies are treated in the same
+     way.  */
+  if (c->expr1->ts.type == BT_CHARACTER
+	&& c->expr1->ref
+	&& c->expr2->expr_type == EXPR_VARIABLE
+	&& lsym == c->expr2->symtree->n.sym)
+    {
+      for (lref = c->expr1->ref; lref; lref = lref->next)
+	if (lref->type == REF_SUBSTRING)
+	  break;
+      for (rref = c->expr2->ref; rref; rref = rref->next)
+	if (rref->type == REF_SUBSTRING)
+	  break;
+
+      if (rref && lref
+	    && gfc_dep_compare_expr (rref->u.ss.start, lref->u.ss.start) < 0)
+	{
+	  forall_make_variable_temp (c, pre, post);
+	  need_temp = 0;
+	}
+    }
+  return need_temp;
+}
+
+
+static void
+cleanup_forall_symtrees (gfc_code *c)
+{
+  forall_restore_symtree (c->expr1);
+  forall_restore_symtree (c->expr2);
+  free (new_symtree->n.sym);
+  free (new_symtree);
+}
+
+
+/* Generate the loops for a FORALL block, specified by FORALL_TMP.  BODY
+   is the contents of the FORALL block/stmt to be iterated.  MASK_FLAG
+   indicates whether we should generate code to test the FORALLs mask
+   array.  OUTER is the loop header to be used for initializing mask
+   indices.
+
+   The generated loop format is:
+    count = (end - start + step) / step
+    loopvar = start
+    while (1)
+      {
+        if (count <=0 )
+          goto end_of_loop
+        <body>
+        loopvar += step
+        count --
+      }
+    end_of_loop:  */
+
+static tree
+gfc_trans_forall_loop (forall_info *forall_tmp, tree body,
+                       int mask_flag, stmtblock_t *outer)
+{
+  int n, nvar;
+  tree tmp;
+  tree cond;
+  stmtblock_t block;
+  tree exit_label;
+  tree count;
+  tree var, start, end, step;
+  iter_info *iter;
+
+  /* Initialize the mask index outside the FORALL nest.  */
+  if (mask_flag && forall_tmp->mask)
+    gfc_add_modify (outer, forall_tmp->maskindex, gfc_index_zero_node);
+
+  iter = forall_tmp->this_loop;
+  nvar = forall_tmp->nvar;
+  for (n = 0; n < nvar; n++)
+    {
+      var = iter->var;
+      start = iter->start;
+      end = iter->end;
+      step = iter->step;
+
+      exit_label = gfc_build_label_decl (NULL_TREE);
+      TREE_USED (exit_label) = 1;
+
+      /* The loop counter.  */
+      count = gfc_create_var (TREE_TYPE (var), "count");
+
+      /* The body of the loop.  */
+      gfc_init_block (&block);
+
+      /* The exit condition.  */
+      cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
+			      count, build_int_cst (TREE_TYPE (count), 0));
+      if (forall_tmp->do_concurrent)
+	cond = build2 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
+		       build_int_cst (integer_type_node,
+				      annot_expr_ivdep_kind));
+
+      tmp = build1_v (GOTO_EXPR, exit_label);
+      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+			     cond, tmp, build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&block, tmp);
+
+      /* The main loop body.  */
+      gfc_add_expr_to_block (&block, body);
+
+      /* Increment the loop variable.  */
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var,
+			     step);
+      gfc_add_modify (&block, var, tmp);
+
+      /* Advance to the next mask element.  Only do this for the
+	 innermost loop.  */
+      if (n == 0 && mask_flag && forall_tmp->mask)
+	{
+	  tree maskindex = forall_tmp->maskindex;
+	  tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+				 maskindex, gfc_index_one_node);
+	  gfc_add_modify (&block, maskindex, tmp);
+	}
+
+      /* Decrement the loop counter.  */
+      tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), count,
+			     build_int_cst (TREE_TYPE (var), 1));
+      gfc_add_modify (&block, count, tmp);
+
+      body = gfc_finish_block (&block);
+
+      /* Loop var initialization.  */
+      gfc_init_block (&block);
+      gfc_add_modify (&block, var, start);
+
+
+      /* Initialize the loop counter.  */
+      tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), step,
+			     start);
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), end,
+			     tmp);
+      tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (var),
+			     tmp, step);
+      gfc_add_modify (&block, count, tmp);
+
+      /* The loop expression.  */
+      tmp = build1_v (LOOP_EXPR, body);
+      gfc_add_expr_to_block (&block, tmp);
+
+      /* The exit label.  */
+      tmp = build1_v (LABEL_EXPR, exit_label);
+      gfc_add_expr_to_block (&block, tmp);
+
+      body = gfc_finish_block (&block);
+      iter = iter->next;
+    }
+  return body;
+}
+
+
+/* Generate the body and loops according to MASK_FLAG.  If MASK_FLAG
+   is nonzero, the body is controlled by all masks in the forall nest.
+   Otherwise, the innermost loop is not controlled by it's mask.  This
+   is used for initializing that mask.  */
+
+static tree
+gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body,
+                              int mask_flag)
+{
+  tree tmp;
+  stmtblock_t header;
+  forall_info *forall_tmp;
+  tree mask, maskindex;
+
+  gfc_start_block (&header);
+
+  forall_tmp = nested_forall_info;
+  while (forall_tmp != NULL)
+    {
+      /* Generate body with masks' control.  */
+      if (mask_flag)
+        {
+          mask = forall_tmp->mask;
+          maskindex = forall_tmp->maskindex;
+
+          /* If a mask was specified make the assignment conditional.  */
+          if (mask)
+            {
+              tmp = gfc_build_array_ref (mask, maskindex, NULL);
+              body = build3_v (COND_EXPR, tmp, body,
+			       build_empty_stmt (input_location));
+            }
+        }
+      body = gfc_trans_forall_loop (forall_tmp, body, mask_flag, &header);
+      forall_tmp = forall_tmp->prev_nest;
+      mask_flag = 1;
+    }
+
+  gfc_add_expr_to_block (&header, body);
+  return gfc_finish_block (&header);
+}
+
+
+/* Allocate data for holding a temporary array.  Returns either a local
+   temporary array or a pointer variable.  */
+
+static tree
+gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock,
+                 tree elem_type)
+{
+  tree tmpvar;
+  tree type;
+  tree tmp;
+
+  if (INTEGER_CST_P (size))
+    tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			   size, gfc_index_one_node);
+  else
+    tmp = NULL_TREE;
+
+  type = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
+  type = build_array_type (elem_type, type);
+  if (gfc_can_put_var_on_stack (bytesize))
+    {
+      gcc_assert (INTEGER_CST_P (size));
+      tmpvar = gfc_create_var (type, "temp");
+      *pdata = NULL_TREE;
+    }
+  else
+    {
+      tmpvar = gfc_create_var (build_pointer_type (type), "temp");
+      *pdata = convert (pvoid_type_node, tmpvar);
+
+      tmp = gfc_call_malloc (pblock, TREE_TYPE (tmpvar), bytesize);
+      gfc_add_modify (pblock, tmpvar, tmp);
+    }
+  return tmpvar;
+}
+
+
+/* Generate codes to copy the temporary to the actual lhs.  */
+
+static tree
+generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
+			       tree count1, tree wheremask, bool invert)
+{
+  gfc_ss *lss;
+  gfc_se lse, rse;
+  stmtblock_t block, body;
+  gfc_loopinfo loop1;
+  tree tmp;
+  tree wheremaskexpr;
+
+  /* Walk the lhs.  */
+  lss = gfc_walk_expr (expr);
+
+  if (lss == gfc_ss_terminator)
+    {
+      gfc_start_block (&block);
+
+      gfc_init_se (&lse, NULL);
+
+      /* Translate the expression.  */
+      gfc_conv_expr (&lse, expr);
+
+      /* Form the expression for the temporary.  */
+      tmp = gfc_build_array_ref (tmp1, count1, NULL);
+
+      /* Use the scalar assignment as is.  */
+      gfc_add_block_to_block (&block, &lse.pre);
+      gfc_add_modify (&block, lse.expr, tmp);
+      gfc_add_block_to_block (&block, &lse.post);
+
+      /* Increment the count1.  */
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
+			     count1, gfc_index_one_node);
+      gfc_add_modify (&block, count1, tmp);
+
+      tmp = gfc_finish_block (&block);
+    }
+  else
+    {
+      gfc_start_block (&block);
+
+      gfc_init_loopinfo (&loop1);
+      gfc_init_se (&rse, NULL);
+      gfc_init_se (&lse, NULL);
+
+      /* Associate the lss with the loop.  */
+      gfc_add_ss_to_loop (&loop1, lss);
+
+      /* Calculate the bounds of the scalarization.  */
+      gfc_conv_ss_startstride (&loop1);
+      /* Setup the scalarizing loops.  */
+      gfc_conv_loop_setup (&loop1, &expr->where);
+
+      gfc_mark_ss_chain_used (lss, 1);
+
+      /* Start the scalarized loop body.  */
+      gfc_start_scalarized_body (&loop1, &body);
+
+      /* Setup the gfc_se structures.  */
+      gfc_copy_loopinfo_to_se (&lse, &loop1);
+      lse.ss = lss;
+
+      /* Form the expression of the temporary.  */
+      if (lss != gfc_ss_terminator)
+	rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
+      /* Translate expr.  */
+      gfc_conv_expr (&lse, expr);
+
+      /* Use the scalar assignment.  */
+      rse.string_length = lse.string_length;
+      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true, true);
+
+      /* Form the mask expression according to the mask tree list.  */
+      if (wheremask)
+	{
+	  wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
+	  if (invert)
+	    wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
+					     TREE_TYPE (wheremaskexpr),
+					     wheremaskexpr);
+	  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+				 wheremaskexpr, tmp,
+				 build_empty_stmt (input_location));
+       }
+
+      gfc_add_expr_to_block (&body, tmp);
+
+      /* Increment count1.  */
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			     count1, gfc_index_one_node);
+      gfc_add_modify (&body, count1, tmp);
+
+      /* Increment count3.  */
+      if (count3)
+	{
+	  tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type, count3,
+				 gfc_index_one_node);
+	  gfc_add_modify (&body, count3, tmp);
+	}
+
+      /* Generate the copying loops.  */
+      gfc_trans_scalarizing_loops (&loop1, &body);
+      gfc_add_block_to_block (&block, &loop1.pre);
+      gfc_add_block_to_block (&block, &loop1.post);
+      gfc_cleanup_loop (&loop1);
+
+      tmp = gfc_finish_block (&block);
+    }
+  return tmp;
+}
+
+
+/* Generate codes to copy rhs to the temporary. TMP1 is the address of
+   temporary, LSS and RSS are formed in function compute_inner_temp_size(),
+   and should not be freed.  WHEREMASK is the conditional execution mask
+   whose sense may be inverted by INVERT.  */
+
+static tree
+generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3,
+			       tree count1, gfc_ss *lss, gfc_ss *rss,
+			       tree wheremask, bool invert)
+{
+  stmtblock_t block, body1;
+  gfc_loopinfo loop;
+  gfc_se lse;
+  gfc_se rse;
+  tree tmp;
+  tree wheremaskexpr;
+
+  gfc_start_block (&block);
+
+  gfc_init_se (&rse, NULL);
+  gfc_init_se (&lse, NULL);
+
+  if (lss == gfc_ss_terminator)
+    {
+      gfc_init_block (&body1);
+      gfc_conv_expr (&rse, expr2);
+      lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
+    }
+  else
+    {
+      /* Initialize the loop.  */
+      gfc_init_loopinfo (&loop);
+
+      /* We may need LSS to determine the shape of the expression.  */
+      gfc_add_ss_to_loop (&loop, lss);
+      gfc_add_ss_to_loop (&loop, rss);
+
+      gfc_conv_ss_startstride (&loop);
+      gfc_conv_loop_setup (&loop, &expr2->where);
+
+      gfc_mark_ss_chain_used (rss, 1);
+      /* Start the loop body.  */
+      gfc_start_scalarized_body (&loop, &body1);
+
+      /* Translate the expression.  */
+      gfc_copy_loopinfo_to_se (&rse, &loop);
+      rse.ss = rss;
+      gfc_conv_expr (&rse, expr2);
+
+      /* Form the expression of the temporary.  */
+      lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
+    }
+
+  /* Use the scalar assignment.  */
+  lse.string_length = rse.string_length;
+  tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, true,
+				 expr2->expr_type == EXPR_VARIABLE, true);
+
+  /* Form the mask expression according to the mask tree list.  */
+  if (wheremask)
+    {
+      wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
+      if (invert)
+	wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
+					 TREE_TYPE (wheremaskexpr),
+					 wheremaskexpr);
+      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+			     wheremaskexpr, tmp,
+			     build_empty_stmt (input_location));
+    }
+
+  gfc_add_expr_to_block (&body1, tmp);
+
+  if (lss == gfc_ss_terminator)
+    {
+      gfc_add_block_to_block (&block, &body1);
+
+      /* Increment count1.  */
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
+			     count1, gfc_index_one_node);
+      gfc_add_modify (&block, count1, tmp);
+    }
+  else
+    {
+      /* Increment count1.  */
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			     count1, gfc_index_one_node);
+      gfc_add_modify (&body1, count1, tmp);
+
+      /* Increment count3.  */
+      if (count3)
+	{
+	  tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type,
+				 count3, gfc_index_one_node);
+	  gfc_add_modify (&body1, count3, tmp);
+	}
+
+      /* Generate the copying loops.  */
+      gfc_trans_scalarizing_loops (&loop, &body1);
+
+      gfc_add_block_to_block (&block, &loop.pre);
+      gfc_add_block_to_block (&block, &loop.post);
+
+      gfc_cleanup_loop (&loop);
+      /* TODO: Reuse lss and rss when copying temp->lhs.  Need to be careful
+	 as tree nodes in SS may not be valid in different scope.  */
+    }
+
+  tmp = gfc_finish_block (&block);
+  return tmp;
+}
+
+
+/* Calculate the size of temporary needed in the assignment inside forall.
+   LSS and RSS are filled in this function.  */
+
+static tree
+compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2,
+			 stmtblock_t * pblock,
+                         gfc_ss **lss, gfc_ss **rss)
+{
+  gfc_loopinfo loop;
+  tree size;
+  int i;
+  int save_flag;
+  tree tmp;
+
+  *lss = gfc_walk_expr (expr1);
+  *rss = NULL;
+
+  size = gfc_index_one_node;
+  if (*lss != gfc_ss_terminator)
+    {
+      gfc_init_loopinfo (&loop);
+
+      /* Walk the RHS of the expression.  */
+      *rss = gfc_walk_expr (expr2);
+      if (*rss == gfc_ss_terminator)
+	/* The rhs is scalar.  Add a ss for the expression.  */
+	*rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
+
+      /* Associate the SS with the loop.  */
+      gfc_add_ss_to_loop (&loop, *lss);
+      /* We don't actually need to add the rhs at this point, but it might
+         make guessing the loop bounds a bit easier.  */
+      gfc_add_ss_to_loop (&loop, *rss);
+
+      /* We only want the shape of the expression, not rest of the junk
+         generated by the scalarizer.  */
+      loop.array_parameter = 1;
+
+      /* Calculate the bounds of the scalarization.  */
+      save_flag = gfc_option.rtcheck;
+      gfc_option.rtcheck &= ~GFC_RTCHECK_BOUNDS;
+      gfc_conv_ss_startstride (&loop);
+      gfc_option.rtcheck = save_flag;
+      gfc_conv_loop_setup (&loop, &expr2->where);
+
+      /* Figure out how many elements we need.  */
+      for (i = 0; i < loop.dimen; i++)
+        {
+	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				 gfc_array_index_type,
+				 gfc_index_one_node, loop.from[i]);
+          tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type, tmp, loop.to[i]);
+          size = fold_build2_loc (input_location, MULT_EXPR,
+				  gfc_array_index_type, size, tmp);
+        }
+      gfc_add_block_to_block (pblock, &loop.pre);
+      size = gfc_evaluate_now (size, pblock);
+      gfc_add_block_to_block (pblock, &loop.post);
+
+      /* TODO: write a function that cleans up a loopinfo without freeing
+         the SS chains.  Currently a NOP.  */
+    }
+
+  return size;
+}
+
+
+/* Calculate the overall iterator number of the nested forall construct.
+   This routine actually calculates the number of times the body of the
+   nested forall specified by NESTED_FORALL_INFO is executed and multiplies
+   that by the expression INNER_SIZE.  The BLOCK argument specifies the
+   block in which to calculate the result, and the optional INNER_SIZE_BODY
+   argument contains any statements that need to executed (inside the loop)
+   to initialize or calculate INNER_SIZE.  */
+
+static tree
+compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size,
+			     stmtblock_t *inner_size_body, stmtblock_t *block)
+{
+  forall_info *forall_tmp = nested_forall_info;
+  tree tmp, number;
+  stmtblock_t body;
+
+  /* We can eliminate the innermost unconditional loops with constant
+     array bounds.  */
+  if (INTEGER_CST_P (inner_size))
+    {
+      while (forall_tmp
+	     && !forall_tmp->mask
+	     && INTEGER_CST_P (forall_tmp->size))
+	{
+	  inner_size = fold_build2_loc (input_location, MULT_EXPR,
+					gfc_array_index_type,
+					inner_size, forall_tmp->size);
+	  forall_tmp = forall_tmp->prev_nest;
+	}
+
+      /* If there are no loops left, we have our constant result.  */
+      if (!forall_tmp)
+	return inner_size;
+    }
+
+  /* Otherwise, create a temporary variable to compute the result.  */
+  number = gfc_create_var (gfc_array_index_type, "num");
+  gfc_add_modify (block, number, gfc_index_zero_node);
+
+  gfc_start_block (&body);
+  if (inner_size_body)
+    gfc_add_block_to_block (&body, inner_size_body);
+  if (forall_tmp)
+    tmp = fold_build2_loc (input_location, PLUS_EXPR,
+			   gfc_array_index_type, number, inner_size);
+  else
+    tmp = inner_size;
+  gfc_add_modify (&body, number, tmp);
+  tmp = gfc_finish_block (&body);
+
+  /* Generate loops.  */
+  if (forall_tmp != NULL)
+    tmp = gfc_trans_nested_forall_loop (forall_tmp, tmp, 1);
+
+  gfc_add_expr_to_block (block, tmp);
+
+  return number;
+}
+
+
+/* Allocate temporary for forall construct.  SIZE is the size of temporary
+   needed.  PTEMP1 is returned for space free.  */
+
+static tree
+allocate_temp_for_forall_nest_1 (tree type, tree size, stmtblock_t * block,
+				 tree * ptemp1)
+{
+  tree bytesize;
+  tree unit;
+  tree tmp;
+
+  unit = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (type));
+  if (!integer_onep (unit))
+    bytesize = fold_build2_loc (input_location, MULT_EXPR,
+				gfc_array_index_type, size, unit);
+  else
+    bytesize = size;
+
+  *ptemp1 = NULL;
+  tmp = gfc_do_allocate (bytesize, size, ptemp1, block, type);
+
+  if (*ptemp1)
+    tmp = build_fold_indirect_ref_loc (input_location, tmp);
+  return tmp;
+}
+
+
+/* Allocate temporary for forall construct according to the information in
+   nested_forall_info.  INNER_SIZE is the size of temporary needed in the
+   assignment inside forall.  PTEMP1 is returned for space free.  */
+
+static tree
+allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type,
+			       tree inner_size, stmtblock_t * inner_size_body,
+			       stmtblock_t * block, tree * ptemp1)
+{
+  tree size;
+
+  /* Calculate the total size of temporary needed in forall construct.  */
+  size = compute_overall_iter_number (nested_forall_info, inner_size,
+				      inner_size_body, block);
+
+  return allocate_temp_for_forall_nest_1 (type, size, block, ptemp1);
+}
+
+
+/* Handle assignments inside forall which need temporary.
+
+    forall (i=start:end:stride; maskexpr)
+      e<i> = f<i>
+    end forall
+   (where e,f<i> are arbitrary expressions possibly involving i
+    and there is a dependency between e<i> and f<i>)
+   Translates to:
+    masktmp(:) = maskexpr(:)
+
+    maskindex = 0;
+    count1 = 0;
+    num = 0;
+    for (i = start; i <= end; i += stride)
+      num += SIZE (f<i>)
+    count1 = 0;
+    ALLOCATE (tmp(num))
+    for (i = start; i <= end; i += stride)
+      {
+	if (masktmp[maskindex++])
+	  tmp[count1++] = f<i>
+      }
+    maskindex = 0;
+    count1 = 0;
+    for (i = start; i <= end; i += stride)
+      {
+	if (masktmp[maskindex++])
+	  e<i> = tmp[count1++]
+      }
+    DEALLOCATE (tmp)
+  */
+static void
+gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
+			    tree wheremask, bool invert,
+                            forall_info * nested_forall_info,
+                            stmtblock_t * block)
+{
+  tree type;
+  tree inner_size;
+  gfc_ss *lss, *rss;
+  tree count, count1;
+  tree tmp, tmp1;
+  tree ptemp1;
+  stmtblock_t inner_size_body;
+
+  /* Create vars. count1 is the current iterator number of the nested
+     forall.  */
+  count1 = gfc_create_var (gfc_array_index_type, "count1");
+
+  /* Count is the wheremask index.  */
+  if (wheremask)
+    {
+      count = gfc_create_var (gfc_array_index_type, "count");
+      gfc_add_modify (block, count, gfc_index_zero_node);
+    }
+  else
+    count = NULL;
+
+  /* Initialize count1.  */
+  gfc_add_modify (block, count1, gfc_index_zero_node);
+
+  /* Calculate the size of temporary needed in the assignment. Return loop, lss
+     and rss which are used in function generate_loop_for_rhs_to_temp().  */
+  gfc_init_block (&inner_size_body);
+  inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
+					&lss, &rss);
+
+  /* The type of LHS. Used in function allocate_temp_for_forall_nest */
+  if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->length)
+    {
+      if (!expr1->ts.u.cl->backend_decl)
+	{
+	  gfc_se tse;
+	  gfc_init_se (&tse, NULL);
+	  gfc_conv_expr (&tse, expr1->ts.u.cl->length);
+	  expr1->ts.u.cl->backend_decl = tse.expr;
+	}
+      type = gfc_get_character_type_len (gfc_default_character_kind,
+				         expr1->ts.u.cl->backend_decl);
+    }
+  else
+    type = gfc_typenode_for_spec (&expr1->ts);
+
+  /* Allocate temporary for nested forall construct according to the
+     information in nested_forall_info and inner_size.  */
+  tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size,
+					&inner_size_body, block, &ptemp1);
+
+  /* Generate codes to copy rhs to the temporary .  */
+  tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, count, count1, lss, rss,
+				       wheremask, invert);
+
+  /* Generate body and loops according to the information in
+     nested_forall_info.  */
+  tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
+  gfc_add_expr_to_block (block, tmp);
+
+  /* Reset count1.  */
+  gfc_add_modify (block, count1, gfc_index_zero_node);
+
+  /* Reset count.  */
+  if (wheremask)
+    gfc_add_modify (block, count, gfc_index_zero_node);
+
+  /* Generate codes to copy the temporary to lhs.  */
+  tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1,
+				       wheremask, invert);
+
+  /* Generate body and loops according to the information in
+     nested_forall_info.  */
+  tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
+  gfc_add_expr_to_block (block, tmp);
+
+  if (ptemp1)
+    {
+      /* Free the temporary.  */
+      tmp = gfc_call_free (ptemp1);
+      gfc_add_expr_to_block (block, tmp);
+    }
+}
+
+
+/* Translate pointer assignment inside FORALL which need temporary.  */
+
+static void
+gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
+                                    forall_info * nested_forall_info,
+                                    stmtblock_t * block)
+{
+  tree type;
+  tree inner_size;
+  gfc_ss *lss, *rss;
+  gfc_se lse;
+  gfc_se rse;
+  gfc_array_info *info;
+  gfc_loopinfo loop;
+  tree desc;
+  tree parm;
+  tree parmtype;
+  stmtblock_t body;
+  tree count;
+  tree tmp, tmp1, ptemp1;
+
+  count = gfc_create_var (gfc_array_index_type, "count");
+  gfc_add_modify (block, count, gfc_index_zero_node);
+
+  inner_size = gfc_index_one_node;
+  lss = gfc_walk_expr (expr1);
+  rss = gfc_walk_expr (expr2);
+  if (lss == gfc_ss_terminator)
+    {
+      type = gfc_typenode_for_spec (&expr1->ts);
+      type = build_pointer_type (type);
+
+      /* Allocate temporary for nested forall construct according to the
+         information in nested_forall_info and inner_size.  */
+      tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type,
+					    inner_size, NULL, block, &ptemp1);
+      gfc_start_block (&body);
+      gfc_init_se (&lse, NULL);
+      lse.expr = gfc_build_array_ref (tmp1, count, NULL);
+      gfc_init_se (&rse, NULL);
+      rse.want_pointer = 1;
+      gfc_conv_expr (&rse, expr2);
+      gfc_add_block_to_block (&body, &rse.pre);
+      gfc_add_modify (&body, lse.expr,
+			   fold_convert (TREE_TYPE (lse.expr), rse.expr));
+      gfc_add_block_to_block (&body, &rse.post);
+
+      /* Increment count.  */
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			     count, gfc_index_one_node);
+      gfc_add_modify (&body, count, tmp);
+
+      tmp = gfc_finish_block (&body);
+
+      /* Generate body and loops according to the information in
+         nested_forall_info.  */
+      tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
+      gfc_add_expr_to_block (block, tmp);
+
+      /* Reset count.  */
+      gfc_add_modify (block, count, gfc_index_zero_node);
+
+      gfc_start_block (&body);
+      gfc_init_se (&lse, NULL);
+      gfc_init_se (&rse, NULL);
+      rse.expr = gfc_build_array_ref (tmp1, count, NULL);
+      lse.want_pointer = 1;
+      gfc_conv_expr (&lse, expr1);
+      gfc_add_block_to_block (&body, &lse.pre);
+      gfc_add_modify (&body, lse.expr, rse.expr);
+      gfc_add_block_to_block (&body, &lse.post);
+      /* Increment count.  */
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			     count, gfc_index_one_node);
+      gfc_add_modify (&body, count, tmp);
+      tmp = gfc_finish_block (&body);
+
+      /* Generate body and loops according to the information in
+         nested_forall_info.  */
+      tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
+      gfc_add_expr_to_block (block, tmp);
+    }
+  else
+    {
+      gfc_init_loopinfo (&loop);
+
+      /* Associate the SS with the loop.  */
+      gfc_add_ss_to_loop (&loop, rss);
+
+      /* Setup the scalarizing loops and bounds.  */
+      gfc_conv_ss_startstride (&loop);
+
+      gfc_conv_loop_setup (&loop, &expr2->where);
+
+      info = &rss->info->data.array;
+      desc = info->descriptor;
+
+      /* Make a new descriptor.  */
+      parmtype = gfc_get_element_type (TREE_TYPE (desc));
+      parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
+                                            loop.from, loop.to, 1,
+					    GFC_ARRAY_UNKNOWN, true);
+
+      /* Allocate temporary for nested forall construct.  */
+      tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype,
+					    inner_size, NULL, block, &ptemp1);
+      gfc_start_block (&body);
+      gfc_init_se (&lse, NULL);
+      lse.expr = gfc_build_array_ref (tmp1, count, NULL);
+      lse.direct_byref = 1;
+      gfc_conv_expr_descriptor (&lse, expr2);
+
+      gfc_add_block_to_block (&body, &lse.pre);
+      gfc_add_block_to_block (&body, &lse.post);
+
+      /* Increment count.  */
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			     count, gfc_index_one_node);
+      gfc_add_modify (&body, count, tmp);
+
+      tmp = gfc_finish_block (&body);
+
+      /* Generate body and loops according to the information in
+         nested_forall_info.  */
+      tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
+      gfc_add_expr_to_block (block, tmp);
+
+      /* Reset count.  */
+      gfc_add_modify (block, count, gfc_index_zero_node);
+
+      parm = gfc_build_array_ref (tmp1, count, NULL);
+      gfc_init_se (&lse, NULL);
+      gfc_conv_expr_descriptor (&lse, expr1);
+      gfc_add_modify (&lse.pre, lse.expr, parm);
+      gfc_start_block (&body);
+      gfc_add_block_to_block (&body, &lse.pre);
+      gfc_add_block_to_block (&body, &lse.post);
+
+      /* Increment count.  */
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			     count, gfc_index_one_node);
+      gfc_add_modify (&body, count, tmp);
+
+      tmp = gfc_finish_block (&body);
+
+      tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
+      gfc_add_expr_to_block (block, tmp);
+    }
+  /* Free the temporary.  */
+  if (ptemp1)
+    {
+      tmp = gfc_call_free (ptemp1);
+      gfc_add_expr_to_block (block, tmp);
+    }
+}
+
+
+/* FORALL and WHERE statements are really nasty, especially when you nest
+   them. All the rhs of a forall assignment must be evaluated before the
+   actual assignments are performed. Presumably this also applies to all the
+   assignments in an inner where statement.  */
+
+/* Generate code for a FORALL statement.  Any temporaries are allocated as a
+   linear array, relying on the fact that we process in the same order in all
+   loops.
+
+    forall (i=start:end:stride; maskexpr)
+      e<i> = f<i>
+      g<i> = h<i>
+    end forall
+   (where e,f,g,h<i> are arbitrary expressions possibly involving i)
+   Translates to:
+    count = ((end + 1 - start) / stride)
+    masktmp(:) = maskexpr(:)
+
+    maskindex = 0;
+    for (i = start; i <= end; i += stride)
+      {
+        if (masktmp[maskindex++])
+          e<i> = f<i>
+      }
+    maskindex = 0;
+    for (i = start; i <= end; i += stride)
+      {
+        if (masktmp[maskindex++])
+          g<i> = h<i>
+      }
+
+    Note that this code only works when there are no dependencies.
+    Forall loop with array assignments and data dependencies are a real pain,
+    because the size of the temporary cannot always be determined before the
+    loop is executed.  This problem is compounded by the presence of nested
+    FORALL constructs.
+ */
+
+static tree
+gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
+{
+  stmtblock_t pre;
+  stmtblock_t post;
+  stmtblock_t block;
+  stmtblock_t body;
+  tree *var;
+  tree *start;
+  tree *end;
+  tree *step;
+  gfc_expr **varexpr;
+  tree tmp;
+  tree assign;
+  tree size;
+  tree maskindex;
+  tree mask;
+  tree pmask;
+  tree cycle_label = NULL_TREE;
+  int n;
+  int nvar;
+  int need_temp;
+  gfc_forall_iterator *fa;
+  gfc_se se;
+  gfc_code *c;
+  gfc_saved_var *saved_vars;
+  iter_info *this_forall;
+  forall_info *info;
+  bool need_mask;
+
+  /* Do nothing if the mask is false.  */
+  if (code->expr1
+      && code->expr1->expr_type == EXPR_CONSTANT
+      && !code->expr1->value.logical)
+    return build_empty_stmt (input_location);
+
+  n = 0;
+  /* Count the FORALL index number.  */
+  for (fa = code->ext.forall_iterator; fa; fa = fa->next)
+    n++;
+  nvar = n;
+
+  /* Allocate the space for var, start, end, step, varexpr.  */
+  var = XCNEWVEC (tree, nvar);
+  start = XCNEWVEC (tree, nvar);
+  end = XCNEWVEC (tree, nvar);
+  step = XCNEWVEC (tree, nvar);
+  varexpr = XCNEWVEC (gfc_expr *, nvar);
+  saved_vars = XCNEWVEC (gfc_saved_var, nvar);
+
+  /* Allocate the space for info.  */
+  info = XCNEW (forall_info);
+
+  gfc_start_block (&pre);
+  gfc_init_block (&post);
+  gfc_init_block (&block);
+
+  n = 0;
+  for (fa = code->ext.forall_iterator; fa; fa = fa->next)
+    {
+      gfc_symbol *sym = fa->var->symtree->n.sym;
+
+      /* Allocate space for this_forall.  */
+      this_forall = XCNEW (iter_info);
+
+      /* Create a temporary variable for the FORALL index.  */
+      tmp = gfc_typenode_for_spec (&sym->ts);
+      var[n] = gfc_create_var (tmp, sym->name);
+      gfc_shadow_sym (sym, var[n], &saved_vars[n]);
+
+      /* Record it in this_forall.  */
+      this_forall->var = var[n];
+
+      /* Replace the index symbol's backend_decl with the temporary decl.  */
+      sym->backend_decl = var[n];
+
+      /* Work out the start, end and stride for the loop.  */
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr_val (&se, fa->start);
+      /* Record it in this_forall.  */
+      this_forall->start = se.expr;
+      gfc_add_block_to_block (&block, &se.pre);
+      start[n] = se.expr;
+
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr_val (&se, fa->end);
+      /* Record it in this_forall.  */
+      this_forall->end = se.expr;
+      gfc_make_safe_expr (&se);
+      gfc_add_block_to_block (&block, &se.pre);
+      end[n] = se.expr;
+
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr_val (&se, fa->stride);
+      /* Record it in this_forall.  */
+      this_forall->step = se.expr;
+      gfc_make_safe_expr (&se);
+      gfc_add_block_to_block (&block, &se.pre);
+      step[n] = se.expr;
+
+      /* Set the NEXT field of this_forall to NULL.  */
+      this_forall->next = NULL;
+      /* Link this_forall to the info construct.  */
+      if (info->this_loop)
+        {
+          iter_info *iter_tmp = info->this_loop;
+          while (iter_tmp->next != NULL)
+            iter_tmp = iter_tmp->next;
+          iter_tmp->next = this_forall;
+        }
+      else
+        info->this_loop = this_forall;
+
+      n++;
+    }
+  nvar = n;
+
+  /* Calculate the size needed for the current forall level.  */
+  size = gfc_index_one_node;
+  for (n = 0; n < nvar; n++)
+    {
+      /* size = (end + step - start) / step.  */
+      tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (start[n]),
+			     step[n], start[n]);
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (end[n]),
+			     end[n], tmp);
+      tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, TREE_TYPE (tmp),
+			     tmp, step[n]);
+      tmp = convert (gfc_array_index_type, tmp);
+
+      size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			      size, tmp);
+    }
+
+  /* Record the nvar and size of current forall level.  */
+  info->nvar = nvar;
+  info->size = size;
+
+  if (code->expr1)
+    {
+      /* If the mask is .true., consider the FORALL unconditional.  */
+      if (code->expr1->expr_type == EXPR_CONSTANT
+	  && code->expr1->value.logical)
+	need_mask = false;
+      else
+	need_mask = true;
+    }
+  else
+    need_mask = false;
+
+  /* First we need to allocate the mask.  */
+  if (need_mask)
+    {
+      /* As the mask array can be very big, prefer compact boolean types.  */
+      tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
+      mask = allocate_temp_for_forall_nest (nested_forall_info, mask_type,
+					    size, NULL, &block, &pmask);
+      maskindex = gfc_create_var_np (gfc_array_index_type, "mi");
+
+      /* Record them in the info structure.  */
+      info->maskindex = maskindex;
+      info->mask = mask;
+    }
+  else
+    {
+      /* No mask was specified.  */
+      maskindex = NULL_TREE;
+      mask = pmask = NULL_TREE;
+    }
+
+  /* Link the current forall level to nested_forall_info.  */
+  info->prev_nest = nested_forall_info;
+  nested_forall_info = info;
+
+  /* Copy the mask into a temporary variable if required.
+     For now we assume a mask temporary is needed.  */
+  if (need_mask)
+    {
+      /* As the mask array can be very big, prefer compact boolean types.  */
+      tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
+
+      gfc_add_modify (&block, maskindex, gfc_index_zero_node);
+
+      /* Start of mask assignment loop body.  */
+      gfc_start_block (&body);
+
+      /* Evaluate the mask expression.  */
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr_val (&se, code->expr1);
+      gfc_add_block_to_block (&body, &se.pre);
+
+      /* Store the mask.  */
+      se.expr = convert (mask_type, se.expr);
+
+      tmp = gfc_build_array_ref (mask, maskindex, NULL);
+      gfc_add_modify (&body, tmp, se.expr);
+
+      /* Advance to the next mask element.  */
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			     maskindex, gfc_index_one_node);
+      gfc_add_modify (&body, maskindex, tmp);
+
+      /* Generate the loops.  */
+      tmp = gfc_finish_block (&body);
+      tmp = gfc_trans_nested_forall_loop (info, tmp, 0);
+      gfc_add_expr_to_block (&block, tmp);
+    }
+
+  if (code->op == EXEC_DO_CONCURRENT)
+    {
+      gfc_init_block (&body);
+      cycle_label = gfc_build_label_decl (NULL_TREE);
+      code->cycle_label = cycle_label;
+      tmp = gfc_trans_code (code->block->next);
+      gfc_add_expr_to_block (&body, tmp);
+
+      if (TREE_USED (cycle_label))
+	{
+	  tmp = build1_v (LABEL_EXPR, cycle_label);
+	  gfc_add_expr_to_block (&body, tmp);
+	}
+
+      tmp = gfc_finish_block (&body);
+      nested_forall_info->do_concurrent = true;
+      tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
+      gfc_add_expr_to_block (&block, tmp);
+      goto done;
+    }
+
+  c = code->block->next;
+
+  /* TODO: loop merging in FORALL statements.  */
+  /* Now that we've got a copy of the mask, generate the assignment loops.  */
+  while (c)
+    {
+      switch (c->op)
+	{
+	case EXEC_ASSIGN:
+          /* A scalar or array assignment.  DO the simple check for
+	     lhs to rhs dependencies.  These make a temporary for the
+	     rhs and form a second forall block to copy to variable.  */
+	  need_temp = check_forall_dependencies(c, &pre, &post);
+
+          /* Temporaries due to array assignment data dependencies introduce
+             no end of problems.  */
+	  if (need_temp)
+            gfc_trans_assign_need_temp (c->expr1, c->expr2, NULL, false,
+                                        nested_forall_info, &block);
+          else
+            {
+              /* Use the normal assignment copying routines.  */
+              assign = gfc_trans_assignment (c->expr1, c->expr2, false, true);
+
+              /* Generate body and loops.  */
+              tmp = gfc_trans_nested_forall_loop (nested_forall_info,
+						  assign, 1);
+              gfc_add_expr_to_block (&block, tmp);
+            }
+
+	  /* Cleanup any temporary symtrees that have been made to deal
+	     with dependencies.  */
+	  if (new_symtree)
+	    cleanup_forall_symtrees (c);
+
+	  break;
+
+        case EXEC_WHERE:
+	  /* Translate WHERE or WHERE construct nested in FORALL.  */
+	  gfc_trans_where_2 (c, NULL, false, nested_forall_info, &block);
+	  break;
+
+        /* Pointer assignment inside FORALL.  */
+	case EXEC_POINTER_ASSIGN:
+          need_temp = gfc_check_dependency (c->expr1, c->expr2, 0);
+          if (need_temp)
+            gfc_trans_pointer_assign_need_temp (c->expr1, c->expr2,
+                                                nested_forall_info, &block);
+          else
+            {
+              /* Use the normal assignment copying routines.  */
+              assign = gfc_trans_pointer_assignment (c->expr1, c->expr2);
+
+              /* Generate body and loops.  */
+              tmp = gfc_trans_nested_forall_loop (nested_forall_info,
+						  assign, 1);
+              gfc_add_expr_to_block (&block, tmp);
+            }
+          break;
+
+	case EXEC_FORALL:
+	  tmp = gfc_trans_forall_1 (c, nested_forall_info);
+          gfc_add_expr_to_block (&block, tmp);
+          break;
+
+	/* Explicit subroutine calls are prevented by the frontend but interface
+	   assignments can legitimately produce them.  */
+	case EXEC_ASSIGN_CALL:
+	  assign = gfc_trans_call (c, true, NULL_TREE, NULL_TREE, false);
+          tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1);
+          gfc_add_expr_to_block (&block, tmp);
+          break;
+
+	default:
+	  gcc_unreachable ();
+	}
+
+      c = c->next;
+    }
+
+done:
+  /* Restore the original index variables.  */
+  for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++)
+    gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
+
+  /* Free the space for var, start, end, step, varexpr.  */
+  free (var);
+  free (start);
+  free (end);
+  free (step);
+  free (varexpr);
+  free (saved_vars);
+
+  for (this_forall = info->this_loop; this_forall;)
+    {
+      iter_info *next = this_forall->next;
+      free (this_forall);
+      this_forall = next;
+    }
+
+  /* Free the space for this forall_info.  */
+  free (info);
+
+  if (pmask)
+    {
+      /* Free the temporary for the mask.  */
+      tmp = gfc_call_free (pmask);
+      gfc_add_expr_to_block (&block, tmp);
+    }
+  if (maskindex)
+    pushdecl (maskindex);
+
+  gfc_add_block_to_block (&pre, &block);
+  gfc_add_block_to_block (&pre, &post);
+
+  return gfc_finish_block (&pre);
+}
+
+
+/* Translate the FORALL statement or construct.  */
+
+tree gfc_trans_forall (gfc_code * code)
+{
+  return gfc_trans_forall_1 (code, NULL);
+}
+
+
+/* Translate the DO CONCURRENT construct.  */
+
+tree gfc_trans_do_concurrent (gfc_code * code)
+{
+  return gfc_trans_forall_1 (code, NULL);
+}
+
+
+/* Evaluate the WHERE mask expression, copy its value to a temporary.
+   If the WHERE construct is nested in FORALL, compute the overall temporary
+   needed by the WHERE mask expression multiplied by the iterator number of
+   the nested forall.
+   ME is the WHERE mask expression.
+   MASK is the current execution mask upon input, whose sense may or may
+   not be inverted as specified by the INVERT argument.
+   CMASK is the updated execution mask on output, or NULL if not required.
+   PMASK is the pending execution mask on output, or NULL if not required.
+   BLOCK is the block in which to place the condition evaluation loops.  */
+
+static void
+gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
+                         tree mask, bool invert, tree cmask, tree pmask,
+                         tree mask_type, stmtblock_t * block)
+{
+  tree tmp, tmp1;
+  gfc_ss *lss, *rss;
+  gfc_loopinfo loop;
+  stmtblock_t body, body1;
+  tree count, cond, mtmp;
+  gfc_se lse, rse;
+
+  gfc_init_loopinfo (&loop);
+
+  lss = gfc_walk_expr (me);
+  rss = gfc_walk_expr (me);
+
+  /* Variable to index the temporary.  */
+  count = gfc_create_var (gfc_array_index_type, "count");
+  /* Initialize count.  */
+  gfc_add_modify (block, count, gfc_index_zero_node);
+
+  gfc_start_block (&body);
+
+  gfc_init_se (&rse, NULL);
+  gfc_init_se (&lse, NULL);
+
+  if (lss == gfc_ss_terminator)
+    {
+      gfc_init_block (&body1);
+    }
+  else
+    {
+      /* Initialize the loop.  */
+      gfc_init_loopinfo (&loop);
+
+      /* We may need LSS to determine the shape of the expression.  */
+      gfc_add_ss_to_loop (&loop, lss);
+      gfc_add_ss_to_loop (&loop, rss);
+
+      gfc_conv_ss_startstride (&loop);
+      gfc_conv_loop_setup (&loop, &me->where);
+
+      gfc_mark_ss_chain_used (rss, 1);
+      /* Start the loop body.  */
+      gfc_start_scalarized_body (&loop, &body1);
+
+      /* Translate the expression.  */
+      gfc_copy_loopinfo_to_se (&rse, &loop);
+      rse.ss = rss;
+      gfc_conv_expr (&rse, me);
+    }
+
+  /* Variable to evaluate mask condition.  */
+  cond = gfc_create_var (mask_type, "cond");
+  if (mask && (cmask || pmask))
+    mtmp = gfc_create_var (mask_type, "mask");
+  else mtmp = NULL_TREE;
+
+  gfc_add_block_to_block (&body1, &lse.pre);
+  gfc_add_block_to_block (&body1, &rse.pre);
+
+  gfc_add_modify (&body1, cond, fold_convert (mask_type, rse.expr));
+
+  if (mask && (cmask || pmask))
+    {
+      tmp = gfc_build_array_ref (mask, count, NULL);
+      if (invert)
+	tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, tmp);
+      gfc_add_modify (&body1, mtmp, tmp);
+    }
+
+  if (cmask)
+    {
+      tmp1 = gfc_build_array_ref (cmask, count, NULL);
+      tmp = cond;
+      if (mask)
+	tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type,
+			       mtmp, tmp);
+      gfc_add_modify (&body1, tmp1, tmp);
+    }
+
+  if (pmask)
+    {
+      tmp1 = gfc_build_array_ref (pmask, count, NULL);
+      tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, cond);
+      if (mask)
+	tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type, mtmp,
+			       tmp);
+      gfc_add_modify (&body1, tmp1, tmp);
+    }
+
+  gfc_add_block_to_block (&body1, &lse.post);
+  gfc_add_block_to_block (&body1, &rse.post);
+
+  if (lss == gfc_ss_terminator)
+    {
+      gfc_add_block_to_block (&body, &body1);
+    }
+  else
+    {
+      /* Increment count.  */
+      tmp1 = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			      count, gfc_index_one_node);
+      gfc_add_modify (&body1, count, tmp1);
+
+      /* Generate the copying loops.  */
+      gfc_trans_scalarizing_loops (&loop, &body1);
+
+      gfc_add_block_to_block (&body, &loop.pre);
+      gfc_add_block_to_block (&body, &loop.post);
+
+      gfc_cleanup_loop (&loop);
+      /* TODO: Reuse lss and rss when copying temp->lhs.  Need to be careful
+         as tree nodes in SS may not be valid in different scope.  */
+    }
+
+  tmp1 = gfc_finish_block (&body);
+  /* If the WHERE construct is inside FORALL, fill the full temporary.  */
+  if (nested_forall_info != NULL)
+    tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1);
+
+  gfc_add_expr_to_block (block, tmp1);
+}
+
+
+/* Translate an assignment statement in a WHERE statement or construct
+   statement. The MASK expression is used to control which elements
+   of EXPR1 shall be assigned.  The sense of MASK is specified by
+   INVERT.  */
+
+static tree
+gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
+			tree mask, bool invert,
+                        tree count1, tree count2,
+			gfc_code *cnext)
+{
+  gfc_se lse;
+  gfc_se rse;
+  gfc_ss *lss;
+  gfc_ss *lss_section;
+  gfc_ss *rss;
+
+  gfc_loopinfo loop;
+  tree tmp;
+  stmtblock_t block;
+  stmtblock_t body;
+  tree index, maskexpr;
+
+  /* A defined assignment. */
+  if (cnext && cnext->resolved_sym)
+    return gfc_trans_call (cnext, true, mask, count1, invert);
+
+#if 0
+  /* TODO: handle this special case.
+     Special case a single function returning an array.  */
+  if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
+    {
+      tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
+      if (tmp)
+        return tmp;
+    }
+#endif
+
+ /* Assignment of the form lhs = rhs.  */
+  gfc_start_block (&block);
+
+  gfc_init_se (&lse, NULL);
+  gfc_init_se (&rse, NULL);
+
+  /* Walk the lhs.  */
+  lss = gfc_walk_expr (expr1);
+  rss = NULL;
+
+  /* In each where-assign-stmt, the mask-expr and the variable being
+     defined shall be arrays of the same shape.  */
+  gcc_assert (lss != gfc_ss_terminator);
+
+  /* The assignment needs scalarization.  */
+  lss_section = lss;
+
+  /* Find a non-scalar SS from the lhs.  */
+  while (lss_section != gfc_ss_terminator
+	 && lss_section->info->type != GFC_SS_SECTION)
+    lss_section = lss_section->next;
+
+  gcc_assert (lss_section != gfc_ss_terminator);
+
+  /* Initialize the scalarizer.  */
+  gfc_init_loopinfo (&loop);
+
+  /* Walk the rhs.  */
+  rss = gfc_walk_expr (expr2);
+  if (rss == gfc_ss_terminator)
+    {
+      /* The rhs is scalar.  Add a ss for the expression.  */
+      rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
+      rss->info->where = 1;
+    }
+
+  /* Associate the SS with the loop.  */
+  gfc_add_ss_to_loop (&loop, lss);
+  gfc_add_ss_to_loop (&loop, rss);
+
+  /* Calculate the bounds of the scalarization.  */
+  gfc_conv_ss_startstride (&loop);
+
+  /* Resolve any data dependencies in the statement.  */
+  gfc_conv_resolve_dependencies (&loop, lss_section, rss);
+
+  /* Setup the scalarizing loops.  */
+  gfc_conv_loop_setup (&loop, &expr2->where);
+
+  /* Setup the gfc_se structures.  */
+  gfc_copy_loopinfo_to_se (&lse, &loop);
+  gfc_copy_loopinfo_to_se (&rse, &loop);
+
+  rse.ss = rss;
+  gfc_mark_ss_chain_used (rss, 1);
+  if (loop.temp_ss == NULL)
+    {
+      lse.ss = lss;
+      gfc_mark_ss_chain_used (lss, 1);
+    }
+  else
+    {
+      lse.ss = loop.temp_ss;
+      gfc_mark_ss_chain_used (lss, 3);
+      gfc_mark_ss_chain_used (loop.temp_ss, 3);
+    }
+
+  /* Start the scalarized loop body.  */
+  gfc_start_scalarized_body (&loop, &body);
+
+  /* Translate the expression.  */
+  gfc_conv_expr (&rse, expr2);
+  if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
+    gfc_conv_tmp_array_ref (&lse);
+  else
+    gfc_conv_expr (&lse, expr1);
+
+  /* Form the mask expression according to the mask.  */
+  index = count1;
+  maskexpr = gfc_build_array_ref (mask, index, NULL);
+  if (invert)
+    maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
+				TREE_TYPE (maskexpr), maskexpr);
+
+  /* Use the scalar assignment as is.  */
+  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
+				 loop.temp_ss != NULL, false, true);
+
+  tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt (input_location));
+
+  gfc_add_expr_to_block (&body, tmp);
+
+  if (lss == gfc_ss_terminator)
+    {
+      /* Increment count1.  */
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			     count1, gfc_index_one_node);
+      gfc_add_modify (&body, count1, tmp);
+
+      /* Use the scalar assignment as is.  */
+      gfc_add_block_to_block (&block, &body);
+    }
+  else
+    {
+      gcc_assert (lse.ss == gfc_ss_terminator
+		  && rse.ss == gfc_ss_terminator);
+
+      if (loop.temp_ss != NULL)
+        {
+          /* Increment count1 before finish the main body of a scalarized
+             expression.  */
+          tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type, count1, gfc_index_one_node);
+          gfc_add_modify (&body, count1, tmp);
+          gfc_trans_scalarized_loop_boundary (&loop, &body);
+
+          /* We need to copy the temporary to the actual lhs.  */
+          gfc_init_se (&lse, NULL);
+          gfc_init_se (&rse, NULL);
+          gfc_copy_loopinfo_to_se (&lse, &loop);
+          gfc_copy_loopinfo_to_se (&rse, &loop);
+
+          rse.ss = loop.temp_ss;
+          lse.ss = lss;
+
+          gfc_conv_tmp_array_ref (&rse);
+          gfc_conv_expr (&lse, expr1);
+
+          gcc_assert (lse.ss == gfc_ss_terminator
+		      && rse.ss == gfc_ss_terminator);
+
+          /* Form the mask expression according to the mask tree list.  */
+          index = count2;
+          maskexpr = gfc_build_array_ref (mask, index, NULL);
+	  if (invert)
+	    maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
+					TREE_TYPE (maskexpr), maskexpr);
+
+          /* Use the scalar assignment as is.  */
+          tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false,
+					 true);
+          tmp = build3_v (COND_EXPR, maskexpr, tmp,
+			  build_empty_stmt (input_location));
+          gfc_add_expr_to_block (&body, tmp);
+
+          /* Increment count2.  */
+          tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type, count2,
+				 gfc_index_one_node);
+          gfc_add_modify (&body, count2, tmp);
+        }
+      else
+        {
+          /* Increment count1.  */
+          tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type, count1,
+				 gfc_index_one_node);
+          gfc_add_modify (&body, count1, tmp);
+        }
+
+      /* Generate the copying loops.  */
+      gfc_trans_scalarizing_loops (&loop, &body);
+
+      /* Wrap the whole thing up.  */
+      gfc_add_block_to_block (&block, &loop.pre);
+      gfc_add_block_to_block (&block, &loop.post);
+      gfc_cleanup_loop (&loop);
+    }
+
+  return gfc_finish_block (&block);
+}
+
+
+/* Translate the WHERE construct or statement.
+   This function can be called iteratively to translate the nested WHERE
+   construct or statement.
+   MASK is the control mask.  */
+
+static void
+gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
+		   forall_info * nested_forall_info, stmtblock_t * block)
+{
+  stmtblock_t inner_size_body;
+  tree inner_size, size;
+  gfc_ss *lss, *rss;
+  tree mask_type;
+  gfc_expr *expr1;
+  gfc_expr *expr2;
+  gfc_code *cblock;
+  gfc_code *cnext;
+  tree tmp;
+  tree cond;
+  tree count1, count2;
+  bool need_cmask;
+  bool need_pmask;
+  int need_temp;
+  tree pcmask = NULL_TREE;
+  tree ppmask = NULL_TREE;
+  tree cmask = NULL_TREE;
+  tree pmask = NULL_TREE;
+  gfc_actual_arglist *arg;
+
+  /* the WHERE statement or the WHERE construct statement.  */
+  cblock = code->block;
+
+  /* As the mask array can be very big, prefer compact boolean types.  */
+  mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
+
+  /* Determine which temporary masks are needed.  */
+  if (!cblock->block)
+    {
+      /* One clause: No ELSEWHEREs.  */
+      need_cmask = (cblock->next != 0);
+      need_pmask = false;
+    }
+  else if (cblock->block->block)
+    {
+      /* Three or more clauses: Conditional ELSEWHEREs.  */
+      need_cmask = true;
+      need_pmask = true;
+    }
+  else if (cblock->next)
+    {
+      /* Two clauses, the first non-empty.  */
+      need_cmask = true;
+      need_pmask = (mask != NULL_TREE
+		    && cblock->block->next != 0);
+    }
+  else if (!cblock->block->next)
+    {
+      /* Two clauses, both empty.  */
+      need_cmask = false;
+      need_pmask = false;
+    }
+  /* Two clauses, the first empty, the second non-empty.  */
+  else if (mask)
+    {
+      need_cmask = (cblock->block->expr1 != 0);
+      need_pmask = true;
+    }
+  else
+    {
+      need_cmask = true;
+      need_pmask = false;
+    }
+
+  if (need_cmask || need_pmask)
+    {
+      /* Calculate the size of temporary needed by the mask-expr.  */
+      gfc_init_block (&inner_size_body);
+      inner_size = compute_inner_temp_size (cblock->expr1, cblock->expr1,
+					    &inner_size_body, &lss, &rss);
+
+      gfc_free_ss_chain (lss);
+      gfc_free_ss_chain (rss);
+
+      /* Calculate the total size of temporary needed.  */
+      size = compute_overall_iter_number (nested_forall_info, inner_size,
+					  &inner_size_body, block);
+
+      /* Check whether the size is negative.  */
+      cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, size,
+			      gfc_index_zero_node);
+      size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
+			      cond, gfc_index_zero_node, size);
+      size = gfc_evaluate_now (size, block);
+
+      /* Allocate temporary for WHERE mask if needed.  */
+      if (need_cmask)
+	cmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
+						 &pcmask);
+
+      /* Allocate temporary for !mask if needed.  */
+      if (need_pmask)
+	pmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
+						 &ppmask);
+    }
+
+  while (cblock)
+    {
+      /* Each time around this loop, the where clause is conditional
+	 on the value of mask and invert, which are updated at the
+	 bottom of the loop.  */
+
+      /* Has mask-expr.  */
+      if (cblock->expr1)
+        {
+          /* Ensure that the WHERE mask will be evaluated exactly once.
+	     If there are no statements in this WHERE/ELSEWHERE clause,
+	     then we don't need to update the control mask (cmask).
+	     If this is the last clause of the WHERE construct, then
+	     we don't need to update the pending control mask (pmask).  */
+	  if (mask)
+	    gfc_evaluate_where_mask (cblock->expr1, nested_forall_info,
+				     mask, invert,
+				     cblock->next  ? cmask : NULL_TREE,
+				     cblock->block ? pmask : NULL_TREE,
+				     mask_type, block);
+	  else
+	    gfc_evaluate_where_mask (cblock->expr1, nested_forall_info,
+				     NULL_TREE, false,
+				     (cblock->next || cblock->block)
+				     ? cmask : NULL_TREE,
+				     NULL_TREE, mask_type, block);
+
+	  invert = false;
+        }
+      /* It's a final elsewhere-stmt. No mask-expr is present.  */
+      else
+        cmask = mask;
+
+      /* The body of this where clause are controlled by cmask with
+	 sense specified by invert.  */
+
+      /* Get the assignment statement of a WHERE statement, or the first
+         statement in where-body-construct of a WHERE construct.  */
+      cnext = cblock->next;
+      while (cnext)
+        {
+          switch (cnext->op)
+            {
+            /* WHERE assignment statement.  */
+	    case EXEC_ASSIGN_CALL:
+
+	      arg = cnext->ext.actual;
+	      expr1 = expr2 = NULL;
+	      for (; arg; arg = arg->next)
+		{
+		  if (!arg->expr)
+		    continue;
+		  if (expr1 == NULL)
+		    expr1 = arg->expr;
+		  else
+		    expr2 = arg->expr;
+		}
+	      goto evaluate;
+
+            case EXEC_ASSIGN:
+              expr1 = cnext->expr1;
+              expr2 = cnext->expr2;
+    evaluate:
+              if (nested_forall_info != NULL)
+                {
+                  need_temp = gfc_check_dependency (expr1, expr2, 0);
+                  if (need_temp && cnext->op != EXEC_ASSIGN_CALL)
+                    gfc_trans_assign_need_temp (expr1, expr2,
+						cmask, invert,
+                                                nested_forall_info, block);
+                  else
+                    {
+                      /* Variables to control maskexpr.  */
+                      count1 = gfc_create_var (gfc_array_index_type, "count1");
+                      count2 = gfc_create_var (gfc_array_index_type, "count2");
+                      gfc_add_modify (block, count1, gfc_index_zero_node);
+                      gfc_add_modify (block, count2, gfc_index_zero_node);
+
+                      tmp = gfc_trans_where_assign (expr1, expr2,
+						    cmask, invert,
+						    count1, count2,
+						    cnext);
+
+                      tmp = gfc_trans_nested_forall_loop (nested_forall_info,
+                                                          tmp, 1);
+                      gfc_add_expr_to_block (block, tmp);
+                    }
+                }
+              else
+                {
+                  /* Variables to control maskexpr.  */
+                  count1 = gfc_create_var (gfc_array_index_type, "count1");
+                  count2 = gfc_create_var (gfc_array_index_type, "count2");
+                  gfc_add_modify (block, count1, gfc_index_zero_node);
+                  gfc_add_modify (block, count2, gfc_index_zero_node);
+
+                  tmp = gfc_trans_where_assign (expr1, expr2,
+						cmask, invert,
+						count1, count2,
+						cnext);
+                  gfc_add_expr_to_block (block, tmp);
+
+                }
+              break;
+
+            /* WHERE or WHERE construct is part of a where-body-construct.  */
+            case EXEC_WHERE:
+	      gfc_trans_where_2 (cnext, cmask, invert,
+				 nested_forall_info, block);
+	      break;
+
+            default:
+              gcc_unreachable ();
+            }
+
+         /* The next statement within the same where-body-construct.  */
+         cnext = cnext->next;
+       }
+    /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt.  */
+    cblock = cblock->block;
+    if (mask == NULL_TREE)
+      {
+        /* If we're the initial WHERE, we can simply invert the sense
+	   of the current mask to obtain the "mask" for the remaining
+	   ELSEWHEREs.  */
+	invert = true;
+	mask = cmask;
+      }
+    else
+      {
+	/* Otherwise, for nested WHERE's we need to use the pending mask.  */
+        invert = false;
+        mask = pmask;
+      }
+  }
+
+  /* If we allocated a pending mask array, deallocate it now.  */
+  if (ppmask)
+    {
+      tmp = gfc_call_free (ppmask);
+      gfc_add_expr_to_block (block, tmp);
+    }
+
+  /* If we allocated a current mask array, deallocate it now.  */
+  if (pcmask)
+    {
+      tmp = gfc_call_free (pcmask);
+      gfc_add_expr_to_block (block, tmp);
+    }
+}
+
+/* Translate a simple WHERE construct or statement without dependencies.
+   CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
+   is the mask condition, and EBLOCK if non-NULL is the "else" clause.
+   Currently both CBLOCK and EBLOCK are restricted to single assignments.  */
+
+static tree
+gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock)
+{
+  stmtblock_t block, body;
+  gfc_expr *cond, *tdst, *tsrc, *edst, *esrc;
+  tree tmp, cexpr, tstmt, estmt;
+  gfc_ss *css, *tdss, *tsss;
+  gfc_se cse, tdse, tsse, edse, esse;
+  gfc_loopinfo loop;
+  gfc_ss *edss = 0;
+  gfc_ss *esss = 0;
+
+  /* Allow the scalarizer to workshare simple where loops.  */
+  if (ompws_flags & OMPWS_WORKSHARE_FLAG)
+    ompws_flags |= OMPWS_SCALARIZER_WS;
+
+  cond = cblock->expr1;
+  tdst = cblock->next->expr1;
+  tsrc = cblock->next->expr2;
+  edst = eblock ? eblock->next->expr1 : NULL;
+  esrc = eblock ? eblock->next->expr2 : NULL;
+
+  gfc_start_block (&block);
+  gfc_init_loopinfo (&loop);
+
+  /* Handle the condition.  */
+  gfc_init_se (&cse, NULL);
+  css = gfc_walk_expr (cond);
+  gfc_add_ss_to_loop (&loop, css);
+
+  /* Handle the then-clause.  */
+  gfc_init_se (&tdse, NULL);
+  gfc_init_se (&tsse, NULL);
+  tdss = gfc_walk_expr (tdst);
+  tsss = gfc_walk_expr (tsrc);
+  if (tsss == gfc_ss_terminator)
+    {
+      tsss = gfc_get_scalar_ss (gfc_ss_terminator, tsrc);
+      tsss->info->where = 1;
+    }
+  gfc_add_ss_to_loop (&loop, tdss);
+  gfc_add_ss_to_loop (&loop, tsss);
+
+  if (eblock)
+    {
+      /* Handle the else clause.  */
+      gfc_init_se (&edse, NULL);
+      gfc_init_se (&esse, NULL);
+      edss = gfc_walk_expr (edst);
+      esss = gfc_walk_expr (esrc);
+      if (esss == gfc_ss_terminator)
+	{
+	  esss = gfc_get_scalar_ss (gfc_ss_terminator, esrc);
+	  esss->info->where = 1;
+	}
+      gfc_add_ss_to_loop (&loop, edss);
+      gfc_add_ss_to_loop (&loop, esss);
+    }
+
+  gfc_conv_ss_startstride (&loop);
+  gfc_conv_loop_setup (&loop, &tdst->where);
+
+  gfc_mark_ss_chain_used (css, 1);
+  gfc_mark_ss_chain_used (tdss, 1);
+  gfc_mark_ss_chain_used (tsss, 1);
+  if (eblock)
+    {
+      gfc_mark_ss_chain_used (edss, 1);
+      gfc_mark_ss_chain_used (esss, 1);
+    }
+
+  gfc_start_scalarized_body (&loop, &body);
+
+  gfc_copy_loopinfo_to_se (&cse, &loop);
+  gfc_copy_loopinfo_to_se (&tdse, &loop);
+  gfc_copy_loopinfo_to_se (&tsse, &loop);
+  cse.ss = css;
+  tdse.ss = tdss;
+  tsse.ss = tsss;
+  if (eblock)
+    {
+      gfc_copy_loopinfo_to_se (&edse, &loop);
+      gfc_copy_loopinfo_to_se (&esse, &loop);
+      edse.ss = edss;
+      esse.ss = esss;
+    }
+
+  gfc_conv_expr (&cse, cond);
+  gfc_add_block_to_block (&body, &cse.pre);
+  cexpr = cse.expr;
+
+  gfc_conv_expr (&tsse, tsrc);
+  if (tdss != gfc_ss_terminator && loop.temp_ss != NULL)
+    gfc_conv_tmp_array_ref (&tdse);
+  else
+    gfc_conv_expr (&tdse, tdst);
+
+  if (eblock)
+    {
+      gfc_conv_expr (&esse, esrc);
+      if (edss != gfc_ss_terminator && loop.temp_ss != NULL)
+	gfc_conv_tmp_array_ref (&edse);
+      else
+	gfc_conv_expr (&edse, edst);
+    }
+
+  tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, false, true);
+  estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, false,
+					    false, true)
+		 : build_empty_stmt (input_location);
+  tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
+  gfc_add_expr_to_block (&body, tmp);
+  gfc_add_block_to_block (&body, &cse.post);
+
+  gfc_trans_scalarizing_loops (&loop, &body);
+  gfc_add_block_to_block (&block, &loop.pre);
+  gfc_add_block_to_block (&block, &loop.post);
+  gfc_cleanup_loop (&loop);
+
+  return gfc_finish_block (&block);
+}
+
+/* As the WHERE or WHERE construct statement can be nested, we call
+   gfc_trans_where_2 to do the translation, and pass the initial
+   NULL values for both the control mask and the pending control mask.  */
+
+tree
+gfc_trans_where (gfc_code * code)
+{
+  stmtblock_t block;
+  gfc_code *cblock;
+  gfc_code *eblock;
+
+  cblock = code->block;
+  if (cblock->next
+      && cblock->next->op == EXEC_ASSIGN
+      && !cblock->next->next)
+    {
+      eblock = cblock->block;
+      if (!eblock)
+	{
+          /* A simple "WHERE (cond) x = y" statement or block is
+	     dependence free if cond is not dependent upon writing x,
+	     and the source y is unaffected by the destination x.  */
+	  if (!gfc_check_dependency (cblock->next->expr1,
+				     cblock->expr1, 0)
+	      && !gfc_check_dependency (cblock->next->expr1,
+					cblock->next->expr2, 0))
+	    return gfc_trans_where_3 (cblock, NULL);
+	}
+      else if (!eblock->expr1
+	       && !eblock->block
+	       && eblock->next
+	       && eblock->next->op == EXEC_ASSIGN
+	       && !eblock->next->next)
+	{
+          /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
+	     block is dependence free if cond is not dependent on writes
+	     to x1 and x2, y1 is not dependent on writes to x2, and y2
+	     is not dependent on writes to x1, and both y's are not
+	     dependent upon their own x's.  In addition to this, the
+	     final two dependency checks below exclude all but the same
+	     array reference if the where and elswhere destinations
+	     are the same.  In short, this is VERY conservative and this
+	     is needed because the two loops, required by the standard
+	     are coalesced in gfc_trans_where_3.  */
+	  if (!gfc_check_dependency (cblock->next->expr1,
+				    cblock->expr1, 0)
+	      && !gfc_check_dependency (eblock->next->expr1,
+				       cblock->expr1, 0)
+	      && !gfc_check_dependency (cblock->next->expr1,
+				       eblock->next->expr2, 1)
+	      && !gfc_check_dependency (eblock->next->expr1,
+				       cblock->next->expr2, 1)
+	      && !gfc_check_dependency (cblock->next->expr1,
+				       cblock->next->expr2, 1)
+	      && !gfc_check_dependency (eblock->next->expr1,
+				       eblock->next->expr2, 1)
+	      && !gfc_check_dependency (cblock->next->expr1,
+				       eblock->next->expr1, 0)
+	      && !gfc_check_dependency (eblock->next->expr1,
+				       cblock->next->expr1, 0))
+	    return gfc_trans_where_3 (cblock, eblock);
+	}
+    }
+
+  gfc_start_block (&block);
+
+  gfc_trans_where_2 (code, NULL, false, NULL, &block);
+
+  return gfc_finish_block (&block);
+}
+
+
+/* CYCLE a DO loop. The label decl has already been created by
+   gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
+   node at the head of the loop. We must mark the label as used.  */
+
+tree
+gfc_trans_cycle (gfc_code * code)
+{
+  tree cycle_label;
+
+  cycle_label = code->ext.which_construct->cycle_label;
+  gcc_assert (cycle_label);
+
+  TREE_USED (cycle_label) = 1;
+  return build1_v (GOTO_EXPR, cycle_label);
+}
+
+
+/* EXIT a DO loop. Similar to CYCLE, but now the label is in
+   TREE_VALUE (backend_decl) of the gfc_code node at the head of the
+   loop.  */
+
+tree
+gfc_trans_exit (gfc_code * code)
+{
+  tree exit_label;
+
+  exit_label = code->ext.which_construct->exit_label;
+  gcc_assert (exit_label);
+
+  TREE_USED (exit_label) = 1;
+  return build1_v (GOTO_EXPR, exit_label);
+}
+
+
+/* Translate the ALLOCATE statement.  */
+
+tree
+gfc_trans_allocate (gfc_code * code)
+{
+  gfc_alloc *al;
+  gfc_expr *e;
+  gfc_expr *expr;
+  gfc_se se;
+  tree tmp;
+  tree parm;
+  tree stat;
+  tree errmsg;
+  tree errlen;
+  tree label_errmsg;
+  tree label_finish;
+  tree memsz;
+  tree expr3;
+  tree slen3;
+  stmtblock_t block;
+  stmtblock_t post;
+  gfc_expr *sz;
+  gfc_se se_sz;
+  tree class_expr;
+  tree nelems;
+  tree memsize = NULL_TREE;
+  tree classexpr = NULL_TREE;
+
+  if (!code->ext.alloc.list)
+    return NULL_TREE;
+
+  stat = tmp = memsz = NULL_TREE;
+  label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
+
+  gfc_init_block (&block);
+  gfc_init_block (&post);
+
+  /* STAT= (and maybe ERRMSG=) is present.  */
+  if (code->expr1)
+    {
+      /* STAT=.  */
+      tree gfc_int4_type_node = gfc_get_int_type (4);
+      stat = gfc_create_var (gfc_int4_type_node, "stat");
+
+      /* ERRMSG= only makes sense with STAT=.  */
+      if (code->expr2)
+	{
+	  gfc_init_se (&se, NULL);
+	  se.want_pointer = 1;
+	  gfc_conv_expr_lhs (&se, code->expr2);
+	  errmsg = se.expr;
+	  errlen = se.string_length;
+	}
+      else
+	{
+	  errmsg = null_pointer_node;
+	  errlen = build_int_cst (gfc_charlen_type_node, 0);
+	}
+
+      /* GOTO destinations.  */
+      label_errmsg = gfc_build_label_decl (NULL_TREE);
+      label_finish = gfc_build_label_decl (NULL_TREE);
+      TREE_USED (label_finish) = 0;
+    }
+
+  expr3 = NULL_TREE;
+  slen3 = NULL_TREE;
+
+  for (al = code->ext.alloc.list; al != NULL; al = al->next)
+    {
+      expr = gfc_copy_expr (al->expr);
+
+      if (expr->ts.type == BT_CLASS)
+	gfc_add_data_component (expr);
+
+      gfc_init_se (&se, NULL);
+
+      se.want_pointer = 1;
+      se.descriptor_only = 1;
+      gfc_conv_expr (&se, expr);
+
+      /* Evaluate expr3 just once if not a variable.  */
+      if (al == code->ext.alloc.list
+	    && al->expr->ts.type == BT_CLASS
+	    && code->expr3
+	    && code->expr3->ts.type == BT_CLASS
+	    && code->expr3->expr_type != EXPR_VARIABLE)
+	{
+	  gfc_init_se (&se_sz, NULL);
+	  gfc_conv_expr_reference (&se_sz, code->expr3);
+	  gfc_conv_class_to_class (&se_sz, code->expr3,
+				   code->expr3->ts, false, true, false, false);
+	  gfc_add_block_to_block (&se.pre, &se_sz.pre);
+	  gfc_add_block_to_block (&se.post, &se_sz.post);
+	  classexpr = build_fold_indirect_ref_loc (input_location,
+						   se_sz.expr);
+	  classexpr = gfc_evaluate_now (classexpr, &se.pre);
+	  memsize = gfc_vtable_size_get (classexpr);
+	  memsize = fold_convert (sizetype, memsize);
+	}
+
+      memsz = memsize;
+      class_expr = classexpr;
+
+      nelems = NULL_TREE;
+      if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish,
+			       memsz, &nelems, code->expr3, &code->ext.alloc.ts))
+	{
+	  bool unlimited_char;
+
+	  unlimited_char = UNLIMITED_POLY (al->expr)
+			   && ((code->expr3 && code->expr3->ts.type == BT_CHARACTER)
+			      || (code->ext.alloc.ts.type == BT_CHARACTER
+				  && code->ext.alloc.ts.u.cl
+				  && code->ext.alloc.ts.u.cl->length));
+
+	  /* A scalar or derived type.  */
+
+	  /* Determine allocate size.  */
+	  if (al->expr->ts.type == BT_CLASS
+		&& !unlimited_char
+		&& code->expr3
+		&& memsz == NULL_TREE)
+	    {
+	      if (code->expr3->ts.type == BT_CLASS)
+		{
+		  sz = gfc_copy_expr (code->expr3);
+		  gfc_add_vptr_component (sz);
+		  gfc_add_size_component (sz);
+		  gfc_init_se (&se_sz, NULL);
+		  gfc_conv_expr (&se_sz, sz);
+		  gfc_free_expr (sz);
+		  memsz = se_sz.expr;
+		}
+	      else
+		memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts));
+	    }
+	  else if (((al->expr->ts.type == BT_CHARACTER && al->expr->ts.deferred)
+		   || unlimited_char) && code->expr3)
+	    {
+	      if (!code->expr3->ts.u.cl->backend_decl)
+		{
+		  /* Convert and use the length expression.  */
+		  gfc_init_se (&se_sz, NULL);
+		  if (code->expr3->expr_type == EXPR_VARIABLE
+			|| code->expr3->expr_type == EXPR_CONSTANT)
+		    {
+		      gfc_conv_expr (&se_sz, code->expr3);
+		      gfc_add_block_to_block (&se.pre, &se_sz.pre);
+		      se_sz.string_length
+			= gfc_evaluate_now (se_sz.string_length, &se.pre);
+		      gfc_add_block_to_block (&se.pre, &se_sz.post);
+		      memsz = se_sz.string_length;
+		    }
+		  else if (code->expr3->mold
+			     && code->expr3->ts.u.cl
+			     && code->expr3->ts.u.cl->length)
+		    {
+		      gfc_conv_expr (&se_sz, code->expr3->ts.u.cl->length);
+		      gfc_add_block_to_block (&se.pre, &se_sz.pre);
+		      se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre);
+		      gfc_add_block_to_block (&se.pre, &se_sz.post);
+		      memsz = se_sz.expr;
+		    }
+		  else
+		    {
+		      /* This is would be inefficient and possibly could
+			 generate wrong code if the result were not stored
+			 in expr3/slen3.  */
+		      if (slen3 == NULL_TREE)
+			{
+			  gfc_conv_expr (&se_sz, code->expr3);
+			  gfc_add_block_to_block (&se.pre, &se_sz.pre);
+			  expr3 = gfc_evaluate_now (se_sz.expr, &se.pre);
+			  gfc_add_block_to_block (&post, &se_sz.post);
+			  slen3 = gfc_evaluate_now (se_sz.string_length,
+						    &se.pre);
+			}
+		      memsz = slen3;
+		    }
+		}
+	      else
+		/* Otherwise use the stored string length.  */
+		memsz = code->expr3->ts.u.cl->backend_decl;
+	      tmp = al->expr->ts.u.cl->backend_decl;
+
+	      /* Store the string length.  */
+	      if (tmp && TREE_CODE (tmp) == VAR_DECL)
+		gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
+				memsz));
+	      else if (al->expr->ts.type == BT_CHARACTER
+		       && al->expr->ts.deferred && se.string_length)
+		gfc_add_modify (&se.pre, se.string_length,
+				fold_convert (TREE_TYPE (se.string_length),
+				memsz));
+
+	      /* Convert to size in bytes, using the character KIND.  */
+	      if (unlimited_char)
+		tmp = TREE_TYPE (gfc_typenode_for_spec (&code->expr3->ts));
+	      else
+	      tmp = TREE_TYPE (gfc_typenode_for_spec (&al->expr->ts));
+	      tmp = TYPE_SIZE_UNIT (tmp);
+	      memsz = fold_build2_loc (input_location, MULT_EXPR,
+				       TREE_TYPE (tmp), tmp,
+				       fold_convert (TREE_TYPE (tmp), memsz));
+	    }
+          else if ((al->expr->ts.type == BT_CHARACTER && al->expr->ts.deferred)
+		    || unlimited_char)
+	    {
+	      gcc_assert (code->ext.alloc.ts.u.cl && code->ext.alloc.ts.u.cl->length);
+	      gfc_init_se (&se_sz, NULL);
+	      gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
+	      gfc_add_block_to_block (&se.pre, &se_sz.pre);
+	      se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre);
+	      gfc_add_block_to_block (&se.pre, &se_sz.post);
+	      /* Store the string length.  */
+	      tmp = al->expr->ts.u.cl->backend_decl;
+	      gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
+			      se_sz.expr));
+              tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts));
+              tmp = TYPE_SIZE_UNIT (tmp);
+	      memsz = fold_build2_loc (input_location, MULT_EXPR,
+				       TREE_TYPE (tmp), tmp,
+				       fold_convert (TREE_TYPE (se_sz.expr),
+						     se_sz.expr));
+	    }
+	  else if (code->ext.alloc.ts.type != BT_UNKNOWN)
+	    memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
+	  else if (memsz == NULL_TREE)
+	    memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
+
+	  if (expr->ts.type == BT_CHARACTER && memsz == NULL_TREE)
+	    {
+	      memsz = se.string_length;
+
+	      /* Convert to size in bytes, using the character KIND.  */
+	      tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts));
+	      tmp = TYPE_SIZE_UNIT (tmp);
+	      memsz = fold_build2_loc (input_location, MULT_EXPR,
+				       TREE_TYPE (tmp), tmp,
+				       fold_convert (TREE_TYPE (tmp), memsz));
+	    }
+
+	  /* Allocate - for non-pointers with re-alloc checking.  */
+	  if (gfc_expr_attr (expr).allocatable)
+	    gfc_allocate_allocatable (&se.pre, se.expr, memsz, NULL_TREE,
+				      stat, errmsg, errlen, label_finish, expr);
+	  else
+	    gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat);
+
+	  if (al->expr->ts.type == BT_DERIVED
+	      && expr->ts.u.derived->attr.alloc_comp)
+	    {
+	      tmp = build_fold_indirect_ref_loc (input_location, se.expr);
+	      tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, tmp, 0);
+	      gfc_add_expr_to_block (&se.pre, tmp);
+	    }
+	}
+
+      gfc_add_block_to_block (&block, &se.pre);
+
+      /* Error checking -- Note: ERRMSG only makes sense with STAT.  */
+      if (code->expr1)
+	{
+	  tmp = build1_v (GOTO_EXPR, label_errmsg);
+	  parm = fold_build2_loc (input_location, NE_EXPR,
+				  boolean_type_node, stat,
+				  build_int_cst (TREE_TYPE (stat), 0));
+	  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+				 gfc_unlikely (parm, PRED_FORTRAN_FAIL_ALLOC),
+				 tmp, build_empty_stmt (input_location));
+	  gfc_add_expr_to_block (&block, tmp);
+	}
+
+      /* We need the vptr of CLASS objects to be initialized.  */
+      e = gfc_copy_expr (al->expr);
+      if (e->ts.type == BT_CLASS)
+	{
+	  gfc_expr *lhs, *rhs;
+	  gfc_se lse;
+	  gfc_ref *ref, *class_ref, *tail;
+
+	  /* Find the last class reference.  */
+	  class_ref = NULL;
+	  for (ref = e->ref; ref; ref = ref->next)
+	    {
+	      if (ref->type == REF_COMPONENT
+		  && ref->u.c.component->ts.type == BT_CLASS)
+		class_ref = ref;
+
+	      if (ref->next == NULL)
+		break;
+	    }
+
+	  /* Remove and store all subsequent references after the
+	     CLASS reference.  */
+	  if (class_ref)
+	    {
+	      tail = class_ref->next;
+	      class_ref->next = NULL;
+	    }
+	  else
+	    {
+	      tail = e->ref;
+	      e->ref = NULL;
+	    }
+
+	  lhs = gfc_expr_to_initialize (e);
+	  gfc_add_vptr_component (lhs);
+
+	  /* Remove the _vptr component and restore the original tail
+	     references.  */
+	  if (class_ref)
+	    {
+	      gfc_free_ref_list (class_ref->next);
+	      class_ref->next = tail;
+	    }
+	  else
+	    {
+	      gfc_free_ref_list (e->ref);
+	      e->ref = tail;
+	    }
+
+	  if (class_expr != NULL_TREE)
+	    {
+	      /* Polymorphic SOURCE: VPTR must be determined at run time.  */
+	      gfc_init_se (&lse, NULL);
+	      lse.want_pointer = 1;
+	      gfc_conv_expr (&lse, lhs);
+	      tmp = gfc_class_vptr_get (class_expr);
+	      gfc_add_modify (&block, lse.expr,
+			fold_convert (TREE_TYPE (lse.expr), tmp));
+	    }
+	  else if (code->expr3 && code->expr3->ts.type == BT_CLASS)
+	    {
+	      /* Polymorphic SOURCE: VPTR must be determined at run time.  */
+	      rhs = gfc_copy_expr (code->expr3);
+	      gfc_add_vptr_component (rhs);
+	      tmp = gfc_trans_pointer_assignment (lhs, rhs);
+	      gfc_add_expr_to_block (&block, tmp);
+	      gfc_free_expr (rhs);
+	      rhs = gfc_expr_to_initialize (e);
+	    }
+	  else
+	    {
+	      /* VPTR is fixed at compile time.  */
+	      gfc_symbol *vtab;
+	      gfc_typespec *ts;
+	      if (code->expr3)
+		ts = &code->expr3->ts;
+	      else if (e->ts.type == BT_DERIVED)
+		ts = &e->ts;
+	      else if (code->ext.alloc.ts.type == BT_DERIVED || UNLIMITED_POLY (al->expr))
+		ts = &code->ext.alloc.ts;
+	      else if (e->ts.type == BT_CLASS)
+		ts = &CLASS_DATA (e)->ts;
+	      else
+		ts = &e->ts;
+
+	      if (ts->type == BT_DERIVED || UNLIMITED_POLY (e))
+		{
+		  vtab = gfc_find_vtab (ts);
+		  gcc_assert (vtab);
+		  gfc_init_se (&lse, NULL);
+		  lse.want_pointer = 1;
+		  gfc_conv_expr (&lse, lhs);
+		  tmp = gfc_build_addr_expr (NULL_TREE,
+					     gfc_get_symbol_decl (vtab));
+		  gfc_add_modify (&block, lse.expr,
+			fold_convert (TREE_TYPE (lse.expr), tmp));
+		}
+	    }
+	  gfc_free_expr (lhs);
+	}
+
+      gfc_free_expr (e);
+
+      if (code->expr3 && !code->expr3->mold)
+	{
+	  /* Initialization via SOURCE block
+	     (or static default initializer).  */
+	  gfc_expr *rhs = gfc_copy_expr (code->expr3);
+	  if (class_expr != NULL_TREE)
+	    {
+	      tree to;
+	      to = TREE_OPERAND (se.expr, 0);
+
+	      tmp = gfc_copy_class_to_class (class_expr, to, nelems);
+	    }
+	  else if (al->expr->ts.type == BT_CLASS)
+	    {
+	      gfc_actual_arglist *actual;
+	      gfc_expr *ppc;
+	      gfc_code *ppc_code;
+	      gfc_ref *ref, *dataref;
+
+	      /* Do a polymorphic deep copy.  */
+	      actual = gfc_get_actual_arglist ();
+	      actual->expr = gfc_copy_expr (rhs);
+	      if (rhs->ts.type == BT_CLASS)
+		gfc_add_data_component (actual->expr);
+	      actual->next = gfc_get_actual_arglist ();
+	      actual->next->expr = gfc_copy_expr (al->expr);
+	      actual->next->expr->ts.type = BT_CLASS;
+	      gfc_add_data_component (actual->next->expr);
+
+	      dataref = NULL;
+	      /* Make sure we go up through the reference chain to
+		 the _data reference, where the arrayspec is found.  */
+	      for (ref = actual->next->expr->ref; ref; ref = ref->next)
+		if (ref->type == REF_COMPONENT
+		    && strcmp (ref->u.c.component->name, "_data") == 0)
+		  dataref = ref;
+
+	      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);
+		    }
+		}
+	      if (rhs->ts.type == BT_CLASS)
+		{
+		  ppc = gfc_copy_expr (rhs);
+		  gfc_add_vptr_component (ppc);
+		}
+	      else
+		ppc = gfc_lval_expr_from_sym (gfc_find_vtab (&rhs->ts));
+	      gfc_add_component_ref (ppc, "_copy");
+
+	      ppc_code = gfc_get_code (EXEC_CALL);
+	      ppc_code->resolved_sym = ppc->symtree->n.sym;
+	      /* Although '_copy' is set to be elemental in class.c, it is
+		 not staying that way.  Find out why, sometime....  */
+	      ppc_code->resolved_sym->attr.elemental = 1;
+	      ppc_code->ext.actual = actual;
+	      ppc_code->expr1 = ppc;
+	      /* Since '_copy' is elemental, the scalarizer will take care
+		 of arrays in gfc_trans_call.  */
+	      tmp = gfc_trans_call (ppc_code, true, NULL, NULL, false);
+	      gfc_free_statements (ppc_code);
+	    }
+	  else if (expr3 != NULL_TREE)
+	    {
+	      tmp = build_fold_indirect_ref_loc (input_location, se.expr);
+	      gfc_trans_string_copy (&block, slen3, tmp, code->expr3->ts.kind,
+				     slen3, expr3, code->expr3->ts.kind);
+	      tmp = NULL_TREE;
+	    }
+	  else
+	    {
+	      /* Switch off automatic reallocation since we have just done
+		 the ALLOCATE.  */
+	      int realloc_lhs = gfc_option.flag_realloc_lhs;
+	      gfc_option.flag_realloc_lhs = 0;
+	      tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr),
+					  rhs, false, false);
+	      gfc_option.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)
+	{
+	  /* Since the _vptr has already been assigned to the allocate
+	     object, we can use gfc_copy_class_to_class in its
+	     initialization mode.  */
+	  tmp = TREE_OPERAND (se.expr, 0);
+	  tmp = gfc_copy_class_to_class (NULL_TREE, tmp, nelems);
+	  gfc_add_expr_to_block (&block, tmp);
+	}
+
+       gfc_free_expr (expr);
+    }
+
+  /* STAT.  */
+  if (code->expr1)
+    {
+      tmp = build1_v (LABEL_EXPR, label_errmsg);
+      gfc_add_expr_to_block (&block, tmp);
+    }
+
+  /* ERRMSG - only useful if STAT is present.  */
+  if (code->expr1 && code->expr2)
+    {
+      const char *msg = "Attempt to allocate an allocated object";
+      tree slen, dlen, errmsg_str;
+      stmtblock_t errmsg_block;
+
+      gfc_init_block (&errmsg_block);
+
+      errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG");
+      gfc_add_modify (&errmsg_block, errmsg_str,
+		gfc_build_addr_expr (pchar_type_node,
+			gfc_build_localized_cstring_const (msg)));
+
+      slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg)));
+      dlen = gfc_get_expr_charlen (code->expr2);
+      slen = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (slen), dlen,
+			      slen);
+
+      gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind,
+			     slen, errmsg_str, gfc_default_character_kind);
+      dlen = gfc_finish_block (&errmsg_block);
+
+      tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
+			     build_int_cst (TREE_TYPE (stat), 0));
+
+      tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt (input_location));
+
+      gfc_add_expr_to_block (&block, tmp);
+    }
+
+  /* STAT block.  */
+  if (code->expr1)
+    {
+      if (TREE_USED (label_finish))
+	{
+	  tmp = build1_v (LABEL_EXPR, label_finish);
+	  gfc_add_expr_to_block (&block, tmp);
+	}
+
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr_lhs (&se, code->expr1);
+      tmp = convert (TREE_TYPE (se.expr), stat);
+      gfc_add_modify (&block, se.expr, tmp);
+    }
+
+  gfc_add_block_to_block (&block, &se.post);
+  gfc_add_block_to_block (&block, &post);
+
+  return gfc_finish_block (&block);
+}
+
+
+/* Translate a DEALLOCATE statement.  */
+
+tree
+gfc_trans_deallocate (gfc_code *code)
+{
+  gfc_se se;
+  gfc_alloc *al;
+  tree apstat, pstat, stat, errmsg, errlen, tmp;
+  tree label_finish, label_errmsg;
+  stmtblock_t block;
+
+  pstat = apstat = stat = errmsg = errlen = tmp = NULL_TREE;
+  label_finish = label_errmsg = NULL_TREE;
+
+  gfc_start_block (&block);
+
+  /* Count the number of failed deallocations.  If deallocate() was
+     called with STAT= , then set STAT to the count.  If deallocate
+     was called with ERRMSG, then set ERRMG to a string.  */
+  if (code->expr1)
+    {
+      tree gfc_int4_type_node = gfc_get_int_type (4);
+
+      stat = gfc_create_var (gfc_int4_type_node, "stat");
+      pstat = gfc_build_addr_expr (NULL_TREE, stat);
+
+      /* GOTO destinations.  */
+      label_errmsg = gfc_build_label_decl (NULL_TREE);
+      label_finish = gfc_build_label_decl (NULL_TREE);
+      TREE_USED (label_finish) = 0;
+    }
+
+  /* Set ERRMSG - only needed if STAT is available.  */
+  if (code->expr1 && code->expr2)
+    {
+      gfc_init_se (&se, NULL);
+      se.want_pointer = 1;
+      gfc_conv_expr_lhs (&se, code->expr2);
+      errmsg = se.expr;
+      errlen = se.string_length;
+    }
+
+  for (al = code->ext.alloc.list; al != NULL; al = al->next)
+    {
+      gfc_expr *expr = gfc_copy_expr (al->expr);
+      gcc_assert (expr->expr_type == EXPR_VARIABLE);
+
+      if (expr->ts.type == BT_CLASS)
+	gfc_add_data_component (expr);
+
+      gfc_init_se (&se, NULL);
+      gfc_start_block (&se.pre);
+
+      se.want_pointer = 1;
+      se.descriptor_only = 1;
+      gfc_conv_expr (&se, expr);
+
+      if (expr->rank || gfc_is_coarray (expr))
+	{
+	  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp
+	      && !gfc_is_finalizable (expr->ts.u.derived, NULL))
+	    {
+	      gfc_ref *ref;
+	      gfc_ref *last = NULL;
+	      for (ref = expr->ref; ref; ref = ref->next)
+		if (ref->type == REF_COMPONENT)
+		  last = ref;
+
+	      /* Do not deallocate the components of a derived type
+		ultimate pointer component.  */
+	      if (!(last && last->u.c.component->attr.pointer)
+		    && !(!last && expr->symtree->n.sym->attr.pointer))
+		{
+		  tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se.expr,
+						  expr->rank);
+		  gfc_add_expr_to_block (&se.pre, tmp);
+		}
+	    }
+	  tmp = gfc_array_deallocate (se.expr, pstat, errmsg, errlen,
+				      label_finish, expr);
+	  gfc_add_expr_to_block (&se.pre, tmp);
+	  if (al->expr->ts.type == BT_CLASS)
+	    gfc_reset_vptr (&se.pre, al->expr);
+	}
+      else
+	{
+	  tmp = gfc_deallocate_scalar_with_status (se.expr, pstat, false,
+						   al->expr, al->expr->ts);
+	  gfc_add_expr_to_block (&se.pre, tmp);
+
+	  /* Set to zero after deallocation.  */
+	  tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+				 se.expr,
+				 build_int_cst (TREE_TYPE (se.expr), 0));
+	  gfc_add_expr_to_block (&se.pre, tmp);
+
+	  if (al->expr->ts.type == BT_CLASS)
+	    gfc_reset_vptr (&se.pre, al->expr);
+	}
+
+      if (code->expr1)
+	{
+          tree cond;
+
+	  cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
+				  build_int_cst (TREE_TYPE (stat), 0));
+	  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+				 gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC),
+				 build1_v (GOTO_EXPR, label_errmsg),
+				 build_empty_stmt (input_location));
+	  gfc_add_expr_to_block (&se.pre, tmp);
+	}
+
+      tmp = gfc_finish_block (&se.pre);
+      gfc_add_expr_to_block (&block, tmp);
+      gfc_free_expr (expr);
+    }
+
+  if (code->expr1)
+    {
+      tmp = build1_v (LABEL_EXPR, label_errmsg);
+      gfc_add_expr_to_block (&block, tmp);
+    }
+
+  /* Set ERRMSG - only needed if STAT is available.  */
+  if (code->expr1 && code->expr2)
+    {
+      const char *msg = "Attempt to deallocate an unallocated object";
+      stmtblock_t errmsg_block;
+      tree errmsg_str, slen, dlen, cond;
+
+      gfc_init_block (&errmsg_block);
+
+      errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG");
+      gfc_add_modify (&errmsg_block, errmsg_str,
+		gfc_build_addr_expr (pchar_type_node,
+                        gfc_build_localized_cstring_const (msg)));
+      slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg)));
+      dlen = gfc_get_expr_charlen (code->expr2);
+
+      gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind,
+			     slen, errmsg_str, gfc_default_character_kind);
+      tmp = gfc_finish_block (&errmsg_block);
+
+      cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
+			     build_int_cst (TREE_TYPE (stat), 0));
+      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+			     gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC), tmp,
+			     build_empty_stmt (input_location));
+
+      gfc_add_expr_to_block (&block, tmp);
+    }
+
+  if (code->expr1 && TREE_USED (label_finish))
+    {
+      tmp = build1_v (LABEL_EXPR, label_finish);
+      gfc_add_expr_to_block (&block, tmp);
+    }
+
+  /* Set STAT.  */
+  if (code->expr1)
+    {
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr_lhs (&se, code->expr1);
+      tmp = convert (TREE_TYPE (se.expr), stat);
+      gfc_add_modify (&block, se.expr, tmp);
+    }
+
+  return gfc_finish_block (&block);
+}
+
+#include "gt-fortran-trans-stmt.h"
diff --git a/gcc-4.9/gcc/fortran/trans-stmt.h b/gcc-4.9/gcc/fortran/trans-stmt.h
new file mode 100644
index 000000000..8a57be4d5
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/trans-stmt.h
@@ -0,0 +1,81 @@
+/* Header for statement translation functions
+   Copyright (C) 2002-2014 Free Software Foundation, Inc.
+   Contributed by Paul Brook
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+/* Statement translators (gfc_trans_*) return a fully translated tree.
+   Calls gfc_trans_*.  */
+tree gfc_trans_code (gfc_code *);
+
+/* Wrapper function used to pass a check condition for implied DO loops.  */
+tree gfc_trans_code_cond (gfc_code *, tree);
+
+/* All other gfc_trans_* should only need be called by gfc_trans_code */
+
+/* trans-expr.c */
+tree gfc_trans_assign (gfc_code *);
+tree gfc_trans_pointer_assign (gfc_code *);
+tree gfc_trans_init_assign (gfc_code *);
+tree gfc_trans_class_init_assign (gfc_code *);
+tree gfc_trans_class_assign (gfc_expr *, gfc_expr *, gfc_exec_op);
+
+/* trans-stmt.c */
+tree gfc_trans_cycle (gfc_code *);
+tree gfc_trans_critical (gfc_code *);
+tree gfc_trans_exit (gfc_code *);
+tree gfc_trans_label_assign (gfc_code *);
+tree gfc_trans_label_here (gfc_code *);
+tree gfc_trans_goto (gfc_code *);
+tree gfc_trans_entry (gfc_code *);
+tree gfc_trans_pause (gfc_code *);
+tree gfc_trans_stop (gfc_code *, bool);
+tree gfc_trans_call (gfc_code *, bool, tree, tree, bool);
+tree gfc_trans_return (gfc_code *);
+tree gfc_trans_if (gfc_code *);
+tree gfc_trans_arithmetic_if (gfc_code *);
+tree gfc_trans_block_construct (gfc_code *);
+tree gfc_trans_do (gfc_code *, tree);
+tree gfc_trans_do_concurrent (gfc_code *);
+tree gfc_trans_do_while (gfc_code *);
+tree gfc_trans_select (gfc_code *);
+tree gfc_trans_sync (gfc_code *, gfc_exec_op);
+tree gfc_trans_lock_unlock (gfc_code *, gfc_exec_op);
+tree gfc_trans_forall (gfc_code *);
+tree gfc_trans_where (gfc_code *);
+tree gfc_trans_allocate (gfc_code *);
+tree gfc_trans_deallocate (gfc_code *);
+tree gfc_trans_deallocate_array (tree);
+
+/* trans-openmp.c */
+tree gfc_trans_omp_directive (gfc_code *);
+
+/* trans-io.c */
+tree gfc_trans_open (gfc_code *);
+tree gfc_trans_close (gfc_code *);
+tree gfc_trans_read (gfc_code *);
+tree gfc_trans_write (gfc_code *);
+tree gfc_trans_iolength (gfc_code *);
+tree gfc_trans_backspace (gfc_code *);
+tree gfc_trans_endfile (gfc_code *);
+tree gfc_trans_inquire (gfc_code *);
+tree gfc_trans_rewind (gfc_code *);
+tree gfc_trans_flush (gfc_code *);
+
+tree gfc_trans_transfer (gfc_code *);
+tree gfc_trans_dt_end (gfc_code *);
+tree gfc_trans_wait (gfc_code *);
diff --git a/gcc-4.9/gcc/fortran/trans-types.c b/gcc-4.9/gcc/fortran/trans-types.c
new file mode 100644
index 000000000..be268cfbd
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/trans-types.c
@@ -0,0 +1,3125 @@
+/* Backend support for Fortran 95 basic types and derived types.
+   Copyright (C) 2002-2014 Free Software Foundation, Inc.
+   Contributed by Paul Brook <paul@nowt.org>
+   and Steven Bosscher <s.bosscher@student.tudelft.nl>
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+/* trans-types.c -- gfortran backend types */
+
+#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,
+			   LONG_DOUBLE_TYPE_SIZE and LIBGCC2_HAS_TF_MODE.  */
+#include "tree.h"
+#include "stor-layout.h"
+#include "stringpool.h"
+#include "langhooks.h"	/* For iso-c-bindings.def.  */
+#include "target.h"
+#include "ggc.h"
+#include "diagnostic-core.h"  /* For fatal_error.  */
+#include "toplev.h"	/* For rest_of_decl_compilation.  */
+#include "gfortran.h"
+#include "trans.h"
+#include "trans-types.h"
+#include "trans-const.h"
+#include "flags.h"
+#include "dwarf2out.h"	/* For struct array_descr_info.  */
+
+
+#if (GFC_MAX_DIMENSIONS < 10)
+#define GFC_RANK_DIGITS 1
+#define GFC_RANK_PRINTF_FORMAT "%01d"
+#elif (GFC_MAX_DIMENSIONS < 100)
+#define GFC_RANK_DIGITS 2
+#define GFC_RANK_PRINTF_FORMAT "%02d"
+#else
+#error If you really need >99 dimensions, continue the sequence above...
+#endif
+
+/* array of structs so we don't have to worry about xmalloc or free */
+CInteropKind_t c_interop_kinds_table[ISOCBINDING_NUMBER];
+
+tree gfc_array_index_type;
+tree gfc_array_range_type;
+tree gfc_character1_type_node;
+tree pvoid_type_node;
+tree prvoid_type_node;
+tree ppvoid_type_node;
+tree pchar_type_node;
+tree pfunc_type_node;
+
+tree gfc_charlen_type_node;
+
+tree float128_type_node = NULL_TREE;
+tree complex_float128_type_node = NULL_TREE;
+
+bool gfc_real16_is_float128 = false;
+
+static GTY(()) tree gfc_desc_dim_type;
+static GTY(()) tree gfc_max_array_element_size;
+static GTY(()) tree gfc_array_descriptor_base[2 * (GFC_MAX_DIMENSIONS+1)];
+static GTY(()) tree gfc_array_descriptor_base_caf[2 * (GFC_MAX_DIMENSIONS+1)];
+
+/* Arrays for all integral and real kinds.  We'll fill this in at runtime
+   after the target has a chance to process command-line options.  */
+
+#define MAX_INT_KINDS 5
+gfc_integer_info gfc_integer_kinds[MAX_INT_KINDS + 1];
+gfc_logical_info gfc_logical_kinds[MAX_INT_KINDS + 1];
+static GTY(()) tree gfc_integer_types[MAX_INT_KINDS + 1];
+static GTY(()) tree gfc_logical_types[MAX_INT_KINDS + 1];
+
+#define MAX_REAL_KINDS 5
+gfc_real_info gfc_real_kinds[MAX_REAL_KINDS + 1];
+static GTY(()) tree gfc_real_types[MAX_REAL_KINDS + 1];
+static GTY(()) tree gfc_complex_types[MAX_REAL_KINDS + 1];
+
+#define MAX_CHARACTER_KINDS 2
+gfc_character_info gfc_character_kinds[MAX_CHARACTER_KINDS + 1];
+static GTY(()) tree gfc_character_types[MAX_CHARACTER_KINDS + 1];
+static GTY(()) tree gfc_pcharacter_types[MAX_CHARACTER_KINDS + 1];
+
+static tree gfc_add_field_to_struct_1 (tree, tree, tree, tree **);
+
+/* The integer kind to use for array indices.  This will be set to the
+   proper value based on target information from the backend.  */
+
+int gfc_index_integer_kind;
+
+/* The default kinds of the various types.  */
+
+int gfc_default_integer_kind;
+int gfc_max_integer_kind;
+int gfc_default_real_kind;
+int gfc_default_double_kind;
+int gfc_default_character_kind;
+int gfc_default_logical_kind;
+int gfc_default_complex_kind;
+int gfc_c_int_kind;
+int gfc_atomic_int_kind;
+int gfc_atomic_logical_kind;
+
+/* The kind size used for record offsets. If the target system supports
+   kind=8, this will be set to 8, otherwise it is set to 4.  */
+int gfc_intio_kind;
+
+/* The integer kind used to store character lengths.  */
+int gfc_charlen_int_kind;
+
+/* The size of the numeric storage unit and character storage unit.  */
+int gfc_numeric_storage_size;
+int gfc_character_storage_size;
+
+
+bool
+gfc_check_any_c_kind (gfc_typespec *ts)
+{
+  int i;
+
+  for (i = 0; i < ISOCBINDING_NUMBER; i++)
+    {
+      /* Check for any C interoperable kind for the given type/kind in ts.
+         This can be used after verify_c_interop to make sure that the
+         Fortran kind being used exists in at least some form for C.  */
+      if (c_interop_kinds_table[i].f90_type == ts->type &&
+          c_interop_kinds_table[i].value == ts->kind)
+        return true;
+    }
+
+  return false;
+}
+
+
+static int
+get_real_kind_from_node (tree type)
+{
+  int i;
+
+  for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+    if (gfc_real_kinds[i].mode_precision == TYPE_PRECISION (type))
+      return gfc_real_kinds[i].kind;
+
+  return -4;
+}
+
+static int
+get_int_kind_from_node (tree type)
+{
+  int i;
+
+  if (!type)
+    return -2;
+
+  for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
+    if (gfc_integer_kinds[i].bit_size == TYPE_PRECISION (type))
+      return gfc_integer_kinds[i].kind;
+
+  return -1;
+}
+
+/* Return a typenode for the "standard" C type with a given name.  */
+static tree
+get_typenode_from_name (const char *name)
+{
+  if (name == NULL || *name == '\0')
+    return NULL_TREE;
+
+  if (strcmp (name, "char") == 0)
+    return char_type_node;
+  if (strcmp (name, "unsigned char") == 0)
+    return unsigned_char_type_node;
+  if (strcmp (name, "signed char") == 0)
+    return signed_char_type_node;
+
+  if (strcmp (name, "short int") == 0)
+    return short_integer_type_node;
+  if (strcmp (name, "short unsigned int") == 0)
+    return short_unsigned_type_node;
+
+  if (strcmp (name, "int") == 0)
+    return integer_type_node;
+  if (strcmp (name, "unsigned int") == 0)
+    return unsigned_type_node;
+
+  if (strcmp (name, "long int") == 0)
+    return long_integer_type_node;
+  if (strcmp (name, "long unsigned int") == 0)
+    return long_unsigned_type_node;
+
+  if (strcmp (name, "long long int") == 0)
+    return long_long_integer_type_node;
+  if (strcmp (name, "long long unsigned int") == 0)
+    return long_long_unsigned_type_node;
+
+  gcc_unreachable ();
+}
+
+static int
+get_int_kind_from_name (const char *name)
+{
+  return get_int_kind_from_node (get_typenode_from_name (name));
+}
+
+
+/* Get the kind number corresponding to an integer of given size,
+   following the required return values for ISO_FORTRAN_ENV INT* constants:
+   -2 is returned if we support a kind of larger size, -1 otherwise.  */
+int
+gfc_get_int_kind_from_width_isofortranenv (int size)
+{
+  int i;
+
+  /* Look for a kind with matching storage size.  */
+  for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
+    if (gfc_integer_kinds[i].bit_size == size)
+      return gfc_integer_kinds[i].kind;
+
+  /* Look for a kind with larger storage size.  */
+  for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
+    if (gfc_integer_kinds[i].bit_size > size)
+      return -2;
+
+  return -1;
+}
+
+/* Get the kind number corresponding to a real of given storage size,
+   following the required return values for ISO_FORTRAN_ENV REAL* constants:
+   -2 is returned if we support a kind of larger size, -1 otherwise.  */
+int
+gfc_get_real_kind_from_width_isofortranenv (int size)
+{
+  int i;
+
+  size /= 8;
+
+  /* Look for a kind with matching storage size.  */
+  for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+    if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) == size)
+      return gfc_real_kinds[i].kind;
+
+  /* Look for a kind with larger storage size.  */
+  for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+    if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) > size)
+      return -2;
+
+  return -1;
+}
+
+
+
+static int
+get_int_kind_from_width (int size)
+{
+  int i;
+
+  for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
+    if (gfc_integer_kinds[i].bit_size == size)
+      return gfc_integer_kinds[i].kind;
+
+  return -2;
+}
+
+static int
+get_int_kind_from_minimal_width (int size)
+{
+  int i;
+
+  for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
+    if (gfc_integer_kinds[i].bit_size >= size)
+      return gfc_integer_kinds[i].kind;
+
+  return -2;
+}
+
+
+/* Generate the CInteropKind_t objects for the C interoperable
+   kinds.  */
+
+void
+gfc_init_c_interop_kinds (void)
+{
+  int i;
+
+  /* init all pointers in the list to NULL */
+  for (i = 0; i < ISOCBINDING_NUMBER; i++)
+    {
+      /* Initialize the name and value fields.  */
+      c_interop_kinds_table[i].name[0] = '\0';
+      c_interop_kinds_table[i].value = -100;
+      c_interop_kinds_table[i].f90_type = BT_UNKNOWN;
+    }
+
+#define NAMED_INTCST(a,b,c,d) \
+  strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+  c_interop_kinds_table[a].f90_type = BT_INTEGER; \
+  c_interop_kinds_table[a].value = c;
+#define NAMED_REALCST(a,b,c,d) \
+  strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+  c_interop_kinds_table[a].f90_type = BT_REAL; \
+  c_interop_kinds_table[a].value = c;
+#define NAMED_CMPXCST(a,b,c,d) \
+  strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+  c_interop_kinds_table[a].f90_type = BT_COMPLEX; \
+  c_interop_kinds_table[a].value = c;
+#define NAMED_LOGCST(a,b,c) \
+  strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+  c_interop_kinds_table[a].f90_type = BT_LOGICAL; \
+  c_interop_kinds_table[a].value = c;
+#define NAMED_CHARKNDCST(a,b,c) \
+  strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+  c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
+  c_interop_kinds_table[a].value = c;
+#define NAMED_CHARCST(a,b,c) \
+  strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+  c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
+  c_interop_kinds_table[a].value = c;
+#define DERIVED_TYPE(a,b,c) \
+  strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+  c_interop_kinds_table[a].f90_type = BT_DERIVED; \
+  c_interop_kinds_table[a].value = c;
+#define NAMED_FUNCTION(a,b,c,d) \
+  strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+  c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
+  c_interop_kinds_table[a].value = c;
+#define NAMED_SUBROUTINE(a,b,c,d) \
+  strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+  c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
+  c_interop_kinds_table[a].value = c;
+#include "iso-c-binding.def"
+}
+
+
+/* Query the target to determine which machine modes are available for
+   computation.  Choose KIND numbers for them.  */
+
+void
+gfc_init_kinds (void)
+{
+  unsigned int mode;
+  int i_index, r_index, kind;
+  bool saw_i4 = false, saw_i8 = false;
+  bool saw_r4 = false, saw_r8 = false, saw_r10 = false, saw_r16 = false;
+
+  for (i_index = 0, mode = MIN_MODE_INT; mode <= MAX_MODE_INT; mode++)
+    {
+      int kind, bitsize;
+
+      if (!targetm.scalar_mode_supported_p ((enum machine_mode) mode))
+	continue;
+
+      /* The middle end doesn't support constants larger than 2*HWI.
+	 Perhaps the target hook shouldn't have accepted these either,
+	 but just to be safe...  */
+      bitsize = GET_MODE_BITSIZE (mode);
+      if (bitsize > 2*HOST_BITS_PER_WIDE_INT)
+	continue;
+
+      gcc_assert (i_index != MAX_INT_KINDS);
+
+      /* Let the kind equal the bit size divided by 8.  This insulates the
+	 programmer from the underlying byte size.  */
+      kind = bitsize / 8;
+
+      if (kind == 4)
+	saw_i4 = true;
+      if (kind == 8)
+	saw_i8 = true;
+
+      gfc_integer_kinds[i_index].kind = kind;
+      gfc_integer_kinds[i_index].radix = 2;
+      gfc_integer_kinds[i_index].digits = bitsize - 1;
+      gfc_integer_kinds[i_index].bit_size = bitsize;
+
+      gfc_logical_kinds[i_index].kind = kind;
+      gfc_logical_kinds[i_index].bit_size = bitsize;
+
+      i_index += 1;
+    }
+
+  /* Set the kind used to match GFC_INT_IO in libgfortran.  This is
+     used for large file access.  */
+
+  if (saw_i8)
+    gfc_intio_kind = 8;
+  else
+    gfc_intio_kind = 4;
+
+  /* If we do not at least have kind = 4, everything is pointless.  */
+  gcc_assert(saw_i4);
+
+  /* Set the maximum integer kind.  Used with at least BOZ constants.  */
+  gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind;
+
+  for (r_index = 0, mode = MIN_MODE_FLOAT; mode <= MAX_MODE_FLOAT; mode++)
+    {
+      const struct real_format *fmt =
+	REAL_MODE_FORMAT ((enum machine_mode) mode);
+      int kind;
+
+      if (fmt == NULL)
+	continue;
+      if (!targetm.scalar_mode_supported_p ((enum machine_mode) mode))
+	continue;
+
+      /* Only let float, double, long double and __float128 go through.
+	 Runtime support for others is not provided, so they would be
+	 useless.  */
+	if (mode != TYPE_MODE (float_type_node)
+	    && (mode != TYPE_MODE (double_type_node))
+	    && (mode != TYPE_MODE (long_double_type_node))
+#if defined(LIBGCC2_HAS_TF_MODE) && defined(ENABLE_LIBQUADMATH_SUPPORT)
+	    && (mode != TFmode)
+#endif
+	   )
+	continue;
+
+      /* Let the kind equal the precision divided by 8, rounding up.  Again,
+	 this insulates the programmer from the underlying byte size.
+
+	 Also, it effectively deals with IEEE extended formats.  There, the
+	 total size of the type may equal 16, but it's got 6 bytes of padding
+	 and the increased size can get in the way of a real IEEE quad format
+	 which may also be supported by the target.
+
+	 We round up so as to handle IA-64 __floatreg (RFmode), which is an
+	 82 bit type.  Not to be confused with __float80 (XFmode), which is
+	 an 80 bit type also supported by IA-64.  So XFmode should come out
+	 to be kind=10, and RFmode should come out to be kind=11.  Egads.  */
+
+      kind = (GET_MODE_PRECISION (mode) + 7) / 8;
+
+      if (kind == 4)
+	saw_r4 = true;
+      if (kind == 8)
+	saw_r8 = true;
+      if (kind == 10)
+	saw_r10 = true;
+      if (kind == 16)
+	saw_r16 = true;
+
+      /* Careful we don't stumble a weird internal mode.  */
+      gcc_assert (r_index <= 0 || gfc_real_kinds[r_index-1].kind != kind);
+      /* Or have too many modes for the allocated space.  */
+      gcc_assert (r_index != MAX_REAL_KINDS);
+
+      gfc_real_kinds[r_index].kind = kind;
+      gfc_real_kinds[r_index].radix = fmt->b;
+      gfc_real_kinds[r_index].digits = fmt->p;
+      gfc_real_kinds[r_index].min_exponent = fmt->emin;
+      gfc_real_kinds[r_index].max_exponent = fmt->emax;
+      if (fmt->pnan < fmt->p)
+	/* This is an IBM extended double format (or the MIPS variant)
+	   made up of two IEEE doubles.  The value of the long double is
+	   the sum of the values of the two parts.  The most significant
+	   part is required to be the value of the long double rounded
+	   to the nearest double.  If we use emax of 1024 then we can't
+	   represent huge(x) = (1 - b**(-p)) * b**(emax-1) * b, because
+	   rounding will make the most significant part overflow.  */
+	gfc_real_kinds[r_index].max_exponent = fmt->emax - 1;
+      gfc_real_kinds[r_index].mode_precision = GET_MODE_PRECISION (mode);
+      r_index += 1;
+    }
+
+  /* Choose the default integer kind.  We choose 4 unless the user directs us
+     otherwise.  Even if the user specified that the default integer kind is 8,
+     the numeric storage size is not 64 bits.  In this case, a warning will be
+     issued when NUMERIC_STORAGE_SIZE is used.  Set NUMERIC_STORAGE_SIZE to 32.  */
+
+  gfc_numeric_storage_size = 4 * 8;
+
+  if (gfc_option.flag_default_integer)
+    {
+      if (!saw_i8)
+	fatal_error ("INTEGER(KIND=8) is not available for -fdefault-integer-8 option");
+
+      gfc_default_integer_kind = 8;
+
+    }
+  else if (gfc_option.flag_integer4_kind == 8)
+    {
+      if (!saw_i8)
+	fatal_error ("INTEGER(KIND=8) is not available for -finteger-4-integer-8 option");
+
+      gfc_default_integer_kind = 8;
+    }
+  else if (saw_i4)
+    {
+      gfc_default_integer_kind = 4;
+    }
+  else
+    {
+      gfc_default_integer_kind = gfc_integer_kinds[i_index - 1].kind;
+      gfc_numeric_storage_size = gfc_integer_kinds[i_index - 1].bit_size;
+    }
+
+  /* Choose the default real kind.  Again, we choose 4 when possible.  */
+  if (gfc_option.flag_default_real)
+    {
+      if (!saw_r8)
+	fatal_error ("REAL(KIND=8) is not available for -fdefault-real-8 option");
+
+      gfc_default_real_kind = 8;
+    }
+  else if (gfc_option.flag_real4_kind == 8)
+  {
+    if (!saw_r8)
+      fatal_error ("REAL(KIND=8) is not available for -freal-4-real-8 option");
+
+    gfc_default_real_kind = 8;
+  }
+  else if (gfc_option.flag_real4_kind == 10)
+  {
+    if (!saw_r10)
+      fatal_error ("REAL(KIND=10) is not available for -freal-4-real-10 option");
+
+    gfc_default_real_kind = 10;
+  }
+  else if (gfc_option.flag_real4_kind == 16)
+  {
+    if (!saw_r16)
+      fatal_error ("REAL(KIND=16) is not available for -freal-4-real-16 option");
+
+    gfc_default_real_kind = 16;
+  }
+  else if (saw_r4)
+    gfc_default_real_kind = 4;
+  else
+    gfc_default_real_kind = gfc_real_kinds[0].kind;
+
+  /* Choose the default double kind.  If -fdefault-real and -fdefault-double
+     are specified, we use kind=8, if it's available.  If -fdefault-real is
+     specified without -fdefault-double, we use kind=16, if it's available.
+     Otherwise we do not change anything.  */
+  if (gfc_option.flag_default_double && !gfc_option.flag_default_real)
+    fatal_error ("Use of -fdefault-double-8 requires -fdefault-real-8");
+
+  if (gfc_option.flag_default_real && gfc_option.flag_default_double && saw_r8)
+    gfc_default_double_kind = 8;
+  else if (gfc_option.flag_default_real && saw_r16)
+    gfc_default_double_kind = 16;
+  else if (gfc_option.flag_real8_kind == 4)
+    {
+      if (!saw_r4)
+	fatal_error ("REAL(KIND=4) is not available for -freal-8-real-4 option");
+
+	gfc_default_double_kind = 4;
+    }
+  else if (gfc_option.flag_real8_kind == 10 )
+    {
+      if (!saw_r10)
+	fatal_error ("REAL(KIND=10) is not available for -freal-8-real-10 option");
+
+	gfc_default_double_kind = 10;
+    }
+  else if (gfc_option.flag_real8_kind == 16 )
+    {
+      if (!saw_r16)
+	fatal_error ("REAL(KIND=10) is not available for -freal-8-real-16 option");
+
+	gfc_default_double_kind = 16;
+    }
+  else if (saw_r4 && saw_r8)
+    gfc_default_double_kind = 8;
+  else
+    {
+      /* F95 14.6.3.1: A nonpointer scalar object of type double precision
+	 real ... occupies two contiguous numeric storage units.
+
+	 Therefore we must be supplied a kind twice as large as we chose
+	 for single precision.  There are loopholes, in that double
+	 precision must *occupy* two storage units, though it doesn't have
+	 to *use* two storage units.  Which means that you can make this
+	 kind artificially wide by padding it.  But at present there are
+	 no GCC targets for which a two-word type does not exist, so we
+	 just let gfc_validate_kind abort and tell us if something breaks.  */
+
+      gfc_default_double_kind
+	= gfc_validate_kind (BT_REAL, gfc_default_real_kind * 2, false);
+    }
+
+  /* The default logical kind is constrained to be the same as the
+     default integer kind.  Similarly with complex and real.  */
+  gfc_default_logical_kind = gfc_default_integer_kind;
+  gfc_default_complex_kind = gfc_default_real_kind;
+
+  /* We only have two character kinds: ASCII and UCS-4.
+     ASCII corresponds to a 8-bit integer type, if one is available.
+     UCS-4 corresponds to a 32-bit integer type, if one is available. */
+  i_index = 0;
+  if ((kind = get_int_kind_from_width (8)) > 0)
+    {
+      gfc_character_kinds[i_index].kind = kind;
+      gfc_character_kinds[i_index].bit_size = 8;
+      gfc_character_kinds[i_index].name = "ascii";
+      i_index++;
+    }
+  if ((kind = get_int_kind_from_width (32)) > 0)
+    {
+      gfc_character_kinds[i_index].kind = kind;
+      gfc_character_kinds[i_index].bit_size = 32;
+      gfc_character_kinds[i_index].name = "iso_10646";
+      i_index++;
+    }
+
+  /* Choose the smallest integer kind for our default character.  */
+  gfc_default_character_kind = gfc_character_kinds[0].kind;
+  gfc_character_storage_size = gfc_default_character_kind * 8;
+
+  gfc_index_integer_kind = get_int_kind_from_name (PTRDIFF_TYPE);
+
+  /* Pick a kind the same size as the C "int" type.  */
+  gfc_c_int_kind = INT_TYPE_SIZE / 8;
+
+  /* Choose atomic kinds to match C's int.  */
+  gfc_atomic_int_kind = gfc_c_int_kind;
+  gfc_atomic_logical_kind = gfc_c_int_kind;
+}
+
+
+/* Make sure that a valid kind is present.  Returns an index into the
+   associated kinds array, -1 if the kind is not present.  */
+
+static int
+validate_integer (int kind)
+{
+  int i;
+
+  for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
+    if (gfc_integer_kinds[i].kind == kind)
+      return i;
+
+  return -1;
+}
+
+static int
+validate_real (int kind)
+{
+  int i;
+
+  for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+    if (gfc_real_kinds[i].kind == kind)
+      return i;
+
+  return -1;
+}
+
+static int
+validate_logical (int kind)
+{
+  int i;
+
+  for (i = 0; gfc_logical_kinds[i].kind; i++)
+    if (gfc_logical_kinds[i].kind == kind)
+      return i;
+
+  return -1;
+}
+
+static int
+validate_character (int kind)
+{
+  int i;
+
+  for (i = 0; gfc_character_kinds[i].kind; i++)
+    if (gfc_character_kinds[i].kind == kind)
+      return i;
+
+  return -1;
+}
+
+/* Validate a kind given a basic type.  The return value is the same
+   for the child functions, with -1 indicating nonexistence of the
+   type.  If MAY_FAIL is false, then -1 is never returned, and we ICE.  */
+
+int
+gfc_validate_kind (bt type, int kind, bool may_fail)
+{
+  int rc;
+
+  switch (type)
+    {
+    case BT_REAL:		/* Fall through */
+    case BT_COMPLEX:
+      rc = validate_real (kind);
+      break;
+    case BT_INTEGER:
+      rc = validate_integer (kind);
+      break;
+    case BT_LOGICAL:
+      rc = validate_logical (kind);
+      break;
+    case BT_CHARACTER:
+      rc = validate_character (kind);
+      break;
+
+    default:
+      gfc_internal_error ("gfc_validate_kind(): Got bad type");
+    }
+
+  if (rc < 0 && !may_fail)
+    gfc_internal_error ("gfc_validate_kind(): Got bad kind");
+
+  return rc;
+}
+
+
+/* Four subroutines of gfc_init_types.  Create type nodes for the given kind.
+   Reuse common type nodes where possible.  Recognize if the kind matches up
+   with a C type.  This will be used later in determining which routines may
+   be scarfed from libm.  */
+
+static tree
+gfc_build_int_type (gfc_integer_info *info)
+{
+  int mode_precision = info->bit_size;
+
+  if (mode_precision == CHAR_TYPE_SIZE)
+    info->c_char = 1;
+  if (mode_precision == SHORT_TYPE_SIZE)
+    info->c_short = 1;
+  if (mode_precision == INT_TYPE_SIZE)
+    info->c_int = 1;
+  if (mode_precision == LONG_TYPE_SIZE)
+    info->c_long = 1;
+  if (mode_precision == LONG_LONG_TYPE_SIZE)
+    info->c_long_long = 1;
+
+  if (TYPE_PRECISION (intQI_type_node) == mode_precision)
+    return intQI_type_node;
+  if (TYPE_PRECISION (intHI_type_node) == mode_precision)
+    return intHI_type_node;
+  if (TYPE_PRECISION (intSI_type_node) == mode_precision)
+    return intSI_type_node;
+  if (TYPE_PRECISION (intDI_type_node) == mode_precision)
+    return intDI_type_node;
+  if (TYPE_PRECISION (intTI_type_node) == mode_precision)
+    return intTI_type_node;
+
+  return make_signed_type (mode_precision);
+}
+
+tree
+gfc_build_uint_type (int size)
+{
+  if (size == CHAR_TYPE_SIZE)
+    return unsigned_char_type_node;
+  if (size == SHORT_TYPE_SIZE)
+    return short_unsigned_type_node;
+  if (size == INT_TYPE_SIZE)
+    return unsigned_type_node;
+  if (size == LONG_TYPE_SIZE)
+    return long_unsigned_type_node;
+  if (size == LONG_LONG_TYPE_SIZE)
+    return long_long_unsigned_type_node;
+
+  return make_unsigned_type (size);
+}
+
+
+static tree
+gfc_build_real_type (gfc_real_info *info)
+{
+  int mode_precision = info->mode_precision;
+  tree new_type;
+
+  if (mode_precision == FLOAT_TYPE_SIZE)
+    info->c_float = 1;
+  if (mode_precision == DOUBLE_TYPE_SIZE)
+    info->c_double = 1;
+  if (mode_precision == LONG_DOUBLE_TYPE_SIZE)
+    info->c_long_double = 1;
+  if (mode_precision != LONG_DOUBLE_TYPE_SIZE && mode_precision == 128)
+    {
+      info->c_float128 = 1;
+      gfc_real16_is_float128 = true;
+    }
+
+  if (TYPE_PRECISION (float_type_node) == mode_precision)
+    return float_type_node;
+  if (TYPE_PRECISION (double_type_node) == mode_precision)
+    return double_type_node;
+  if (TYPE_PRECISION (long_double_type_node) == mode_precision)
+    return long_double_type_node;
+
+  new_type = make_node (REAL_TYPE);
+  TYPE_PRECISION (new_type) = mode_precision;
+  layout_type (new_type);
+  return new_type;
+}
+
+static tree
+gfc_build_complex_type (tree scalar_type)
+{
+  tree new_type;
+
+  if (scalar_type == NULL)
+    return NULL;
+  if (scalar_type == float_type_node)
+    return complex_float_type_node;
+  if (scalar_type == double_type_node)
+    return complex_double_type_node;
+  if (scalar_type == long_double_type_node)
+    return complex_long_double_type_node;
+
+  new_type = make_node (COMPLEX_TYPE);
+  TREE_TYPE (new_type) = scalar_type;
+  layout_type (new_type);
+  return new_type;
+}
+
+static tree
+gfc_build_logical_type (gfc_logical_info *info)
+{
+  int bit_size = info->bit_size;
+  tree new_type;
+
+  if (bit_size == BOOL_TYPE_SIZE)
+    {
+      info->c_bool = 1;
+      return boolean_type_node;
+    }
+
+  new_type = make_unsigned_type (bit_size);
+  TREE_SET_CODE (new_type, BOOLEAN_TYPE);
+  TYPE_MAX_VALUE (new_type) = build_int_cst (new_type, 1);
+  TYPE_PRECISION (new_type) = 1;
+
+  return new_type;
+}
+
+
+/* Create the backend type nodes. We map them to their
+   equivalent C type, at least for now.  We also give
+   names to the types here, and we push them in the
+   global binding level context.*/
+
+void
+gfc_init_types (void)
+{
+  char name_buf[18];
+  int index;
+  tree type;
+  unsigned n;
+  unsigned HOST_WIDE_INT hi;
+  unsigned HOST_WIDE_INT lo;
+
+  /* Create and name the types.  */
+#define PUSH_TYPE(name, node) \
+  pushdecl (build_decl (input_location, \
+			TYPE_DECL, get_identifier (name), node))
+
+  for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
+    {
+      type = gfc_build_int_type (&gfc_integer_kinds[index]);
+      /* Ensure integer(kind=1) doesn't have TYPE_STRING_FLAG set.  */
+      if (TYPE_STRING_FLAG (type))
+	type = make_signed_type (gfc_integer_kinds[index].bit_size);
+      gfc_integer_types[index] = type;
+      snprintf (name_buf, sizeof(name_buf), "integer(kind=%d)",
+		gfc_integer_kinds[index].kind);
+      PUSH_TYPE (name_buf, type);
+    }
+
+  for (index = 0; gfc_logical_kinds[index].kind != 0; ++index)
+    {
+      type = gfc_build_logical_type (&gfc_logical_kinds[index]);
+      gfc_logical_types[index] = type;
+      snprintf (name_buf, sizeof(name_buf), "logical(kind=%d)",
+		gfc_logical_kinds[index].kind);
+      PUSH_TYPE (name_buf, type);
+    }
+
+  for (index = 0; gfc_real_kinds[index].kind != 0; index++)
+    {
+      type = gfc_build_real_type (&gfc_real_kinds[index]);
+      gfc_real_types[index] = type;
+      snprintf (name_buf, sizeof(name_buf), "real(kind=%d)",
+		gfc_real_kinds[index].kind);
+      PUSH_TYPE (name_buf, type);
+
+      if (gfc_real_kinds[index].c_float128)
+	float128_type_node = type;
+
+      type = gfc_build_complex_type (type);
+      gfc_complex_types[index] = type;
+      snprintf (name_buf, sizeof(name_buf), "complex(kind=%d)",
+		gfc_real_kinds[index].kind);
+      PUSH_TYPE (name_buf, type);
+
+      if (gfc_real_kinds[index].c_float128)
+	complex_float128_type_node = type;
+    }
+
+  for (index = 0; gfc_character_kinds[index].kind != 0; ++index)
+    {
+      type = gfc_build_uint_type (gfc_character_kinds[index].bit_size);
+      type = build_qualified_type (type, TYPE_UNQUALIFIED);
+      snprintf (name_buf, sizeof(name_buf), "character(kind=%d)",
+		gfc_character_kinds[index].kind);
+      PUSH_TYPE (name_buf, type);
+      gfc_character_types[index] = type;
+      gfc_pcharacter_types[index] = build_pointer_type (type);
+    }
+  gfc_character1_type_node = gfc_character_types[0];
+
+  PUSH_TYPE ("byte", unsigned_char_type_node);
+  PUSH_TYPE ("void", void_type_node);
+
+  /* DBX debugging output gets upset if these aren't set.  */
+  if (!TYPE_NAME (integer_type_node))
+    PUSH_TYPE ("c_integer", integer_type_node);
+  if (!TYPE_NAME (char_type_node))
+    PUSH_TYPE ("c_char", char_type_node);
+
+#undef PUSH_TYPE
+
+  pvoid_type_node = build_pointer_type (void_type_node);
+  prvoid_type_node = build_qualified_type (pvoid_type_node, TYPE_QUAL_RESTRICT);
+  ppvoid_type_node = build_pointer_type (pvoid_type_node);
+  pchar_type_node = build_pointer_type (gfc_character1_type_node);
+  pfunc_type_node
+    = build_pointer_type (build_function_type_list (void_type_node, NULL_TREE));
+
+  gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind);
+  /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
+     since this function is called before gfc_init_constants.  */
+  gfc_array_range_type
+	  = build_range_type (gfc_array_index_type,
+			      build_int_cst (gfc_array_index_type, 0),
+			      NULL_TREE);
+
+  /* The maximum array element size that can be handled is determined
+     by the number of bits available to store this field in the array
+     descriptor.  */
+
+  n = TYPE_PRECISION (gfc_array_index_type) - GFC_DTYPE_SIZE_SHIFT;
+  lo = ~ (unsigned HOST_WIDE_INT) 0;
+  if (n > HOST_BITS_PER_WIDE_INT)
+    hi = lo >> (2*HOST_BITS_PER_WIDE_INT - n);
+  else
+    hi = 0, lo >>= HOST_BITS_PER_WIDE_INT - n;
+  gfc_max_array_element_size
+    = build_int_cst_wide (long_unsigned_type_node, lo, hi);
+
+  boolean_type_node = gfc_get_logical_type (gfc_default_logical_kind);
+  boolean_true_node = build_int_cst (boolean_type_node, 1);
+  boolean_false_node = build_int_cst (boolean_type_node, 0);
+
+  /* ??? Shouldn't this be based on gfc_index_integer_kind or so?  */
+  gfc_charlen_int_kind = 4;
+  gfc_charlen_type_node = gfc_get_int_type (gfc_charlen_int_kind);
+}
+
+/* Get the type node for the given type and kind.  */
+
+tree
+gfc_get_int_type (int kind)
+{
+  int index = gfc_validate_kind (BT_INTEGER, kind, true);
+  return index < 0 ? 0 : gfc_integer_types[index];
+}
+
+tree
+gfc_get_real_type (int kind)
+{
+  int index = gfc_validate_kind (BT_REAL, kind, true);
+  return index < 0 ? 0 : gfc_real_types[index];
+}
+
+tree
+gfc_get_complex_type (int kind)
+{
+  int index = gfc_validate_kind (BT_COMPLEX, kind, true);
+  return index < 0 ? 0 : gfc_complex_types[index];
+}
+
+tree
+gfc_get_logical_type (int kind)
+{
+  int index = gfc_validate_kind (BT_LOGICAL, kind, true);
+  return index < 0 ? 0 : gfc_logical_types[index];
+}
+
+tree
+gfc_get_char_type (int kind)
+{
+  int index = gfc_validate_kind (BT_CHARACTER, kind, true);
+  return index < 0 ? 0 : gfc_character_types[index];
+}
+
+tree
+gfc_get_pchar_type (int kind)
+{
+  int index = gfc_validate_kind (BT_CHARACTER, kind, true);
+  return index < 0 ? 0 : gfc_pcharacter_types[index];
+}
+
+
+/* Create a character type with the given kind and length.  */
+
+tree
+gfc_get_character_type_len_for_eltype (tree eltype, tree len)
+{
+  tree bounds, type;
+
+  bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len);
+  type = build_array_type (eltype, bounds);
+  TYPE_STRING_FLAG (type) = 1;
+
+  return type;
+}
+
+tree
+gfc_get_character_type_len (int kind, tree len)
+{
+  gfc_validate_kind (BT_CHARACTER, kind, false);
+  return gfc_get_character_type_len_for_eltype (gfc_get_char_type (kind), len);
+}
+
+
+/* Get a type node for a character kind.  */
+
+tree
+gfc_get_character_type (int kind, gfc_charlen * cl)
+{
+  tree len;
+
+  len = (cl == NULL) ? NULL_TREE : cl->backend_decl;
+
+  return gfc_get_character_type_len (kind, len);
+}
+
+/* Covert a basic type.  This will be an array for character types.  */
+
+tree
+gfc_typenode_for_spec (gfc_typespec * spec)
+{
+  tree basetype;
+
+  switch (spec->type)
+    {
+    case BT_UNKNOWN:
+      gcc_unreachable ();
+
+    case BT_INTEGER:
+      /* We use INTEGER(c_intptr_t) for C_PTR and C_FUNPTR once the symbol
+         has been resolved.  This is done so we can convert C_PTR and
+         C_FUNPTR to simple variables that get translated to (void *).  */
+      if (spec->f90_type == BT_VOID)
+	{
+	  if (spec->u.derived
+	      && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR)
+	    basetype = ptr_type_node;
+	  else
+	    basetype = pfunc_type_node;
+	}
+      else
+        basetype = gfc_get_int_type (spec->kind);
+      break;
+
+    case BT_REAL:
+      basetype = gfc_get_real_type (spec->kind);
+      break;
+
+    case BT_COMPLEX:
+      basetype = gfc_get_complex_type (spec->kind);
+      break;
+
+    case BT_LOGICAL:
+      basetype = gfc_get_logical_type (spec->kind);
+      break;
+
+    case BT_CHARACTER:
+#if 0
+      if (spec->deferred)
+	basetype = gfc_get_character_type (spec->kind, NULL);
+      else
+#endif
+	basetype = gfc_get_character_type (spec->kind, spec->u.cl);
+      break;
+
+    case BT_HOLLERITH:
+      /* Since this cannot be used, return a length one character.  */
+      basetype = gfc_get_character_type_len (gfc_default_character_kind,
+					     gfc_index_one_node);
+      break;
+
+    case BT_DERIVED:
+    case BT_CLASS:
+      basetype = gfc_get_derived_type (spec->u.derived);
+
+      if (spec->type == BT_CLASS)
+	GFC_CLASS_TYPE_P (basetype) = 1;
+
+      /* If we're dealing with either C_PTR or C_FUNPTR, we modified the
+         type and kind to fit a (void *) and the basetype returned was a
+         ptr_type_node.  We need to pass up this new information to the
+         symbol that was declared of type C_PTR or C_FUNPTR.  */
+      if (spec->u.derived->ts.f90_type == BT_VOID)
+        {
+          spec->type = BT_INTEGER;
+          spec->kind = gfc_index_integer_kind;
+          spec->f90_type = BT_VOID;
+        }
+      break;
+    case BT_VOID:
+    case BT_ASSUMED:
+      /* This is for the second arg to c_f_pointer and c_f_procpointer
+         of the iso_c_binding module, to accept any ptr type.  */
+      basetype = ptr_type_node;
+      if (spec->f90_type == BT_VOID)
+	{
+	  if (spec->u.derived
+	      && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR)
+	    basetype = ptr_type_node;
+	  else
+	    basetype = pfunc_type_node;
+	}
+       break;
+    default:
+      gcc_unreachable ();
+    }
+  return basetype;
+}
+
+/* Build an INT_CST for constant expressions, otherwise return NULL_TREE.  */
+
+static tree
+gfc_conv_array_bound (gfc_expr * expr)
+{
+  /* If expr is an integer constant, return that.  */
+  if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
+    return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind);
+
+  /* Otherwise return NULL.  */
+  return NULL_TREE;
+}
+
+tree
+gfc_get_element_type (tree type)
+{
+  tree element;
+
+  if (GFC_ARRAY_TYPE_P (type))
+    {
+      if (TREE_CODE (type) == POINTER_TYPE)
+        type = TREE_TYPE (type);
+      if (GFC_TYPE_ARRAY_RANK (type) == 0)
+	{
+	  gcc_assert (GFC_TYPE_ARRAY_CORANK (type) > 0);
+	  element = type;
+	}
+      else
+	{
+	  gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
+	  element = TREE_TYPE (type);
+	}
+    }
+  else
+    {
+      gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+      element = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
+
+      gcc_assert (TREE_CODE (element) == POINTER_TYPE);
+      element = TREE_TYPE (element);
+
+      /* For arrays, which are not scalar coarrays.  */
+      if (TREE_CODE (element) == ARRAY_TYPE && !TYPE_STRING_FLAG (element))
+	element = TREE_TYPE (element);
+    }
+
+  return element;
+}
+
+/* Build an array.  This function is called from gfc_sym_type().
+   Actually returns array descriptor type.
+
+   Format of array descriptors is as follows:
+
+    struct gfc_array_descriptor
+    {
+      array *data
+      index offset;
+      index dtype;
+      struct descriptor_dimension dimension[N_DIM];
+    }
+
+    struct descriptor_dimension
+    {
+      index stride;
+      index lbound;
+      index ubound;
+    }
+
+   Translation code should use gfc_conv_descriptor_* rather than
+   accessing the descriptor directly.  Any changes to the array
+   descriptor type will require changes in gfc_conv_descriptor_* and
+   gfc_build_array_initializer.
+
+   This is represented internally as a RECORD_TYPE. The index nodes
+   are gfc_array_index_type and the data node is a pointer to the
+   data.  See below for the handling of character types.
+
+   The dtype member is formatted as follows:
+    rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits
+    type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
+    size = dtype >> GFC_DTYPE_SIZE_SHIFT
+
+   I originally used nested ARRAY_TYPE nodes to represent arrays, but
+   this generated poor code for assumed/deferred size arrays.  These
+   require use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part
+   of the GENERIC grammar.  Also, there is no way to explicitly set
+   the array stride, so all data must be packed(1).  I've tried to
+   mark all the functions which would require modification with a GCC
+   ARRAYS comment.
+
+   The data component points to the first element in the array.  The
+   offset field is the position of the origin of the array (i.e. element
+   (0, 0 ...)).  This may be outside the bounds of the array.
+
+   An element is accessed by
+    data[offset + index0*stride0 + index1*stride1 + index2*stride2]
+   This gives good performance as the computation does not involve the
+   bounds of the array.  For packed arrays, this is optimized further
+   by substituting the known strides.
+
+   This system has one problem: all array bounds must be within 2^31
+   elements of the origin (2^63 on 64-bit machines).  For example
+    integer, dimension (80000:90000, 80000:90000, 2) :: array
+   may not work properly on 32-bit machines because 80000*80000 >
+   2^31, so the calculation for stride2 would overflow.  This may
+   still work, but I haven't checked, and it relies on the overflow
+   doing the right thing.
+
+   The way to fix this problem is to access elements as follows:
+    data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
+   Obviously this is much slower.  I will make this a compile time
+   option, something like -fsmall-array-offsets.  Mixing code compiled
+   with and without this switch will work.
+
+   (1) This can be worked around by modifying the upper bound of the
+   previous dimension.  This requires extra fields in the descriptor
+   (both real_ubound and fake_ubound).  */
+
+
+/* Returns true if the array sym does not require a descriptor.  */
+
+int
+gfc_is_nodesc_array (gfc_symbol * sym)
+{
+  gcc_assert (sym->attr.dimension || sym->attr.codimension);
+
+  /* We only want local arrays.  */
+  if (sym->attr.pointer || sym->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)
+    return 0;
+
+  if (sym->attr.dummy)
+    return sym->as->type != AS_ASSUMED_SHAPE
+	   && sym->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);
+
+  return 1;
+}
+
+
+/* Create an array descriptor type.  */
+
+static tree
+gfc_build_array_type (tree type, gfc_array_spec * as,
+		      enum gfc_array_kind akind, bool restricted,
+		      bool contiguous)
+{
+  tree lbound[GFC_MAX_DIMENSIONS];
+  tree ubound[GFC_MAX_DIMENSIONS];
+  int n;
+
+  if (as->type == AS_ASSUMED_RANK)
+    for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
+      {
+	lbound[n] = NULL_TREE;
+	ubound[n] = NULL_TREE;
+      }
+
+  for (n = 0; n < as->rank; n++)
+    {
+      /* Create expressions for the known bounds of the array.  */
+      if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL)
+        lbound[n] = gfc_index_one_node;
+      else
+        lbound[n] = gfc_conv_array_bound (as->lower[n]);
+      ubound[n] = gfc_conv_array_bound (as->upper[n]);
+    }
+
+  for (n = as->rank; n < as->rank + as->corank; n++)
+    {
+      if (as->type != AS_DEFERRED && as->lower[n] == NULL)
+        lbound[n] = gfc_index_one_node;
+      else
+        lbound[n] = gfc_conv_array_bound (as->lower[n]);
+
+      if (n < as->rank + as->corank - 1)
+	ubound[n] = gfc_conv_array_bound (as->upper[n]);
+    }
+
+  if (as->type == AS_ASSUMED_SHAPE)
+    akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT
+		       : GFC_ARRAY_ASSUMED_SHAPE;
+  else if (as->type == AS_ASSUMED_RANK)
+    akind = contiguous ? GFC_ARRAY_ASSUMED_RANK_CONT
+		       : GFC_ARRAY_ASSUMED_RANK;
+  return gfc_get_array_type_bounds (type, as->rank == -1
+					  ? GFC_MAX_DIMENSIONS : as->rank,
+				    as->corank, lbound,
+				    ubound, 0, akind, restricted);
+}
+
+/* Returns the struct descriptor_dimension type.  */
+
+static tree
+gfc_get_desc_dim_type (void)
+{
+  tree type;
+  tree decl, *chain = NULL;
+
+  if (gfc_desc_dim_type)
+    return gfc_desc_dim_type;
+
+  /* Build the type node.  */
+  type = make_node (RECORD_TYPE);
+
+  TYPE_NAME (type) = get_identifier ("descriptor_dimension");
+  TYPE_PACKED (type) = 1;
+
+  /* Consists of the stride, lbound and ubound members.  */
+  decl = gfc_add_field_to_struct_1 (type,
+				    get_identifier ("stride"),
+				    gfc_array_index_type, &chain);
+  TREE_NO_WARNING (decl) = 1;
+
+  decl = gfc_add_field_to_struct_1 (type,
+				    get_identifier ("lbound"),
+				    gfc_array_index_type, &chain);
+  TREE_NO_WARNING (decl) = 1;
+
+  decl = gfc_add_field_to_struct_1 (type,
+				    get_identifier ("ubound"),
+				    gfc_array_index_type, &chain);
+  TREE_NO_WARNING (decl) = 1;
+
+  /* Finish off the type.  */
+  gfc_finish_type (type);
+  TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1;
+
+  gfc_desc_dim_type = type;
+  return type;
+}
+
+
+/* Return the DTYPE for an array.  This describes the type and type parameters
+   of the array.  */
+/* TODO: Only call this when the value is actually used, and make all the
+   unknown cases abort.  */
+
+tree
+gfc_get_dtype (tree type)
+{
+  tree size;
+  int n;
+  HOST_WIDE_INT i;
+  tree tmp;
+  tree dtype;
+  tree etype;
+  int rank;
+
+  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type));
+
+  if (GFC_TYPE_ARRAY_DTYPE (type))
+    return GFC_TYPE_ARRAY_DTYPE (type);
+
+  rank = GFC_TYPE_ARRAY_RANK (type);
+  etype = gfc_get_element_type (type);
+
+  switch (TREE_CODE (etype))
+    {
+    case INTEGER_TYPE:
+      n = BT_INTEGER;
+      break;
+
+    case BOOLEAN_TYPE:
+      n = BT_LOGICAL;
+      break;
+
+    case REAL_TYPE:
+      n = BT_REAL;
+      break;
+
+    case COMPLEX_TYPE:
+      n = BT_COMPLEX;
+      break;
+
+    /* We will never have arrays of arrays.  */
+    case RECORD_TYPE:
+      n = BT_DERIVED;
+      break;
+
+    case ARRAY_TYPE:
+      n = BT_CHARACTER;
+      break;
+
+    case POINTER_TYPE:
+      n = BT_ASSUMED;
+      break;
+
+    default:
+      /* TODO: Don't do dtype for temporary descriptorless arrays.  */
+      /* We can strange array types for temporary arrays.  */
+      return gfc_index_zero_node;
+    }
+
+  gcc_assert (rank <= GFC_DTYPE_RANK_MASK);
+  size = TYPE_SIZE_UNIT (etype);
+
+  i = rank | (n << GFC_DTYPE_TYPE_SHIFT);
+  if (size && INTEGER_CST_P (size))
+    {
+      if (tree_int_cst_lt (gfc_max_array_element_size, size))
+	gfc_fatal_error ("Array element size too big at %C");
+
+      i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT;
+    }
+  dtype = build_int_cst (gfc_array_index_type, i);
+
+  if (size && !INTEGER_CST_P (size))
+    {
+      tmp = build_int_cst (gfc_array_index_type, GFC_DTYPE_SIZE_SHIFT);
+      tmp  = fold_build2_loc (input_location, LSHIFT_EXPR,
+			      gfc_array_index_type,
+			      fold_convert (gfc_array_index_type, size), tmp);
+      dtype = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			       tmp, dtype);
+    }
+  /* If we don't know the size we leave it as zero.  This should never happen
+     for anything that is actually used.  */
+  /* TODO: Check this is actually true, particularly when repacking
+     assumed size parameters.  */
+
+  GFC_TYPE_ARRAY_DTYPE (type) = dtype;
+  return dtype;
+}
+
+
+/* Build an array type for use without a descriptor, packed according
+   to the value of PACKED.  */
+
+tree
+gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
+			   bool restricted)
+{
+  tree range;
+  tree type;
+  tree tmp;
+  int n;
+  int known_stride;
+  int known_offset;
+  mpz_t offset;
+  mpz_t stride;
+  mpz_t delta;
+  gfc_expr *expr;
+
+  mpz_init_set_ui (offset, 0);
+  mpz_init_set_ui (stride, 1);
+  mpz_init (delta);
+
+  /* We don't use build_array_type because this does not include include
+     lang-specific information (i.e. the bounds of the array) when checking
+     for duplicates.  */
+  if (as->rank)
+    type = make_node (ARRAY_TYPE);
+  else
+    type = build_variant_type_copy (etype);
+
+  GFC_ARRAY_TYPE_P (type) = 1;
+  TYPE_LANG_SPECIFIC (type)
+      = ggc_alloc_cleared_lang_type (sizeof (struct lang_type));
+
+  known_stride = (packed != PACKED_NO);
+  known_offset = 1;
+  for (n = 0; n < as->rank; n++)
+    {
+      /* Fill in the stride and bound components of the type.  */
+      if (known_stride)
+	tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
+      else
+        tmp = NULL_TREE;
+      GFC_TYPE_ARRAY_STRIDE (type, n) = tmp;
+
+      expr = as->lower[n];
+      if (expr->expr_type == EXPR_CONSTANT)
+        {
+          tmp = gfc_conv_mpz_to_tree (expr->value.integer,
+				      gfc_index_integer_kind);
+        }
+      else
+        {
+          known_stride = 0;
+          tmp = NULL_TREE;
+        }
+      GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
+
+      if (known_stride)
+	{
+          /* Calculate the offset.  */
+          mpz_mul (delta, stride, as->lower[n]->value.integer);
+          mpz_sub (offset, offset, delta);
+	}
+      else
+	known_offset = 0;
+
+      expr = as->upper[n];
+      if (expr && expr->expr_type == EXPR_CONSTANT)
+        {
+	  tmp = gfc_conv_mpz_to_tree (expr->value.integer,
+			          gfc_index_integer_kind);
+        }
+      else
+        {
+          tmp = NULL_TREE;
+          known_stride = 0;
+        }
+      GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
+
+      if (known_stride)
+        {
+          /* Calculate the stride.  */
+          mpz_sub (delta, as->upper[n]->value.integer,
+	           as->lower[n]->value.integer);
+          mpz_add_ui (delta, delta, 1);
+          mpz_mul (stride, stride, delta);
+        }
+
+      /* Only the first stride is known for partial packed arrays.  */
+      if (packed == PACKED_NO || packed == PACKED_PARTIAL)
+        known_stride = 0;
+    }
+  for (n = as->rank; n < as->rank + as->corank; n++)
+    {
+      expr = as->lower[n];
+      if (expr->expr_type == EXPR_CONSTANT)
+	tmp = gfc_conv_mpz_to_tree (expr->value.integer,
+				    gfc_index_integer_kind);
+      else
+      	tmp = NULL_TREE;
+      GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
+
+      expr = as->upper[n];
+      if (expr && expr->expr_type == EXPR_CONSTANT)
+	tmp = gfc_conv_mpz_to_tree (expr->value.integer,
+				    gfc_index_integer_kind);
+      else
+ 	tmp = NULL_TREE;
+      if (n < as->rank + as->corank - 1)
+      GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
+    }
+
+  if (known_offset)
+    {
+      GFC_TYPE_ARRAY_OFFSET (type) =
+        gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind);
+    }
+  else
+    GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE;
+
+  if (known_stride)
+    {
+      GFC_TYPE_ARRAY_SIZE (type) =
+        gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
+    }
+  else
+    GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
+
+  GFC_TYPE_ARRAY_RANK (type) = as->rank;
+  GFC_TYPE_ARRAY_CORANK (type) = as->corank;
+  GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE;
+  range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
+			    NULL_TREE);
+  /* TODO: use main type if it is unbounded.  */
+  GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
+    build_pointer_type (build_array_type (etype, range));
+  if (restricted)
+    GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
+      build_qualified_type (GFC_TYPE_ARRAY_DATAPTR_TYPE (type),
+			    TYPE_QUAL_RESTRICT);
+
+  if (as->rank == 0)
+    {
+      if (packed != PACKED_STATIC  || gfc_option.coarray == GFC_FCOARRAY_LIB)
+	{
+	  type = build_pointer_type (type);
+
+	  if (restricted)
+	    type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
+
+	  GFC_ARRAY_TYPE_P (type) = 1;
+	  TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
+	}
+
+      return type;
+    }
+
+  if (known_stride)
+    {
+      mpz_sub_ui (stride, stride, 1);
+      range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
+    }
+  else
+    range = NULL_TREE;
+
+  range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range);
+  TYPE_DOMAIN (type) = range;
+
+  build_pointer_type (etype);
+  TREE_TYPE (type) = etype;
+
+  layout_type (type);
+
+  mpz_clear (offset);
+  mpz_clear (stride);
+  mpz_clear (delta);
+
+  /* Represent packed arrays as multi-dimensional if they have rank >
+     1 and with proper bounds, instead of flat arrays.  This makes for
+     better debug info.  */
+  if (known_offset)
+    {
+      tree gtype = etype, rtype, type_decl;
+
+      for (n = as->rank - 1; n >= 0; n--)
+	{
+	  rtype = build_range_type (gfc_array_index_type,
+				    GFC_TYPE_ARRAY_LBOUND (type, n),
+				    GFC_TYPE_ARRAY_UBOUND (type, n));
+	  gtype = build_array_type (gtype, rtype);
+	}
+      TYPE_NAME (type) = type_decl = build_decl (input_location,
+						 TYPE_DECL, NULL, gtype);
+      DECL_ORIGINAL_TYPE (type_decl) = gtype;
+    }
+
+  if (packed != PACKED_STATIC || !known_stride
+      || (as->corank && gfc_option.coarray == GFC_FCOARRAY_LIB))
+    {
+      /* For dummy arrays and automatic (heap allocated) arrays we
+	 want a pointer to the array.  */
+      type = build_pointer_type (type);
+      if (restricted)
+	type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
+      GFC_ARRAY_TYPE_P (type) = 1;
+      TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
+    }
+  return type;
+}
+
+
+/* Return or create the base type for an array descriptor.  */
+
+static tree
+gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted,
+			       enum gfc_array_kind akind)
+{
+  tree fat_type, decl, arraytype, *chain = NULL;
+  char name[16 + 2*GFC_RANK_DIGITS + 1 + 1];
+  int idx;
+
+  /* Assumed-rank array.  */
+  if (dimen == -1)
+    dimen = GFC_MAX_DIMENSIONS;
+
+  idx = 2 * (codimen + dimen) + restricted;
+
+  gcc_assert (codimen + dimen >= 0 && codimen + dimen <= GFC_MAX_DIMENSIONS);
+
+  if (gfc_option.coarray == GFC_FCOARRAY_LIB && codimen)
+    {
+      if (gfc_array_descriptor_base_caf[idx])
+	return gfc_array_descriptor_base_caf[idx];
+    }
+  else if (gfc_array_descriptor_base[idx])
+    return gfc_array_descriptor_base[idx];
+
+  /* Build the type node.  */
+  fat_type = make_node (RECORD_TYPE);
+
+  sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen + codimen);
+  TYPE_NAME (fat_type) = get_identifier (name);
+  TYPE_NAMELESS (fat_type) = 1;
+
+  /* Add the data member as the first element of the descriptor.  */
+  decl = gfc_add_field_to_struct_1 (fat_type,
+				    get_identifier ("data"),
+				    (restricted
+				     ? prvoid_type_node
+				     : ptr_type_node), &chain);
+
+  /* Add the base component.  */
+  decl = gfc_add_field_to_struct_1 (fat_type,
+				    get_identifier ("offset"),
+				    gfc_array_index_type, &chain);
+  TREE_NO_WARNING (decl) = 1;
+
+  /* Add the dtype component.  */
+  decl = gfc_add_field_to_struct_1 (fat_type,
+				    get_identifier ("dtype"),
+				    gfc_array_index_type, &chain);
+  TREE_NO_WARNING (decl) = 1;
+
+  /* Build the array type for the stride and bound components.  */
+  if (dimen + codimen > 0)
+    {
+      arraytype =
+	build_array_type (gfc_get_desc_dim_type (),
+			  build_range_type (gfc_array_index_type,
+					    gfc_index_zero_node,
+					    gfc_rank_cst[codimen + dimen - 1]));
+
+      decl = gfc_add_field_to_struct_1 (fat_type, get_identifier ("dim"),
+					arraytype, &chain);
+      TREE_NO_WARNING (decl) = 1;
+    }
+
+  if (gfc_option.coarray == GFC_FCOARRAY_LIB && codimen
+      && akind == GFC_ARRAY_ALLOCATABLE)
+    {
+      decl = gfc_add_field_to_struct_1 (fat_type,
+					get_identifier ("token"),
+					prvoid_type_node, &chain);
+      TREE_NO_WARNING (decl) = 1;
+    }
+
+  /* Finish off the type.  */
+  gfc_finish_type (fat_type);
+  TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type)) = 1;
+
+  if (gfc_option.coarray == GFC_FCOARRAY_LIB && codimen
+      && akind == GFC_ARRAY_ALLOCATABLE)
+    gfc_array_descriptor_base_caf[idx] = fat_type;
+  else
+    gfc_array_descriptor_base[idx] = fat_type;
+
+  return fat_type;
+}
+
+
+/* Build an array (descriptor) type with given bounds.  */
+
+tree
+gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound,
+			   tree * ubound, int packed,
+			   enum gfc_array_kind akind, bool restricted)
+{
+  char name[8 + 2*GFC_RANK_DIGITS + 1 + GFC_MAX_SYMBOL_LEN];
+  tree fat_type, base_type, arraytype, lower, upper, stride, tmp, rtype;
+  const char *type_name;
+  int n;
+
+  base_type = gfc_get_array_descriptor_base (dimen, codimen, restricted, akind);
+  fat_type = build_distinct_type_copy (base_type);
+  /* Make sure that nontarget and target array type have the same canonical
+     type (and same stub decl for debug info).  */
+  base_type = gfc_get_array_descriptor_base (dimen, codimen, false, akind);
+  TYPE_CANONICAL (fat_type) = base_type;
+  TYPE_STUB_DECL (fat_type) = TYPE_STUB_DECL (base_type);
+
+  tmp = TYPE_NAME (etype);
+  if (tmp && TREE_CODE (tmp) == TYPE_DECL)
+    tmp = DECL_NAME (tmp);
+  if (tmp)
+    type_name = IDENTIFIER_POINTER (tmp);
+  else
+    type_name = "unknown";
+  sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen + codimen,
+	   GFC_MAX_SYMBOL_LEN, type_name);
+  TYPE_NAME (fat_type) = get_identifier (name);
+  TYPE_NAMELESS (fat_type) = 1;
+
+  GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
+  TYPE_LANG_SPECIFIC (fat_type)
+    = ggc_alloc_cleared_lang_type (sizeof (struct lang_type));
+
+  GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
+  GFC_TYPE_ARRAY_CORANK (fat_type) = codimen;
+  GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;
+  GFC_TYPE_ARRAY_AKIND (fat_type) = akind;
+
+  /* Build an array descriptor record type.  */
+  if (packed != 0)
+    stride = gfc_index_one_node;
+  else
+    stride = NULL_TREE;
+  for (n = 0; n < dimen + codimen; n++)
+    {
+      if (n < dimen)
+	GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
+
+      if (lbound)
+	lower = lbound[n];
+      else
+	lower = NULL_TREE;
+
+      if (lower != NULL_TREE)
+	{
+	  if (INTEGER_CST_P (lower))
+	    GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower;
+	  else
+	    lower = NULL_TREE;
+	}
+
+      if (codimen && n == dimen + codimen - 1)
+	break;
+
+      upper = ubound[n];
+      if (upper != NULL_TREE)
+	{
+	  if (INTEGER_CST_P (upper))
+	    GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper;
+	  else
+	    upper = NULL_TREE;
+	}
+
+      if (n >= dimen)
+	continue;
+
+      if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
+	{
+	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				 gfc_array_index_type, upper, lower);
+	  tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type, tmp,
+				 gfc_index_one_node);
+	  stride = fold_build2_loc (input_location, MULT_EXPR,
+				    gfc_array_index_type, tmp, stride);
+	  /* Check the folding worked.  */
+	  gcc_assert (INTEGER_CST_P (stride));
+	}
+      else
+	stride = NULL_TREE;
+    }
+  GFC_TYPE_ARRAY_SIZE (fat_type) = stride;
+
+  /* TODO: known offsets for descriptors.  */
+  GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
+
+  if (dimen == 0)
+    {
+      arraytype =  build_pointer_type (etype);
+      if (restricted)
+	arraytype = build_qualified_type (arraytype, TYPE_QUAL_RESTRICT);
+
+      GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
+      return fat_type;
+    }
+
+  /* We define data as an array with the correct size if possible.
+     Much better than doing pointer arithmetic.  */
+  if (stride)
+    rtype = build_range_type (gfc_array_index_type, gfc_index_zero_node,
+			      int_const_binop (MINUS_EXPR, stride,
+					       integer_one_node));
+  else
+    rtype = gfc_array_range_type;
+  arraytype = build_array_type (etype, rtype);
+  arraytype = build_pointer_type (arraytype);
+  if (restricted)
+    arraytype = build_qualified_type (arraytype, TYPE_QUAL_RESTRICT);
+  GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
+
+  /* This will generate the base declarations we need to emit debug
+     information for this type.  FIXME: there must be a better way to
+     avoid divergence between compilations with and without debug
+     information.  */
+  {
+    struct array_descr_info info;
+    gfc_get_array_descr_info (fat_type, &info);
+    gfc_get_array_descr_info (build_pointer_type (fat_type), &info);
+  }
+
+  return fat_type;
+}
+
+/* Build a pointer type. This function is called from gfc_sym_type().  */
+
+static tree
+gfc_build_pointer_type (gfc_symbol * sym, tree type)
+{
+  /* Array pointer types aren't actually pointers.  */
+  if (sym->attr.dimension)
+    return type;
+  else
+    return build_pointer_type (type);
+}
+
+static tree gfc_nonrestricted_type (tree t);
+/* Given two record or union type nodes TO and FROM, ensure
+   that all fields in FROM have a corresponding field in TO,
+   their type being nonrestrict variants.  This accepts a TO
+   node that already has a prefix of the fields in FROM.  */
+static void
+mirror_fields (tree to, tree from)
+{
+  tree fto, ffrom;
+  tree *chain;
+
+  /* Forward to the end of TOs fields.  */
+  fto = TYPE_FIELDS (to);
+  ffrom = TYPE_FIELDS (from);
+  chain = &TYPE_FIELDS (to);
+  while (fto)
+    {
+      gcc_assert (ffrom && DECL_NAME (fto) == DECL_NAME (ffrom));
+      chain = &DECL_CHAIN (fto);
+      fto = DECL_CHAIN (fto);
+      ffrom = DECL_CHAIN (ffrom);
+    }
+
+  /* Now add all fields remaining in FROM (starting with ffrom).  */
+  for (; ffrom; ffrom = DECL_CHAIN (ffrom))
+    {
+      tree newfield = copy_node (ffrom);
+      DECL_CONTEXT (newfield) = to;
+      /* The store to DECL_CHAIN might seem redundant with the
+	 stores to *chain, but not clearing it here would mean
+	 leaving a chain into the old fields.  If ever
+	 our called functions would look at them confusion
+	 will arise.  */
+      DECL_CHAIN (newfield) = NULL_TREE;
+      *chain = newfield;
+      chain = &DECL_CHAIN (newfield);
+
+      if (TREE_CODE (ffrom) == FIELD_DECL)
+	{
+	  tree elemtype = gfc_nonrestricted_type (TREE_TYPE (ffrom));
+	  TREE_TYPE (newfield) = elemtype;
+	}
+    }
+  *chain = NULL_TREE;
+}
+
+/* Given a type T, returns a different type of the same structure,
+   except that all types it refers to (recursively) are always
+   non-restrict qualified types.  */
+static tree
+gfc_nonrestricted_type (tree t)
+{
+  tree ret = t;
+
+  /* If the type isn't laid out yet, don't copy it.  If something
+     needs it for real it should wait until the type got finished.  */
+  if (!TYPE_SIZE (t))
+    return t;
+
+  if (!TYPE_LANG_SPECIFIC (t))
+    TYPE_LANG_SPECIFIC (t)
+      = ggc_alloc_cleared_lang_type (sizeof (struct lang_type));
+  /* If we're dealing with this very node already further up
+     the call chain (recursion via pointers and struct members)
+     we haven't yet determined if we really need a new type node.
+     Assume we don't, return T itself.  */
+  if (TYPE_LANG_SPECIFIC (t)->nonrestricted_type == error_mark_node)
+    return t;
+
+  /* If we have calculated this all already, just return it.  */
+  if (TYPE_LANG_SPECIFIC (t)->nonrestricted_type)
+    return TYPE_LANG_SPECIFIC (t)->nonrestricted_type;
+
+  /* Mark this type.  */
+  TYPE_LANG_SPECIFIC (t)->nonrestricted_type = error_mark_node;
+
+  switch (TREE_CODE (t))
+    {
+      default:
+	break;
+
+      case POINTER_TYPE:
+      case REFERENCE_TYPE:
+	{
+	  tree totype = gfc_nonrestricted_type (TREE_TYPE (t));
+	  if (totype == TREE_TYPE (t))
+	    ret = t;
+	  else if (TREE_CODE (t) == POINTER_TYPE)
+	    ret = build_pointer_type (totype);
+	  else
+	    ret = build_reference_type (totype);
+	  ret = build_qualified_type (ret,
+				      TYPE_QUALS (t) & ~TYPE_QUAL_RESTRICT);
+	}
+	break;
+
+      case ARRAY_TYPE:
+	{
+	  tree elemtype = gfc_nonrestricted_type (TREE_TYPE (t));
+	  if (elemtype == TREE_TYPE (t))
+	    ret = t;
+	  else
+	    {
+	      ret = build_variant_type_copy (t);
+	      TREE_TYPE (ret) = elemtype;
+	      if (TYPE_LANG_SPECIFIC (t)
+		  && GFC_TYPE_ARRAY_DATAPTR_TYPE (t))
+		{
+		  tree dataptr_type = GFC_TYPE_ARRAY_DATAPTR_TYPE (t);
+		  dataptr_type = gfc_nonrestricted_type (dataptr_type);
+		  if (dataptr_type != GFC_TYPE_ARRAY_DATAPTR_TYPE (t))
+		    {
+		      TYPE_LANG_SPECIFIC (ret)
+			= ggc_alloc_cleared_lang_type (sizeof (struct
+							       lang_type));
+		      *TYPE_LANG_SPECIFIC (ret) = *TYPE_LANG_SPECIFIC (t);
+		      GFC_TYPE_ARRAY_DATAPTR_TYPE (ret) = dataptr_type;
+		    }
+		}
+	    }
+	}
+	break;
+
+      case RECORD_TYPE:
+      case UNION_TYPE:
+      case QUAL_UNION_TYPE:
+	{
+	  tree field;
+	  /* First determine if we need a new type at all.
+	     Careful, the two calls to gfc_nonrestricted_type per field
+	     might return different values.  That happens exactly when
+	     one of the fields reaches back to this very record type
+	     (via pointers).  The first calls will assume that we don't
+	     need to copy T (see the error_mark_node marking).  If there
+	     are any reasons for copying T apart from having to copy T,
+	     we'll indeed copy it, and the second calls to
+	     gfc_nonrestricted_type will use that new node if they
+	     reach back to T.  */
+	  for (field = TYPE_FIELDS (t); field; field = DECL_CHAIN (field))
+	    if (TREE_CODE (field) == FIELD_DECL)
+	      {
+		tree elemtype = gfc_nonrestricted_type (TREE_TYPE (field));
+		if (elemtype != TREE_TYPE (field))
+		  break;
+	      }
+	  if (!field)
+	    break;
+	  ret = build_variant_type_copy (t);
+	  TYPE_FIELDS (ret) = NULL_TREE;
+
+	  /* Here we make sure that as soon as we know we have to copy
+	     T, that also fields reaching back to us will use the new
+	     copy.  It's okay if that copy still contains the old fields,
+	     we won't look at them.  */
+	  TYPE_LANG_SPECIFIC (t)->nonrestricted_type = ret;
+	  mirror_fields (ret, t);
+	}
+        break;
+    }
+
+  TYPE_LANG_SPECIFIC (t)->nonrestricted_type = ret;
+  return ret;
+}
+
+
+/* Return the type for a symbol.  Special handling is required for character
+   types to get the correct level of indirection.
+   For functions return the return type.
+   For subroutines return void_type_node.
+   Calling this multiple times for the same symbol should be avoided,
+   especially for character and array types.  */
+
+tree
+gfc_sym_type (gfc_symbol * sym)
+{
+  tree type;
+  int byref;
+  bool restricted;
+
+  /* Procedure Pointers inside COMMON blocks.  */
+  if (sym->attr.proc_pointer && sym->attr.in_common)
+    {
+      /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type.  */
+      sym->attr.proc_pointer = 0;
+      type = build_pointer_type (gfc_get_function_type (sym));
+      sym->attr.proc_pointer = 1;
+      return type;
+    }
+
+  if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
+    return void_type_node;
+
+  /* In the case of a function the fake result variable may have a
+     type different from the function type, so don't return early in
+     that case.  */
+  if (sym->backend_decl && !sym->attr.function)
+    return TREE_TYPE (sym->backend_decl);
+
+  if (sym->ts.type == BT_CHARACTER
+      && ((sym->attr.function && sym->attr.is_bind_c)
+	  || (sym->attr.result
+	      && sym->ns->proc_name
+	      && sym->ns->proc_name->attr.is_bind_c)))
+    type = gfc_character1_type_node;
+  else
+    type = gfc_typenode_for_spec (&sym->ts);
+
+  if (sym->attr.dummy && !sym->attr.function && !sym->attr.value)
+    byref = 1;
+  else
+    byref = 0;
+
+  restricted = !sym->attr.target && !sym->attr.pointer
+               && !sym->attr.proc_pointer && !sym->attr.cray_pointee;
+  if (!restricted)
+    type = gfc_nonrestricted_type (type);
+
+  if (sym->attr.dimension || sym->attr.codimension)
+    {
+      if (gfc_is_nodesc_array (sym))
+        {
+	  /* If this is a character argument of unknown length, just use the
+	     base type.  */
+	  if (sym->ts.type != BT_CHARACTER
+	      || !(sym->attr.dummy || sym->attr.function)
+	      || sym->ts.u.cl->backend_decl)
+	    {
+	      type = gfc_get_nodesc_array_type (type, sym->as,
+						byref ? PACKED_FULL
+						      : PACKED_STATIC,
+						restricted);
+	      byref = 0;
+	    }
+
+	  if (sym->attr.cray_pointee)
+	    GFC_POINTER_TYPE_P (type) = 1;
+        }
+      else
+	{
+	  enum gfc_array_kind akind = GFC_ARRAY_UNKNOWN;
+	  if (sym->attr.pointer)
+	    akind = sym->attr.contiguous ? GFC_ARRAY_POINTER_CONT
+					 : GFC_ARRAY_POINTER;
+	  else if (sym->attr.allocatable)
+	    akind = GFC_ARRAY_ALLOCATABLE;
+	  type = gfc_build_array_type (type, sym->as, akind, restricted,
+				       sym->attr.contiguous);
+	}
+    }
+  else
+    {
+      if (sym->attr.allocatable || sym->attr.pointer
+	  || gfc_is_associate_pointer (sym))
+	type = gfc_build_pointer_type (sym, type);
+      if (sym->attr.pointer || sym->attr.cray_pointee)
+	GFC_POINTER_TYPE_P (type) = 1;
+    }
+
+  /* We currently pass all parameters by reference.
+     See f95_get_function_decl.  For dummy function parameters return the
+     function type.  */
+  if (byref)
+    {
+      /* We must use pointer types for potentially absent variables.  The
+	 optimizers assume a reference type argument is never NULL.  */
+      if (sym->attr.optional
+	  || (sym->ns->proc_name && sym->ns->proc_name->attr.entry_master))
+	type = build_pointer_type (type);
+      else
+	{
+	  type = build_reference_type (type);
+	  if (restricted)
+	    type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
+	}
+    }
+
+  return (type);
+}
+
+/* Layout and output debug info for a record type.  */
+
+void
+gfc_finish_type (tree type)
+{
+  tree decl;
+
+  decl = build_decl (input_location,
+		     TYPE_DECL, NULL_TREE, type);
+  TYPE_STUB_DECL (type) = decl;
+  layout_type (type);
+  rest_of_type_compilation (type, 1);
+  rest_of_decl_compilation (decl, 1, 0);
+}
+
+/* Add a field of given NAME and TYPE to the context of a UNION_TYPE
+   or RECORD_TYPE pointed to by CONTEXT.  The new field is chained
+   to the end of the field list pointed to by *CHAIN.
+
+   Returns a pointer to the new field.  */
+
+static tree
+gfc_add_field_to_struct_1 (tree context, tree name, tree type, tree **chain)
+{
+  tree decl = build_decl (input_location, FIELD_DECL, name, type);
+
+  DECL_CONTEXT (decl) = context;
+  DECL_CHAIN (decl) = NULL_TREE;
+  if (TYPE_FIELDS (context) == NULL_TREE)
+    TYPE_FIELDS (context) = decl;
+  if (chain != NULL)
+    {
+      if (*chain != NULL)
+	**chain = decl;
+      *chain = &DECL_CHAIN (decl);
+    }
+
+  return decl;
+}
+
+/* Like `gfc_add_field_to_struct_1', but adds alignment
+   information.  */
+
+tree
+gfc_add_field_to_struct (tree context, tree name, tree type, tree **chain)
+{
+  tree decl = gfc_add_field_to_struct_1 (context, name, type, chain);
+
+  DECL_INITIAL (decl) = 0;
+  DECL_ALIGN (decl) = 0;
+  DECL_USER_ALIGN (decl) = 0;
+
+  return decl;
+}
+
+
+/* Copy the backend_decl and component backend_decls if
+   the two derived type symbols are "equal", as described
+   in 4.4.2 and resolved by gfc_compare_derived_types.  */
+
+int
+gfc_copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to,
+			   bool from_gsym)
+{
+  gfc_component *to_cm;
+  gfc_component *from_cm;
+
+  if (from == to)
+    return 1;
+
+  if (from->backend_decl == NULL
+	|| !gfc_compare_derived_types (from, to))
+    return 0;
+
+  to->backend_decl = from->backend_decl;
+
+  to_cm = to->components;
+  from_cm = from->components;
+
+  /* Copy the component declarations.  If a component is itself
+     a derived type, we need a copy of its component declarations.
+     This is done by recursing into gfc_get_derived_type and
+     ensures that the component's component declarations have
+     been built.  If it is a character, we need the character
+     length, as well.  */
+  for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
+    {
+      to_cm->backend_decl = from_cm->backend_decl;
+      if (from_cm->ts.type == BT_DERIVED
+	  && (!from_cm->attr.pointer || from_gsym))
+	gfc_get_derived_type (to_cm->ts.u.derived);
+      else if (from_cm->ts.type == BT_CLASS
+	       && (!CLASS_DATA (from_cm)->attr.class_pointer || from_gsym))
+	gfc_get_derived_type (to_cm->ts.u.derived);
+      else if (from_cm->ts.type == BT_CHARACTER)
+	to_cm->ts.u.cl->backend_decl = from_cm->ts.u.cl->backend_decl;
+    }
+
+  return 1;
+}
+
+
+/* Build a tree node for a procedure pointer component.  */
+
+tree
+gfc_get_ppc_type (gfc_component* c)
+{
+  tree t;
+
+  /* Explicit interface.  */
+  if (c->attr.if_source != IFSRC_UNKNOWN && c->ts.interface)
+    return build_pointer_type (gfc_get_function_type (c->ts.interface));
+
+  /* Implicit interface (only return value may be known).  */
+  if (c->attr.function && !c->attr.dimension && c->ts.type != BT_CHARACTER)
+    t = gfc_typenode_for_spec (&c->ts);
+  else
+    t = void_type_node;
+
+  return build_pointer_type (build_function_type_list (t, NULL_TREE));
+}
+
+
+/* Build a tree node for a derived type.  If there are equal
+   derived types, with different local names, these are built
+   at the same time.  If an equal derived type has been built
+   in a parent namespace, this is used.  */
+
+tree
+gfc_get_derived_type (gfc_symbol * derived)
+{
+  tree typenode = NULL, field = NULL, field_type = NULL;
+  tree canonical = NULL_TREE;
+  tree *chain = NULL;
+  bool got_canonical = false;
+  bool unlimited_entity = false;
+  gfc_component *c;
+  gfc_dt_list *dt;
+  gfc_namespace *ns;
+
+  if (derived->attr.unlimited_polymorphic)
+    return ptr_type_node;
+
+  if (derived && derived->attr.flavor == FL_PROCEDURE
+      && derived->attr.generic)
+    derived = gfc_find_dt_in_generic (derived);
+
+  /* See if it's one of the iso_c_binding derived types.  */
+  if (derived->attr.is_iso_c == 1 || derived->ts.f90_type == BT_VOID)
+    {
+      if (derived->backend_decl)
+	return derived->backend_decl;
+
+      if (derived->intmod_sym_id == ISOCBINDING_PTR)
+	derived->backend_decl = ptr_type_node;
+      else
+	derived->backend_decl = pfunc_type_node;
+
+      derived->ts.kind = gfc_index_integer_kind;
+      derived->ts.type = BT_INTEGER;
+      /* Set the f90_type to BT_VOID as a way to recognize something of type
+         BT_INTEGER that needs to fit a void * for the purpose of the
+         iso_c_binding derived types.  */
+      derived->ts.f90_type = BT_VOID;
+
+      return derived->backend_decl;
+    }
+
+  /* If use associated, use the module type for this one.  */
+  if (derived->backend_decl == NULL
+      && derived->attr.use_assoc
+      && derived->module
+      && gfc_get_module_backend_decl (derived))
+    goto copy_derived_types;
+
+  /* The derived types from an earlier namespace can be used as the
+     canonical type.  */
+  if (derived->backend_decl == NULL && !derived->attr.use_assoc
+      && gfc_global_ns_list)
+    {
+      for (ns = gfc_global_ns_list;
+	   ns->translated && !got_canonical;
+	   ns = ns->sibling)
+	{
+	  dt = ns->derived_types;
+	  for (; dt && !canonical; dt = dt->next)
+	    {
+	      gfc_copy_dt_decls_ifequal (dt->derived, derived, true);
+	      if (derived->backend_decl)
+		got_canonical = true;
+	    }
+	}
+    }
+
+  /* Store up the canonical type to be added to this one.  */
+  if (got_canonical)
+    {
+      if (TYPE_CANONICAL (derived->backend_decl))
+	canonical = TYPE_CANONICAL (derived->backend_decl);
+      else
+	canonical = derived->backend_decl;
+
+      derived->backend_decl = NULL_TREE;
+    }
+
+  /* derived->backend_decl != 0 means we saw it before, but its
+     components' backend_decl may have not been built.  */
+  if (derived->backend_decl)
+    {
+      /* Its components' backend_decl have been built or we are
+	 seeing recursion through the formal arglist of a procedure
+	 pointer component.  */
+      if (TYPE_FIELDS (derived->backend_decl)
+	    || derived->attr.proc_pointer_comp)
+        return derived->backend_decl;
+      else
+        typenode = derived->backend_decl;
+    }
+  else
+    {
+      /* We see this derived type first time, so build the type node.  */
+      typenode = make_node (RECORD_TYPE);
+      TYPE_NAME (typenode) = get_identifier (derived->name);
+      TYPE_PACKED (typenode) = gfc_option.flag_pack_derived;
+      derived->backend_decl = typenode;
+    }
+
+  if (derived->components
+	&& derived->components->ts.type == BT_DERIVED
+	&& strcmp (derived->components->name, "_data") == 0
+	&& derived->components->ts.u.derived->attr.unlimited_polymorphic)
+    unlimited_entity = true;
+
+  /* Go through the derived type components, building them as
+     necessary. The reason for doing this now is that it is
+     possible to recurse back to this derived type through a
+     pointer component (PR24092). If this happens, the fields
+     will be built and so we can return the type.  */
+  for (c = derived->components; c; c = c->next)
+    {
+      if (c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
+	continue;
+
+      if ((!c->attr.pointer && !c->attr.proc_pointer)
+	  || c->ts.u.derived->backend_decl == NULL)
+	c->ts.u.derived->backend_decl = gfc_get_derived_type (c->ts.u.derived);
+
+      if (c->ts.u.derived->attr.is_iso_c)
+        {
+          /* Need to copy the modified ts from the derived type.  The
+             typespec was modified because C_PTR/C_FUNPTR are translated
+             into (void *) from derived types.  */
+          c->ts.type = c->ts.u.derived->ts.type;
+          c->ts.kind = c->ts.u.derived->ts.kind;
+          c->ts.f90_type = c->ts.u.derived->ts.f90_type;
+	  if (c->initializer)
+	    {
+	      c->initializer->ts.type = c->ts.type;
+	      c->initializer->ts.kind = c->ts.kind;
+	      c->initializer->ts.f90_type = c->ts.f90_type;
+	      c->initializer->expr_type = EXPR_NULL;
+	    }
+        }
+    }
+
+  if (TYPE_FIELDS (derived->backend_decl))
+    return derived->backend_decl;
+
+  /* Build the type member list. Install the newly created RECORD_TYPE
+     node as DECL_CONTEXT of each FIELD_DECL.  */
+  for (c = derived->components; c; c = c->next)
+    {
+      if (c->attr.proc_pointer)
+	field_type = gfc_get_ppc_type (c);
+      else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+        field_type = c->ts.u.derived->backend_decl;
+      else
+	{
+	  if (c->ts.type == BT_CHARACTER && !c->ts.deferred)
+	    {
+	      /* Evaluate the string length.  */
+	      gfc_conv_const_charlen (c->ts.u.cl);
+	      gcc_assert (c->ts.u.cl->backend_decl);
+	    }
+	  else if (c->ts.type == BT_CHARACTER)
+	    c->ts.u.cl->backend_decl
+			= build_int_cst (gfc_charlen_type_node, 0);
+
+	  field_type = gfc_typenode_for_spec (&c->ts);
+	}
+
+      /* This returns an array descriptor type.  Initialization may be
+         required.  */
+      if ((c->attr.dimension || c->attr.codimension) && !c->attr.proc_pointer )
+	{
+	  if (c->attr.pointer || c->attr.allocatable)
+	    {
+	      enum gfc_array_kind akind;
+	      if (c->attr.pointer)
+		akind = c->attr.contiguous ? GFC_ARRAY_POINTER_CONT
+					   : GFC_ARRAY_POINTER;
+	      else
+		akind = GFC_ARRAY_ALLOCATABLE;
+	      /* Pointers to arrays aren't actually pointer types.  The
+	         descriptors are separate, but the data is common.  */
+	      field_type = gfc_build_array_type (field_type, c->as, akind,
+						 !c->attr.target
+						 && !c->attr.pointer,
+						 c->attr.contiguous);
+	    }
+	  else
+	    field_type = gfc_get_nodesc_array_type (field_type, c->as,
+						    PACKED_STATIC,
+						    !c->attr.target);
+	}
+      else if ((c->attr.pointer || c->attr.allocatable)
+	       && !c->attr.proc_pointer
+	       && !(unlimited_entity && c == derived->components))
+	field_type = build_pointer_type (field_type);
+
+      if (c->attr.pointer)
+	field_type = gfc_nonrestricted_type (field_type);
+
+      /* vtype fields can point to different types to the base type.  */
+      if (c->ts.type == BT_DERIVED
+	    && c->ts.u.derived && c->ts.u.derived->attr.vtype)
+	  field_type = build_pointer_type_for_mode (TREE_TYPE (field_type),
+						    ptr_mode, true);
+
+      /* Ensure that the CLASS language specific flag is set.  */
+      if (c->ts.type == BT_CLASS)
+	{
+	  if (POINTER_TYPE_P (field_type))
+	    GFC_CLASS_TYPE_P (TREE_TYPE (field_type)) = 1;
+	  else
+	    GFC_CLASS_TYPE_P (field_type) = 1;
+	}
+
+      field = gfc_add_field_to_struct (typenode,
+				       get_identifier (c->name),
+				       field_type, &chain);
+      if (c->loc.lb)
+	gfc_set_decl_location (field, &c->loc);
+      else if (derived->declared_at.lb)
+	gfc_set_decl_location (field, &derived->declared_at);
+
+      DECL_PACKED (field) |= TYPE_PACKED (typenode);
+
+      gcc_assert (field);
+      if (!c->backend_decl)
+	c->backend_decl = field;
+    }
+
+  /* Now lay out the derived type, including the fields.  */
+  if (canonical)
+    TYPE_CANONICAL (typenode) = canonical;
+
+  gfc_finish_type (typenode);
+  gfc_set_decl_location (TYPE_STUB_DECL (typenode), &derived->declared_at);
+  if (derived->module && derived->ns->proc_name
+      && derived->ns->proc_name->attr.flavor == FL_MODULE)
+    {
+      if (derived->ns->proc_name->backend_decl
+	  && TREE_CODE (derived->ns->proc_name->backend_decl)
+	     == NAMESPACE_DECL)
+	{
+	  TYPE_CONTEXT (typenode) = derived->ns->proc_name->backend_decl;
+	  DECL_CONTEXT (TYPE_STUB_DECL (typenode))
+	    = derived->ns->proc_name->backend_decl;
+	}
+    }
+
+  derived->backend_decl = typenode;
+
+copy_derived_types:
+
+  for (dt = gfc_derived_types; dt; dt = dt->next)
+    gfc_copy_dt_decls_ifequal (derived, dt->derived, false);
+
+  return derived->backend_decl;
+}
+
+
+int
+gfc_return_by_reference (gfc_symbol * sym)
+{
+  if (!sym->attr.function)
+    return 0;
+
+  if (sym->attr.dimension)
+    return 1;
+
+  if (sym->ts.type == BT_CHARACTER
+      && !sym->attr.is_bind_c
+      && (!sym->attr.result
+	  || !sym->ns->proc_name
+	  || !sym->ns->proc_name->attr.is_bind_c))
+    return 1;
+
+  /* Possibly return complex numbers by reference for g77 compatibility.
+     We don't do this for calls to intrinsics (as the library uses the
+     -fno-f2c calling convention), nor for calls to functions which always
+     require an explicit interface, as no compatibility problems can
+     arise there.  */
+  if (gfc_option.flag_f2c
+      && sym->ts.type == BT_COMPLEX
+      && !sym->attr.intrinsic && !sym->attr.always_explicit)
+    return 1;
+
+  return 0;
+}
+
+static tree
+gfc_get_mixed_entry_union (gfc_namespace *ns)
+{
+  tree type;
+  tree *chain = NULL;
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_entry_list *el, *el2;
+
+  gcc_assert (ns->proc_name->attr.mixed_entry_master);
+  gcc_assert (memcmp (ns->proc_name->name, "master.", 7) == 0);
+
+  snprintf (name, GFC_MAX_SYMBOL_LEN, "munion.%s", ns->proc_name->name + 7);
+
+  /* Build the type node.  */
+  type = make_node (UNION_TYPE);
+
+  TYPE_NAME (type) = get_identifier (name);
+
+  for (el = ns->entries; el; el = el->next)
+    {
+      /* Search for duplicates.  */
+      for (el2 = ns->entries; el2 != el; el2 = el2->next)
+	if (el2->sym->result == el->sym->result)
+	  break;
+
+      if (el == el2)
+	gfc_add_field_to_struct_1 (type,
+				   get_identifier (el->sym->result->name),
+				   gfc_sym_type (el->sym->result), &chain);
+    }
+
+  /* Finish off the type.  */
+  gfc_finish_type (type);
+  TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1;
+  return type;
+}
+
+/* Create a "fn spec" based on the formal arguments;
+   cf. create_function_arglist.  */
+
+static tree
+create_fn_spec (gfc_symbol *sym, tree fntype)
+{
+  char spec[150];
+  size_t spec_len;
+  gfc_formal_arglist *f;
+  tree tmp;
+
+  memset (&spec, 0, sizeof (spec));
+  spec[0] = '.';
+  spec_len = 1;
+
+  if (sym->attr.entry_master)
+    spec[spec_len++] = 'R';
+  if (gfc_return_by_reference (sym))
+    {
+      gfc_symbol *result = sym->result ? sym->result : sym;
+
+      if (result->attr.pointer || sym->attr.proc_pointer)
+	spec[spec_len++] = '.';
+      else
+	spec[spec_len++] = 'w';
+      if (sym->ts.type == BT_CHARACTER)
+	spec[spec_len++] = 'R';
+    }
+
+  for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
+    if (spec_len < sizeof (spec))
+      {
+	if (!f->sym || f->sym->attr.pointer || f->sym->attr.target
+	    || f->sym->attr.external || f->sym->attr.cray_pointer
+	    || (f->sym->ts.type == BT_DERIVED
+		&& (f->sym->ts.u.derived->attr.proc_pointer_comp
+		    || f->sym->ts.u.derived->attr.pointer_comp))
+	    || (f->sym->ts.type == BT_CLASS
+		&& (CLASS_DATA (f->sym)->ts.u.derived->attr.proc_pointer_comp
+		    || CLASS_DATA (f->sym)->ts.u.derived->attr.pointer_comp)))
+	  spec[spec_len++] = '.';
+	else if (f->sym->attr.intent == INTENT_IN)
+	  spec[spec_len++] = 'r';
+	else if (f->sym)
+	  spec[spec_len++] = 'w';
+      }
+
+  tmp = build_tree_list (NULL_TREE, build_string (spec_len, spec));
+  tmp = tree_cons (get_identifier ("fn spec"), tmp, TYPE_ATTRIBUTES (fntype));
+  return build_type_attribute_variant (fntype, tmp);
+}
+
+
+tree
+gfc_get_function_type (gfc_symbol * sym)
+{
+  tree type;
+  vec<tree, va_gc> *typelist;
+  gfc_formal_arglist *f;
+  gfc_symbol *arg;
+  int alternate_return;
+  bool is_varargs = true, recursive_type = false;
+
+  /* Make sure this symbol is a function, a subroutine or the main
+     program.  */
+  gcc_assert (sym->attr.flavor == FL_PROCEDURE
+	      || sym->attr.flavor == FL_PROGRAM);
+
+  /* To avoid recursing infinitely on recursive types, we use error_mark_node
+     so that they can be detected here and handled further down.  */
+  if (sym->backend_decl == NULL)
+    sym->backend_decl = error_mark_node;
+  else if (sym->backend_decl == error_mark_node)
+    recursive_type = true;
+  else if (sym->attr.proc_pointer)
+    return TREE_TYPE (TREE_TYPE (sym->backend_decl));
+  else
+    return TREE_TYPE (sym->backend_decl);
+
+  alternate_return = 0;
+  typelist = NULL;
+
+  if (sym->attr.entry_master)
+    /* Additional parameter for selecting an entry point.  */
+    vec_safe_push (typelist, gfc_array_index_type);
+
+  if (sym->result)
+    arg = sym->result;
+  else
+    arg = sym;
+
+  if (arg->ts.type == BT_CHARACTER)
+    gfc_conv_const_charlen (arg->ts.u.cl);
+
+  /* Some functions we use an extra parameter for the return value.  */
+  if (gfc_return_by_reference (sym))
+    {
+      type = gfc_sym_type (arg);
+      if (arg->ts.type == BT_COMPLEX
+	  || arg->attr.dimension
+	  || arg->ts.type == BT_CHARACTER)
+	type = build_reference_type (type);
+
+      vec_safe_push (typelist, type);
+      if (arg->ts.type == BT_CHARACTER)
+	{
+	  if (!arg->ts.deferred)
+	    /* Transfer by value.  */
+	    vec_safe_push (typelist, gfc_charlen_type_node);
+	  else
+	    /* Deferred character lengths are transferred by reference
+	       so that the value can be returned.  */
+	    vec_safe_push (typelist, build_pointer_type(gfc_charlen_type_node));
+	}
+    }
+
+  /* Build the argument types for the function.  */
+  for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
+    {
+      arg = f->sym;
+      if (arg)
+	{
+	  /* Evaluate constant character lengths here so that they can be
+	     included in the type.  */
+	  if (arg->ts.type == BT_CHARACTER)
+	    gfc_conv_const_charlen (arg->ts.u.cl);
+
+	  if (arg->attr.flavor == FL_PROCEDURE)
+	    {
+	      /* We don't know in the general case which argument causes
+		 recursion.  But we know that it is a procedure.  So we give up
+		 creating the procedure argument type list at the first
+		 procedure argument.  */
+	      if (recursive_type)
+	        goto arg_type_list_done;
+
+	      type = gfc_get_function_type (arg);
+	      type = build_pointer_type (type);
+	    }
+	  else
+	    type = gfc_sym_type (arg);
+
+	  /* Parameter Passing Convention
+
+	     We currently pass all parameters by reference.
+	     Parameters with INTENT(IN) could be passed by value.
+	     The problem arises if a function is called via an implicit
+	     prototype. In this situation the INTENT is not known.
+	     For this reason all parameters to global functions must be
+	     passed by reference.  Passing by value would potentially
+	     generate bad code.  Worse there would be no way of telling that
+	     this code was bad, except that it would give incorrect results.
+
+	     Contained procedures could pass by value as these are never
+	     used without an explicit interface, and cannot be passed as
+	     actual parameters for a dummy procedure.  */
+
+	  vec_safe_push (typelist, type);
+	}
+      else
+        {
+          if (sym->attr.subroutine)
+            alternate_return = 1;
+        }
+    }
+
+  /* Add hidden string length parameters.  */
+  for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
+    {
+      arg = f->sym;
+      if (arg && arg->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)
+	{
+	  if (!arg->ts.deferred)
+	    /* Transfer by value.  */
+	    type = gfc_charlen_type_node;
+	  else
+	    /* Deferred character lengths are transferred by reference
+	       so that the value can be returned.  */
+	    type = build_pointer_type (gfc_charlen_type_node);
+
+	  vec_safe_push (typelist, type);
+	}
+    }
+
+  if (!vec_safe_is_empty (typelist)
+      || sym->attr.is_main_program
+      || sym->attr.if_source != IFSRC_UNKNOWN)
+    is_varargs = false;
+
+arg_type_list_done:
+
+  if (!recursive_type && sym->backend_decl == error_mark_node)
+    sym->backend_decl = NULL_TREE;
+
+  if (alternate_return)
+    type = integer_type_node;
+  else if (!sym->attr.function || gfc_return_by_reference (sym))
+    type = void_type_node;
+  else if (sym->attr.mixed_entry_master)
+    type = gfc_get_mixed_entry_union (sym->ns);
+  else if (gfc_option.flag_f2c
+	   && sym->ts.type == BT_REAL
+	   && sym->ts.kind == gfc_default_real_kind
+	   && !sym->attr.always_explicit)
+    {
+      /* Special case: f2c calling conventions require that (scalar)
+	 default REAL functions return the C type double instead.  f2c
+	 compatibility is only an issue with functions that don't
+	 require an explicit interface, as only these could be
+	 implemented in Fortran 77.  */
+      sym->ts.kind = gfc_default_double_kind;
+      type = gfc_typenode_for_spec (&sym->ts);
+      sym->ts.kind = gfc_default_real_kind;
+    }
+  else if (sym->result && sym->result->attr.proc_pointer)
+    /* Procedure pointer return values.  */
+    {
+      if (sym->result->attr.result && strcmp (sym->name,"ppr@") != 0)
+	{
+	  /* Unset proc_pointer as gfc_get_function_type
+	     is called recursively.  */
+	  sym->result->attr.proc_pointer = 0;
+	  type = build_pointer_type (gfc_get_function_type (sym->result));
+	  sym->result->attr.proc_pointer = 1;
+	}
+      else
+       type = gfc_sym_type (sym->result);
+    }
+  else
+    type = gfc_sym_type (sym);
+
+  if (is_varargs || recursive_type)
+    type = build_varargs_function_type_vec (type, typelist);
+  else
+    type = build_function_type_vec (type, typelist);
+  type = create_fn_spec (sym, type);
+
+  return type;
+}
+
+/* Language hooks for middle-end access to type nodes.  */
+
+/* Return an integer type with BITS bits of precision,
+   that is unsigned if UNSIGNEDP is nonzero, otherwise signed.  */
+
+tree
+gfc_type_for_size (unsigned bits, int unsignedp)
+{
+  if (!unsignedp)
+    {
+      int i;
+      for (i = 0; i <= MAX_INT_KINDS; ++i)
+	{
+	  tree type = gfc_integer_types[i];
+	  if (type && bits == TYPE_PRECISION (type))
+	    return type;
+	}
+
+      /* Handle TImode as a special case because it is used by some backends
+         (e.g. ARM) even though it is not available for normal use.  */
+#if HOST_BITS_PER_WIDE_INT >= 64
+      if (bits == TYPE_PRECISION (intTI_type_node))
+	return intTI_type_node;
+#endif
+
+      if (bits <= TYPE_PRECISION (intQI_type_node))
+	return intQI_type_node;
+      if (bits <= TYPE_PRECISION (intHI_type_node))
+	return intHI_type_node;
+      if (bits <= TYPE_PRECISION (intSI_type_node))
+	return intSI_type_node;
+      if (bits <= TYPE_PRECISION (intDI_type_node))
+	return intDI_type_node;
+      if (bits <= TYPE_PRECISION (intTI_type_node))
+	return intTI_type_node;
+    }
+  else
+    {
+      if (bits <= TYPE_PRECISION (unsigned_intQI_type_node))
+        return unsigned_intQI_type_node;
+      if (bits <= TYPE_PRECISION (unsigned_intHI_type_node))
+	return unsigned_intHI_type_node;
+      if (bits <= TYPE_PRECISION (unsigned_intSI_type_node))
+	return unsigned_intSI_type_node;
+      if (bits <= TYPE_PRECISION (unsigned_intDI_type_node))
+	return unsigned_intDI_type_node;
+      if (bits <= TYPE_PRECISION (unsigned_intTI_type_node))
+	return unsigned_intTI_type_node;
+    }
+
+  return NULL_TREE;
+}
+
+/* Return a data type that has machine mode MODE.  If the mode is an
+   integer, then UNSIGNEDP selects between signed and unsigned types.  */
+
+tree
+gfc_type_for_mode (enum machine_mode mode, int unsignedp)
+{
+  int i;
+  tree *base;
+
+  if (GET_MODE_CLASS (mode) == MODE_FLOAT)
+    base = gfc_real_types;
+  else if (GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT)
+    base = gfc_complex_types;
+  else if (SCALAR_INT_MODE_P (mode))
+    {
+      tree type = gfc_type_for_size (GET_MODE_PRECISION (mode), unsignedp);
+      return type != NULL_TREE && mode == TYPE_MODE (type) ? type : NULL_TREE;
+    }
+  else if (VECTOR_MODE_P (mode))
+    {
+      enum machine_mode inner_mode = GET_MODE_INNER (mode);
+      tree inner_type = gfc_type_for_mode (inner_mode, unsignedp);
+      if (inner_type != NULL_TREE)
+        return build_vector_type_for_mode (inner_type, mode);
+      return NULL_TREE;
+    }
+  else
+    return NULL_TREE;
+
+  for (i = 0; i <= MAX_REAL_KINDS; ++i)
+    {
+      tree type = base[i];
+      if (type && mode == TYPE_MODE (type))
+	return type;
+    }
+
+  return NULL_TREE;
+}
+
+/* Return TRUE if TYPE is a type with a hidden descriptor, fill in INFO
+   in that case.  */
+
+bool
+gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
+{
+  int rank, dim;
+  bool indirect = false;
+  tree etype, ptype, field, t, base_decl;
+  tree data_off, dim_off, dim_size, elem_size;
+  tree lower_suboff, upper_suboff, stride_suboff;
+
+  if (! GFC_DESCRIPTOR_TYPE_P (type))
+    {
+      if (! POINTER_TYPE_P (type))
+	return false;
+      type = TREE_TYPE (type);
+      if (! GFC_DESCRIPTOR_TYPE_P (type))
+	return false;
+      indirect = true;
+    }
+
+  rank = GFC_TYPE_ARRAY_RANK (type);
+  if (rank >= (int) (sizeof (info->dimen) / sizeof (info->dimen[0])))
+    return false;
+
+  etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
+  gcc_assert (POINTER_TYPE_P (etype));
+  etype = TREE_TYPE (etype);
+
+  /* If the type is not a scalar coarray.  */
+  if (TREE_CODE (etype) == ARRAY_TYPE)
+    etype = TREE_TYPE (etype);
+
+  /* Can't handle variable sized elements yet.  */
+  if (int_size_in_bytes (etype) <= 0)
+    return false;
+  /* Nor non-constant lower bounds in assumed shape arrays.  */
+  if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE
+      || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT)
+    {
+      for (dim = 0; dim < rank; dim++)
+	if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE
+	    || TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) != INTEGER_CST)
+	  return false;
+    }
+
+  memset (info, '\0', sizeof (*info));
+  info->ndimensions = rank;
+  info->element_type = etype;
+  ptype = build_pointer_type (gfc_array_index_type);
+  base_decl = GFC_TYPE_ARRAY_BASE_DECL (type, indirect);
+  if (!base_decl)
+    {
+      base_decl = build_decl (input_location, VAR_DECL, NULL_TREE,
+			      indirect ? build_pointer_type (ptype) : ptype);
+      GFC_TYPE_ARRAY_BASE_DECL (type, indirect) = base_decl;
+    }
+  info->base_decl = base_decl;
+  if (indirect)
+    base_decl = build1 (INDIRECT_REF, ptype, base_decl);
+
+  if (GFC_TYPE_ARRAY_SPAN (type))
+    elem_size = GFC_TYPE_ARRAY_SPAN (type);
+  else
+    elem_size = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (etype));
+  field = TYPE_FIELDS (TYPE_MAIN_VARIANT (type));
+  data_off = byte_position (field);
+  field = DECL_CHAIN (field);
+  field = DECL_CHAIN (field);
+  field = DECL_CHAIN (field);
+  dim_off = byte_position (field);
+  dim_size = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (field)));
+  field = TYPE_FIELDS (TREE_TYPE (TREE_TYPE (field)));
+  stride_suboff = byte_position (field);
+  field = DECL_CHAIN (field);
+  lower_suboff = byte_position (field);
+  field = DECL_CHAIN (field);
+  upper_suboff = byte_position (field);
+
+  t = base_decl;
+  if (!integer_zerop (data_off))
+    t = fold_build_pointer_plus (t, data_off);
+  t = build1 (NOP_EXPR, build_pointer_type (ptr_type_node), t);
+  info->data_location = build1 (INDIRECT_REF, ptr_type_node, t);
+  if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
+    info->allocated = build2 (NE_EXPR, boolean_type_node,
+			      info->data_location, null_pointer_node);
+  else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
+	   || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)
+    info->associated = build2 (NE_EXPR, boolean_type_node,
+			       info->data_location, null_pointer_node);
+
+  for (dim = 0; dim < rank; dim++)
+    {
+      t = fold_build_pointer_plus (base_decl,
+				   size_binop (PLUS_EXPR,
+					       dim_off, lower_suboff));
+      t = build1 (INDIRECT_REF, gfc_array_index_type, t);
+      info->dimen[dim].lower_bound = t;
+      t = fold_build_pointer_plus (base_decl,
+				   size_binop (PLUS_EXPR,
+					       dim_off, upper_suboff));
+      t = build1 (INDIRECT_REF, gfc_array_index_type, t);
+      info->dimen[dim].upper_bound = t;
+      if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE
+	  || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT)
+	{
+	  /* Assumed shape arrays have known lower bounds.  */
+	  info->dimen[dim].upper_bound
+	    = build2 (MINUS_EXPR, gfc_array_index_type,
+		      info->dimen[dim].upper_bound,
+		      info->dimen[dim].lower_bound);
+	  info->dimen[dim].lower_bound
+	    = fold_convert (gfc_array_index_type,
+			    GFC_TYPE_ARRAY_LBOUND (type, dim));
+	  info->dimen[dim].upper_bound
+	    = build2 (PLUS_EXPR, gfc_array_index_type,
+		      info->dimen[dim].lower_bound,
+		      info->dimen[dim].upper_bound);
+	}
+      t = fold_build_pointer_plus (base_decl,
+				   size_binop (PLUS_EXPR,
+					       dim_off, stride_suboff));
+      t = build1 (INDIRECT_REF, gfc_array_index_type, t);
+      t = build2 (MULT_EXPR, gfc_array_index_type, t, elem_size);
+      info->dimen[dim].stride = t;
+      dim_off = size_binop (PLUS_EXPR, dim_off, dim_size);
+    }
+
+  return true;
+}
+
+#include "gt-fortran-trans-types.h"
diff --git a/gcc-4.9/gcc/fortran/trans-types.h b/gcc-4.9/gcc/fortran/trans-types.h
new file mode 100644
index 000000000..e57c9d108
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/trans-types.h
@@ -0,0 +1,104 @@
+/* Header for Fortran 95 types backend support.
+   Copyright (C) 2002-2014 Free Software Foundation, Inc.
+   Contributed by Paul Brook <paul@nowt.org>
+   and Steven Bosscher <s.bosscher@student.tudelft.nl>
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+
+#ifndef GFC_BACKEND_H
+#define GFC_BACKEND_H
+
+extern GTY(()) tree gfc_array_index_type;
+extern GTY(()) tree gfc_array_range_type;
+extern GTY(()) tree gfc_character1_type_node;
+extern GTY(()) tree ppvoid_type_node;
+extern GTY(()) tree pvoid_type_node;
+extern GTY(()) tree prvoid_type_node;
+extern GTY(()) tree pchar_type_node;
+extern GTY(()) tree float128_type_node;
+extern GTY(()) tree complex_float128_type_node;
+
+/* This is the type used to hold the lengths of character variables.
+   It must be the same as the corresponding definition in gfortran.h.  */
+/* TODO: This is still hardcoded as kind=4 in some bits of the compiler
+   and runtime library.  */
+extern GTY(()) tree gfc_charlen_type_node;
+
+/* The following flags give us information on the correspondence of
+   real (and complex) kinds with C floating-point types long double
+   and __float128.  */
+extern bool gfc_real16_is_float128;
+
+typedef enum {
+  PACKED_NO = 0,
+  PACKED_PARTIAL,
+  PACKED_FULL,
+  PACKED_STATIC
+} gfc_packed;
+
+/* be-function.c */
+void gfc_convert_function_code (gfc_namespace *);
+
+/* trans-types.c */
+void gfc_init_kinds (void);
+void gfc_init_types (void);
+void gfc_init_c_interop_kinds (void);
+
+tree gfc_get_int_type (int);
+tree gfc_get_real_type (int);
+tree gfc_get_complex_type (int);
+tree gfc_get_logical_type (int);
+tree gfc_get_char_type (int);
+tree gfc_get_pchar_type (int);
+tree gfc_get_character_type (int, gfc_charlen *);
+tree gfc_get_character_type_len (int, tree);
+tree gfc_get_character_type_len_for_eltype (tree, tree);
+
+tree gfc_sym_type (gfc_symbol *);
+tree gfc_typenode_for_spec (gfc_typespec *);
+int gfc_copy_dt_decls_ifequal (gfc_symbol *, gfc_symbol *, bool);
+
+tree gfc_get_function_type (gfc_symbol *);
+
+tree gfc_type_for_size (unsigned, int);
+tree gfc_type_for_mode (enum machine_mode, int);
+tree gfc_build_uint_type (int);
+
+tree gfc_get_element_type (tree);
+tree gfc_get_array_type_bounds (tree, int, int, tree *, tree *, int,
+				enum gfc_array_kind, bool);
+tree gfc_get_nodesc_array_type (tree, gfc_array_spec *, gfc_packed, bool);
+
+/* Add a field of given name and type to a UNION_TYPE or RECORD_TYPE.  */
+tree gfc_add_field_to_struct (tree, tree, tree, tree **);
+
+/* Layout and output debugging info for a type.  */
+void gfc_finish_type (tree);
+
+/* Some functions have an extra parameter for the return value.  */
+int gfc_return_by_reference (gfc_symbol *);
+
+/* Returns true if the array sym does not require a descriptor.  */
+int gfc_is_nodesc_array (gfc_symbol *);
+
+/* Return the DTYPE for an array.  */
+tree gfc_get_dtype (tree);
+
+tree gfc_get_ppc_type (gfc_component *);
+
+#endif
diff --git a/gcc-4.9/gcc/fortran/trans.c b/gcc-4.9/gcc/fortran/trans.c
new file mode 100644
index 000000000..5961c267e
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/trans.c
@@ -0,0 +1,2090 @@
+/* Code translation -- generate GCC trees from gfc_code.
+   Copyright (C) 2002-2014 Free Software Foundation, Inc.
+   Contributed by Paul Brook
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "tree.h"
+#include "gimple-expr.h"	/* For create_tmp_var_raw.  */
+#include "stringpool.h"
+#include "tree-iterator.h"
+#include "diagnostic-core.h"  /* For internal_error.  */
+#include "flags.h"
+#include "gfortran.h"
+#include "trans.h"
+#include "trans-stmt.h"
+#include "trans-array.h"
+#include "trans-types.h"
+#include "trans-const.h"
+
+/* Naming convention for backend interface code:
+
+   gfc_trans_*	translate gfc_code into STMT trees.
+
+   gfc_conv_*	expression conversion
+
+   gfc_get_*	get a backend tree representation of a decl or type  */
+
+static gfc_file *gfc_current_backend_file;
+
+const char gfc_msg_fault[] = N_("Array reference out of bounds");
+const char gfc_msg_wrong_return[] = N_("Incorrect function return value");
+
+
+/* Advance along TREE_CHAIN n times.  */
+
+tree
+gfc_advance_chain (tree t, int n)
+{
+  for (; n > 0; n--)
+    {
+      gcc_assert (t != NULL_TREE);
+      t = DECL_CHAIN (t);
+    }
+  return t;
+}
+
+
+/* Strip off a legitimate source ending from the input
+   string NAME of length LEN.  */
+
+static inline void
+remove_suffix (char *name, int len)
+{
+  int i;
+
+  for (i = 2; i < 8 && len > i; i++)
+    {
+      if (name[len - i] == '.')
+	{
+	  name[len - i] = '\0';
+	  break;
+	}
+    }
+}
+
+
+/* Creates a variable declaration with a given TYPE.  */
+
+tree
+gfc_create_var_np (tree type, const char *prefix)
+{
+  tree t;
+
+  t = create_tmp_var_raw (type, prefix);
+
+  /* No warnings for anonymous variables.  */
+  if (prefix == NULL)
+    TREE_NO_WARNING (t) = 1;
+
+  return t;
+}
+
+
+/* Like above, but also adds it to the current scope.  */
+
+tree
+gfc_create_var (tree type, const char *prefix)
+{
+  tree tmp;
+
+  tmp = gfc_create_var_np (type, prefix);
+
+  pushdecl (tmp);
+
+  return tmp;
+}
+
+
+/* If the expression is not constant, evaluate it now.  We assign the
+   result of the expression to an artificially created variable VAR, and
+   return a pointer to the VAR_DECL node for this variable.  */
+
+tree
+gfc_evaluate_now_loc (location_t loc, tree expr, stmtblock_t * pblock)
+{
+  tree var;
+
+  if (CONSTANT_CLASS_P (expr))
+    return expr;
+
+  var = gfc_create_var (TREE_TYPE (expr), NULL);
+  gfc_add_modify_loc (loc, pblock, var, expr);
+
+  return var;
+}
+
+
+tree
+gfc_evaluate_now (tree expr, stmtblock_t * pblock)
+{
+  return gfc_evaluate_now_loc (input_location, expr, pblock);
+}
+
+
+/* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
+   A MODIFY_EXPR is an assignment:
+   LHS <- RHS.  */
+
+void
+gfc_add_modify_loc (location_t loc, stmtblock_t * pblock, tree lhs, tree rhs)
+{
+  tree tmp;
+
+#ifdef ENABLE_CHECKING
+  tree t1, t2;
+  t1 = TREE_TYPE (rhs);
+  t2 = TREE_TYPE (lhs);
+  /* Make sure that the types of the rhs and the lhs are the same
+     for scalar assignments.  We should probably have something
+     similar for aggregates, but right now removing that check just
+     breaks everything.  */
+  gcc_assert (t1 == t2
+	      || AGGREGATE_TYPE_P (TREE_TYPE (lhs)));
+#endif
+
+  tmp = fold_build2_loc (loc, MODIFY_EXPR, void_type_node, lhs,
+			 rhs);
+  gfc_add_expr_to_block (pblock, tmp);
+}
+
+
+void
+gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs)
+{
+  gfc_add_modify_loc (input_location, pblock, lhs, rhs);
+}
+
+
+/* Create a new scope/binding level and initialize a block.  Care must be
+   taken when translating expressions as any temporaries will be placed in
+   the innermost scope.  */
+
+void
+gfc_start_block (stmtblock_t * block)
+{
+  /* Start a new binding level.  */
+  pushlevel ();
+  block->has_scope = 1;
+
+  /* The block is empty.  */
+  block->head = NULL_TREE;
+}
+
+
+/* Initialize a block without creating a new scope.  */
+
+void
+gfc_init_block (stmtblock_t * block)
+{
+  block->head = NULL_TREE;
+  block->has_scope = 0;
+}
+
+
+/* Sometimes we create a scope but it turns out that we don't actually
+   need it.  This function merges the scope of BLOCK with its parent.
+   Only variable decls will be merged, you still need to add the code.  */
+
+void
+gfc_merge_block_scope (stmtblock_t * block)
+{
+  tree decl;
+  tree next;
+
+  gcc_assert (block->has_scope);
+  block->has_scope = 0;
+
+  /* Remember the decls in this scope.  */
+  decl = getdecls ();
+  poplevel (0, 0);
+
+  /* Add them to the parent scope.  */
+  while (decl != NULL_TREE)
+    {
+      next = DECL_CHAIN (decl);
+      DECL_CHAIN (decl) = NULL_TREE;
+
+      pushdecl (decl);
+      decl = next;
+    }
+}
+
+
+/* Finish a scope containing a block of statements.  */
+
+tree
+gfc_finish_block (stmtblock_t * stmtblock)
+{
+  tree decl;
+  tree expr;
+  tree block;
+
+  expr = stmtblock->head;
+  if (!expr)
+    expr = build_empty_stmt (input_location);
+
+  stmtblock->head = NULL_TREE;
+
+  if (stmtblock->has_scope)
+    {
+      decl = getdecls ();
+
+      if (decl)
+	{
+	  block = poplevel (1, 0);
+	  expr = build3_v (BIND_EXPR, decl, expr, block);
+	}
+      else
+	poplevel (0, 0);
+    }
+
+  return expr;
+}
+
+
+/* Build an ADDR_EXPR and cast the result to TYPE.  If TYPE is NULL, the
+   natural type is used.  */
+
+tree
+gfc_build_addr_expr (tree type, tree t)
+{
+  tree base_type = TREE_TYPE (t);
+  tree natural_type;
+
+  if (type && POINTER_TYPE_P (type)
+      && TREE_CODE (base_type) == ARRAY_TYPE
+      && TYPE_MAIN_VARIANT (TREE_TYPE (type))
+	 == TYPE_MAIN_VARIANT (TREE_TYPE (base_type)))
+    {
+      tree min_val = size_zero_node;
+      tree type_domain = TYPE_DOMAIN (base_type);
+      if (type_domain && TYPE_MIN_VALUE (type_domain))
+        min_val = TYPE_MIN_VALUE (type_domain);
+      t = fold (build4_loc (input_location, ARRAY_REF, TREE_TYPE (type),
+			    t, min_val, NULL_TREE, NULL_TREE));
+      natural_type = type;
+    }
+  else
+    natural_type = build_pointer_type (base_type);
+
+  if (TREE_CODE (t) == INDIRECT_REF)
+    {
+      if (!type)
+	type = natural_type;
+      t = TREE_OPERAND (t, 0);
+      natural_type = TREE_TYPE (t);
+    }
+  else
+    {
+      tree base = get_base_address (t);
+      if (base && DECL_P (base))
+        TREE_ADDRESSABLE (base) = 1;
+      t = fold_build1_loc (input_location, ADDR_EXPR, natural_type, t);
+    }
+
+  if (type && natural_type != type)
+    t = convert (type, t);
+
+  return t;
+}
+
+
+/* Build an ARRAY_REF with its natural type.  */
+
+tree
+gfc_build_array_ref (tree base, tree offset, tree decl)
+{
+  tree type = TREE_TYPE (base);
+  tree tmp;
+  tree span;
+
+  if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0)
+    {
+      gcc_assert (GFC_TYPE_ARRAY_CORANK (type) > 0);
+
+      return fold_convert (TYPE_MAIN_VARIANT (type), base);
+    }
+
+  /* Scalar coarray, there is nothing to do.  */
+  if (TREE_CODE (type) != ARRAY_TYPE)
+    {
+      gcc_assert (decl == NULL_TREE);
+      gcc_assert (integer_zerop (offset));
+      return base;
+    }
+
+  type = TREE_TYPE (type);
+
+  if (DECL_P (base))
+    TREE_ADDRESSABLE (base) = 1;
+
+  /* Strip NON_LVALUE_EXPR nodes.  */
+  STRIP_TYPE_NOPS (offset);
+
+  /* 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)))
+	   || GFC_DECL_CLASS (decl)))
+    {
+      if (GFC_DECL_CLASS (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_vtable_size_get (decl);
+	}
+      else if (GFC_DECL_SUBREF_ARRAY_P (decl))
+	span = GFC_DECL_SPAN(decl);
+      else
+	gcc_unreachable ();
+
+      offset = fold_build2_loc (input_location, MULT_EXPR,
+				gfc_array_index_type,
+				offset, span);
+      tmp = gfc_build_addr_expr (pvoid_type_node, base);
+      tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
+      tmp = fold_convert (build_pointer_type (type), tmp);
+      if (!TYPE_STRING_FLAG (type))
+	tmp = build_fold_indirect_ref_loc (input_location, tmp);
+      return tmp;
+    }
+  else
+    /* Otherwise use a straightforward array reference.  */
+    return build4_loc (input_location, ARRAY_REF, type, base, offset,
+		       NULL_TREE, NULL_TREE);
+}
+
+
+/* Generate a call to print a runtime error possibly including multiple
+   arguments and a locus.  */
+
+static tree
+trans_runtime_error_vararg (bool error, locus* where, const char* msgid,
+			    va_list ap)
+{
+  stmtblock_t block;
+  tree tmp;
+  tree arg, arg2;
+  tree *argarray;
+  tree fntype;
+  char *message;
+  const char *p;
+  int line, nargs, i;
+  location_t loc;
+
+  /* Compute the number of extra arguments from the format string.  */
+  for (p = msgid, nargs = 0; *p; p++)
+    if (*p == '%')
+      {
+	p++;
+	if (*p != '%')
+	  nargs++;
+      }
+
+  /* The code to generate the error.  */
+  gfc_start_block (&block);
+
+  if (where)
+    {
+      line = LOCATION_LINE (where->lb->location);
+      asprintf (&message, "At line %d of file %s",  line,
+		where->lb->file->filename);
+    }
+  else
+    asprintf (&message, "In file '%s', around line %d",
+	      gfc_source_file, LOCATION_LINE (input_location) + 1);
+
+  arg = gfc_build_addr_expr (pchar_type_node,
+			     gfc_build_localized_cstring_const (message));
+  free (message);
+
+  asprintf (&message, "%s", _(msgid));
+  arg2 = gfc_build_addr_expr (pchar_type_node,
+			      gfc_build_localized_cstring_const (message));
+  free (message);
+
+  /* Build the argument array.  */
+  argarray = XALLOCAVEC (tree, nargs + 2);
+  argarray[0] = arg;
+  argarray[1] = arg2;
+  for (i = 0; i < nargs; i++)
+    argarray[2 + i] = va_arg (ap, tree);
+
+  /* Build the function call to runtime_(warning,error)_at; because of the
+     variable number of arguments, we can't use build_call_expr_loc dinput_location,
+     irectly.  */
+  if (error)
+    fntype = TREE_TYPE (gfor_fndecl_runtime_error_at);
+  else
+    fntype = TREE_TYPE (gfor_fndecl_runtime_warning_at);
+
+  loc = where ? where->lb->location : input_location;
+  tmp = fold_builtin_call_array (loc, TREE_TYPE (fntype),
+				 fold_build1_loc (loc, ADDR_EXPR,
+					     build_pointer_type (fntype),
+					     error
+					     ? gfor_fndecl_runtime_error_at
+					     : gfor_fndecl_runtime_warning_at),
+				 nargs + 2, argarray);
+  gfc_add_expr_to_block (&block, tmp);
+
+  return gfc_finish_block (&block);
+}
+
+
+tree
+gfc_trans_runtime_error (bool error, locus* where, const char* msgid, ...)
+{
+  va_list ap;
+  tree result;
+
+  va_start (ap, msgid);
+  result = trans_runtime_error_vararg (error, where, msgid, ap);
+  va_end (ap);
+  return result;
+}
+
+
+/* Generate a runtime error if COND is true.  */
+
+void
+gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
+			 locus * where, const char * msgid, ...)
+{
+  va_list ap;
+  stmtblock_t block;
+  tree body;
+  tree tmp;
+  tree tmpvar = NULL;
+
+  if (integer_zerop (cond))
+    return;
+
+  if (once)
+    {
+       tmpvar = gfc_create_var (boolean_type_node, "print_warning");
+       TREE_STATIC (tmpvar) = 1;
+       DECL_INITIAL (tmpvar) = boolean_true_node;
+       gfc_add_expr_to_block (pblock, tmpvar);
+    }
+
+  gfc_start_block (&block);
+
+  /* For error, runtime_error_at already implies PRED_NORETURN.  */
+  if (!error && once)
+    gfc_add_expr_to_block (&block, build_predict_expr (PRED_FORTRAN_WARN_ONCE,
+						       NOT_TAKEN));
+
+  /* The code to generate the error.  */
+  va_start (ap, msgid);
+  gfc_add_expr_to_block (&block,
+			 trans_runtime_error_vararg (error, where,
+						     msgid, ap));
+  va_end (ap);
+
+  if (once)
+    gfc_add_modify (&block, tmpvar, boolean_false_node);
+
+  body = gfc_finish_block (&block);
+
+  if (integer_onep (cond))
+    {
+      gfc_add_expr_to_block (pblock, body);
+    }
+  else
+    {
+      if (once)
+	cond = fold_build2_loc (where->lb->location, TRUTH_AND_EXPR,
+				long_integer_type_node, tmpvar, cond);
+      else
+	cond = fold_convert (long_integer_type_node, cond);
+
+      tmp = fold_build3_loc (where->lb->location, COND_EXPR, void_type_node,
+			     cond, body,
+			     build_empty_stmt (where->lb->location));
+      gfc_add_expr_to_block (pblock, tmp);
+    }
+}
+
+
+/* Call malloc to allocate size bytes of memory, with special conditions:
+      + if size == 0, return a malloced area of size 1,
+      + if malloc returns NULL, issue a runtime error.  */
+tree
+gfc_call_malloc (stmtblock_t * block, tree type, tree size)
+{
+  tree tmp, msg, malloc_result, null_result, res, malloc_tree;
+  stmtblock_t block2;
+
+  size = gfc_evaluate_now (size, block);
+
+  if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
+    size = fold_convert (size_type_node, size);
+
+  /* Create a variable to hold the result.  */
+  res = gfc_create_var (prvoid_type_node, NULL);
+
+  /* Call malloc.  */
+  gfc_start_block (&block2);
+
+  size = fold_build2_loc (input_location, MAX_EXPR, size_type_node, size,
+			  build_int_cst (size_type_node, 1));
+
+  malloc_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
+  gfc_add_modify (&block2, res,
+		  fold_convert (prvoid_type_node,
+				build_call_expr_loc (input_location,
+						     malloc_tree, 1, size)));
+
+  /* Optionally check whether malloc was successful.  */
+  if (gfc_option.rtcheck & GFC_RTCHECK_MEM)
+    {
+      null_result = fold_build2_loc (input_location, EQ_EXPR,
+				     boolean_type_node, res,
+				     build_int_cst (pvoid_type_node, 0));
+      msg = gfc_build_addr_expr (pchar_type_node,
+	      gfc_build_localized_cstring_const ("Memory allocation failed"));
+      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+			     null_result,
+	      build_call_expr_loc (input_location,
+				   gfor_fndecl_os_error, 1, msg),
+				   build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&block2, tmp);
+    }
+
+  malloc_result = gfc_finish_block (&block2);
+
+  gfc_add_expr_to_block (block, malloc_result);
+
+  if (type != NULL)
+    res = fold_convert (type, res);
+  return res;
+}
+
+
+/* Allocate memory, using an optional status argument.
+
+   This function follows the following pseudo-code:
+
+    void *
+    allocate (size_t size, integer_type stat)
+    {
+      void *newmem;
+
+      if (stat requested)
+	stat = 0;
+
+      newmem = malloc (MAX (size, 1));
+      if (newmem == NULL)
+      {
+        if (stat)
+          *stat = LIBERROR_ALLOCATION;
+        else
+	  runtime_error ("Allocation would exceed memory limit");
+      }
+      return newmem;
+    }  */
+void
+gfc_allocate_using_malloc (stmtblock_t * block, tree pointer,
+			   tree size, tree status)
+{
+  tree tmp, error_cond;
+  stmtblock_t on_error;
+  tree status_type = status ? TREE_TYPE (status) : NULL_TREE;
+
+  /* Evaluate size only once, and make sure it has the right type.  */
+  size = gfc_evaluate_now (size, block);
+  if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
+    size = fold_convert (size_type_node, size);
+
+  /* If successful and stat= is given, set status to 0.  */
+  if (status != NULL_TREE)
+      gfc_add_expr_to_block (block,
+	     fold_build2_loc (input_location, MODIFY_EXPR, status_type,
+			      status, build_int_cst (status_type, 0)));
+
+  /* The allocation itself.  */
+  gfc_add_modify (block, pointer,
+	  fold_convert (TREE_TYPE (pointer),
+		build_call_expr_loc (input_location,
+			     builtin_decl_explicit (BUILT_IN_MALLOC), 1,
+			     fold_build2_loc (input_location,
+				      MAX_EXPR, size_type_node, size,
+				      build_int_cst (size_type_node, 1)))));
+
+  /* What to do in case of error.  */
+  gfc_start_block (&on_error);
+  if (status != NULL_TREE)
+    {
+      gfc_add_expr_to_block (&on_error,
+			     build_predict_expr (PRED_FORTRAN_FAIL_ALLOC,
+						 NOT_TAKEN));
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, status,
+			     build_int_cst (status_type, LIBERROR_ALLOCATION));
+      gfc_add_expr_to_block (&on_error, tmp);
+    }
+  else
+    {
+      /* Here, os_error already implies PRED_NORETURN.  */
+      tmp = build_call_expr_loc (input_location, gfor_fndecl_os_error, 1,
+		    gfc_build_addr_expr (pchar_type_node,
+				 gfc_build_localized_cstring_const
+				    ("Allocation would exceed memory limit")));
+      gfc_add_expr_to_block (&on_error, tmp);
+    }
+
+  error_cond = fold_build2_loc (input_location, EQ_EXPR,
+				boolean_type_node, pointer,
+				build_int_cst (prvoid_type_node, 0));
+  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+			 error_cond, gfc_finish_block (&on_error),
+			 build_empty_stmt (input_location));
+
+  gfc_add_expr_to_block (block, tmp);
+}
+
+
+/* Allocate memory, using an optional status argument.
+
+   This function follows the following pseudo-code:
+
+    void *
+    allocate (size_t size, void** token, int *stat, char* errmsg, int errlen)
+    {
+      void *newmem;
+
+      newmem = _caf_register (size, regtype, token, &stat, errmsg, errlen);
+      return newmem;
+    }  */
+static void
+gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size,
+			tree token, tree status, tree errmsg, tree errlen)
+{
+  tree tmp, pstat;
+
+  gcc_assert (token != NULL_TREE);
+
+  /* Evaluate size only once, and make sure it has the right type.  */
+  size = gfc_evaluate_now (size, block);
+  if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
+    size = fold_convert (size_type_node, size);
+
+  /* The allocation itself.  */
+  if (status == NULL_TREE)
+    pstat  = null_pointer_node;
+  else
+    pstat  = gfc_build_addr_expr (NULL_TREE, status);
+
+  if (errmsg == NULL_TREE)
+    {
+      gcc_assert(errlen == NULL_TREE);
+      errmsg = null_pointer_node;
+      errlen = build_int_cst (integer_type_node, 0);
+    }
+
+  tmp = build_call_expr_loc (input_location,
+	     gfor_fndecl_caf_register, 6,
+	     fold_build2_loc (input_location,
+			      MAX_EXPR, size_type_node, size,
+			      build_int_cst (size_type_node, 1)),
+	     build_int_cst (integer_type_node,
+			    GFC_CAF_COARRAY_ALLOC),
+	     token, pstat, errmsg, errlen);
+
+  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+			 TREE_TYPE (pointer), pointer,
+			 fold_convert ( TREE_TYPE (pointer), tmp));
+  gfc_add_expr_to_block (block, tmp);
+}
+
+
+/* Generate code for an ALLOCATE statement when the argument is an
+   allocatable variable.  If the variable is currently allocated, it is an
+   error to allocate it again.
+
+   This function follows the following pseudo-code:
+
+    void *
+    allocate_allocatable (void *mem, size_t size, integer_type stat)
+    {
+      if (mem == NULL)
+	return allocate (size, stat);
+      else
+      {
+	if (stat)
+	  stat = LIBERROR_ALLOCATION;
+	else
+	  runtime_error ("Attempting to allocate already allocated variable");
+      }
+    }
+
+    expr must be set to the original expression being allocated for its locus
+    and variable name in case a runtime error has to be printed.  */
+void
+gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree token,
+			  tree status, tree errmsg, tree errlen, tree label_finish,
+			  gfc_expr* expr)
+{
+  stmtblock_t alloc_block;
+  tree tmp, null_mem, alloc, error;
+  tree type = TREE_TYPE (mem);
+
+  if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
+    size = fold_convert (size_type_node, size);
+
+  null_mem = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
+					    boolean_type_node, mem,
+					    build_int_cst (type, 0)),
+			   PRED_FORTRAN_FAIL_ALLOC);
+
+  /* If mem is NULL, we call gfc_allocate_using_malloc or
+     gfc_allocate_using_lib.  */
+  gfc_start_block (&alloc_block);
+
+  if (gfc_option.coarray == GFC_FCOARRAY_LIB
+      && gfc_expr_attr (expr).codimension)
+    {
+      tree cond;
+
+      gfc_allocate_using_lib (&alloc_block, mem, size, token, status,
+			      errmsg, errlen);
+      if (status != NULL_TREE)
+	{
+	  TREE_USED (label_finish) = 1;
+	  tmp = build1_v (GOTO_EXPR, label_finish);
+	  cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+				  status, build_zero_cst (TREE_TYPE (status)));
+	  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+				 gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC),
+				 tmp, build_empty_stmt (input_location));
+	  gfc_add_expr_to_block (&alloc_block, tmp);
+	}
+    }
+  else
+    gfc_allocate_using_malloc (&alloc_block, mem, size, status);
+
+  alloc = gfc_finish_block (&alloc_block);
+
+  /* If mem is not NULL, we issue a runtime error or set the
+     status variable.  */
+  if (expr)
+    {
+      tree varname;
+
+      gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->symtree);
+      varname = gfc_build_cstring_const (expr->symtree->name);
+      varname = gfc_build_addr_expr (pchar_type_node, varname);
+
+      error = gfc_trans_runtime_error (true, &expr->where,
+				       "Attempting to allocate already"
+				       " allocated variable '%s'",
+				       varname);
+    }
+  else
+    error = gfc_trans_runtime_error (true, NULL,
+				     "Attempting to allocate already allocated"
+				     " variable");
+
+  if (status != NULL_TREE)
+    {
+      tree status_type = TREE_TYPE (status);
+
+      error = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
+	      status, build_int_cst (status_type, LIBERROR_ALLOCATION));
+    }
+
+  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem,
+			 error, alloc);
+  gfc_add_expr_to_block (block, tmp);
+}
+
+
+/* Free a given variable, if it's not NULL.  */
+tree
+gfc_call_free (tree var)
+{
+  stmtblock_t block;
+  tree tmp, cond, call;
+
+  if (TREE_TYPE (var) != TREE_TYPE (pvoid_type_node))
+    var = fold_convert (pvoid_type_node, var);
+
+  gfc_start_block (&block);
+  var = gfc_evaluate_now (var, &block);
+  cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, var,
+			  build_int_cst (pvoid_type_node, 0));
+  call = build_call_expr_loc (input_location,
+			      builtin_decl_explicit (BUILT_IN_FREE),
+			      1, var);
+  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, call,
+			 build_empty_stmt (input_location));
+  gfc_add_expr_to_block (&block, tmp);
+
+  return gfc_finish_block (&block);
+}
+
+
+/* Build a call to a FINAL procedure, which finalizes "var".  */
+
+static tree
+gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
+		      bool fini_coarray, gfc_expr *class_size)
+{
+  stmtblock_t block;
+  gfc_se se;
+  tree final_fndecl, array, size, tmp;
+  symbol_attribute attr;
+
+  gcc_assert (final_wrapper->expr_type == EXPR_VARIABLE);
+  gcc_assert (var);
+
+  gfc_start_block (&block);
+  gfc_init_se (&se, NULL);
+  gfc_conv_expr (&se, final_wrapper);
+  final_fndecl = se.expr;
+  if (POINTER_TYPE_P (TREE_TYPE (final_fndecl)))
+    final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl);
+
+  if (ts.type == BT_DERIVED)
+    {
+      tree elem_size;
+
+      gcc_assert (!class_size);
+      elem_size = gfc_typenode_for_spec (&ts);
+      elem_size = TYPE_SIZE_UNIT (elem_size);
+      size = fold_convert (gfc_array_index_type, elem_size);
+
+      gfc_init_se (&se, NULL);
+      se.want_pointer = 1;
+      if (var->rank)
+	{
+	  se.descriptor_only = 1;
+	  gfc_conv_expr_descriptor (&se, var);
+	  array = se.expr;
+	}
+      else
+	{
+	  gfc_conv_expr (&se, var);
+	  gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE);
+	  array = se.expr;
+
+	  /* No copy back needed, hence set attr's allocatable/pointer
+	     to zero.  */
+	  gfc_clear_attr (&attr);
+	  gfc_init_se (&se, NULL);
+	  array = gfc_conv_scalar_to_descriptor (&se, array, attr);
+	  gcc_assert (se.post.head == NULL_TREE);
+	}
+    }
+  else
+    {
+      gfc_expr *array_expr;
+      gcc_assert (class_size);
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr (&se, class_size);
+      gfc_add_block_to_block (&block, &se.pre);
+      gcc_assert (se.post.head == NULL_TREE);
+      size = se.expr;
+
+      array_expr = gfc_copy_expr (var);
+      gfc_init_se (&se, NULL);
+      se.want_pointer = 1;
+      if (array_expr->rank)
+	{
+	  gfc_add_class_array_ref (array_expr);
+	  se.descriptor_only = 1;
+	  gfc_conv_expr_descriptor (&se, array_expr);
+	  array = se.expr;
+	}
+      else
+	{
+	  gfc_add_data_component (array_expr);
+	  gfc_conv_expr (&se, array_expr);
+	  gfc_add_block_to_block (&block, &se.pre);
+	  gcc_assert (se.post.head == NULL_TREE);
+	  array = se.expr;
+	  if (TREE_CODE (array) == ADDR_EXPR
+	      && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array, 0))))
+	    tmp = TREE_OPERAND (array, 0);
+
+	  if (!gfc_is_coarray (array_expr))
+	    {
+	      /* No copy back needed, hence set attr's allocatable/pointer
+		 to zero.  */
+	      gfc_clear_attr (&attr);
+	      gfc_init_se (&se, NULL);
+	      array = gfc_conv_scalar_to_descriptor (&se, array, attr);
+	    }
+	  gcc_assert (se.post.head == NULL_TREE);
+	}
+      gfc_free_expr (array_expr);
+    }
+
+  if (!POINTER_TYPE_P (TREE_TYPE (array)))
+    array = gfc_build_addr_expr (NULL, array);
+
+  gfc_add_block_to_block (&block, &se.pre);
+  tmp = build_call_expr_loc (input_location,
+			     final_fndecl, 3, array,
+			     size, fini_coarray ? boolean_true_node
+						: boolean_false_node);
+  gfc_add_block_to_block (&block, &se.post);
+  gfc_add_expr_to_block (&block, tmp);
+  return gfc_finish_block (&block);
+}
+
+
+bool
+gfc_add_comp_finalizer_call (stmtblock_t *block, tree decl, gfc_component *comp,
+			     bool fini_coarray)
+{
+  gfc_se se;
+  stmtblock_t block2;
+  tree final_fndecl, size, array, tmp, cond;
+  symbol_attribute attr;
+  gfc_expr *final_expr = NULL;
+
+  if (comp->ts.type != BT_DERIVED && comp->ts.type != BT_CLASS)
+    return false;
+
+  gfc_init_block (&block2);
+
+  if (comp->ts.type == BT_DERIVED)
+    {
+      if (comp->attr.pointer)
+	return false;
+
+      gfc_is_finalizable (comp->ts.u.derived, &final_expr);
+      if (!final_expr)
+        return false;
+
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr (&se, final_expr);
+      final_fndecl = se.expr;
+      size = gfc_typenode_for_spec (&comp->ts);
+      size = TYPE_SIZE_UNIT (size);
+      size = fold_convert (gfc_array_index_type, size);
+
+      array = decl;
+    }
+  else /* comp->ts.type == BT_CLASS.  */
+    {
+      if (CLASS_DATA (comp)->attr.class_pointer)
+	return false;
+
+      gfc_is_finalizable (CLASS_DATA (comp)->ts.u.derived, &final_expr);
+      final_fndecl = gfc_vtable_final_get (decl);
+      size = gfc_vtable_size_get (decl);
+      array = gfc_class_data_get (decl);
+    }
+
+  if (comp->attr.allocatable
+      || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.allocatable))
+    {
+      tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array))
+	    ?  gfc_conv_descriptor_data_get (array) : array;
+      cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			    tmp, fold_convert (TREE_TYPE (tmp),
+						 null_pointer_node));
+    }
+  else
+    cond = boolean_true_node;
+
+  if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array)))
+    {
+      gfc_clear_attr (&attr);
+      gfc_init_se (&se, NULL);
+      array = gfc_conv_scalar_to_descriptor (&se, array, attr);
+      gfc_add_block_to_block (&block2, &se.pre);
+      gcc_assert (se.post.head == NULL_TREE);
+    }
+
+  if (!POINTER_TYPE_P (TREE_TYPE (array)))
+    array = gfc_build_addr_expr (NULL, array);
+
+  if (!final_expr)
+    {
+      tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			     final_fndecl,
+			     fold_convert (TREE_TYPE (final_fndecl),
+					   null_pointer_node));
+      cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
+			      boolean_type_node, cond, tmp);
+    }
+
+  if (POINTER_TYPE_P (TREE_TYPE (final_fndecl)))
+    final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl);
+
+  tmp = build_call_expr_loc (input_location,
+			     final_fndecl, 3, array,
+			     size, fini_coarray ? boolean_true_node
+						: boolean_false_node);
+  gfc_add_expr_to_block (&block2, tmp);
+  tmp = gfc_finish_block (&block2);
+
+  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
+			 build_empty_stmt (input_location));
+  gfc_add_expr_to_block (block, tmp);
+
+  return true;
+}
+
+
+/* Add a call to the finalizer, using the passed *expr. Returns
+   true when a finalizer call has been inserted.  */
+
+bool
+gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2)
+{
+  tree tmp;
+  gfc_ref *ref;
+  gfc_expr *expr;
+  gfc_expr *final_expr = NULL;
+  gfc_expr *elem_size = NULL;
+  bool has_finalizer = false;
+
+  if (!expr2 || (expr2->ts.type != BT_DERIVED && expr2->ts.type != BT_CLASS))
+    return false;
+
+  if (expr2->ts.type == BT_DERIVED)
+    {
+      gfc_is_finalizable (expr2->ts.u.derived, &final_expr);
+      if (!final_expr)
+        return false;
+    }
+
+  /* If we have a class array, we need go back to the class
+     container. */
+  expr = gfc_copy_expr (expr2);
+
+  if (expr->ref && expr->ref->next && !expr->ref->next->next
+      && expr->ref->next->type == REF_ARRAY
+      && expr->ref->type == REF_COMPONENT
+      && strcmp (expr->ref->u.c.component->name, "_data") == 0)
+    {
+      gfc_free_ref_list (expr->ref);
+      expr->ref = NULL;
+    }
+  else
+    for (ref = expr->ref; ref; ref = ref->next)
+      if (ref->next && ref->next->next && !ref->next->next->next
+         && ref->next->next->type == REF_ARRAY
+         && ref->next->type == REF_COMPONENT
+         && strcmp (ref->next->u.c.component->name, "_data") == 0)
+       {
+         gfc_free_ref_list (ref->next);
+         ref->next = NULL;
+       }
+
+  if (expr->ts.type == BT_CLASS)
+    {
+      has_finalizer = gfc_is_finalizable (expr->ts.u.derived, NULL);
+
+      if (!expr2->rank && !expr2->ref && CLASS_DATA (expr2->symtree->n.sym)->as)
+	expr->rank = CLASS_DATA (expr2->symtree->n.sym)->as->rank;
+
+      final_expr = gfc_copy_expr (expr);
+      gfc_add_vptr_component (final_expr);
+      gfc_add_component_ref (final_expr, "_final");
+
+      elem_size = gfc_copy_expr (expr);
+      gfc_add_vptr_component (elem_size);
+      gfc_add_component_ref (elem_size, "_size");
+    }
+
+  gcc_assert (final_expr->expr_type == EXPR_VARIABLE);
+
+  tmp = gfc_build_final_call (expr->ts, final_expr, expr,
+			      false, elem_size);
+
+  if (expr->ts.type == BT_CLASS && !has_finalizer)
+    {
+      tree cond;
+      gfc_se se;
+
+      gfc_init_se (&se, NULL);
+      se.want_pointer = 1;
+      gfc_conv_expr (&se, final_expr);
+      cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			      se.expr, build_int_cst (TREE_TYPE (se.expr), 0));
+
+      /* For CLASS(*) not only sym->_vtab->_final can be NULL
+	 but already sym->_vtab itself.  */
+      if (UNLIMITED_POLY (expr))
+	{
+	  tree cond2;
+	  gfc_expr *vptr_expr;
+
+	  vptr_expr = gfc_copy_expr (expr);
+	  gfc_add_vptr_component (vptr_expr);
+
+	  gfc_init_se (&se, NULL);
+	  se.want_pointer = 1;
+	  gfc_conv_expr (&se, vptr_expr);
+	  gfc_free_expr (vptr_expr);
+
+	  cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+				   se.expr,
+				   build_int_cst (TREE_TYPE (se.expr), 0));
+	  cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
+				  boolean_type_node, cond2, cond);
+	}
+
+      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+			     cond, tmp, build_empty_stmt (input_location));
+    }
+
+  gfc_add_expr_to_block (block, tmp);
+
+  return true;
+}
+
+
+/* User-deallocate; we emit the code directly from the front-end, and the
+   logic is the same as the previous library function:
+
+    void
+    deallocate (void *pointer, GFC_INTEGER_4 * stat)
+    {
+      if (!pointer)
+	{
+	  if (stat)
+	    *stat = 1;
+	  else
+	    runtime_error ("Attempt to DEALLOCATE unallocated memory.");
+	}
+      else
+	{
+	  free (pointer);
+	  if (stat)
+	    *stat = 0;
+	}
+    }
+
+   In this front-end version, status doesn't have to be GFC_INTEGER_4.
+   Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
+   even when no status variable is passed to us (this is used for
+   unconditional deallocation generated by the front-end at end of
+   each procedure).
+
+   If a runtime-message is possible, `expr' must point to the original
+   expression being deallocated for its locus and variable name.
+
+   For coarrays, "pointer" must be the array descriptor and not its
+   "data" component.  */
+tree
+gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
+			    tree errlen, tree label_finish,
+			    bool can_fail, gfc_expr* expr, bool coarray)
+{
+  stmtblock_t null, non_null;
+  tree cond, tmp, error;
+  tree status_type = NULL_TREE;
+  tree caf_decl = NULL_TREE;
+
+  if (coarray)
+    {
+      gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)));
+      caf_decl = pointer;
+      pointer = gfc_conv_descriptor_data_get (caf_decl);
+      STRIP_NOPS (pointer);
+    }
+
+  cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
+			  build_int_cst (TREE_TYPE (pointer), 0));
+
+  /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
+     we emit a runtime error.  */
+  gfc_start_block (&null);
+  if (!can_fail)
+    {
+      tree varname;
+
+      gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
+
+      varname = gfc_build_cstring_const (expr->symtree->name);
+      varname = gfc_build_addr_expr (pchar_type_node, varname);
+
+      error = gfc_trans_runtime_error (true, &expr->where,
+				       "Attempt to DEALLOCATE unallocated '%s'",
+				       varname);
+    }
+  else
+    error = build_empty_stmt (input_location);
+
+  if (status != NULL_TREE && !integer_zerop (status))
+    {
+      tree cond2;
+
+      status_type = TREE_TYPE (TREE_TYPE (status));
+      cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			       status, build_int_cst (TREE_TYPE (status), 0));
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
+			     fold_build1_loc (input_location, INDIRECT_REF,
+					      status_type, status),
+			     build_int_cst (status_type, 1));
+      error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+			       cond2, tmp, error);
+    }
+
+  gfc_add_expr_to_block (&null, error);
+
+  /* When POINTER is not NULL, we free it.  */
+  gfc_start_block (&non_null);
+  gfc_add_finalizer_call (&non_null, expr);
+  if (!coarray || gfc_option.coarray != GFC_FCOARRAY_LIB)
+    {
+      tmp = build_call_expr_loc (input_location,
+				 builtin_decl_explicit (BUILT_IN_FREE), 1,
+				 fold_convert (pvoid_type_node, pointer));
+      gfc_add_expr_to_block (&non_null, tmp);
+
+      if (status != NULL_TREE && !integer_zerop (status))
+	{
+	  /* We set STATUS to zero if it is present.  */
+	  tree status_type = TREE_TYPE (TREE_TYPE (status));
+	  tree cond2;
+
+	  cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+				   status,
+				   build_int_cst (TREE_TYPE (status), 0));
+	  tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
+				 fold_build1_loc (input_location, INDIRECT_REF,
+						  status_type, status),
+				 build_int_cst (status_type, 0));
+	  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+				 gfc_unlikely (cond2, PRED_FORTRAN_FAIL_ALLOC),
+				 tmp, build_empty_stmt (input_location));
+	  gfc_add_expr_to_block (&non_null, tmp);
+	}
+    }
+  else
+    {
+      tree caf_type, token, cond2;
+      tree pstat = null_pointer_node;
+
+      if (errmsg == NULL_TREE)
+	{
+	  gcc_assert (errlen == NULL_TREE);
+	  errmsg = null_pointer_node;
+	  errlen = build_zero_cst (integer_type_node);
+	}
+      else
+	{
+	  gcc_assert (errlen != NULL_TREE);
+	  if (!POINTER_TYPE_P (TREE_TYPE (errmsg)))
+	    errmsg = gfc_build_addr_expr (NULL_TREE, errmsg);
+	}
+
+      caf_type = TREE_TYPE (caf_decl);
+
+      if (status != NULL_TREE && !integer_zerop (status))
+	{
+	  gcc_assert (status_type == integer_type_node);
+	  pstat = status;
+	}
+
+      if (GFC_DESCRIPTOR_TYPE_P (caf_type)
+	  && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
+	token = gfc_conv_descriptor_token (caf_decl);
+      else if (DECL_LANG_SPECIFIC (caf_decl)
+	       && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
+	token = GFC_DECL_TOKEN (caf_decl);
+      else
+	{
+	  gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
+		      && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
+	  token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
+	}
+
+      token = gfc_build_addr_expr  (NULL_TREE, token);
+      tmp = build_call_expr_loc (input_location,
+	     gfor_fndecl_caf_deregister, 4,
+	     token, pstat, errmsg, errlen);
+      gfc_add_expr_to_block (&non_null, tmp);
+
+      if (status != NULL_TREE)
+	{
+	  tree stat = build_fold_indirect_ref_loc (input_location, status);
+
+	  TREE_USED (label_finish) = 1;
+	  tmp = build1_v (GOTO_EXPR, label_finish);
+	  cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+				   stat, build_zero_cst (TREE_TYPE (stat)));
+	  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+				 gfc_unlikely (cond2, PRED_FORTRAN_FAIL_ALLOC),
+				 tmp, build_empty_stmt (input_location));
+	  gfc_add_expr_to_block (&non_null, tmp);
+	}
+    }
+
+  return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+			  gfc_finish_block (&null),
+			  gfc_finish_block (&non_null));
+}
+
+
+/* Generate code for deallocation of allocatable scalars (variables or
+   components). Before the object itself is freed, any allocatable
+   subcomponents are being deallocated.  */
+
+tree
+gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail,
+				   gfc_expr* expr, gfc_typespec ts)
+{
+  stmtblock_t null, non_null;
+  tree cond, tmp, error;
+  bool finalizable;
+
+  cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
+			  build_int_cst (TREE_TYPE (pointer), 0));
+
+  /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
+     we emit a runtime error.  */
+  gfc_start_block (&null);
+  if (!can_fail)
+    {
+      tree varname;
+
+      gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
+
+      varname = gfc_build_cstring_const (expr->symtree->name);
+      varname = gfc_build_addr_expr (pchar_type_node, varname);
+
+      error = gfc_trans_runtime_error (true, &expr->where,
+				       "Attempt to DEALLOCATE unallocated '%s'",
+				       varname);
+    }
+  else
+    error = build_empty_stmt (input_location);
+
+  if (status != NULL_TREE && !integer_zerop (status))
+    {
+      tree status_type = TREE_TYPE (TREE_TYPE (status));
+      tree cond2;
+
+      cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			       status, build_int_cst (TREE_TYPE (status), 0));
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
+			     fold_build1_loc (input_location, INDIRECT_REF,
+					      status_type, status),
+			     build_int_cst (status_type, 1));
+      error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+			       cond2, tmp, error);
+    }
+
+  gfc_add_expr_to_block (&null, error);
+
+  /* When POINTER is not NULL, we free it.  */
+  gfc_start_block (&non_null);
+
+  /* Free allocatable components.  */
+  finalizable = gfc_add_finalizer_call (&non_null, expr);
+  if (!finalizable && ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
+    {
+      tmp = build_fold_indirect_ref_loc (input_location, pointer);
+      tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
+      gfc_add_expr_to_block (&non_null, tmp);
+    }
+
+  tmp = build_call_expr_loc (input_location,
+			     builtin_decl_explicit (BUILT_IN_FREE), 1,
+			     fold_convert (pvoid_type_node, pointer));
+  gfc_add_expr_to_block (&non_null, tmp);
+
+  if (status != NULL_TREE && !integer_zerop (status))
+    {
+      /* We set STATUS to zero if it is present.  */
+      tree status_type = TREE_TYPE (TREE_TYPE (status));
+      tree cond2;
+
+      cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			       status, build_int_cst (TREE_TYPE (status), 0));
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
+			     fold_build1_loc (input_location, INDIRECT_REF,
+					      status_type, status),
+			     build_int_cst (status_type, 0));
+      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
+			     tmp, build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&non_null, tmp);
+    }
+
+  return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+			  gfc_finish_block (&null),
+			  gfc_finish_block (&non_null));
+}
+
+
+/* Reallocate MEM so it has SIZE bytes of data.  This behaves like the
+   following pseudo-code:
+
+void *
+internal_realloc (void *mem, size_t size)
+{
+  res = realloc (mem, size);
+  if (!res && size != 0)
+    _gfortran_os_error ("Allocation would exceed memory limit");
+
+  return res;
+}  */
+tree
+gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
+{
+  tree msg, res, nonzero, null_result, tmp;
+  tree type = TREE_TYPE (mem);
+
+  size = gfc_evaluate_now (size, block);
+
+  if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
+    size = fold_convert (size_type_node, size);
+
+  /* Create a variable to hold the result.  */
+  res = gfc_create_var (type, NULL);
+
+  /* Call realloc and check the result.  */
+  tmp = build_call_expr_loc (input_location,
+			 builtin_decl_explicit (BUILT_IN_REALLOC), 2,
+			 fold_convert (pvoid_type_node, mem), size);
+  gfc_add_modify (block, res, fold_convert (type, tmp));
+  null_result = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+				 res, build_int_cst (pvoid_type_node, 0));
+  nonzero = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, size,
+			     build_int_cst (size_type_node, 0));
+  null_result = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
+				 null_result, nonzero);
+  msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
+			     ("Allocation would exceed memory limit"));
+  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+			 null_result,
+			 build_call_expr_loc (input_location,
+					      gfor_fndecl_os_error, 1, msg),
+			 build_empty_stmt (input_location));
+  gfc_add_expr_to_block (block, tmp);
+
+  return res;
+}
+
+
+/* Add an expression to another one, either at the front or the back.  */
+
+static void
+add_expr_to_chain (tree* chain, tree expr, bool front)
+{
+  if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
+    return;
+
+  if (*chain)
+    {
+      if (TREE_CODE (*chain) != STATEMENT_LIST)
+	{
+	  tree tmp;
+
+	  tmp = *chain;
+	  *chain = NULL_TREE;
+	  append_to_statement_list (tmp, chain);
+	}
+
+      if (front)
+	{
+	  tree_stmt_iterator i;
+
+	  i = tsi_start (*chain);
+	  tsi_link_before (&i, expr, TSI_CONTINUE_LINKING);
+	}
+      else
+	append_to_statement_list (expr, chain);
+    }
+  else
+    *chain = expr;
+}
+
+
+/* Add a statement at the end of a block.  */
+
+void
+gfc_add_expr_to_block (stmtblock_t * block, tree expr)
+{
+  gcc_assert (block);
+  add_expr_to_chain (&block->head, expr, false);
+}
+
+
+/* Add a statement at the beginning of a block.  */
+
+void
+gfc_prepend_expr_to_block (stmtblock_t * block, tree expr)
+{
+  gcc_assert (block);
+  add_expr_to_chain (&block->head, expr, true);
+}
+
+
+/* Add a block the end of a block.  */
+
+void
+gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
+{
+  gcc_assert (append);
+  gcc_assert (!append->has_scope);
+
+  gfc_add_expr_to_block (block, append->head);
+  append->head = NULL_TREE;
+}
+
+
+/* Save the current locus.  The structure may not be complete, and should
+   only be used with gfc_restore_backend_locus.  */
+
+void
+gfc_save_backend_locus (locus * loc)
+{
+  loc->lb = XCNEW (gfc_linebuf);
+  loc->lb->location = input_location;
+  loc->lb->file = gfc_current_backend_file;
+}
+
+
+/* Set the current locus.  */
+
+void
+gfc_set_backend_locus (locus * loc)
+{
+  gfc_current_backend_file = loc->lb->file;
+  input_location = loc->lb->location;
+}
+
+
+/* Restore the saved locus. Only used in conjunction with
+   gfc_save_backend_locus, to free the memory when we are done.  */
+
+void
+gfc_restore_backend_locus (locus * loc)
+{
+  gfc_set_backend_locus (loc);
+  free (loc->lb);
+}
+
+
+/* Translate an executable statement. The tree cond is used by gfc_trans_do.
+   This static function is wrapped by gfc_trans_code_cond and
+   gfc_trans_code.  */
+
+static tree
+trans_code (gfc_code * code, tree cond)
+{
+  stmtblock_t block;
+  tree res;
+
+  if (!code)
+    return build_empty_stmt (input_location);
+
+  gfc_start_block (&block);
+
+  /* Translate statements one by one into GENERIC trees until we reach
+     the end of this gfc_code branch.  */
+  for (; code; code = code->next)
+    {
+      if (code->here != 0)
+	{
+	  res = gfc_trans_label_here (code);
+	  gfc_add_expr_to_block (&block, res);
+	}
+
+      gfc_set_backend_locus (&code->loc);
+
+      switch (code->op)
+	{
+	case EXEC_NOP:
+	case EXEC_END_BLOCK:
+	case EXEC_END_NESTED_BLOCK:
+	case EXEC_END_PROCEDURE:
+	  res = NULL_TREE;
+	  break;
+
+	case EXEC_ASSIGN:
+	  if (code->expr1->ts.type == BT_CLASS)
+	    res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
+	  else
+	    res = gfc_trans_assign (code);
+	  break;
+
+        case EXEC_LABEL_ASSIGN:
+          res = gfc_trans_label_assign (code);
+          break;
+
+	case EXEC_POINTER_ASSIGN:
+	  if (code->expr1->ts.type == BT_CLASS)
+	    res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
+	  else if (UNLIMITED_POLY (code->expr2)
+		   && code->expr1->ts.type == BT_DERIVED
+		   && (code->expr1->ts.u.derived->attr.sequence
+		       || code->expr1->ts.u.derived->attr.is_bind_c))
+	    /* F2003: C717  */
+	    res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
+	  else
+	    res = gfc_trans_pointer_assign (code);
+	  break;
+
+	case EXEC_INIT_ASSIGN:
+	  if (code->expr1->ts.type == BT_CLASS)
+	    res = gfc_trans_class_init_assign (code);
+	  else
+	    res = gfc_trans_init_assign (code);
+	  break;
+
+	case EXEC_CONTINUE:
+	  res = NULL_TREE;
+	  break;
+
+	case EXEC_CRITICAL:
+	  res = gfc_trans_critical (code);
+	  break;
+
+	case EXEC_CYCLE:
+	  res = gfc_trans_cycle (code);
+	  break;
+
+	case EXEC_EXIT:
+	  res = gfc_trans_exit (code);
+	  break;
+
+	case EXEC_GOTO:
+	  res = gfc_trans_goto (code);
+	  break;
+
+	case EXEC_ENTRY:
+	  res = gfc_trans_entry (code);
+	  break;
+
+	case EXEC_PAUSE:
+	  res = gfc_trans_pause (code);
+	  break;
+
+	case EXEC_STOP:
+	case EXEC_ERROR_STOP:
+	  res = gfc_trans_stop (code, code->op == EXEC_ERROR_STOP);
+	  break;
+
+	case EXEC_CALL:
+	  /* For MVBITS we've got the special exception that we need a
+	     dependency check, too.  */
+	  {
+	    bool is_mvbits = false;
+
+	    if (code->resolved_isym)
+	      {
+		res = gfc_conv_intrinsic_subroutine (code);
+		if (res != NULL_TREE)
+		  break;
+	      }
+
+	    if (code->resolved_isym
+		&& code->resolved_isym->id == GFC_ISYM_MVBITS)
+	      is_mvbits = true;
+
+	    res = gfc_trans_call (code, is_mvbits, NULL_TREE,
+				  NULL_TREE, false);
+	  }
+	  break;
+
+	case EXEC_CALL_PPC:
+	  res = gfc_trans_call (code, false, NULL_TREE,
+				NULL_TREE, false);
+	  break;
+
+	case EXEC_ASSIGN_CALL:
+	  res = gfc_trans_call (code, true, NULL_TREE,
+				NULL_TREE, false);
+	  break;
+
+	case EXEC_RETURN:
+	  res = gfc_trans_return (code);
+	  break;
+
+	case EXEC_IF:
+	  res = gfc_trans_if (code);
+	  break;
+
+	case EXEC_ARITHMETIC_IF:
+	  res = gfc_trans_arithmetic_if (code);
+	  break;
+
+	case EXEC_BLOCK:
+	  res = gfc_trans_block_construct (code);
+	  break;
+
+	case EXEC_DO:
+	  res = gfc_trans_do (code, cond);
+	  break;
+
+	case EXEC_DO_CONCURRENT:
+	  res = gfc_trans_do_concurrent (code);
+	  break;
+
+	case EXEC_DO_WHILE:
+	  res = gfc_trans_do_while (code);
+	  break;
+
+	case EXEC_SELECT:
+	  res = gfc_trans_select (code);
+	  break;
+
+	case EXEC_SELECT_TYPE:
+	  /* Do nothing. SELECT TYPE statements should be transformed into
+	  an ordinary SELECT CASE at resolution stage.
+	  TODO: Add an error message here once this is done.  */
+	  res = NULL_TREE;
+	  break;
+
+	case EXEC_FLUSH:
+	  res = gfc_trans_flush (code);
+	  break;
+
+	case EXEC_SYNC_ALL:
+	case EXEC_SYNC_IMAGES:
+	case EXEC_SYNC_MEMORY:
+	  res = gfc_trans_sync (code, code->op);
+	  break;
+
+	case EXEC_LOCK:
+	case EXEC_UNLOCK:
+	  res = gfc_trans_lock_unlock (code, code->op);
+	  break;
+
+	case EXEC_FORALL:
+	  res = gfc_trans_forall (code);
+	  break;
+
+	case EXEC_WHERE:
+	  res = gfc_trans_where (code);
+	  break;
+
+	case EXEC_ALLOCATE:
+	  res = gfc_trans_allocate (code);
+	  break;
+
+	case EXEC_DEALLOCATE:
+	  res = gfc_trans_deallocate (code);
+	  break;
+
+	case EXEC_OPEN:
+	  res = gfc_trans_open (code);
+	  break;
+
+	case EXEC_CLOSE:
+	  res = gfc_trans_close (code);
+	  break;
+
+	case EXEC_READ:
+	  res = gfc_trans_read (code);
+	  break;
+
+	case EXEC_WRITE:
+	  res = gfc_trans_write (code);
+	  break;
+
+	case EXEC_IOLENGTH:
+	  res = gfc_trans_iolength (code);
+	  break;
+
+	case EXEC_BACKSPACE:
+	  res = gfc_trans_backspace (code);
+	  break;
+
+	case EXEC_ENDFILE:
+	  res = gfc_trans_endfile (code);
+	  break;
+
+	case EXEC_INQUIRE:
+	  res = gfc_trans_inquire (code);
+	  break;
+
+	case EXEC_WAIT:
+	  res = gfc_trans_wait (code);
+	  break;
+
+	case EXEC_REWIND:
+	  res = gfc_trans_rewind (code);
+	  break;
+
+	case EXEC_TRANSFER:
+	  res = gfc_trans_transfer (code);
+	  break;
+
+	case EXEC_DT_END:
+	  res = gfc_trans_dt_end (code);
+	  break;
+
+	case EXEC_OMP_ATOMIC:
+	case EXEC_OMP_BARRIER:
+	case EXEC_OMP_CRITICAL:
+	case EXEC_OMP_DO:
+	case EXEC_OMP_FLUSH:
+	case EXEC_OMP_MASTER:
+	case EXEC_OMP_ORDERED:
+	case EXEC_OMP_PARALLEL:
+	case EXEC_OMP_PARALLEL_DO:
+	case EXEC_OMP_PARALLEL_SECTIONS:
+	case EXEC_OMP_PARALLEL_WORKSHARE:
+	case EXEC_OMP_SECTIONS:
+	case EXEC_OMP_SINGLE:
+	case EXEC_OMP_TASK:
+	case EXEC_OMP_TASKWAIT:
+	case EXEC_OMP_TASKYIELD:
+	case EXEC_OMP_WORKSHARE:
+	  res = gfc_trans_omp_directive (code);
+	  break;
+
+	default:
+	  internal_error ("gfc_trans_code(): Bad statement code");
+	}
+
+      gfc_set_backend_locus (&code->loc);
+
+      if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
+	{
+	  if (TREE_CODE (res) != STATEMENT_LIST)
+	    SET_EXPR_LOCATION (res, input_location);
+
+	  /* Add the new statement to the block.  */
+	  gfc_add_expr_to_block (&block, res);
+	}
+    }
+
+  /* Return the finished block.  */
+  return gfc_finish_block (&block);
+}
+
+
+/* Translate an executable statement with condition, cond.  The condition is
+   used by gfc_trans_do to test for IO result conditions inside implied
+   DO loops of READ and WRITE statements.  See build_dt in trans-io.c.  */
+
+tree
+gfc_trans_code_cond (gfc_code * code, tree cond)
+{
+  return trans_code (code, cond);
+}
+
+/* Translate an executable statement without condition.  */
+
+tree
+gfc_trans_code (gfc_code * code)
+{
+  return trans_code (code, NULL_TREE);
+}
+
+
+/* This function is called after a complete program unit has been parsed
+   and resolved.  */
+
+void
+gfc_generate_code (gfc_namespace * ns)
+{
+  ompws_flags = 0;
+  if (ns->is_block_data)
+    {
+      gfc_generate_block_data (ns);
+      return;
+    }
+
+  gfc_generate_function_code (ns);
+}
+
+
+/* This function is called after a complete module has been parsed
+   and resolved.  */
+
+void
+gfc_generate_module_code (gfc_namespace * ns)
+{
+  gfc_namespace *n;
+  struct module_htab_entry *entry;
+
+  gcc_assert (ns->proc_name->backend_decl == NULL);
+  ns->proc_name->backend_decl
+    = build_decl (ns->proc_name->declared_at.lb->location,
+		  NAMESPACE_DECL, get_identifier (ns->proc_name->name),
+		  void_type_node);
+  entry = gfc_find_module (ns->proc_name->name);
+  if (entry->namespace_decl)
+    /* Buggy sourcecode, using a module before defining it?  */
+    htab_empty (entry->decls);
+  entry->namespace_decl = ns->proc_name->backend_decl;
+
+  gfc_generate_module_vars (ns);
+
+  /* We need to generate all module function prototypes first, to allow
+     sibling calls.  */
+  for (n = ns->contained; n; n = n->sibling)
+    {
+      gfc_entry_list *el;
+
+      if (!n->proc_name)
+        continue;
+
+      gfc_create_function_decl (n, false);
+      DECL_CONTEXT (n->proc_name->backend_decl) = ns->proc_name->backend_decl;
+      gfc_module_add_decl (entry, n->proc_name->backend_decl);
+      for (el = ns->entries; el; el = el->next)
+	{
+	  DECL_CONTEXT (el->sym->backend_decl) = ns->proc_name->backend_decl;
+	  gfc_module_add_decl (entry, el->sym->backend_decl);
+	}
+    }
+
+  for (n = ns->contained; n; n = n->sibling)
+    {
+      if (!n->proc_name)
+        continue;
+
+      gfc_generate_function_code (n);
+    }
+}
+
+
+/* Initialize an init/cleanup block with existing code.  */
+
+void
+gfc_start_wrapped_block (gfc_wrapped_block* block, tree code)
+{
+  gcc_assert (block);
+
+  block->init = NULL_TREE;
+  block->code = code;
+  block->cleanup = NULL_TREE;
+}
+
+
+/* Add a new pair of initializers/clean-up code.  */
+
+void
+gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup)
+{
+  gcc_assert (block);
+
+  /* The new pair of init/cleanup should be "wrapped around" the existing
+     block of code, thus the initialization is added to the front and the
+     cleanup to the back.  */
+  add_expr_to_chain (&block->init, init, true);
+  add_expr_to_chain (&block->cleanup, cleanup, false);
+}
+
+
+/* Finish up a wrapped block by building a corresponding try-finally expr.  */
+
+tree
+gfc_finish_wrapped_block (gfc_wrapped_block* block)
+{
+  tree result;
+
+  gcc_assert (block);
+
+  /* Build the final expression.  For this, just add init and body together,
+     and put clean-up with that into a TRY_FINALLY_EXPR.  */
+  result = block->init;
+  add_expr_to_chain (&result, block->code, false);
+  if (block->cleanup)
+    result = build2_loc (input_location, TRY_FINALLY_EXPR, void_type_node,
+			 result, block->cleanup);
+
+  /* Clear the block.  */
+  block->init = NULL_TREE;
+  block->code = NULL_TREE;
+  block->cleanup = NULL_TREE;
+
+  return result;
+}
+
+
+/* Helper function for marking a boolean expression tree as unlikely.  */
+
+tree
+gfc_unlikely (tree cond, enum br_predictor predictor)
+{
+  tree tmp;
+
+  if (optimize)
+    {
+      cond = fold_convert (long_integer_type_node, cond);
+      tmp = build_zero_cst (long_integer_type_node);
+      cond = build_call_expr_loc (input_location,
+				  builtin_decl_explicit (BUILT_IN_EXPECT),
+				  3, cond, tmp,
+				  build_int_cst (integer_type_node,
+						 predictor));
+    }
+  cond = fold_convert (boolean_type_node, cond);
+  return cond;
+}
+
+
+/* Helper function for marking a boolean expression tree as likely.  */
+
+tree
+gfc_likely (tree cond, enum br_predictor predictor)
+{
+  tree tmp;
+
+  if (optimize)
+    {
+      cond = fold_convert (long_integer_type_node, cond);
+      tmp = build_one_cst (long_integer_type_node);
+      cond = build_call_expr_loc (input_location,
+				  builtin_decl_explicit (BUILT_IN_EXPECT),
+				  3, cond, tmp,
+				  build_int_cst (integer_type_node,
+						 predictor));
+    }
+  cond = fold_convert (boolean_type_node, cond);
+  return cond;
+}
+
+
+/* Get the string length for a deferred character length component.  */
+
+bool
+gfc_deferred_strlen (gfc_component *c, tree *decl)
+{
+  char name[GFC_MAX_SYMBOL_LEN+9];
+  gfc_component *strlen;
+  if (!(c->ts.type == BT_CHARACTER && c->ts.deferred))
+    return false;
+  sprintf (name, "_%s_length", c->name);
+  for (strlen = c; strlen; strlen = strlen->next)
+    if (strcmp (strlen->name, name) == 0)
+      break;
+  *decl = strlen ? strlen->backend_decl : NULL_TREE;
+  return strlen != NULL;
+}
diff --git a/gcc-4.9/gcc/fortran/trans.h b/gcc-4.9/gcc/fortran/trans.h
new file mode 100644
index 000000000..4ae68c6cb
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/trans.h
@@ -0,0 +1,969 @@
+/* Header for code translation functions
+   Copyright (C) 2002-2014 Free Software Foundation, Inc.
+   Contributed by Paul Brook
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+#ifndef GFC_TRANS_H
+#define GFC_TRANS_H
+
+#include "predict.h"  /* For enum br_predictor and PRED_*.  */
+
+/* Mangled symbols take the form __module__name.  */
+#define GFC_MAX_MANGLED_SYMBOL_LEN  (GFC_MAX_SYMBOL_LEN*2+4)
+
+/* Struct for holding a block of statements.  It should be treated as an
+   opaque entity and not modified directly.  This allows us to change the
+   underlying representation of statement lists.  */
+typedef struct
+{
+  tree head;
+  unsigned int has_scope:1;
+}
+stmtblock_t;
+
+/* a simplified expression */
+typedef struct gfc_se
+{
+  /* Code blocks to be executed before and after using the value.  */
+  stmtblock_t pre;
+  stmtblock_t post;
+
+  /* the result of the expression */
+  tree expr;
+
+  /* The length of a character string value.  */
+  tree string_length;
+
+  /* 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.  */
+  unsigned descriptor_only:1;
+
+  /* When this is set gfc_conv_expr returns the address of a variable.  Only
+     applies to EXPR_VARIABLE nodes.
+     Also used by gfc_conv_array_parameter. When set this indicates a pointer
+     to the descriptor should be returned, rather than the descriptor itself.
+   */
+  unsigned want_pointer:1;
+
+  /* An array function call returning without a temporary.  Also used for array
+     pointer assignments.  */
+  unsigned direct_byref:1;
+
+  /* If direct_byref is set, do work out the descriptor as in that case but
+     do still create a new descriptor variable instead of using an
+     existing one.  This is useful for special pointer assignments like
+     rank remapping where we have to process the descriptor before
+     assigning to final one.  */
+  unsigned byref_noassign:1;
+
+  /* Ignore absent optional arguments.  Used for some intrinsics.  */
+  unsigned ignore_optional:1;
+
+  /* When this is set the data and offset fields of the returned descriptor
+     are NULL.  Used by intrinsic size.  */
+  unsigned data_not_needed:1;
+
+  /* If set, gfc_conv_procedure_call does not put byref calls into se->pre.  */
+  unsigned no_function_call:1;
+
+  /* If set, we will force the creation of a temporary. Useful to disable
+     non-copying procedure argument passing optimizations, when some function
+     args alias.  */
+  unsigned force_tmp:1;
+
+  unsigned want_coarray:1;
+
+  /* Scalarization parameters.  */
+  struct gfc_se *parent;
+  struct gfc_ss *ss;
+  struct gfc_loopinfo *loop;
+}
+gfc_se;
+
+
+/* Denotes different types of coarray.
+   Please keep in sync with libgfortran/caf/libcaf.h.  */
+typedef enum 
+{
+  GFC_CAF_COARRAY_STATIC,
+  GFC_CAF_COARRAY_ALLOC,
+  GFC_CAF_LOCK,
+  GFC_CAF_LOCK_COMP
+}
+gfc_coarray_type;
+
+
+/* The array-specific scalarization information.  The array members of
+   this struct are indexed by actual array index, and thus can be sparse.  */
+
+typedef struct gfc_array_info
+{
+  mpz_t *shape;
+
+  /* The ref that holds information on this section.  */
+  gfc_ref *ref;
+  /* The descriptor of this array.  */
+  tree descriptor;
+  /* holds the pointer to the data array.  */
+  tree data;
+  /* To move some of the array index calculation out of the innermost loop.  */
+  tree offset;
+  tree saved_offset;
+  tree stride0;
+  /* Holds the SS for a subscript.  Indexed by actual dimension.  */
+  struct gfc_ss *subscript[GFC_MAX_DIMENSIONS];
+
+  /* stride and delta are used to access this inside a scalarization loop.
+     start is used in the calculation of these.  Indexed by scalarizer
+     dimension.  */
+  tree start[GFC_MAX_DIMENSIONS];
+  tree end[GFC_MAX_DIMENSIONS];
+  tree stride[GFC_MAX_DIMENSIONS];
+  tree delta[GFC_MAX_DIMENSIONS];
+}
+gfc_array_info;
+
+typedef enum
+{
+  /* A scalar value.  This will be evaluated before entering the
+     scalarization loop.  */
+  GFC_SS_SCALAR,
+
+  /* Like GFC_SS_SCALAR it evaluates the expression outside the
+     loop.  Is always evaluated as a reference to the temporary, unless
+     temporary evaluation can result in a NULL pointer dereferencing (case of
+     optional arguments).  Used for elemental function arguments.  */
+  GFC_SS_REFERENCE,
+
+  /* An array section.  Scalarization indices will be substituted during
+     expression translation.  */
+  GFC_SS_SECTION,
+
+  /* A non-elemental function call returning an array.  The call is executed
+     before entering the scalarization loop, storing the result in a
+     temporary.  This temporary is then used inside the scalarization loop.
+     Simple assignments, e.g. a(:) = fn(), are handled without a temporary
+     as a special case.  */
+  GFC_SS_FUNCTION,
+
+  /* An array constructor.  The current implementation is sub-optimal in
+     many cases.  It allocated a temporary, assigns the values to it, then
+     uses this temporary inside the scalarization loop.  */
+  GFC_SS_CONSTRUCTOR,
+
+  /* A vector subscript.  The vector's descriptor is cached in the
+     "descriptor" field of the associated gfc_ss_info.  */
+  GFC_SS_VECTOR,
+
+  /* A temporary array allocated by the scalarizer.  Its rank can be less
+     than that of the assignment expression.  */
+  GFC_SS_TEMP,
+
+  /* An intrinsic function call.  Many intrinsic functions which map directly
+     to library calls are created as GFC_SS_FUNCTION nodes.  */
+  GFC_SS_INTRINSIC,
+  
+  /* A component of a derived type.  */
+  GFC_SS_COMPONENT
+}
+gfc_ss_type;
+
+
+typedef struct gfc_ss_info
+{
+  int refcount;
+  gfc_ss_type type;
+  gfc_expr *expr;
+  tree string_length;
+
+  union
+  {
+    /* If type is GFC_SS_SCALAR or GFC_SS_REFERENCE.  */
+    struct
+    {
+      tree value;
+    }
+    scalar;
+
+    /* GFC_SS_TEMP.  */
+    struct
+    {
+      tree type;
+    }
+    temp;
+
+    /* All other types.  */
+    gfc_array_info array;
+  }
+  data;
+
+  /* This is used by assignments requiring temporaries.  The bits specify which
+     loops the terms appear in.  This will be 1 for the RHS expressions,
+     2 for the LHS expressions, and 3(=1|2) for the temporary.  */
+  unsigned useflags:2;
+
+  /* Suppresses precalculation of scalars in WHERE assignments.  */
+  unsigned where:1;
+
+  /* Tells whether the SS is for an actual argument which can be a NULL
+     reference.  In other words, the associated dummy argument is OPTIONAL.
+     Used to handle elemental procedures.  */
+  bool can_be_null_ref;
+}
+gfc_ss_info;
+
+#define gfc_get_ss_info() XCNEW (gfc_ss_info)
+
+
+/* Scalarization State chain.  Created by walking an expression tree before
+   creating the scalarization loops.  Then passed as part of a gfc_se structure
+   to translate the expression inside the loop.  Note that these chains are
+   terminated by gfc_ss_terminator, not NULL.  A NULL pointer in a gfc_se
+   indicates to gfc_conv_* that this is a scalar expression.
+   SS structures can only belong to a single loopinfo.  They must be added
+   otherwise they will not get freed.  */
+
+typedef struct gfc_ss
+{
+  gfc_ss_info *info;
+
+  int dimen;
+  /* Translation from loop dimensions to actual array dimensions.
+     actual_dim = dim[loop_dim]  */
+  int dim[GFC_MAX_DIMENSIONS];
+
+  /* All the SS in a loop and linked through loop_chain.  The SS for an
+     expression are linked by the next pointer.  */
+  struct gfc_ss *loop_chain;
+  struct gfc_ss *next;
+
+  /* Non-null if the ss is part of a nested loop.  */
+  struct gfc_ss *parent;
+
+  /* If the evaluation of an expression requires a nested loop (for example
+     if the sum intrinsic is evaluated inline), this points to the nested
+     loop's gfc_ss.  */
+  struct gfc_ss *nested_ss;
+
+  /* The loop this gfc_ss is in.  */
+  struct gfc_loopinfo *loop;
+
+  unsigned is_alloc_lhs:1;
+}
+gfc_ss;
+#define gfc_get_ss() XCNEW (gfc_ss)
+
+/* The contents of this aren't actually used.  A NULL SS chain indicates a
+   scalar expression, so this pointer is used to terminate SS chains.  */
+extern gfc_ss * const gfc_ss_terminator;
+
+/* Holds information about an expression while it is being scalarized.  */
+typedef struct gfc_loopinfo
+{
+  stmtblock_t pre;
+  stmtblock_t post;
+
+  int dimen;
+
+  /* All the SS involved with this loop.  */
+  gfc_ss *ss;
+  /* The SS describing the temporary used in an assignment.  */
+  gfc_ss *temp_ss;
+
+  /* Non-null if this loop is nested in another one.  */
+  struct gfc_loopinfo *parent;
+
+  /* Chain of nested loops.  */
+  struct gfc_loopinfo *nested, *next;
+
+  /* The scalarization loop index variables.  */
+  tree loopvar[GFC_MAX_DIMENSIONS];
+
+  /* The bounds of the scalarization loops.  */
+  tree from[GFC_MAX_DIMENSIONS];
+  tree to[GFC_MAX_DIMENSIONS];
+  gfc_ss *specloop[GFC_MAX_DIMENSIONS];
+
+  /* The code member contains the code for the body of the next outer loop.  */
+  stmtblock_t code[GFC_MAX_DIMENSIONS];
+
+  /* Order in which the dimensions should be looped, innermost first.  */
+  int order[GFC_MAX_DIMENSIONS];
+
+  /* Enum to control loop reversal.  */
+  gfc_reverse reverse[GFC_MAX_DIMENSIONS];
+
+  /* The number of dimensions for which a temporary is used.  */
+  int temp_dim;
+
+  /* If set we don't need the loop variables.  */
+  unsigned array_parameter:1;
+}
+gfc_loopinfo;
+
+#define gfc_get_loopinfo() XCNEW (gfc_loopinfo)
+
+/* Information about a symbol that has been shadowed by a temporary.  */
+typedef struct
+{
+  symbol_attribute attr;
+  tree decl;
+}
+gfc_saved_var;
+
+
+/* Store information about a block of code together with special
+   initialization and clean-up code.  This can be used to incrementally add
+   init and cleanup, and in the end put everything together to a
+   try-finally expression.  */
+typedef struct
+{
+  tree init;
+  tree cleanup;
+  tree code;
+}
+gfc_wrapped_block;
+
+/* Class API functions.  */
+tree gfc_class_data_get (tree);
+tree gfc_class_vptr_get (tree);
+void gfc_reset_vptr (stmtblock_t *, gfc_expr *);
+tree gfc_class_set_static_fields (tree, tree, tree);
+tree gfc_vtable_hash_get (tree);
+tree gfc_vtable_size_get (tree);
+tree gfc_vtable_extends_get (tree);
+tree gfc_vtable_def_init_get (tree);
+tree gfc_vtable_copy_get (tree);
+tree gfc_vtable_final_get (tree);
+tree gfc_get_vptr_from_expr (tree);
+tree gfc_get_class_array_ref (tree, tree);
+tree gfc_copy_class_to_class (tree, tree, tree);
+bool gfc_add_finalizer_call (stmtblock_t *, gfc_expr *);
+bool gfc_add_comp_finalizer_call (stmtblock_t *, tree, gfc_component *, bool);
+
+void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree, bool,
+				bool);
+void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool, bool,
+			      bool, bool);
+
+/* Initialize an init/cleanup block.  */
+void gfc_start_wrapped_block (gfc_wrapped_block* block, tree code);
+/* Add a pair of init/cleanup code to the block.  Each one might be a
+   NULL_TREE if not required.  */
+void gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup);
+/* Finalize the block, that is, create a single expression encapsulating the
+   original code together with init and clean-up code.  */
+tree gfc_finish_wrapped_block (gfc_wrapped_block* block);
+
+
+/* Advance the SS chain to the next term.  */
+void gfc_advance_se_ss_chain (gfc_se *);
+
+/* Call this to initialize a gfc_se structure before use
+   first parameter is structure to initialize, second is
+   parent to get scalarization data from, or NULL.  */
+void gfc_init_se (gfc_se *, gfc_se *);
+
+/* Create an artificial variable decl and add it to the current scope.  */
+tree gfc_create_var (tree, const char *);
+/* Like above but doesn't add it to the current scope.  */
+tree gfc_create_var_np (tree, const char *);
+
+/* Store the result of an expression in a temp variable so it can be used
+   repeatedly even if the original changes */
+void gfc_make_safe_expr (gfc_se * se);
+
+/* Makes sure se is suitable for passing as a function string parameter.  */
+void gfc_conv_string_parameter (gfc_se * se);
+
+/* Compare two strings.  */
+tree gfc_build_compare_string (tree, tree, tree, tree, int, enum tree_code);
+
+/* When using the gfc_conv_* make sure you understand what they do, i.e.
+   when a POST chain may be created, and what the returned expression may be
+   used for.  Note that character strings have special handling.  This
+   should not be a problem as most statements/operations only deal with
+   numeric/logical types.  See the implementations in trans-expr.c
+   for details of the individual functions.  */
+
+void gfc_conv_expr (gfc_se * se, gfc_expr * expr);
+void gfc_conv_expr_val (gfc_se * se, gfc_expr * expr);
+void gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr);
+void gfc_conv_expr_reference (gfc_se * se, gfc_expr *);
+void gfc_conv_expr_type (gfc_se * se, gfc_expr *, tree);
+
+tree gfc_conv_scalar_to_descriptor (gfc_se *, tree, symbol_attribute);
+
+
+/* trans-expr.c */
+void gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr);
+tree gfc_string_to_single_character (tree len, tree str, int kind);
+
+/* Find the decl containing the auxiliary variables for assigned variables.  */
+void gfc_conv_label_variable (gfc_se * se, gfc_expr * expr);
+/* If the value is not constant, Create a temporary and copy the value.  */
+tree gfc_evaluate_now_loc (location_t, tree, stmtblock_t *);
+tree gfc_evaluate_now (tree, stmtblock_t *);
+
+/* Find the appropriate variant of a math intrinsic.  */
+tree gfc_builtin_decl_for_float_kind (enum built_in_function, int);
+
+tree size_of_string_in_bytes (int, tree);
+
+/* Intrinsic procedure handling.  */
+tree gfc_conv_intrinsic_subroutine (gfc_code *);
+void gfc_conv_intrinsic_function (gfc_se *, gfc_expr *);
+
+/* Does an intrinsic map directly to an external library call
+   This is true for array-returning intrinsics, unless
+   gfc_inline_intrinsic_function_p returns true.  */
+int gfc_is_intrinsic_libcall (gfc_expr *);
+
+/* Used to call ordinary functions/subroutines
+   and procedure pointer components.  */
+int gfc_conv_procedure_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *,
+			     gfc_expr *, vec<tree, va_gc> *);
+
+void gfc_conv_subref_array_arg (gfc_se *, gfc_expr *, int, sym_intent, bool);
+
+/* Generate code for a scalar assignment.  */
+tree gfc_trans_scalar_assign (gfc_se *, gfc_se *, gfc_typespec, bool, bool,
+			      bool);
+
+/* Translate COMMON blocks.  */
+void gfc_trans_common (gfc_namespace *);
+
+/* Translate a derived type constructor.  */
+void gfc_conv_structure (gfc_se *, gfc_expr *, int);
+
+/* Return an expression which determines if a dummy parameter is present.  */
+tree gfc_conv_expr_present (gfc_symbol *);
+/* Convert a missing, dummy argument into a null or zero.  */
+void gfc_conv_missing_dummy (gfc_se *, gfc_expr *, gfc_typespec, int);
+
+/* Generate code to allocate a string temporary.  */
+tree gfc_conv_string_tmp (gfc_se *, tree, tree);
+/* Get the string length variable belonging to an expression.  */
+tree gfc_get_expr_charlen (gfc_expr *);
+/* Initialize a string length variable.  */
+void gfc_conv_string_length (gfc_charlen *, gfc_expr *, stmtblock_t *);
+/* Ensure type sizes can be gimplified.  */
+void gfc_trans_vla_type_sizes (gfc_symbol *, stmtblock_t *);
+
+/* Add an expression to the end of a block.  */
+void gfc_add_expr_to_block (stmtblock_t *, tree);
+/* Add an expression to the beginning of a block.  */
+void gfc_prepend_expr_to_block (stmtblock_t *, tree);
+/* Add a block to the end of a block.  */
+void gfc_add_block_to_block (stmtblock_t *, stmtblock_t *);
+/* Add a MODIFY_EXPR to a block.  */
+void gfc_add_modify_loc (location_t, stmtblock_t *, tree, tree);
+void gfc_add_modify (stmtblock_t *, tree, tree);
+
+/* Initialize a statement block.  */
+void gfc_init_block (stmtblock_t *);
+/* Start a new statement block.  Like gfc_init_block but also starts a new
+   variable scope.  */
+void gfc_start_block (stmtblock_t *);
+/* Finish a statement block.  Also closes the scope if the block was created
+   with gfc_start_block.  */
+tree gfc_finish_block (stmtblock_t *);
+/* Merge the scope of a block with its parent.  */
+void gfc_merge_block_scope (stmtblock_t * block);
+
+/* Return the backend label decl.  */
+tree gfc_get_label_decl (gfc_st_label *);
+
+/* Return the decl for an external function.  */
+tree gfc_get_extern_function_decl (gfc_symbol *);
+
+/* Return the decl for a function.  */
+tree gfc_get_function_decl (gfc_symbol *);
+
+/* Build an ADDR_EXPR.  */
+tree gfc_build_addr_expr (tree, tree);
+
+/* Build an ARRAY_REF.  */
+tree gfc_build_array_ref (tree, tree, tree);
+
+/* Creates a label.  Decl is artificial if label_id == NULL_TREE.  */
+tree gfc_build_label_decl (tree);
+
+/* Return the decl used to hold the function return value.
+   Do not use if the function has an explicit result variable.  */
+tree gfc_get_fake_result_decl (gfc_symbol *, int);
+
+/* Add a decl to the binding level for the current function.  */
+void gfc_add_decl_to_function (tree);
+
+/* Make prototypes for runtime library functions.  */
+void gfc_build_builtin_function_decls (void);
+
+/* Set the backend source location of a decl.  */
+void gfc_set_decl_location (tree, locus *);
+
+/* Get a module symbol backend_decl if possible.  */
+bool gfc_get_module_backend_decl (gfc_symbol *);
+
+/* Return the variable decl for a symbol.  */
+tree gfc_get_symbol_decl (gfc_symbol *);
+
+/* Build a static initializer.  */
+tree gfc_conv_initializer (gfc_expr *, gfc_typespec *, tree, bool, bool, bool);
+
+/* Assign a default initializer to a derived type.  */
+void gfc_init_default_dt (gfc_symbol *, stmtblock_t *, bool);
+
+/* Substitute a temporary variable in place of the real one.  */
+void gfc_shadow_sym (gfc_symbol *, tree, gfc_saved_var *);
+
+/* Restore the original variable.  */
+void gfc_restore_sym (gfc_symbol *, gfc_saved_var *);
+
+/* Setting a decl assembler name, mangling it according to target rules
+   (like Windows @NN decorations).  */
+void gfc_set_decl_assembler_name (tree, tree);
+
+/* Returns true if a variable of specified size should go on the stack.  */
+int gfc_can_put_var_on_stack (tree);
+
+/* Allocate the lang-specific part of a decl node.  */
+void gfc_allocate_lang_decl (tree);
+
+/* Advance along a TREE_CHAIN.  */
+tree gfc_advance_chain (tree, int);
+
+/* Create a decl for a function.  */
+void gfc_create_function_decl (gfc_namespace *, bool);
+/* Generate the code for a function.  */
+void gfc_generate_function_code (gfc_namespace *);
+/* Output a BLOCK DATA program unit.  */
+void gfc_generate_block_data (gfc_namespace *);
+/* Output a decl for a module variable.  */
+void gfc_generate_module_vars (gfc_namespace *);
+/* Get the appropriate return statement for a procedure.  */
+tree gfc_generate_return (void);
+
+struct GTY(()) module_htab_entry {
+  const char *name;
+  tree namespace_decl;
+  htab_t GTY ((param_is (union tree_node))) decls;
+};
+
+struct module_htab_entry *gfc_find_module (const char *);
+void gfc_module_add_decl (struct module_htab_entry *, tree);
+
+/* Get and set the current location.  */
+void gfc_save_backend_locus (locus *);
+void gfc_set_backend_locus (locus *);
+void gfc_restore_backend_locus (locus *);
+
+/* Handle static constructor functions.  */
+extern GTY(()) tree gfc_static_ctors;
+void gfc_generate_constructors (void);
+
+/* Get the string length of an array constructor.  */
+bool get_array_ctor_strlen (stmtblock_t *, gfc_constructor_base, tree *);
+
+/* Mark a condition as likely or unlikely.  */
+tree gfc_likely (tree, enum br_predictor);
+tree gfc_unlikely (tree, enum br_predictor);
+
+/* Return the string length of a deferred character length component.  */
+bool gfc_deferred_strlen (gfc_component *, tree *);
+
+/* Generate a runtime error call.  */
+tree gfc_trans_runtime_error (bool, locus*, const char*, ...);
+
+/* Generate a runtime warning/error check.  */
+void gfc_trans_runtime_check (bool, bool, tree, stmtblock_t *, locus *,
+			      const char *, ...);
+
+/* Generate a runtime check for same string length.  */
+void gfc_trans_same_strlen_check (const char*, locus*, tree, tree,
+				  stmtblock_t*);
+
+/* Generate a call to free() after checking that its arg is non-NULL.  */
+tree gfc_call_free (tree);
+
+/* Allocate memory after performing a few checks.  */
+tree gfc_call_malloc (stmtblock_t *, tree, tree);
+
+/* Build a memcpy call.  */
+tree gfc_build_memcpy_call (tree, tree, tree);
+
+/* Allocate memory for allocatable variables, with optional status variable.  */
+void gfc_allocate_allocatable (stmtblock_t*, tree, tree, tree, tree,
+			       tree, tree, tree, gfc_expr*);
+
+/* Allocate memory, with optional status variable.  */
+void gfc_allocate_using_malloc (stmtblock_t *, tree, tree, tree);
+
+/* Generate code to deallocate an array.  */
+tree gfc_deallocate_with_status (tree, tree, tree, tree, tree, bool,
+				 gfc_expr *, bool);
+tree gfc_deallocate_scalar_with_status (tree, tree, bool, gfc_expr*, gfc_typespec);
+
+/* Generate code to call realloc().  */
+tree gfc_call_realloc (stmtblock_t *, tree, tree);
+
+/* Generate code for an assignment, includes scalarization.  */
+tree gfc_trans_assignment (gfc_expr *, gfc_expr *, bool, bool);
+
+/* Generate code for a pointer assignment.  */
+tree gfc_trans_pointer_assignment (gfc_expr *, gfc_expr *);
+
+/* Initialize function decls for library functions.  */
+void gfc_build_intrinsic_lib_fndecls (void);
+/* Create function decls for IO library functions.  */
+void gfc_build_io_library_fndecls (void);
+/* Build a function decl for a library function.  */
+tree gfc_build_library_function_decl (tree, tree, int, ...);
+tree gfc_build_library_function_decl_with_spec (tree name, const char *spec,
+						tree rettype, int nargs, ...);
+
+/* Process the local variable decls of a block construct.  */
+void gfc_process_block_locals (gfc_namespace*);
+
+/* Output initialization/clean-up code that was deferred.  */
+void gfc_trans_deferred_vars (gfc_symbol*, gfc_wrapped_block *);
+
+/* In f95-lang.c.  */
+tree pushdecl (tree);
+tree pushdecl_top_level (tree);
+void pushlevel (void);
+tree poplevel (int, int);
+tree getdecls (void);
+
+/* In trans-types.c.  */
+struct array_descr_info;
+bool gfc_get_array_descr_info (const_tree, struct array_descr_info *);
+
+/* In trans-openmp.c */
+bool gfc_omp_privatize_by_reference (const_tree);
+enum omp_clause_default_kind gfc_omp_predetermined_sharing (tree);
+tree gfc_omp_report_decl (tree);
+tree gfc_omp_clause_default_ctor (tree, tree, tree);
+tree gfc_omp_clause_copy_ctor (tree, tree, tree);
+tree gfc_omp_clause_assign_op (tree, tree, tree);
+tree gfc_omp_clause_dtor (tree, tree);
+bool gfc_omp_disregard_value_expr (tree, bool);
+bool gfc_omp_private_debug_clause (tree, bool);
+bool gfc_omp_private_outer_ref (tree);
+struct gimplify_omp_ctx;
+void gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *, tree);
+
+/* Runtime library function decls.  */
+extern GTY(()) tree gfor_fndecl_pause_numeric;
+extern GTY(()) tree gfor_fndecl_pause_string;
+extern GTY(()) tree gfor_fndecl_stop_numeric;
+extern GTY(()) tree gfor_fndecl_stop_numeric_f08;
+extern GTY(()) tree gfor_fndecl_stop_string;
+extern GTY(()) tree gfor_fndecl_error_stop_numeric;
+extern GTY(()) tree gfor_fndecl_error_stop_string;
+extern GTY(()) tree gfor_fndecl_runtime_error;
+extern GTY(()) tree gfor_fndecl_runtime_error_at;
+extern GTY(()) tree gfor_fndecl_runtime_warning_at;
+extern GTY(()) tree gfor_fndecl_os_error;
+extern GTY(()) tree gfor_fndecl_generate_error;
+extern GTY(()) tree gfor_fndecl_set_fpe;
+extern GTY(()) tree gfor_fndecl_set_options;
+extern GTY(()) tree gfor_fndecl_ttynam;
+extern GTY(()) tree gfor_fndecl_ctime;
+extern GTY(()) tree gfor_fndecl_fdate;
+extern GTY(()) tree gfor_fndecl_in_pack;
+extern GTY(()) tree gfor_fndecl_in_unpack;
+extern GTY(()) tree gfor_fndecl_associated;
+
+
+/* Coarray run-time library function decls.  */
+extern GTY(()) tree gfor_fndecl_caf_init;
+extern GTY(()) tree gfor_fndecl_caf_finalize;
+extern GTY(()) tree gfor_fndecl_caf_register;
+extern GTY(()) tree gfor_fndecl_caf_deregister;
+extern GTY(()) tree gfor_fndecl_caf_critical;
+extern GTY(()) tree gfor_fndecl_caf_end_critical;
+extern GTY(()) tree gfor_fndecl_caf_sync_all;
+extern GTY(()) tree gfor_fndecl_caf_sync_images;
+extern GTY(()) tree gfor_fndecl_caf_error_stop;
+extern GTY(()) tree gfor_fndecl_caf_error_stop_str;
+
+/* Coarray global variables for num_images/this_image.  */
+extern GTY(()) tree gfort_gvar_caf_num_images;
+extern GTY(()) tree gfort_gvar_caf_this_image;
+
+
+/* Math functions.  Many other math functions are handled in
+   trans-intrinsic.c.  */
+
+typedef struct GTY(()) gfc_powdecl_list {
+  tree integer;
+  tree real;
+  tree cmplx;
+}
+gfc_powdecl_list;
+
+extern GTY(()) gfc_powdecl_list gfor_fndecl_math_powi[4][3];
+extern GTY(()) tree gfor_fndecl_math_ishftc4;
+extern GTY(()) tree gfor_fndecl_math_ishftc8;
+extern GTY(()) tree gfor_fndecl_math_ishftc16;
+
+/* BLAS functions.  */
+extern GTY(()) tree gfor_fndecl_sgemm;
+extern GTY(()) tree gfor_fndecl_dgemm;
+extern GTY(()) tree gfor_fndecl_cgemm;
+extern GTY(()) tree gfor_fndecl_zgemm;
+
+/* String functions.  */
+extern GTY(()) tree gfor_fndecl_compare_string;
+extern GTY(()) tree gfor_fndecl_concat_string;
+extern GTY(()) tree gfor_fndecl_string_len_trim;
+extern GTY(()) tree gfor_fndecl_string_index;
+extern GTY(()) tree gfor_fndecl_string_scan;
+extern GTY(()) tree gfor_fndecl_string_verify;
+extern GTY(()) tree gfor_fndecl_string_trim;
+extern GTY(()) tree gfor_fndecl_string_minmax;
+extern GTY(()) tree gfor_fndecl_adjustl;
+extern GTY(()) tree gfor_fndecl_adjustr;
+extern GTY(()) tree gfor_fndecl_select_string;
+extern GTY(()) tree gfor_fndecl_compare_string_char4;
+extern GTY(()) tree gfor_fndecl_concat_string_char4;
+extern GTY(()) tree gfor_fndecl_string_len_trim_char4;
+extern GTY(()) tree gfor_fndecl_string_index_char4;
+extern GTY(()) tree gfor_fndecl_string_scan_char4;
+extern GTY(()) tree gfor_fndecl_string_verify_char4;
+extern GTY(()) tree gfor_fndecl_string_trim_char4;
+extern GTY(()) tree gfor_fndecl_string_minmax_char4;
+extern GTY(()) tree gfor_fndecl_adjustl_char4;
+extern GTY(()) tree gfor_fndecl_adjustr_char4;
+extern GTY(()) tree gfor_fndecl_select_string_char4;
+
+/* Conversion between character kinds.  */
+extern GTY(()) tree gfor_fndecl_convert_char1_to_char4;
+extern GTY(()) tree gfor_fndecl_convert_char4_to_char1;
+
+/* Other misc. runtime library functions.  */
+extern GTY(()) tree gfor_fndecl_size0;
+extern GTY(()) tree gfor_fndecl_size1;
+extern GTY(()) tree gfor_fndecl_iargc;
+
+/* Implemented in Fortran.  */
+extern GTY(()) tree gfor_fndecl_sc_kind;
+extern GTY(()) tree gfor_fndecl_si_kind;
+extern GTY(()) tree gfor_fndecl_sr_kind;
+
+
+/* True if node is an integer constant.  */
+#define INTEGER_CST_P(node) (TREE_CODE(node) == INTEGER_CST)
+
+/* gfortran-specific declaration information, the _CONT versions denote
+   arrays with CONTIGUOUS attribute.  */
+
+enum gfc_array_kind
+{
+  GFC_ARRAY_UNKNOWN,
+  GFC_ARRAY_ASSUMED_SHAPE,
+  GFC_ARRAY_ASSUMED_SHAPE_CONT,
+  GFC_ARRAY_ASSUMED_RANK,
+  GFC_ARRAY_ASSUMED_RANK_CONT,
+  GFC_ARRAY_ALLOCATABLE,
+  GFC_ARRAY_POINTER,
+  GFC_ARRAY_POINTER_CONT
+};
+
+/* Array types only.  */
+/* FIXME: the variable_size annotation here is needed because these types are
+   variable-sized in some other frontends.  Due to gengtype deficiency the GTY
+   options of such types have to agree across all frontends. */
+struct GTY((variable_size))	lang_type	 {
+  int rank, corank;
+  enum gfc_array_kind akind;
+  tree lbound[GFC_MAX_DIMENSIONS];
+  tree ubound[GFC_MAX_DIMENSIONS];
+  tree stride[GFC_MAX_DIMENSIONS];
+  tree size;
+  tree offset;
+  tree dtype;
+  tree dataptr_type;
+  tree span;
+  tree base_decl[2];
+  tree nonrestricted_type;
+  tree caf_token;
+  tree caf_offset;
+};
+
+struct GTY((variable_size)) lang_decl {
+  /* Dummy variables.  */
+  tree saved_descriptor;
+  /* Assigned integer nodes.  Stringlength is the IO format string's length.
+     Addr is the address of the string or the target label. Stringlength is
+     initialized to -2 and assigned to -1 when addr is assigned to the
+     address of target label.  */
+  tree stringlen;
+  tree addr;
+  tree span;
+  /* For assumed-shape coarrays.  */
+  tree token, caf_offset;
+};
+
+
+#define GFC_DECL_ASSIGN_ADDR(node) DECL_LANG_SPECIFIC(node)->addr
+#define GFC_DECL_STRING_LEN(node) DECL_LANG_SPECIFIC(node)->stringlen
+#define GFC_DECL_SPAN(node) DECL_LANG_SPECIFIC(node)->span
+#define GFC_DECL_TOKEN(node) DECL_LANG_SPECIFIC(node)->token
+#define GFC_DECL_CAF_OFFSET(node) DECL_LANG_SPECIFIC(node)->caf_offset
+#define GFC_DECL_SAVED_DESCRIPTOR(node) \
+  (DECL_LANG_SPECIFIC(node)->saved_descriptor)
+#define GFC_DECL_PACKED_ARRAY(node) DECL_LANG_FLAG_0(node)
+#define GFC_DECL_PARTIAL_PACKED_ARRAY(node) DECL_LANG_FLAG_1(node)
+#define GFC_DECL_ASSIGN(node) DECL_LANG_FLAG_2(node)
+#define GFC_DECL_COMMON_OR_EQUIV(node) DECL_LANG_FLAG_3(node)
+#define GFC_DECL_CRAY_POINTEE(node) DECL_LANG_FLAG_4(node)
+#define GFC_DECL_RESULT(node) DECL_LANG_FLAG_5(node)
+#define GFC_DECL_SUBREF_ARRAY_P(node) DECL_LANG_FLAG_6(node)
+#define GFC_DECL_CLASS(node) DECL_LANG_FLAG_8(node)
+
+/* An array descriptor.  */
+#define GFC_DESCRIPTOR_TYPE_P(node) TYPE_LANG_FLAG_1(node)
+/* An array without a descriptor.  */
+#define GFC_ARRAY_TYPE_P(node) TYPE_LANG_FLAG_2(node)
+/* Fortran POINTER type.  */
+#define GFC_POINTER_TYPE_P(node) TYPE_LANG_FLAG_3(node)
+/* Fortran CLASS type.  */
+#define GFC_CLASS_TYPE_P(node) TYPE_LANG_FLAG_4(node)
+/* The GFC_TYPE_ARRAY_* members are present in both descriptor and
+   descriptorless array types.  */
+#define GFC_TYPE_ARRAY_LBOUND(node, dim) \
+  (TYPE_LANG_SPECIFIC(node)->lbound[dim])
+#define GFC_TYPE_ARRAY_UBOUND(node, dim) \
+  (TYPE_LANG_SPECIFIC(node)->ubound[dim])
+#define GFC_TYPE_ARRAY_STRIDE(node, dim) \
+  (TYPE_LANG_SPECIFIC(node)->stride[dim])
+#define GFC_TYPE_ARRAY_RANK(node) (TYPE_LANG_SPECIFIC(node)->rank)
+#define GFC_TYPE_ARRAY_CORANK(node) (TYPE_LANG_SPECIFIC(node)->corank)
+#define GFC_TYPE_ARRAY_CAF_TOKEN(node) (TYPE_LANG_SPECIFIC(node)->caf_token)
+#define GFC_TYPE_ARRAY_CAF_OFFSET(node) (TYPE_LANG_SPECIFIC(node)->caf_offset)
+#define GFC_TYPE_ARRAY_SIZE(node) (TYPE_LANG_SPECIFIC(node)->size)
+#define GFC_TYPE_ARRAY_OFFSET(node) (TYPE_LANG_SPECIFIC(node)->offset)
+#define GFC_TYPE_ARRAY_AKIND(node) (TYPE_LANG_SPECIFIC(node)->akind)
+/* Code should use gfc_get_dtype instead of accessing this directly.  It may
+   not be known when the type is created.  */
+#define GFC_TYPE_ARRAY_DTYPE(node) (TYPE_LANG_SPECIFIC(node)->dtype)
+#define GFC_TYPE_ARRAY_DATAPTR_TYPE(node) \
+  (TYPE_LANG_SPECIFIC(node)->dataptr_type)
+#define GFC_TYPE_ARRAY_SPAN(node) (TYPE_LANG_SPECIFIC(node)->span)
+#define GFC_TYPE_ARRAY_BASE_DECL(node, internal) \
+  (TYPE_LANG_SPECIFIC(node)->base_decl[(internal)])
+
+
+/* Build an expression with void type.  */
+#define build1_v(code, arg) \
+	fold_build1_loc (input_location, code, void_type_node, arg)
+#define build2_v(code, arg1, arg2) \
+	fold_build2_loc (input_location, code, void_type_node, arg1, arg2)
+#define build3_v(code, arg1, arg2, arg3) \
+	fold_build3_loc (input_location, code, void_type_node, arg1, arg2, arg3)
+#define build4_v(code, arg1, arg2, arg3, arg4) \
+	build4_loc (input_location, code, void_type_node, arg1, arg2, \
+		    arg3, arg4)
+
+/* This group of functions allows a caller to evaluate an expression from
+   the callee's interface.  It establishes a mapping between the interface's
+   dummy arguments and the caller's actual arguments, then applies that
+   mapping to a given gfc_expr.
+
+   You can initialize a mapping structure like so:
+
+       gfc_interface_mapping mapping;
+       ...
+       gfc_init_interface_mapping (&mapping);
+
+   You should then evaluate each actual argument into a temporary
+   gfc_se structure, here called "se", and map the result to the
+   dummy argument's symbol, here called "sym":
+
+       gfc_add_interface_mapping (&mapping, sym, &se);
+
+   After adding all mappings, you should call:
+
+       gfc_finish_interface_mapping (&mapping, pre, post);
+
+   where "pre" and "post" are statement blocks for initialization
+   and finalization code respectively.  You can then evaluate an
+   interface expression "expr" as follows:
+
+       gfc_apply_interface_mapping (&mapping, se, expr);
+
+   Once you've evaluated all expressions, you should free
+   the mapping structure with:
+
+       gfc_free_interface_mapping (&mapping); */
+
+
+/* This structure represents a mapping from OLD to NEW, where OLD is a
+   dummy argument symbol and NEW is a symbol that represents the value
+   of an actual argument.  Mappings are linked together using NEXT
+   (in no particular order).  */
+typedef struct gfc_interface_sym_mapping
+{
+  struct gfc_interface_sym_mapping *next;
+  gfc_symbol *old;
+  gfc_symtree *new_sym;
+  gfc_expr *expr;
+}
+gfc_interface_sym_mapping;
+
+
+/* This structure is used by callers to evaluate an expression from
+   a callee's interface.  */
+typedef struct gfc_interface_mapping
+{
+  /* Maps the interface's dummy arguments to the values that the caller
+     is passing.  The whole list is owned by this gfc_interface_mapping.  */
+  gfc_interface_sym_mapping *syms;
+
+  /* A list of gfc_charlens that were needed when creating copies of
+     expressions.  The whole list is owned by this gfc_interface_mapping.  */
+  gfc_charlen *charlens;
+}
+gfc_interface_mapping;
+
+void gfc_init_interface_mapping (gfc_interface_mapping *);
+void gfc_free_interface_mapping (gfc_interface_mapping *);
+void gfc_add_interface_mapping (gfc_interface_mapping *,
+				gfc_symbol *, gfc_se *, gfc_expr *);
+void gfc_finish_interface_mapping (gfc_interface_mapping *,
+				   stmtblock_t *, stmtblock_t *);
+void gfc_apply_interface_mapping (gfc_interface_mapping *,
+				  gfc_se *, gfc_expr *);
+
+
+/* Standard error messages used in all the trans-*.c files.  */
+extern const char gfc_msg_fault[];
+extern const char gfc_msg_wrong_return[];
+
+#define OMPWS_WORKSHARE_FLAG	1	/* Set if in a workshare construct.  */
+#define OMPWS_CURR_SINGLEUNIT	2	/* Set if current gfc_code in workshare
+					   construct is not workshared.  */
+#define OMPWS_SCALARIZER_WS	4	/* Set if scalarizer should attempt
+					   to create parallel loops.  */
+#define OMPWS_NOWAIT		8	/* Use NOWAIT on OMP_FOR.  */
+extern int ompws_flags;
+
+#endif /* GFC_TRANS_H */
diff --git a/gcc-4.9/gcc/fortran/types.def b/gcc-4.9/gcc/fortran/types.def
new file mode 100644
index 000000000..78fc679f1
--- /dev/null
+++ b/gcc-4.9/gcc/fortran/types.def
@@ -0,0 +1,217 @@
+/* Copyright (C) 2001-2014 Free Software Foundation, Inc.
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+/* This header contains a subset of ../builtin-types.def needed for
+   Fortran frontend builtins.
+
+   Before including this header, you must define the following macros:
+
+   DEF_PRIMITIVE_TYPE (ENUM, TYPE)
+
+     The ENUM is an identifier indicating which type is being defined.
+     TYPE is an expression for a `tree' that represents the type.
+
+   DEF_FUNCTION_TYPE_0 (ENUM, RETURN)
+   DEF_FUNCTION_TYPE_1 (ENUM, RETURN, ARG1)
+   DEF_FUNCTION_TYPE_2 (ENUM, RETURN, ARG1, ARG2)
+   DEF_FUNCTION_TYPE_3 (ENUM, RETURN, ARG1, ARG2, ARG3)
+   DEF_FUNCTION_TYPE_4 (ENUM, RETURN, ARG1, ARG2, ARG3, ARG4)
+   DEF_FUNCTION_TYPE_5 (ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5)
+   DEF_FUNCTION_TYPE_6 (ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6)
+   DEF_FUNCTION_TYPE_7 (ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7)
+   DEF_FUNCTION_TYPE_8 (ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7,
+			ARG8)
+
+     These macros describe function types.  ENUM is as above.  The
+     RETURN type is one of the enumerals already defined.  ARG1, ARG2,
+     and ARG3 give the types of the arguments, similarly.
+
+   DEF_FUNCTION_TYPE_VAR_0 (ENUM, RETURN)
+
+     Similar, but for function types that take variable arguments.
+
+  DEF_POINTER_TYPE (ENUM, TYPE)
+
+    This macro describes a pointer type.  ENUM is as above; TYPE is
+    the type pointed to.  */
+
+DEF_PRIMITIVE_TYPE (BT_VOID, void_type_node)
+DEF_PRIMITIVE_TYPE (BT_BOOL,
+		    (*lang_hooks.types.type_for_size) (BOOL_TYPE_SIZE, 1))
+DEF_PRIMITIVE_TYPE (BT_INT, integer_type_node)
+DEF_PRIMITIVE_TYPE (BT_UINT, unsigned_type_node)
+DEF_PRIMITIVE_TYPE (BT_LONG, long_integer_type_node)
+DEF_PRIMITIVE_TYPE (BT_ULONGLONG, long_long_unsigned_type_node)
+DEF_PRIMITIVE_TYPE (BT_WORD, (*lang_hooks.types.type_for_mode) (word_mode, 1))
+DEF_PRIMITIVE_TYPE (BT_SIZE, size_type_node)
+
+DEF_PRIMITIVE_TYPE (BT_I1, builtin_type_for_size (BITS_PER_UNIT*1, 1))
+DEF_PRIMITIVE_TYPE (BT_I2, builtin_type_for_size (BITS_PER_UNIT*2, 1))
+DEF_PRIMITIVE_TYPE (BT_I4, builtin_type_for_size (BITS_PER_UNIT*4, 1))
+DEF_PRIMITIVE_TYPE (BT_I8, builtin_type_for_size (BITS_PER_UNIT*8, 1))
+DEF_PRIMITIVE_TYPE (BT_I16, builtin_type_for_size (BITS_PER_UNIT*16, 1))
+
+DEF_PRIMITIVE_TYPE (BT_PTR, ptr_type_node)
+DEF_PRIMITIVE_TYPE (BT_CONST_PTR, const_ptr_type_node)
+DEF_PRIMITIVE_TYPE (BT_VOLATILE_PTR,
+                    build_pointer_type
+                     (build_qualified_type (void_type_node,
+                                            TYPE_QUAL_VOLATILE)))
+DEF_PRIMITIVE_TYPE (BT_CONST_VOLATILE_PTR,
+		    build_pointer_type
+		     (build_qualified_type (void_type_node,
+					  TYPE_QUAL_VOLATILE|TYPE_QUAL_CONST)))
+DEF_POINTER_TYPE (BT_PTR_LONG, BT_LONG)
+DEF_POINTER_TYPE (BT_PTR_ULONGLONG, BT_ULONGLONG)
+DEF_POINTER_TYPE (BT_PTR_PTR, BT_PTR)
+DEF_FUNCTION_TYPE_0 (BT_FN_BOOL, BT_BOOL)
+DEF_FUNCTION_TYPE_0 (BT_FN_PTR, BT_PTR)
+DEF_FUNCTION_TYPE_0 (BT_FN_INT, BT_INT)
+DEF_FUNCTION_TYPE_0 (BT_FN_UINT, BT_UINT)
+DEF_FUNCTION_TYPE_0 (BT_FN_VOID, BT_VOID)
+
+DEF_FUNCTION_TYPE_1 (BT_FN_VOID_PTR, BT_VOID, BT_PTR)
+DEF_FUNCTION_TYPE_1 (BT_FN_VOID_PTRPTR, BT_VOID, BT_PTR_PTR)
+DEF_FUNCTION_TYPE_1 (BT_FN_VOID_VPTR, BT_VOID, BT_VOLATILE_PTR)
+DEF_FUNCTION_TYPE_1 (BT_FN_UINT_UINT, BT_UINT, BT_UINT)
+DEF_FUNCTION_TYPE_1 (BT_FN_PTR_PTR, BT_PTR, BT_PTR)
+DEF_FUNCTION_TYPE_1 (BT_FN_VOID_INT, BT_VOID, BT_INT)
+DEF_FUNCTION_TYPE_1 (BT_FN_BOOL_INT, BT_BOOL, BT_INT)
+
+DEF_POINTER_TYPE (BT_PTR_FN_VOID_PTR, BT_FN_VOID_PTR)
+
+DEF_FUNCTION_TYPE_2 (BT_FN_BOOL_LONGPTR_LONGPTR,
+                     BT_BOOL, BT_PTR_LONG, BT_PTR_LONG)
+DEF_FUNCTION_TYPE_2 (BT_FN_BOOL_ULONGLONGPTR_ULONGLONGPTR,
+		     BT_BOOL, BT_PTR_ULONGLONG, BT_PTR_ULONGLONG)
+DEF_FUNCTION_TYPE_2 (BT_FN_I1_VPTR_I1, BT_I1, BT_VOLATILE_PTR, BT_I1)
+DEF_FUNCTION_TYPE_2 (BT_FN_I2_VPTR_I2, BT_I2, BT_VOLATILE_PTR, BT_I2)
+DEF_FUNCTION_TYPE_2 (BT_FN_I4_VPTR_I4, BT_I4, BT_VOLATILE_PTR, BT_I4)
+DEF_FUNCTION_TYPE_2 (BT_FN_I8_VPTR_I8, BT_I8, BT_VOLATILE_PTR, BT_I8)
+DEF_FUNCTION_TYPE_2 (BT_FN_I16_VPTR_I16, BT_I16, BT_VOLATILE_PTR, BT_I16)
+DEF_FUNCTION_TYPE_2 (BT_FN_VOID_PTR_PTR, BT_VOID, BT_PTR, BT_PTR)
+DEF_FUNCTION_TYPE_2 (BT_FN_I1_CONST_VPTR_INT, BT_I1, BT_CONST_VOLATILE_PTR,
+		     BT_INT)
+DEF_FUNCTION_TYPE_2 (BT_FN_I2_CONST_VPTR_INT, BT_I2, BT_CONST_VOLATILE_PTR,
+		     BT_INT)
+DEF_FUNCTION_TYPE_2 (BT_FN_I4_CONST_VPTR_INT, BT_I4, BT_CONST_VOLATILE_PTR,
+		     BT_INT)
+DEF_FUNCTION_TYPE_2 (BT_FN_I8_CONST_VPTR_INT, BT_I8, BT_CONST_VOLATILE_PTR,
+		     BT_INT)
+DEF_FUNCTION_TYPE_2 (BT_FN_I16_CONST_VPTR_INT, BT_I16, BT_CONST_VOLATILE_PTR,
+		     BT_INT)
+DEF_FUNCTION_TYPE_2 (BT_FN_VOID_VPTR_INT, BT_VOID, BT_VOLATILE_PTR, BT_INT)
+DEF_FUNCTION_TYPE_2 (BT_FN_BOOL_VPTR_INT, BT_BOOL, BT_VOLATILE_PTR, BT_INT)
+DEF_FUNCTION_TYPE_2 (BT_FN_BOOL_SIZE_CONST_VPTR, BT_BOOL, BT_SIZE,
+		     BT_CONST_VOLATILE_PTR)
+DEF_FUNCTION_TYPE_2 (BT_FN_BOOL_INT_BOOL, BT_BOOL, BT_INT, BT_BOOL)
+DEF_FUNCTION_TYPE_2 (BT_FN_VOID_UINT_UINT, BT_VOID, BT_UINT, BT_UINT)
+
+DEF_POINTER_TYPE (BT_PTR_FN_VOID_PTR_PTR, BT_FN_VOID_PTR_PTR)
+
+DEF_FUNCTION_TYPE_3 (BT_FN_BOOL_VPTR_I1_I1, BT_BOOL, BT_VOLATILE_PTR,
+                     BT_I1, BT_I1)
+DEF_FUNCTION_TYPE_3 (BT_FN_BOOL_VPTR_I2_I2, BT_BOOL, BT_VOLATILE_PTR,
+                     BT_I2, BT_I2)
+DEF_FUNCTION_TYPE_3 (BT_FN_BOOL_VPTR_I4_I4, BT_BOOL, BT_VOLATILE_PTR,
+                     BT_I4, BT_I4)
+DEF_FUNCTION_TYPE_3 (BT_FN_BOOL_VPTR_I8_I8, BT_BOOL, BT_VOLATILE_PTR,
+                     BT_I8, BT_I8)
+DEF_FUNCTION_TYPE_3 (BT_FN_BOOL_VPTR_I16_I16, BT_BOOL, BT_VOLATILE_PTR,
+                     BT_I16, BT_I16)
+DEF_FUNCTION_TYPE_3 (BT_FN_I1_VPTR_I1_I1, BT_I1, BT_VOLATILE_PTR, BT_I1, BT_I1)
+DEF_FUNCTION_TYPE_3 (BT_FN_I2_VPTR_I2_I2, BT_I2, BT_VOLATILE_PTR, BT_I2, BT_I2)
+DEF_FUNCTION_TYPE_3 (BT_FN_I4_VPTR_I4_I4, BT_I4, BT_VOLATILE_PTR, BT_I4, BT_I4)
+DEF_FUNCTION_TYPE_3 (BT_FN_I8_VPTR_I8_I8, BT_I8, BT_VOLATILE_PTR, BT_I8, BT_I8)
+DEF_FUNCTION_TYPE_3 (BT_FN_I16_VPTR_I16_I16, BT_I16, BT_VOLATILE_PTR,
+		     BT_I16, BT_I16)
+DEF_FUNCTION_TYPE_3 (BT_FN_I1_VPTR_I1_INT, BT_I1, BT_VOLATILE_PTR, BT_I1, BT_INT)
+DEF_FUNCTION_TYPE_3 (BT_FN_I2_VPTR_I2_INT, BT_I2, BT_VOLATILE_PTR, BT_I2, BT_INT)
+DEF_FUNCTION_TYPE_3 (BT_FN_I4_VPTR_I4_INT, BT_I4, BT_VOLATILE_PTR, BT_I4, BT_INT)
+DEF_FUNCTION_TYPE_3 (BT_FN_I8_VPTR_I8_INT, BT_I8, BT_VOLATILE_PTR, BT_I8, BT_INT)
+DEF_FUNCTION_TYPE_3 (BT_FN_I16_VPTR_I16_INT, BT_I16, BT_VOLATILE_PTR, BT_I16, BT_INT)
+DEF_FUNCTION_TYPE_3 (BT_FN_VOID_VPTR_I1_INT, BT_VOID, BT_VOLATILE_PTR, BT_I1, BT_INT)
+DEF_FUNCTION_TYPE_3 (BT_FN_VOID_VPTR_I2_INT, BT_VOID, BT_VOLATILE_PTR, BT_I2, BT_INT)
+DEF_FUNCTION_TYPE_3 (BT_FN_VOID_VPTR_I4_INT, BT_VOID, BT_VOLATILE_PTR, BT_I4, BT_INT)
+DEF_FUNCTION_TYPE_3 (BT_FN_VOID_VPTR_I8_INT, BT_VOID, BT_VOLATILE_PTR, BT_I8, BT_INT)
+DEF_FUNCTION_TYPE_3 (BT_FN_VOID_VPTR_I16_INT, BT_VOID, BT_VOLATILE_PTR, BT_I16, BT_INT)
+
+DEF_FUNCTION_TYPE_4 (BT_FN_VOID_OMPFN_PTR_UINT_UINT,
+                     BT_VOID, BT_PTR_FN_VOID_PTR, BT_PTR, BT_UINT, BT_UINT)
+DEF_FUNCTION_TYPE_4 (BT_FN_VOID_PTR_WORD_WORD_PTR,
+		     BT_VOID, BT_PTR, BT_WORD, BT_WORD, BT_PTR)
+DEF_FUNCTION_TYPE_4 (BT_FN_VOID_SIZE_VPTR_PTR_INT, BT_VOID, BT_SIZE,
+		     BT_VOLATILE_PTR, BT_PTR, BT_INT)
+DEF_FUNCTION_TYPE_4 (BT_FN_VOID_SIZE_CONST_VPTR_PTR_INT, BT_VOID, BT_SIZE,
+		     BT_CONST_VOLATILE_PTR, BT_PTR, BT_INT)
+
+DEF_FUNCTION_TYPE_5 (BT_FN_VOID_OMPFN_PTR_UINT_UINT_UINT,
+		     BT_VOID, BT_PTR_FN_VOID_PTR, BT_PTR, BT_UINT, BT_UINT,
+		     BT_UINT)
+DEF_FUNCTION_TYPE_5 (BT_FN_BOOL_LONG_LONG_LONG_LONGPTR_LONGPTR,
+                     BT_BOOL, BT_LONG, BT_LONG, BT_LONG,
+		     BT_PTR_LONG, BT_PTR_LONG)
+DEF_FUNCTION_TYPE_5 (BT_FN_VOID_SIZE_VPTR_PTR_PTR_INT, BT_VOID, BT_SIZE,
+		     BT_VOLATILE_PTR, BT_PTR, BT_PTR, BT_INT)
+
+DEF_FUNCTION_TYPE_6 (BT_FN_BOOL_LONG_LONG_LONG_LONG_LONGPTR_LONGPTR,
+                     BT_BOOL, BT_LONG, BT_LONG, BT_LONG, BT_LONG,
+		     BT_PTR_LONG, BT_PTR_LONG)
+DEF_FUNCTION_TYPE_6 (BT_FN_BOOL_BOOL_ULL_ULL_ULL_ULLPTR_ULLPTR,
+		     BT_BOOL, BT_BOOL, BT_ULONGLONG, BT_ULONGLONG,
+		     BT_ULONGLONG, BT_PTR_ULONGLONG, BT_PTR_ULONGLONG)
+DEF_FUNCTION_TYPE_6 (BT_FN_BOOL_VPTR_PTR_I1_BOOL_INT_INT, 
+		     BT_BOOL, BT_VOLATILE_PTR, BT_PTR, BT_I1, BT_BOOL, BT_INT,
+		     BT_INT)
+DEF_FUNCTION_TYPE_6 (BT_FN_BOOL_VPTR_PTR_I2_BOOL_INT_INT, 
+		     BT_BOOL, BT_VOLATILE_PTR, BT_PTR, BT_I2, BT_BOOL, BT_INT,
+		     BT_INT)
+DEF_FUNCTION_TYPE_6 (BT_FN_BOOL_VPTR_PTR_I4_BOOL_INT_INT, 
+		     BT_BOOL, BT_VOLATILE_PTR, BT_PTR, BT_I4, BT_BOOL, BT_INT,
+		     BT_INT)
+DEF_FUNCTION_TYPE_6 (BT_FN_BOOL_VPTR_PTR_I8_BOOL_INT_INT, 
+		     BT_BOOL, BT_VOLATILE_PTR, BT_PTR, BT_I8, BT_BOOL, BT_INT,
+		     BT_INT)
+DEF_FUNCTION_TYPE_6 (BT_FN_BOOL_VPTR_PTR_I16_BOOL_INT_INT, 
+		     BT_BOOL, BT_VOLATILE_PTR, BT_PTR, BT_I16, BT_BOOL, BT_INT,
+		     BT_INT)
+DEF_FUNCTION_TYPE_6 (BT_FN_BOOL_SIZE_VPTR_PTR_PTR_INT_INT, BT_BOOL, BT_SIZE,
+		     BT_VOLATILE_PTR, BT_PTR, BT_PTR, BT_INT, BT_INT)
+DEF_FUNCTION_TYPE_6 (BT_FN_VOID_INT_PTR_SIZE_PTR_PTR_PTR,
+		     BT_VOID, BT_INT, BT_PTR, BT_SIZE, BT_PTR, BT_PTR, BT_PTR)
+
+DEF_FUNCTION_TYPE_7 (BT_FN_VOID_OMPFN_PTR_UINT_LONG_LONG_LONG_UINT,
+                     BT_VOID, BT_PTR_FN_VOID_PTR, BT_PTR, BT_UINT,
+		     BT_LONG, BT_LONG, BT_LONG, BT_UINT)
+DEF_FUNCTION_TYPE_7 (BT_FN_BOOL_BOOL_ULL_ULL_ULL_ULL_ULLPTR_ULLPTR,
+		     BT_BOOL, BT_BOOL, BT_ULONGLONG, BT_ULONGLONG,
+		     BT_ULONGLONG, BT_ULONGLONG,
+		     BT_PTR_ULONGLONG, BT_PTR_ULONGLONG)
+DEF_FUNCTION_TYPE_7 (BT_FN_VOID_INT_OMPFN_PTR_SIZE_PTR_PTR_PTR,
+		     BT_VOID, BT_INT, BT_PTR_FN_VOID_PTR, BT_PTR, BT_SIZE,
+		     BT_PTR, BT_PTR, BT_PTR)
+
+DEF_FUNCTION_TYPE_8 (BT_FN_VOID_OMPFN_PTR_UINT_LONG_LONG_LONG_LONG_UINT,
+		     BT_VOID, BT_PTR_FN_VOID_PTR, BT_PTR, BT_UINT,
+		     BT_LONG, BT_LONG, BT_LONG, BT_LONG, BT_UINT)
+DEF_FUNCTION_TYPE_8 (BT_FN_VOID_OMPFN_PTR_OMPCPYFN_LONG_LONG_BOOL_UINT_PTR,
+		     BT_VOID, BT_PTR_FN_VOID_PTR, BT_PTR,
+		     BT_PTR_FN_VOID_PTR_PTR, BT_LONG, BT_LONG,
+		     BT_BOOL, BT_UINT, BT_PTR)
+
+DEF_FUNCTION_TYPE_VAR_0 (BT_FN_VOID_VAR, BT_VOID)