Merge branch 'master' into gfortran-testdevel/gfortran-test

28 files changed, 1580 insertions, 323 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 4c7e8d1..9cdf2ab 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,297 @@
+2025-09-01  Harald Anlauf  <anlauf@gmx.de>
+
+	PR fortran/121727
+	* trans-expr.cc (gfc_const_length_character_type_p): New helper
+	function.
+	(conv_dummy_value): Use it to determine if a character actual
+	argument has a constant length.  If a character actual argument is
+	constant and longer than the dummy, truncate it at compile time.
+
+2025-08-31  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/99709
+	* trans-array.cc (structure_alloc_comps): For the case
+	COPY_ALLOC_COMP, do a deep copy of non-allocatable PDT arrays
+	Suppress the use of 'duplicate_allocatable' for PDT arrays.
+	* trans-expr.cc (conv_dummy_value): When passing to a PDT dummy
+	with the VALUE attribute, do a deep copy to ensure that
+	parameterized components are reallocated.
+
+2025-08-29  Harald Anlauf  <anlauf@gmx.de>
+
+	PR fortran/93330
+	* interface.cc (get_sym_storage_size): Add argument size_known to
+	indicate that the storage size could be successfully determined.
+	(get_expr_storage_size): Likewise.
+	(gfc_compare_actual_formal): Use them to handle zero-sized dummy
+	and actual arguments.
+	If a character formal argument has the pointer or allocatable
+	attribute, or is an array that is not assumed or explicit size,
+	we generate an error by default unless -std=legacy is specified,
+	which falls back to just giving a warning.
+	If -Wcharacter-truncation is given, warn on a character actual
+	argument longer than the dummy.  Generate an error for too short
+	scalar character arguments if -std=f* is given instead of just a
+	warning.
+
+2025-08-28  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/82843
+	* intrinsic.cc (gfc_convert_type_warn): If the 'from_ts' is a
+	PDT instance, copy the derived type to the target ts.
+	* resolve.cc (gfc_resolve_ref): A PDT component in a component
+	reference can be that of the pdt_template. Unconditionally use
+	component of the PDT instance to ensure that the backend_decl
+	is set during translation. Likewise if a component is
+	encountered that is a PDT template type, use the component
+	parmeters to convert to the correct PDT instance.
+
+2025-08-28  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/82205
+	* decl.cc (gfc_get_pdt_instance): Copy the default initializer
+	for components that are not PDT parameters or parameterized. If
+	any component is a pointer or allocatable set the attributes
+	'pointer_comp' or 'alloc_comp' of the new PDT instance.
+	* primary.cc (gfc_match_rvalue): Implement the correct form of
+	PDT constructors with 'name (type parms)(component values)'.
+	* trans-array.cc (structure_alloc_comps): Apply scalar default
+	initializers. Array initializers await the coming change in PDT
+	representation.
+	* trans-io.cc (transfer_expr): Do not output the type parms of
+	a PDT in list directed output.
+
+2025-08-27  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/114611
+	* io.cc: Issue an error on use of the H descriptor in
+	a format with -std=f95 or higher. Otherwise, issue a
+	warning.
+
+2025-08-26  Sandra Loosemore  <sloosemore@baylibre.com>
+
+	PR middle-end/118839
+	* trans-openmp.cc (gfc_trans_omp_declare_variant): Error if variant
+	is the same as base.
+
+2025-08-26  Sandra Loosemore  <sloosemore@baylibre.com>
+
+	* openmp.cc (gfc_match_omp_declare_variant): Make check for a
+	missing "match" clause unconditional.
+
+2025-08-21  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/121627
+	* module.cc (create_int_parameter_array):  Avoid NULL
+	pointer dereference and enhance error message.
+
+2025-08-21  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/84122
+	PR fortran/85942
+	* parse.cc (parse_derived): PDT type parameters are not allowed
+	an explicit access specification and must appear before a
+	PRIVATE statement. If a PRIVATE statement is seen, mark all the
+	other components as PRIVATE.
+	* simplify.cc (get_kind): Convert a PDT KIND component into a
+	specification expression using the default initializer.
+
+2025-08-20  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	* intrinsic.texi: Correct the example given for FRACTION.
+	Move the TEAM_NUMBER section to after the TANPI to align
+	with the order gven in the index.
+
+2025-08-16  H.J. Lu  <hjl.tools@gmail.com>
+
+	PR fortran/107421
+	* trans-common.cc (build_common_decl): Call set_decl_tls_model
+	after processing a variable.
+	* trans-decl.cc (gfc_finish_var_decl): Likewise.
+	(get_proc_pointer_decl): Likewise.
+
+2025-08-13  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/89092
+	* resolve.cc (was_declared): Add subroutine attribute.
+
+2025-08-12  Yuao Ma  <c8ef@outlook.com>
+
+	* check.cc (gfc_check_c_f_pointer): Check lower arg legitimacy.
+	* intrinsic.cc (add_subroutines): Teach c_f_pointer about lower arg.
+	* intrinsic.h (gfc_check_c_f_pointer): Add lower arg.
+	* intrinsic.texi: Update lower arg for c_f_pointer.
+	* trans-intrinsic.cc (conv_isocbinding_subroutine): Add logic handle lower.
+
+2025-08-11  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/121398
+	* resolve.cc (check_pdt_args): New function.
+	(check_generic_tbp_ambiguity): Use it to ensure that args to
+	typebound procedures that do not have the same declared type as
+	the containing derived type have 'pass1/2' set to null. This
+	avoids false ambiguity errors.
+	(resolve_typebound_procedure): Do not generate a wrong type
+	error for typebound procedures marked as pass if they are of a
+	different declared type to the containing pdt_type.
+
+2025-08-11  Jakub Jelinek  <jakub@redhat.com>
+
+	* gfortran.h (gfc_case): Fix comment typo, singe -> single.
+
+2025-08-09  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/121182
+	* decl.cc (match_generic_stmt): New function based on original
+	gfc_match_generic but feeding namespace rather than typebound
+	generics.
+	(match_typebound_generic): Renamed original gfc_match_generic.
+	(gfc_match_generic): New function that selects between type
+	bound generic and other generic statements and calls one of the
+	above two functions as appropriate.
+	* parse.cc (decode_specification_statement): Allow generic
+	statements.
+	(parse_spec): Accept a generic statement in a specification
+	block.
+
+2025-08-05  Mikael Morin  <morin-mikael@orange.fr>
+
+	* trans-stmt.cc (trans_associate_var): Remove overwrite of
+	the polymorphic associate variable's array descriptor offset.
+
+2025-08-05  Mikael Morin  <morin-mikael@orange.fr>
+
+	* trans-array.cc (trans_array_constructor): Remove the update of
+	the array descriptor upper bound after array constructor
+	expansion.
+
+2025-08-05  Mikael Morin  <morin-mikael@orange.fr>
+
+	* trans-array.cc (gfc_conv_expr_descriptor): Remove
+	isolated initialization of the span field before passing to
+	the function that will do the initialization.
+
+2025-08-05  Mikael Morin  <morin-mikael@orange.fr>
+
+	* trans-decl.cc (gfc_trans_deferred_vars): Don't default
+	initialize the span of local pointer arrays.
+
+2025-08-05  Mikael Morin  <morin-mikael@orange.fr>
+
+	* trans-stmt.cc (trans_associate_var): Remove overwrite of the
+	span field of the associate variable's array descriptor.
+
+2025-08-05  Mikael Morin  <morin-mikael@orange.fr>
+
+	* trans-expr.cc (gfc_trans_pointer_assignment): Remove overwrite
+	of the span after assignment of the array descriptor in the
+	polymorphic function result to non-polymorphic pointer case.
+
+2025-08-05  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans.h (gfc_se): Remove field use_offset.
+	* trans-expr.cc (gfc_conv_intrinsic_to_class): Remove use_offset
+	initialization.
+	(gfc_conv_procedure_call): Likewise.
+	* trans-stmt.cc (trans_associate_var): Likewise.
+
+2025-08-05  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.cc (gfc_alloc_allocatable_for_assignment): Use the
+	offset setter instead of generating a write to the offset.
+	(gfc_conv_array_parameter): Use the offset setter instead of
+	generating a write to the value returned by the offset getter.
+	* trans-expr.cc (gfc_trans_alloc_subarray_assign): Likewise.
+
+2025-08-05  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-array.cc (gfc_conv_descriptor_data_addr): Remove.
+	* trans-array.h (gfc_conv_descriptor_data_addr): Remove.
+	* trans-decl.cc (gfc_trans_deferred_vars): Use
+	gfc_conv_descriptor_data_get.
+
+2025-08-05  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans.cc (gfc_finalize_tree_expr): Use the data setter instead
+	of writing to the value returned by the data getter.
+	* trans-decl.cc (gfc_trans_deferred_vars): Likewise.
+	* trans-stmt.cc (trans_associate_var): Use the data setter
+	instead of writing to the value dereferenced from the data
+	address.
+
+2025-08-01  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* trans-decl.cc (gfc_trans_deferred_vars): Fix closing brace in
+	a comment.
+
+2025-07-31  Mikael Morin  <morin-mikael@orange.fr>
+
+	PR fortran/121342
+	* trans-expr.cc (gfc_conv_subref_array_arg): Remove offset
+	update.
+	(gfc_conv_procedure_call): For polymorphic functions, move the
+	scalarizer descriptor information...
+	* trans-array.cc (gfc_add_loop_ss_code): ... here, and evaluate
+	the bounds to fresh variables.
+	(get_class_info_from_ss): Remove offset update.
+	(gfc_conv_ss_startstride): Don't set a zero value for function
+	result upper bounds.
+	(late_set_loop_bounds): New.
+	(gfc_conv_loop_setup): If the bounds of a function result have
+	been set, and no other array provided loop bounds for a
+	dimension, use the function result bounds as loop bounds for
+	that dimension.
+	(gfc_set_delta): Don't skip delta setting for polymorphic
+	function results.
+
+2025-07-30  Mikael Morin  <morin-mikael@orange.fr>
+
+	* trans-array.cc (gfc_array_init_size): Remove the nelems
+	argument.
+	(gfc_array_allocate): Update caller.  Remove the nelems
+	argument.
+	* trans-stmt.cc (gfc_trans_allocate): Update caller.  Remove the
+	nelems variable.
+	* trans-array.h (gfc_array_allocate): Update prototype.
+
+2025-07-30  Yuao Ma  <c8ef@outlook.com>
+
+	* check.cc (gfc_check_split): Argument check for SPLIT.
+	* gfortran.h (enum gfc_isym_id): Define GFC_ISYM_SPLIT.
+	* intrinsic.cc (add_subroutines): Register SPLIT intrinsic.
+	* intrinsic.h (gfc_check_split): New decl.
+	(gfc_resolve_split): Ditto.
+	* intrinsic.texi: SPLIT documentation.
+	* iresolve.cc (gfc_resolve_split): Add resolved_sym for SPLIT.
+	* trans-decl.cc (gfc_build_intrinsic_function_decls): Add decl for
+	SPLIT in libgfortran.
+	* trans-intrinsic.cc (conv_intrinsic_split): SPLIT codegen.
+	(gfc_conv_intrinsic_subroutine): Handle SPLIT case.
+	* trans.h (GTY): Declare gfor_fndecl_string_split{, _char4}.
+
+2025-07-27  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/121185
+	* trans-expr.cc (gfc_trans_assignment_1): Use the same condition
+	to set the is_alloc_lhs flag and to decide to generate
+	reallocation code.  Add explicit call to gfc_fix_class_refs
+	before evaluating the condition.
+
+2025-07-27  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/121185
+	* trans-array.cc (set_factored_descriptor_value): Also trigger
+	the saving of the previously selected reference on encountering
+	an INDIRECT_REF.  Extract the saving code...
+	(save_ref): ... here as a new function.
+
+2025-07-27  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/121185
+	* trans-expr.cc (gfc_get_class_from_expr): Give up class
+	container lookup on the second COMPONENT_REF after an array
+	descriptor.
+
 2025-07-25  David Malcolm  <dmalcolm@redhat.com>
 
 	* error.cc: Make diagnostics::context::m_source_printing private.
@@ -147,7 +441,7 @@
 
 2025-07-11  Paul Thomas  <pault@gcc.gnu.org>
 
-	PR fortran/106135
+	PR fortran/106035
 	* decl.cc (build_sym): Emit an error if a symbol associated by
 	an IMPORT, ONLY or IMPORT, all statement is being redeclared.
 	(gfc_match_import): Parse and check the F2018 versions of the
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 838d523..80aac89 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -5559,6 +5559,27 @@ gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
   return true;
 }
 
+bool
+gfc_check_split (gfc_expr *string, gfc_expr *set, gfc_expr *pos, gfc_expr *back)
+{
+  if (!type_check (string, 0, BT_CHARACTER))
+    return false;
+
+  if (!type_check (set, 1, BT_CHARACTER))
+    return false;
+
+  if (!type_check (pos, 2, BT_INTEGER) || !scalar_check (pos, 2))
+    return false;
+
+  if (back != NULL
+      && (!type_check (back, 3, BT_LOGICAL) || !scalar_check (back, 3)))
+    return false;
+
+  if (!same_type_check (string, 0, set, 1))
+    return false;
+
+  return true;
+}
 
 bool
 gfc_check_secnds (gfc_expr *r)
@@ -6060,7 +6081,8 @@ gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2)
 
 
 bool
-gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape)
+gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape,
+		       gfc_expr *lower)
 {
   symbol_attribute attr;
   const char *msg;
@@ -6135,6 +6157,43 @@ gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape)
 	}
     }
 
+  if (lower
+      && !gfc_notify_std (GFC_STD_F2023, "LOWER argument at %L to C_F_POINTER",
+			  &lower->where))
+    return false;
+
+  if (!shape && lower)
+    {
+      gfc_error ("Unexpected LOWER argument at %L to C_F_POINTER "
+		 "with scalar FPTR",
+		 &lower->where);
+      return false;
+    }
+
+  if (lower && !rank_check (lower, 3, 1))
+    return false;
+
+  if (lower && !type_check (lower, 3, BT_INTEGER))
+    return false;
+
+  if (lower)
+    {
+      mpz_t size;
+      if (gfc_array_size (lower, &size))
+	{
+	  if (mpz_cmp_ui (size, fptr->rank) != 0)
+	    {
+	      mpz_clear (size);
+	      gfc_error (
+		"LOWER argument at %L to C_F_POINTER must have the same "
+		"size as the RANK of FPTR",
+		&lower->where);
+	      return false;
+	    }
+	  mpz_clear (size);
+	}
+    }
+
   if (fptr->ts.type == BT_CLASS)
     {
       gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr->where);
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index af42575..fcbbc2f 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -3870,6 +3870,8 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
   bool assumed_seen = false;
   bool deferred_seen = false;
   bool spec_error = false;
+  bool alloc_seen = false;
+  bool ptr_seen = false;
   int kind_value, i;
   gfc_expr *kind_expr;
   gfc_component *c1, *c2;
@@ -4074,6 +4076,11 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
 
       c2->ts = c1->ts;
       c2->attr = c1->attr;
+      if (c1->tb)
+	{
+	  c2->tb = gfc_get_tbp ();
+	  c2->tb = c1->tb;
+	}
 
       /* The order of declaration of the type_specs might not be the
 	 same as that of the components.  */
@@ -4161,6 +4168,17 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
 			 c2->ts.kind, gfc_basic_typename (c2->ts.type));
 	      goto error_return;
 	    }
+	  if (c2->attr.proc_pointer && c2->attr.function
+	      && c1->ts.interface && c1->ts.interface->ts.kind == 0)
+	    {
+	      c2->ts.interface = gfc_new_symbol ("", gfc_current_ns);
+	      c2->ts.interface->result = c2->ts.interface;
+	      c2->ts.interface->ts = c2->ts;
+	      c2->ts.interface->attr.flavor = FL_PROCEDURE;
+	      c2->ts.interface->attr.function = 1;
+	      c2->attr.function = 1;
+	      c2->attr.if_source = IFSRC_UNKNOWN;
+	    }
 	}
 
       /* Similarly, set the string length if parameterized.  */
@@ -4201,6 +4219,12 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
       if (c1->ts.type == BT_CLASS)
 	CLASS_DATA (c2)->as = gfc_copy_array_spec (CLASS_DATA (c1)->as);
 
+      if (c1->attr.allocatable)
+	alloc_seen = true;
+
+      if (c1->attr.pointer)
+	ptr_seen = true;
+
       /* Determine if an array spec is parameterized. If so, substitute
 	 in the parameter expressions for the bounds and set the pdt_array
 	 attribute. Notice that this attribute must be unconditionally set
@@ -4271,8 +4295,17 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
 	  if (c2->attr.allocatable)
 	    instance->attr.alloc_comp = 1;
 	}
+      else if (!(c2->attr.pdt_kind || c2->attr.pdt_len || c2->attr.pdt_string
+		 || c2->attr.pdt_array) && c1->initializer)
+	c2->initializer = gfc_copy_expr (c1->initializer);
     }
 
+  if (alloc_seen)
+    instance->attr.alloc_comp = 1;
+  if (ptr_seen)
+    instance->attr.pointer_comp = 1;
+
+
   gfc_commit_symbol (instance);
   if (ext_param_list)
     *ext_param_list = type_param_spec_list;
@@ -7556,6 +7589,9 @@ match_ppc_decl (void)
 	  *c->tb = *tb;
 	}
 
+      if (saved_kind_expr)
+	c->kind_expr = gfc_copy_expr (saved_kind_expr);
+
       /* Set interface.  */
       if (proc_if != NULL)
 	{
@@ -11710,10 +11746,308 @@ syntax:
 }
 
 
+/* Match a GENERIC statement.
+F2018 15.4.3.3 GENERIC statement
+
+A GENERIC statement specifies a generic identifier for one or more specific
+procedures, in the same way as a generic interface block that does not contain
+interface bodies.
+
+R1510 generic-stmt is:
+GENERIC [ , access-spec ] :: generic-spec => specific-procedure-list
+
+C1510 (R1510) A specific-procedure in a GENERIC statement shall not specify a
+procedure that was specified previously in any accessible interface with the
+same generic identifier.
+
+If access-spec appears, it specifies the accessibility (8.5.2) of generic-spec.
+
+For GENERIC statements outside of a derived type, use is made of the existing,
+typebound matching functions to obtain access-spec and generic-spec.  After
+this the standard INTERFACE machinery is used. */
+
+static match
+match_generic_stmt (void)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  /* Allow space for OPERATOR(...).  */
+  char generic_spec_name[GFC_MAX_SYMBOL_LEN + 16];
+  /* Generics other than uops  */
+  gfc_symbol* generic_spec = NULL;
+  /* Generic uops  */
+  gfc_user_op *generic_uop = NULL;
+  /* For the matching calls  */
+  gfc_typebound_proc tbattr;
+  gfc_namespace* ns = gfc_current_ns;
+  interface_type op_type;
+  gfc_intrinsic_op op;
+  match m;
+  gfc_symtree* st;
+  /* The specific-procedure-list  */
+  gfc_interface *generic = NULL;
+  /* The head of the specific-procedure-list  */
+  gfc_interface **generic_tail = NULL;
+
+  memset (&tbattr, 0, sizeof (tbattr));
+  tbattr.where = gfc_current_locus;
+
+  /* See if we get an access-specifier.  */
+  m = match_binding_attributes (&tbattr, true, false);
+  tbattr.where = gfc_current_locus;
+  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 generic-spec name; depending on type (operator / generic) format
+     it for future error messages in 'generic_spec_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:
+    case INTERFACE_DTIO:
+      snprintf (generic_spec_name, sizeof (generic_spec_name), "%s", name);
+      break;
+
+    case INTERFACE_USER_OP:
+      snprintf (generic_spec_name, sizeof (generic_spec_name), "OPERATOR(.%s.)", name);
+      break;
+
+    case INTERFACE_INTRINSIC_OP:
+      snprintf (generic_spec_name, sizeof (generic_spec_name), "OPERATOR(%s)",
+		gfc_op2string (op));
+      break;
+
+    case INTERFACE_NAMELESS:
+      gfc_error ("Malformed GENERIC statement at %C");
+      goto error;
+      break;
+
+    default:
+      gcc_unreachable ();
+    }
+
+  /* Match the required =>.  */
+  if (gfc_match (" =>") != MATCH_YES)
+    {
+      gfc_error ("Expected %<=>%> at %C");
+      goto error;
+    }
+
+
+  if (gfc_current_state () != COMP_MODULE && tbattr.access != ACCESS_UNKNOWN)
+    {
+      gfc_error ("The access specification at %L not in a module",
+		 &tbattr.where);
+      goto error;
+    }
+
+  /* Try to find existing generic-spec with this name for this operator;
+     if there is something, check that it is another generic-spec and then
+     extend it rather than building a new symbol. Otherwise, create a new
+     one with the right attributes.  */
+
+  switch (op_type)
+    {
+    case INTERFACE_DTIO:
+    case INTERFACE_GENERIC:
+      st = gfc_find_symtree (ns->sym_root, name);
+      generic_spec = st ? st->n.sym : NULL;
+      if (generic_spec)
+	{
+	  if (generic_spec->attr.flavor != FL_PROCEDURE
+	       && generic_spec->attr.flavor != FL_UNKNOWN)
+	    {
+	      gfc_error ("The generic-spec name %qs at %C clashes with the "
+			 "name of an entity declared at %L that is not a "
+			 "procedure", name, &generic_spec->declared_at);
+	      goto error;
+	    }
+
+	  if (op_type == INTERFACE_GENERIC && !generic_spec->attr.generic
+	       && generic_spec->attr.flavor != FL_UNKNOWN)
+	    {
+	      gfc_error ("There's already a non-generic procedure with "
+			 "name %qs at %C", generic_spec->name);
+	      goto error;
+	    }
+
+	  if (tbattr.access != ACCESS_UNKNOWN)
+	    {
+	      if (generic_spec->attr.access != tbattr.access)
+		{
+		  gfc_error ("The access specification at %L conflicts with "
+			     "that already given to %qs", &tbattr.where,
+			     generic_spec->name);
+		  goto error;
+		}
+	      else
+		{
+		  gfc_error ("The access specification at %L repeats that "
+			     "already given to %qs", &tbattr.where,
+			     generic_spec->name);
+		  goto error;
+		}
+	    }
+
+	  if (generic_spec->ts.type != BT_UNKNOWN)
+	    {
+	      gfc_error ("The generic-spec in the generic statement at %C "
+			 "has a type from the declaration at %L",
+			 &generic_spec->declared_at);
+	      goto error;
+	    }
+	}
+
+      /* Now create the generic_spec if it doesn't already exist and provide
+	 is with the appropriate attributes.  */
+      if (!generic_spec || generic_spec->attr.flavor != FL_PROCEDURE)
+	{
+	  if (!generic_spec)
+	    {
+	      gfc_get_symbol (name, ns, &generic_spec, &gfc_current_locus);
+	      gfc_set_sym_referenced (generic_spec);
+	      generic_spec->attr.access = tbattr.access;
+	    }
+	  else if (generic_spec->attr.access == ACCESS_UNKNOWN)
+	    generic_spec->attr.access = tbattr.access;
+	  generic_spec->refs++;
+	  generic_spec->attr.generic = 1;
+	  generic_spec->attr.flavor = FL_PROCEDURE;
+
+	  generic_spec->declared_at = gfc_current_locus;
+	}
+
+      /* Prepare to add the specific procedures.  */
+      generic = generic_spec->generic;
+      generic_tail = &generic_spec->generic;
+      break;
+
+    case INTERFACE_USER_OP:
+      st = gfc_find_symtree (ns->uop_root, name);
+      generic_uop = st ? st->n.uop : NULL;
+      if (generic_uop)
+	{
+	  if (generic_uop->access != ACCESS_UNKNOWN
+	      && tbattr.access != ACCESS_UNKNOWN)
+	    {
+	      if (generic_uop->access != tbattr.access)
+		{
+		  gfc_error ("The user operator at %L must have the same "
+			     "access specification as already defined user "
+			     "operator %qs", &tbattr.where, generic_spec_name);
+		  goto error;
+		}
+	      else
+		{
+		  gfc_error ("The user operator at %L repeats the access "
+			     "specification of already defined user operator " 				   "%qs", &tbattr.where, generic_spec_name);
+		  goto error;
+		}
+	    }
+	  else if (generic_uop->access == ACCESS_UNKNOWN)
+	    generic_uop->access = tbattr.access;
+	}
+      else
+	{
+	  generic_uop = gfc_get_uop (name);
+	  generic_uop->access = tbattr.access;
+	}
+
+      /* Prepare to add the specific procedures.  */
+      generic = generic_uop->op;
+      generic_tail = &generic_uop->op;
+      break;
+
+    case INTERFACE_INTRINSIC_OP:
+      generic = ns->op[op];
+      generic_tail = &ns->op[op];
+      break;
+
+    default:
+      gcc_unreachable ();
+    }
+
+  /* Now, match all following names in the specific-procedure-list.  */
+  do
+    {
+      m = gfc_match_name (name);
+      if (m == MATCH_ERROR)
+	goto error;
+      if (m == MATCH_NO)
+	{
+	  gfc_error ("Expected specific procedure name at %C");
+	  goto error;
+	}
+
+      if (op_type == INTERFACE_GENERIC
+	  && !strcmp (generic_spec->name, name))
+	{
+	  gfc_error ("The name %qs of the specific procedure at %C conflicts "
+		     "with that of the generic-spec", name);
+	  goto error;
+	}
+
+      generic = *generic_tail;
+      for (; generic; generic = generic->next)
+	{
+	  if (!strcmp (generic->sym->name, name))
+	    {
+	      gfc_error ("%qs already defined as a specific procedure for the"
+			 " generic %qs at %C", name, generic_spec->name);
+	      goto error;
+	    }
+	}
+
+      gfc_find_sym_tree (name, ns, 1, &st);
+      if (!st)
+	{
+	  /* This might be a procedure that has not yet been parsed. If
+	     so gfc_fixup_sibling_symbols will replace this symbol with
+	     that of the procedure.  */
+	  gfc_get_sym_tree (name, ns, &st, false);
+	  st->n.sym->refs++;
+	}
+
+      generic = gfc_get_interface();
+      generic->next = *generic_tail;
+      *generic_tail = generic;
+      generic->where = gfc_current_locus;
+      generic->sym = st->n.sym;
+    }
+  while (gfc_match (" ,") == MATCH_YES);
+
+  if (gfc_match_eos () != MATCH_YES)
+    {
+      gfc_error ("Junk after GENERIC statement at %C");
+      goto error;
+    }
+
+  gfc_commit_symbols ();
+  return MATCH_YES;
+
+error:
+  return MATCH_ERROR;
+}
+
+
 /* Match a GENERIC procedure binding inside a derived type.  */
 
-match
-gfc_match_generic (void)
+static match
+match_typebound_generic (void)
 {
   char name[GFC_MAX_SYMBOL_LEN + 1];
   char bind_name[GFC_MAX_SYMBOL_LEN + 16]; /* Allow space for OPERATOR(...).  */
@@ -11923,6 +12257,17 @@ error:
 }
 
 
+match
+gfc_match_generic ()
+{
+  if (gfc_option.allow_std & ~GFC_STD_OPT_F08
+      && gfc_current_state () != COMP_DERIVED_CONTAINS)
+    return match_generic_stmt ();
+  else
+    return match_typebound_generic ();
+}
+
+
 /* Match a FINAL declaration inside a derived type.  */
 
 match
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index b8d04ff..97f931a 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -5911,6 +5911,7 @@ gfc_spec_list_type (gfc_actual_arglist *param_list, gfc_symbol *derived)
   gfc_component *c;
   bool seen_assumed = false;
   bool seen_deferred = false;
+  bool seen_len = false;
 
   if (derived == NULL)
     {
@@ -5932,10 +5933,12 @@ gfc_spec_list_type (gfc_actual_arglist *param_list, gfc_symbol *derived)
 	    return SPEC_EXPLICIT;
 	  seen_assumed = param_list->spec_type == SPEC_ASSUMED;
 	  seen_deferred = param_list->spec_type == SPEC_DEFERRED;
+	  if (c->attr.pdt_len)
+	    seen_len = true;
 	  if (seen_assumed && seen_deferred)
 	    return SPEC_EXPLICIT;
 	}
-      res = seen_assumed ? SPEC_ASSUMED : SPEC_DEFERRED;
+      res = (seen_assumed || !seen_len) ? SPEC_ASSUMED : SPEC_DEFERRED;
     }
   return res;
 }
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 85feb18..482031d 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -729,6 +729,8 @@ enum gfc_isym_id
   GFC_ISYM_COSPI,
   GFC_ISYM_SINPI,
   GFC_ISYM_TANPI,
+
+  GFC_ISYM_SPLIT,
 };
 
 enum init_local_logical
@@ -1914,6 +1916,7 @@ typedef struct gfc_typebound_proc
 }
 gfc_typebound_proc;
 
+#define gfc_get_tbp() XCNEW (gfc_typebound_proc)
 
 /* Symbol nodes.  These are important things.  They are what the
    standard refers to as "entities".  The possibly multiple names that
@@ -2942,7 +2945,7 @@ typedef struct gfc_equiv_list
    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
+   lists of CASEs at the same time.  The single 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
diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index d08f683..ef5a17d 100644
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -3007,15 +3007,17 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 }
 
 
-/* Returns the storage size of a symbol (formal argument) or
-   zero if it cannot be determined.  */
+/* Returns the storage size of a symbol (formal argument) or sets argument
+   size_known to false if it cannot be determined.  */
 
 static unsigned long
-get_sym_storage_size (gfc_symbol *sym)
+get_sym_storage_size (gfc_symbol *sym, bool *size_known)
 {
   int i;
   unsigned long strlen, elements;
 
+  *size_known = false;
+
   if (sym->ts.type == BT_CHARACTER)
     {
       if (sym->ts.u.cl && sym->ts.u.cl->length
@@ -3029,7 +3031,10 @@ get_sym_storage_size (gfc_symbol *sym)
     strlen = 1;
 
   if (symbol_rank (sym) == 0)
-    return strlen;
+    {
+      *size_known = true;
+      return strlen;
+    }
 
   elements = 1;
   if (sym->as->type != AS_EXPLICIT)
@@ -3046,17 +3051,19 @@ get_sym_storage_size (gfc_symbol *sym)
 		  - mpz_get_si (sym->as->lower[i]->value.integer) + 1L;
     }
 
+  *size_known = true;
+
   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
+/* Returns the storage size of an expression (actual argument) or sets argument
+   size_known to false 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)
+get_expr_storage_size (gfc_expr *e, bool *size_known)
 {
   int i;
   long int strlen, elements;
@@ -3064,6 +3071,8 @@ get_expr_storage_size (gfc_expr *e)
   bool is_str_storage = false;
   gfc_ref *ref;
 
+  *size_known = false;
+
   if (e == NULL)
     return 0;
 
@@ -3083,7 +3092,10 @@ get_expr_storage_size (gfc_expr *e)
     strlen = 1; /* Length per element.  */
 
   if (e->rank == 0 && !e->ref)
-    return strlen;
+    {
+      *size_known = true;
+      return strlen;
+    }
 
   elements = 1;
   if (!e->ref)
@@ -3092,7 +3104,10 @@ get_expr_storage_size (gfc_expr *e)
 	return 0;
       for (i = 0; i < e->rank; i++)
 	elements *= mpz_get_si (e->shape[i]);
-      return elements*strlen;
+      {
+	*size_known = true;
+	return elements*strlen;
+      }
     }
 
   for (ref = e->ref; ref; ref = ref->next)
@@ -3231,6 +3246,8 @@ get_expr_storage_size (gfc_expr *e)
 	}
     }
 
+  *size_known = true;
+
   if (substrlen)
     return (is_str_storage) ? substrlen + (elements-1)*strlen
 			    : elements*strlen;
@@ -3331,7 +3348,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
   gfc_array_spec *fas, *aas;
   bool pointer_dummy, pointer_arg, allocatable_arg;
   bool procptr_dummy, optional_dummy, allocatable_dummy;
-
+  bool actual_size_known = false;
+  bool formal_size_known = false;
   bool ok = true;
 
   actual = *ap;
@@ -3584,20 +3602,39 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	  && (mpz_cmp (a->expr->ts.u.cl->length->value.integer,
 		       f->sym->ts.u.cl->length->value.integer) != 0))
 	{
+	  long actual_len, formal_len;
+	  actual_len = mpz_get_si (a->expr->ts.u.cl->length->value.integer);
+	  formal_len = mpz_get_si (f->sym->ts.u.cl->length->value.integer);
+
 	  if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
-	    gfc_warning (0, "Character length mismatch (%ld/%ld) between actual "
-			 "argument and pointer or allocatable dummy argument "
-			 "%qs 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);
+	    {
+	      /* Emit a warning for -std=legacy and an error otherwise. */
+	      if (gfc_option.warn_std == 0)
+		gfc_warning (0, "Character length mismatch (%ld/%ld) between "
+			     "actual argument and pointer or allocatable "
+			     "dummy argument %qs at %L", actual_len, formal_len,
+			     f->sym->name, &a->expr->where);
+	      else
+		gfc_error ("Character length mismatch (%ld/%ld) between "
+			   "actual argument and pointer or allocatable "
+			   "dummy argument %qs at %L", actual_len, formal_len,
+			   f->sym->name, &a->expr->where);
+	    }
 	  else if (where)
-	    gfc_warning (0, "Character length mismatch (%ld/%ld) between actual "
-			 "argument and assumed-shape dummy argument %qs "
-			 "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);
+	    {
+	      /* Emit a warning for -std=legacy and an error otherwise. */
+	      if (gfc_option.warn_std == 0)
+		gfc_warning (0, "Character length mismatch (%ld/%ld) between "
+			     "actual argument and assumed-shape dummy argument "
+			     "%qs at %L", actual_len, formal_len,
+			     f->sym->name, &a->expr->where);
+	      else
+		gfc_error ("Character length mismatch (%ld/%ld) between "
+			   "actual argument and assumed-shape dummy argument "
+			   "%qs at %L", actual_len, formal_len,
+			   f->sym->name, &a->expr->where);
+
+	    }
 	  ok = false;
 	  goto match;
 	}
@@ -3622,21 +3659,74 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
       if (a->expr->expr_type == EXPR_NULL && a->expr->ts.type == BT_UNKNOWN)
 	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
+      actual_size = get_expr_storage_size (a->expr, &actual_size_known);
+      formal_size = get_sym_storage_size (f->sym, &formal_size_known);
+
+      if (actual_size_known && formal_size_known
+	  && actual_size != formal_size
+	  && a->expr->ts.type == BT_CHARACTER
 	  && f->sym->attr.flavor != FL_PROCEDURE)
 	{
-	  if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
+	  /* F2018:15.5.2.4:
+	     (3) "The length type parameter values of a present actual argument
+	     shall agree with the corresponding ones of the dummy argument that
+	     are not assumed, except for the case of the character length
+	     parameter of an actual argument of type character with default
+	     kind or C character kind associated with a dummy argument that is
+	     not assumed-shape or assumed-rank."
+
+	     (4) "If a present scalar dummy argument is of type character with
+	     default kind or C character kind, the length len of the dummy
+	     argument shall be less than or equal to the length of the actual
+	     argument.  The dummy argument becomes associated with the leftmost
+	     len characters of the actual argument.  If a present array dummy
+	     argument is of type character with default kind or C character
+	     kind and is not assumed-shape or assumed-rank, it becomes
+	     associated with the leftmost characters of the actual argument
+	     element sequence."
+
+	     As an extension we treat kind=4 character similarly to kind=1.  */
+
+	  if (actual_size > formal_size)
 	    {
-	      gfc_warning (0, "Character length of actual argument shorter "
-			   "than of dummy argument %qs (%lu/%lu) at %L",
-			   f->sym->name, actual_size, formal_size,
-			   &a->expr->where);
+	      if (a->expr->ts.type == BT_CHARACTER && where
+		  && (!f->sym->as || f->sym->as->type == AS_EXPLICIT))
+		gfc_warning (OPT_Wcharacter_truncation,
+			     "Character length of actual argument longer "
+			     "than of dummy argument %qs (%lu/%lu) at %L",
+			     f->sym->name, actual_size, formal_size,
+			     &a->expr->where);
 	      goto skip_size_check;
 	    }
-          else if (where)
+
+	  if (a->expr->ts.type == BT_CHARACTER && where && !f->sym->as)
+	    {
+	      /* Emit warning for -std=legacy/gnu and an error otherwise. */
+	      if (gfc_notification_std (GFC_STD_LEGACY) == ERROR)
+		{
+		  gfc_error ("Character length of actual argument shorter "
+			     "than of dummy argument %qs (%lu/%lu) at %L",
+			     f->sym->name, actual_size, formal_size,
+			     &a->expr->where);
+		  ok = false;
+		  goto match;
+		}
+	      else
+		gfc_warning (0, "Character length of actual argument shorter "
+			     "than of dummy argument %qs (%lu/%lu) at %L",
+			     f->sym->name, actual_size, formal_size,
+			     &a->expr->where);
+	      goto skip_size_check;
+	    }
+	}
+
+      if (actual_size_known && formal_size_known
+	  && actual_size < formal_size
+	  && f->sym->as
+	  && a->expr->ts.type != BT_PROCEDURE
+	  && f->sym->attr.flavor != FL_PROCEDURE)
+	{
+	  if (where)
 	    {
 	      /* Emit a warning for -std=legacy and an error otherwise. */
 	      if (gfc_option.warn_std == 0)
diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc
index 9e07627..a422fc1 100644
--- a/gcc/fortran/intrinsic.cc
+++ b/gcc/fortran/intrinsic.cc
@@ -3933,13 +3933,22 @@ add_subroutines (void)
 	      pt, BT_INTEGER, di, OPTIONAL, INTENT_IN,
 	      gt, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
 
+  add_sym_4s ("split", GFC_ISYM_SPLIT, CLASS_PURE,
+	      BT_UNKNOWN, 0, GFC_STD_F2023,
+	      gfc_check_split, NULL, gfc_resolve_split,
+	      "string", BT_CHARACTER, dc, REQUIRED, INTENT_IN,
+	      "set", BT_CHARACTER, dc, REQUIRED, INTENT_IN,
+	      "pos", BT_INTEGER, di, REQUIRED, INTENT_INOUT,
+	      "back", BT_LOGICAL, dl, OPTIONAL, INTENT_IN);
+
   /* 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,
+  add_sym_4s ("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);
+	      "shape", BT_INTEGER, di, OPTIONAL, INTENT_IN,
+	      "lower", BT_INTEGER, di, OPTIONAL, INTENT_IN);
   make_from_module();
 
   add_sym_2s ("c_f_procpointer", GFC_ISYM_C_F_PROCPOINTER, CLASS_IMPURE,
@@ -5457,6 +5466,9 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag,
   if (ts->type == BT_UNKNOWN)
     goto bad;
 
+  if (from_ts.type == BT_DERIVED && from_ts.u.derived->attr.pdt_type)
+    *ts = from_ts;
+
   expr->do_not_warn = ! wflag;
 
   /* NULL and zero size arrays get their type here, unless they already have a
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index fd54588..048196d 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -165,7 +165,7 @@ 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_pointer (gfc_expr *, 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 *);
@@ -215,6 +215,7 @@ bool gfc_check_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
 bool gfc_check_random_init (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_split (gfc_expr *, 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 *);
@@ -693,6 +694,7 @@ 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_split (gfc_code *);
 void gfc_resolve_stat_sub (gfc_code *);
 void gfc_resolve_system_clock (gfc_code *);
 void gfc_resolve_system_sub (gfc_code *);
diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index 3103da3..6b9f4cd 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -313,6 +313,7 @@ Some basic guidelines for editing this document:
 * @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{SPLIT}:         SPLIT,     Parse a string into tokens, one at a time.
 * @code{SPREAD}:        SPREAD,    Add a dimension to an array 
 * @code{SQRT}:          SQRT,      Square-root function
 * @code{SRAND}:         SRAND,     Reinitialize the random number generator
@@ -3367,11 +3368,13 @@ Fortran 2003 and later
 
 @table @asis
 @item @emph{Synopsis}:
-@code{CALL C_F_POINTER(CPTR, FPTR[, SHAPE])}
+@code{CALL C_F_POINTER(CPTR, FPTR[, SHAPE, LOWER])}
 
 @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.
+@code{C_F_POINTER(CPTR, FPTR[, SHAPE, LOWER])} assigns the target of the C
+pointer @var{CPTR} to the Fortran pointer @var{FPTR} and specifies its shape.
+For an array @var{FPTR}, the lower bounds are specified by @var{LOWER} if
+present and otherwise equal to 1.
 
 @item @emph{Class}:
 Subroutine
@@ -3383,9 +3386,11 @@ Subroutine
 @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}.
+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}.
+@item @var{LOWER} @tab (Optional) Rank-one array of type @code{INTEGER}
+with @code{INTENT(IN)}. It shall not be present if @var{SHAPE} is not present.
+The size must be equal to the rank of @var{FPTR}.
 @end multitable
 
 @item @emph{Example}:
@@ -3407,7 +3412,7 @@ end program main
 @end smallexample
 
 @item @emph{Standard}:
-Fortran 2003 and later
+Fortran 2003 and later, with @var{LOWER} argument Fortran 2023 and later
 
 @item @emph{See also}:
 @ref{C_LOC}, @*
@@ -6809,7 +6814,6 @@ GNU extension
 @end table
 
 
-
 @node FRACTION
 @section @code{FRACTION} --- Fractional part of the model representation
 @fnindex FRACTION
@@ -6835,14 +6839,15 @@ Elemental function
 @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))}.
+it is @code{X * REAL(RADIX(X))**(-EXPONENT(X))}.
 
 @item @emph{Example}:
 @smallexample
 program test_fraction
+  implicit none
   real :: x
   x = 178.1387e-4
-  print *, fraction(x), x * radix(x)**(-exponent(x))
+  print *, fraction(x), x * real(radix(x))**(-exponent(x))
 end program test_fraction
 @end smallexample
 
@@ -14203,6 +14208,69 @@ Fortran 90 and later
 
 
 
+@node SPLIT
+@section @code{SPLIT} --- Parse a string into tokens, one at a time
+@fnindex SPLIT
+@cindex string, split
+
+@table @asis
+@item @emph{Synopsis}:
+@code{RESULT = SPLIT(STRING, SET, POS [, BACK])}
+
+@item @emph{Description}:
+Updates the integer @var{POS} to the position of the next (or previous)
+separator in @var{STRING}.
+
+If @var{BACK} is absent or is present with the value false, @var{POS} is
+assigned the position of the leftmost token delimiter in @var{STRING} whose
+position is greater than @var{POS}, or if there is no such character, it is
+assigned a value one greater than the length of @var{STRING}. This identifies
+a token with starting position one greater than the value of @var{POS} on
+invocation, and ending position one less than the value of @var{POS} on return.
+
+If @var{BACK} is present with the value true, @var{POS} is assigned the
+position of the rightmost token delimiter in @var{STRING} whose position is
+less than @var{POS}, or if there is no such character, it is assigned the value
+zero. This identifies a token with ending position one less than the value of
+@var{POS} on invocation, and starting position one greater than the value of
+@var{POS} on return.
+
+@item @emph{Class}:
+Subroutine
+
+@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{POS}    @tab Shall be of type @code{INTEGER}.
+@item @var{BACK}   @tab (Optional) Shall be of type @code{LOGICAL}.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+character(len=:), allocatable :: input
+character(len=2) :: set = ', '
+integer :: p
+input = "one,last example"
+p = 0
+do
+  if (p > len(input)) exit
+  istart = p + 1
+  call split(input, set, p)
+  iend = p - 1
+  print '(t7, a)', input(istart:iend)
+end do
+@end smallexample
+
+@item @emph{Standard}:
+Fortran 2023
+
+@item @emph{See also}:
+@ref{SCAN}
+@end table
+
+
+
 @node SPREAD
 @section @code{SPREAD} --- Add a dimension to an array
 @fnindex SPREAD
@@ -14875,54 +14943,6 @@ Fortran 77 and later, for a complex argument Fortran 2008 or later
 
 
 
-@node TEAM_NUMBER
-@section @code{TEAM_NUMBER} --- Retrieve team id of given team
-@fnindex TEAM_NUMBER
-@cindex coarray, @code{TEAM_NUMBER}
-@cindex teams, index of given team
-
-@table @asis
-@item @emph{Synopsis}:
-@item @code{RESULT = TEAM_NUMBER([TEAM])}
-
-@item @emph{Description}:
-Returns the team id for the given @var{TEAM} as assigned by @code{FORM TEAM}.
-If @var{TEAM} is absent, returns the team number of the current team.
-
-@item @emph{Class}:
-Transformational function
-
-@item @emph{Arguments}:
-@multitable @columnfractions .15 .70
-@item @var{TEAM} @tab (optional, intent(in)) The handle of the team for which
-the number, aka id, is desired.
-@end multitable
-
-@item @emph{Return value}:
-Default integer.  The id as given in a call @code{FORM TEAM}. Applying
-@code{TEAM_NUMBER} to the initial team will result in @code{-1} to be returned.
-Returns the id of the current team, if @var{TEAM} is null.
-
-@item @emph{Example}:
-@smallexample
-use, intrinsic :: iso_fortran_env
-type(team_type) :: t
-
-print *, team_number() ! -1
-form team (99, t)
-print *, team_number(t) ! 99
-@end smallexample
-
-@item @emph{Standard}:
-Fortran 2018 and later.
-
-@item @emph{See also}:
-@ref{GET_TEAM}, @*
-@ref{TEAM_NUMBER}
-@end table
-
-
-
 @node TANPI
 @section @code{TANPI} --- Circular tangent function
 @fnindex TANPI
@@ -14972,6 +14992,54 @@ end program test_tanpi
 
 
 
+@node TEAM_NUMBER
+@section @code{TEAM_NUMBER} --- Retrieve team id of given team
+@fnindex TEAM_NUMBER
+@cindex coarray, @code{TEAM_NUMBER}
+@cindex teams, index of given team
+
+@table @asis
+@item @emph{Synopsis}:
+@item @code{RESULT = TEAM_NUMBER([TEAM])}
+
+@item @emph{Description}:
+Returns the team id for the given @var{TEAM} as assigned by @code{FORM TEAM}.
+If @var{TEAM} is absent, returns the team number of the current team.
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{TEAM} @tab (optional, intent(in)) The handle of the team for which
+the number, aka id, is desired.
+@end multitable
+
+@item @emph{Return value}:
+Default integer.  The id as given in a call @code{FORM TEAM}. Applying
+@code{TEAM_NUMBER} to the initial team will result in @code{-1} to be returned.
+Returns the id of the current team, if @var{TEAM} is null.
+
+@item @emph{Example}:
+@smallexample
+use, intrinsic :: iso_fortran_env
+type(team_type) :: t
+
+print *, team_number() ! -1
+form team (99, t)
+print *, team_number(t) ! 99
+@end smallexample
+
+@item @emph{Standard}:
+Fortran 2018 and later.
+
+@item @emph{See also}:
+@ref{GET_TEAM}, @*
+@ref{TEAM_NUMBER}
+@end table
+
+
+
 @node THIS_IMAGE
 @section @code{THIS_IMAGE} --- Function that returns the cosubscript index of this image
 @fnindex THIS_IMAGE
diff --git a/gcc/fortran/io.cc b/gcc/fortran/io.cc
index 4d28c2c..45cac5e 100644
--- a/gcc/fortran/io.cc
+++ b/gcc/fortran/io.cc
@@ -1129,13 +1129,16 @@ data_desc:
       break;
 
     case FMT_H:
-      if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
+      if (!(gfc_option.allow_std & GFC_STD_LEGACY))
 	{
-	  if (mode != MODE_FORMAT)
-	    format_locus.nextc += format_string_pos;
-	  gfc_warning (0, "The H format specifier at %L is"
-		       " a Fortran 95 deleted feature", &format_locus);
+	  error = G_("The H format specifier at %L is a Fortran 95 deleted"
+		     " feature");
+	  goto syntax;
 	}
+      if (mode != MODE_FORMAT)
+	format_locus.nextc += format_string_pos;
+      gfc_warning (0, "The H format specifier at %L is"
+		   " a Fortran 95 deleted feature", &format_locus);
       if (mode == MODE_STRING)
 	{
 	  format_string += value;
@@ -1144,7 +1147,7 @@ data_desc:
 	}
       else
 	{
-	  while (repeat >0)
+	  while (repeat > 0)
 	   {
 	     next_char (INSTRING_WARN);
 	     repeat -- ;
diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc
index 1001309..da354ab 100644
--- a/gcc/fortran/iresolve.cc
+++ b/gcc/fortran/iresolve.cc
@@ -3863,6 +3863,19 @@ gfc_resolve_sleep_sub (gfc_code *c)
   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
 }
 
+void
+gfc_resolve_split (gfc_code *c)
+{
+  const char *name;
+  gfc_expr *string;
+
+  string = c->ext.actual->expr;
+  if (string->ts.type == BT_CHARACTER && string->ts.kind == 4)
+    name = "__split_char4";
+  else
+    name = "__split";
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
 
 /* G77 compatibility function srand().  */
 
diff --git a/gcc/fortran/module.cc b/gcc/fortran/module.cc
index 070b316..e05b08b 100644
--- a/gcc/fortran/module.cc
+++ b/gcc/fortran/module.cc
@@ -7277,10 +7277,13 @@ create_int_parameter_array (const char *name, int size, gfc_expr *value,
   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
   if (tmp_symtree != NULL)
     {
-      if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
+      if (tmp_symtree->n.sym->module &&
+	  strcmp (modname, tmp_symtree->n.sym->module) == 0)
 	return;
       else
-	gfc_error ("Symbol %qs already declared", name);
+	gfc_error ("Symbol %qs already declared at %L conflicts with "
+		   "symbol in %qs at %C", name,
+		   &tmp_symtree->n.sym->declared_at, modname);
     }
 
   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc
index f1acc00..9e282c7 100644
--- a/gcc/fortran/openmp.cc
+++ b/gcc/fortran/openmp.cc
@@ -6982,13 +6982,9 @@ gfc_match_omp_declare_variant (void)
       return MATCH_ERROR;
     }
 
-  if ((has_adjust_args || has_append_args) && !has_match)
+  if (!has_match)
     {
-      gfc_error ("the %qs clause at %L can only be specified if the "
-		 "%<dispatch%> selector of the construct selector set appears "
-		 "in the %<match%> clause",
-		 has_adjust_args ? "adjust_args" : "append_args",
-		 has_adjust_args ?  &adjust_args_loc : &append_args_loc);
+      gfc_error ("expected %<match%> clause at %C");
       return MATCH_ERROR;
     }
 
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index 847ff37..b29f690 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -242,6 +242,7 @@ decode_specification_statement (void)
       break;
 
     case 'g':
+      match ("generic", gfc_match_generic, ST_GENERIC);
       break;
 
     case 'i':
@@ -3937,6 +3938,7 @@ parse_derived (void)
   gfc_state_data s;
   gfc_symbol *sym;
   gfc_component *c, *lock_comp = NULL, *event_comp = NULL;
+  bool pdt_parameters;
 
   accept_statement (ST_DERIVED_DECL);
   push_state (&s, COMP_DERIVED, gfc_new_block);
@@ -3945,9 +3947,11 @@ parse_derived (void)
   seen_private = 0;
   seen_sequence = 0;
   seen_component = 0;
+  pdt_parameters = false;
 
   compiling_type = 1;
 
+
   while (compiling_type)
     {
       st = next_statement ();
@@ -3960,6 +3964,31 @@ parse_derived (void)
 	case ST_PROCEDURE:
 	  accept_statement (st);
 	  seen_component = 1;
+	  /* Type parameters must not have an explicit access specification
+	     and must be placed before a PRIVATE statement. If a PRIVATE
+	     statement is encountered after type parameters, mark the remaining
+	     components as PRIVATE. */
+	  for (c = gfc_current_block ()->components; c; c = c->next)
+	    if (!c->next && (c->attr.pdt_kind || c->attr.pdt_len))
+	      {
+		pdt_parameters = true;
+		if (c->attr.access != ACCESS_UNKNOWN)
+		  {
+		    gfc_error ("Access specification of a type parameter at "
+			       "%C is not allowed");
+		    c->attr.access = ACCESS_PUBLIC;
+		    break;
+		  }
+		if (seen_private)
+		  {
+		    gfc_error ("The type parameter at %C must come before a "
+			       "PRIVATE statement");
+		    break;
+		  }
+	      }
+	    else if (pdt_parameters && seen_private
+		     && !(c->attr.pdt_kind || c->attr.pdt_len))
+	      c->attr.access = ACCESS_PRIVATE;
 	  break;
 
 	case ST_FINAL:
@@ -3985,7 +4014,7 @@ endType:
 	      break;
 	    }
 
-	  if (seen_component)
+	  if (seen_component && !pdt_parameters)
 	    {
 	      gfc_error ("PRIVATE statement at %C must precede "
 			 "structure components");
@@ -3995,7 +4024,10 @@ endType:
 	  if (seen_private)
 	    gfc_error ("Duplicate PRIVATE statement at %C");
 
-	  s.sym->component_access = ACCESS_PRIVATE;
+	  if (pdt_parameters)
+	    s.sym->component_access = ACCESS_PUBLIC;
+	  else
+	    s.sym->component_access = ACCESS_PRIVATE;
 
 	  accept_statement (ST_PRIVATE);
 	  seen_private = 1;
@@ -4534,6 +4566,11 @@ declSt:
       st = next_statement ();
       goto loop;
 
+    case ST_GENERIC:
+      accept_statement (st);
+      st = next_statement ();
+      goto loop;
+
     case ST_ENUM:
       accept_statement (st);
       parse_enum();
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index f0e1fef..6df9555 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -4055,6 +4055,67 @@ gfc_match_rvalue (gfc_expr **result)
 	  break;
 	}
 
+      /* Check to see if this is a PDT constructor.  The format of these
+	 constructors is rather unusual:
+		name (type_params)(component_values)
+	 where, component_values excludes the type_params. With the present
+	 gfortran representation this is rather awkward because the two are not
+	 distinguished, other than by their attributes.  */
+      if (sym->attr.generic)
+	{
+	  gfc_symtree *pdt_st;
+	  gfc_symbol *pdt_sym;
+	  gfc_actual_arglist *ctr_arglist, *tmp;
+	  gfc_component *c;
+
+	  /* Obtain the template.  */
+	  gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &pdt_st);
+	  if (pdt_st && pdt_st->n.sym && pdt_st->n.sym->attr.pdt_template)
+	    {
+	      pdt_sym = pdt_st->n.sym;
+
+	      /* Generate this instance using the type parameters from the
+		 first argument list and return the parameter list in
+		 ctr_arglist.  */
+	      m = gfc_get_pdt_instance (actual_arglist, &pdt_sym, &ctr_arglist);
+	      if (m != MATCH_YES)
+		{
+		  m = MATCH_ERROR;
+		  break;
+		}
+	      /* Now match the component_values.  */
+	      m = gfc_match_actual_arglist (0, &actual_arglist);
+	      if (m != MATCH_YES)
+		{
+		  m = MATCH_ERROR;
+		  break;
+		}
+
+	      /* Make sure that the component names are in place so that this
+		 list can be safely appended to the type parameters.  */
+	      tmp = actual_arglist;
+	      for (c = pdt_sym->components; c && tmp; c = c->next)
+		{
+		  if (c->attr.pdt_kind || c->attr.pdt_len)
+		    continue;
+		  tmp->name = c->name;
+		  tmp = tmp->next;
+		}
+
+	      gfc_get_ha_sym_tree (gfc_dt_lower_string (pdt_sym->name) ,
+				   &symtree);
+	      symtree->n.sym = pdt_sym;
+	      symtree->n.sym->ts.u.derived = pdt_sym;
+	      symtree->n.sym->ts.type = BT_DERIVED;
+
+	      /* Do the appending.  */
+	      for (tmp = ctr_arglist; tmp && tmp->next;)
+		tmp = tmp->next;
+	      tmp->next = actual_arglist;
+	      actual_arglist = ctr_arglist;
+	    }
+	}
+
       gfc_get_ha_sym_tree (name, &symtree);	/* Can't fail */
       sym = symtree->n.sym;
 
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index c33bd17..d51301a 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -1630,7 +1630,7 @@ was_declared (gfc_symbol *sym)
   if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
       || a.optional || a.pointer || a.save || a.target || a.volatile_
       || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
-      || a.asynchronous || a.codimension)
+      || a.asynchronous || a.codimension || a.subroutine)
     return 1;
 
   return 0;
@@ -5880,6 +5880,7 @@ gfc_resolve_ref (gfc_expr *expr)
   int current_part_dimension, n_components, seen_part_dimension, dim;
   gfc_ref *ref, **prev, *array_ref;
   bool equal_length;
+  gfc_symbol *last_pdt = NULL;
 
   for (ref = expr->ref; ref; ref = ref->next)
     if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
@@ -5927,6 +5928,11 @@ gfc_resolve_ref (gfc_expr *expr)
   n_components = 0;
   array_ref = NULL;
 
+  if (expr->expr_type == EXPR_VARIABLE
+      && expr->symtree->n.sym->ts.type == BT_DERIVED
+      && expr->symtree->n.sym->ts.u.derived->attr.pdt_type)
+    last_pdt = expr->symtree->n.sym->ts.u.derived;
+
   for (ref = expr->ref; ref; ref = ref->next)
     {
       switch (ref->type)
@@ -5984,6 +5990,38 @@ gfc_resolve_ref (gfc_expr *expr)
 		}
 	    }
 
+	  /* Sometimes the component in a component reference is that of the
+	     pdt_template. Point to the component of pdt_type instead. This
+	     ensures that the component gets a backend_decl in translation.  */
+	  if (last_pdt)
+	    {
+	      gfc_component *cmp = last_pdt->components;
+	      for (; cmp; cmp = cmp->next)
+		if (!strcmp (cmp->name, ref->u.c.component->name))
+		  {
+		    ref->u.c.component = cmp;
+		    break;
+		  }
+	      ref->u.c.sym = last_pdt;
+	    }
+
+	  /* Convert pdt_templates, if necessary, and update 'last_pdt'.  */
+	  if (ref->u.c.component->ts.type == BT_DERIVED)
+	    {
+	      if (ref->u.c.component->ts.u.derived->attr.pdt_template)
+		{
+		  if (gfc_get_pdt_instance (ref->u.c.component->param_list,
+					    &ref->u.c.component->ts.u.derived,
+					    NULL) != MATCH_YES)
+		    return false;
+		  last_pdt = ref->u.c.component->ts.u.derived;
+		}
+	      else if (ref->u.c.component->ts.u.derived->attr.pdt_type)
+		last_pdt = ref->u.c.component->ts.u.derived;
+	      else
+		last_pdt = NULL;
+	    }
+
 	  n_components++;
 	  break;
 
@@ -15604,6 +15642,31 @@ error:
 }
 
 
+static gfc_symbol * containing_dt;
+
+/* Helper function for check_generic_tbp_ambiguity, which ensures that passed
+   arguments whose declared types are PDT instances only transmit the PASS arg
+   if they match the enclosing derived type.  */
+
+static bool
+check_pdt_args (gfc_tbp_generic* t, const char *pass)
+{
+  gfc_formal_arglist *dummy_args;
+  if (pass && containing_dt != NULL && containing_dt->attr.pdt_type)
+    {
+      dummy_args = gfc_sym_get_dummy_args (t->specific->u.specific->n.sym);
+      while (dummy_args && strcmp (pass, dummy_args->sym->name))
+	dummy_args = dummy_args->next;
+      gcc_assert (strcmp (pass, dummy_args->sym->name) == 0);
+      if (dummy_args->sym->ts.type == BT_CLASS
+	  && strcmp (CLASS_DATA (dummy_args->sym)->ts.u.derived->name,
+		     containing_dt->name))
+	return true;
+    }
+  return false;
+}
+
+
 /* Check if two GENERIC targets are ambiguous and emit an error is they are.  */
 
 static bool
@@ -15661,6 +15724,17 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
 	pass2 = NULL;
     }
 
+  /* Care must be taken with pdt types and templates because the declared type
+     of the argument that is not 'no_pass' need not be the same as the
+     containing derived type.  If this is the case, subject the argument to
+     the full interface check, even though it cannot be used in the type
+     bound context.  */
+  pass1 = check_pdt_args (t1, pass1) ? NULL : pass1;
+  pass2 = check_pdt_args (t2, pass2) ? NULL : pass2;
+
+  if (containing_dt != NULL && containing_dt->attr.pdt_template)
+    pass1 = pass2 = NULL;
+
   /* Compare the interfaces.  */
   if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0,
 			      NULL, 0, pass1, pass2))
@@ -16108,8 +16182,10 @@ resolve_typebound_procedure (gfc_symtree* stree)
 	  goto error;
 	}
 
-      /* The derived type is not a PDT template.  Resolve as usual.  */
+      /* The derived type is not a PDT template or type.  Resolve as usual.  */
       if (!resolve_bindings_derived->attr.pdt_template
+	  && !(containing_dt && containing_dt->attr.pdt_type
+	       && CLASS_DATA (me_arg)->ts.u.derived != containing_dt)
 	  && (CLASS_DATA (me_arg)->ts.u.derived != resolve_bindings_derived))
 	{
 	  gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of "
@@ -16256,6 +16332,7 @@ resolve_typebound_procedures (gfc_symbol* derived)
   resolve_bindings_derived = derived;
   resolve_bindings_result = true;
 
+  containing_dt = derived;  /* Needed for checks of PDTs.  */
   if (derived->f2k_derived->tb_sym_root)
     gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
 			  &resolve_typebound_procedure);
@@ -16263,6 +16340,7 @@ resolve_typebound_procedures (gfc_symbol* derived)
   if (derived->f2k_derived->tb_uop_root)
     gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
 			  &resolve_typebound_user_op);
+  containing_dt = NULL;
 
   for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
     {
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index b25cd2c..00b02f3 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -120,10 +120,26 @@ static int
 get_kind (bt type, gfc_expr *k, const char *name, int default_kind)
 {
   int kind;
+  gfc_expr *tmp;
 
   if (k == NULL)
     return default_kind;
 
+  if (k->expr_type == EXPR_VARIABLE
+      && k->symtree->n.sym->ts.type == BT_DERIVED
+      && k->symtree->n.sym->ts.u.derived->attr.pdt_type)
+    {
+      gfc_ref *ref;
+      for (ref = k->ref; ref; ref = ref->next)
+	if (!ref->next && ref->type == REF_COMPONENT
+	    && ref->u.c.component->attr.pdt_kind
+	    && ref->u.c.component->initializer)
+	  {
+	    tmp = gfc_copy_expr (ref->u.c.component->initializer);
+	    gfc_replace_expr (k, tmp);
+	  }
+    }
+
   if (k->expr_type != EXPR_CONSTANT)
     {
       gfc_error ("KIND parameter of %s at %L must be an initialization "
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 6b759d1..0449c26 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -284,16 +284,6 @@ gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree 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 = gfc_get_descriptor_field (desc, DATA_FIELD);
-  return gfc_build_addr_expr (NULL_TREE, field);
-}
-
 static tree
 gfc_conv_descriptor_offset (tree desc)
 {
@@ -1426,12 +1416,6 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype,
 	  tmp2 = gfc_class_len_get (class_expr);
 	  gfc_add_modify (pre, tmp, tmp2);
 	}
-
-      if (rhs_function)
-	{
-	  tmp = gfc_class_data_get (class_expr);
-	  gfc_conv_descriptor_offset_set (pre, tmp, gfc_index_zero_node);
-	}
     }
   else if (rhs_ss->info->data.array.descriptor)
    {
@@ -3121,7 +3105,6 @@ trans_array_constructor (gfc_ss * ss, locus * where)
 			     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 && VAR_P (*loop_ubound0))
 	gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp);
       else
@@ -3372,18 +3355,51 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
 	  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;
-	  if (gfc_is_class_array_function (expr))
-	    expr->must_finalize = 1;
-	  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);
-	  gfc_add_block_to_block (&outer_loop->post, &se.finalblock);
-	  ss_info->string_length = se.string_length;
+	  {
+	    /* 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;
+	    bool class_func = gfc_is_class_array_function (expr);
+	    if (class_func)
+	      expr->must_finalize = 1;
+	    gfc_conv_expr (&se, expr);
+	    gfc_add_block_to_block (&outer_loop->pre, &se.pre);
+	    if (class_func
+		&& se.expr
+		&& GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)))
+	      {
+		tree tmp = gfc_class_data_get (se.expr);
+		info->descriptor = tmp;
+		info->data = gfc_conv_descriptor_data_get (tmp);
+		info->offset = gfc_conv_descriptor_offset_get (tmp);
+		for (gfc_ss *s = ss; s; s = s->parent)
+		  for (int n = 0; n < s->dimen; n++)
+		    {
+		      int dim = s->dim[n];
+		      tree tree_dim = gfc_rank_cst[dim];
+
+		      tree start;
+		      start = gfc_conv_descriptor_lbound_get (tmp, tree_dim);
+		      start = gfc_evaluate_now (start, &outer_loop->pre);
+		      info->start[dim] = start;
+
+		      tree end;
+		      end = gfc_conv_descriptor_ubound_get (tmp, tree_dim);
+		      end = gfc_evaluate_now (end, &outer_loop->pre);
+		      info->end[dim] = end;
+
+		      tree stride;
+		      stride = gfc_conv_descriptor_stride_get (tmp, tree_dim);
+		      stride = gfc_evaluate_now (stride, &outer_loop->pre);
+		      info->stride[dim] = stride;
+		    }
+	      }
+	    gfc_add_block_to_block (&outer_loop->post, &se.post);
+	    gfc_add_block_to_block (&outer_loop->post, &se.finalblock);
+	    ss_info->string_length = se.string_length;
+	  }
 	  break;
 
 	case GFC_SS_CONSTRUCTOR:
@@ -5383,7 +5399,8 @@ done:
 	      int dim = ss->dim[n];
 
 	      info->start[dim]  = gfc_index_zero_node;
-	      info->end[dim]    = gfc_index_zero_node;
+	      if (ss_info->type != GFC_SS_FUNCTION)
+		info->end[dim]    = gfc_index_zero_node;
 	      info->stride[dim] = gfc_index_one_node;
 	    }
 	  break;
@@ -6068,6 +6085,46 @@ set_loop_bounds (gfc_loopinfo *loop)
 }
 
 
+/* Last attempt to set the loop bounds, in case they depend on an allocatable
+   function result.  */
+
+static void
+late_set_loop_bounds (gfc_loopinfo *loop)
+{
+  int n, dim;
+  gfc_array_info *info;
+  gfc_ss **loopspec;
+
+  loopspec = loop->specloop;
+
+  for (n = 0; n < loop->dimen; n++)
+    {
+      /* Set the extents of this range.  */
+      if (loop->from[n] == NULL_TREE
+	  || loop->to[n] == NULL_TREE)
+	{
+	  /* 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];
+
+	  if (loopspec[n]->info->type == GFC_SS_FUNCTION
+	      && info->start[dim]
+	      && info->end[dim])
+	    {
+	      loop->from[n] = info->start[dim];
+	      loop->to[n] = info->end[dim];
+	    }
+	}
+    }
+
+  for (loop = loop->nested; loop; loop = loop->next)
+    late_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
@@ -6086,6 +6143,8 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
      allocating the temporary.  */
   gfc_add_loop_ss_code (loop, loop->ss, false, where);
 
+  late_set_loop_bounds (loop);
+
   tmp_ss = loop->temp_ss;
   /* If we want a temporary then create it.  */
   if (tmp_ss != NULL)
@@ -6142,9 +6201,11 @@ gfc_set_delta (gfc_loopinfo *loop)
       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)
+      if (!(ss_type == GFC_SS_SECTION
+	    || ss_type == GFC_SS_COMPONENT
+	    || ss_type == GFC_SS_CONSTRUCTOR
+	    || (ss_type == GFC_SS_FUNCTION
+		&& gfc_is_class_array_function (ss->info->expr))))
 	continue;
 
       info = &ss->info->data.array;
@@ -6296,8 +6357,8 @@ static tree
 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 		     gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
 		     stmtblock_t * descriptor_block, tree * overflow,
-		     tree expr3_elem_size, tree *nelems, gfc_expr *expr3,
-		     tree expr3_desc, bool e3_has_nodescriptor, gfc_expr *expr,
+		     tree expr3_elem_size, gfc_expr *expr3, tree expr3_desc,
+		     bool e3_has_nodescriptor, gfc_expr *expr,
 		     tree *element_size, bool explicit_ts)
 {
   tree type;
@@ -6573,7 +6634,6 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
   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
@@ -6662,9 +6722,8 @@ retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in)
 bool
 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
 		    tree errlen, tree label_finish, tree expr3_elem_size,
-		    tree *nelems, gfc_expr *expr3, tree e3_arr_desc,
-		    bool e3_has_nodescriptor, gfc_omp_namelist *omp_alloc,
-		    bool explicit_ts)
+		    gfc_expr *expr3, tree e3_arr_desc, bool e3_has_nodescriptor,
+		    gfc_omp_namelist *omp_alloc, bool explicit_ts)
 {
   tree tmp;
   tree pointer;
@@ -6795,7 +6854,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
 			      coarray ? ref->u.ar.as->corank : 0,
 			      &offset, lower, upper,
 			      &se->pre, &set_descriptor_block, &overflow,
-			      expr3_elem_size, nelems, expr3, e3_arr_desc,
+			      expr3_elem_size, expr3, e3_arr_desc,
 			      e3_has_nodescriptor, expr, &element_size,
 			      explicit_ts);
 
@@ -8439,14 +8498,6 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 	  else
 	    gcc_assert (se->ss == ss);
 
-	  if (!is_pointer_array (se->expr))
-	    {
-	      tmp = gfc_get_element_type (TREE_TYPE (se->expr));
-	      tmp = fold_convert (gfc_array_index_type,
-				  size_in_bytes (tmp));
-	      gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
-	    }
-
 	  se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
 	  gfc_conv_expr (se, expr);
 
@@ -9518,9 +9569,8 @@ gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77,
 	      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);
+	      old_field = gfc_conv_descriptor_offset_get (old_desc);
+	      gfc_conv_descriptor_offset_set (&se->pre, new_desc, old_field);
 
 	      for (int i = 0; i < expr->rank; i++)
 		{
@@ -10660,6 +10710,15 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
 				  cdecl, NULL_TREE);
 	  dcmp = fold_convert (TREE_TYPE (comp), dcmp);
 
+	  if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pdt_type
+	      && !c->attr.allocatable)
+	    {
+	      tmp = gfc_copy_alloc_comp (c->ts.u.derived, comp, dcmp,
+					 0, 0);
+	      gfc_add_expr_to_block (&fnblock, tmp);
+	      continue;
+	    }
+
 	  if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
 	    {
 	      tree ftn_tree;
@@ -10779,7 +10838,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
 					   false, false, size, NULL_TREE);
 	      gfc_add_expr_to_block (&fnblock, tmp);
 	    }
-	  else if (c->attr.pdt_array)
+	  else if (c->attr.pdt_array
+		   && !c->attr.allocatable && !c->attr.pointer)
 	    {
 	      tmp = duplicate_allocatable (dcmp, comp, ctype,
 					   c->as ? c->as->rank : 0,
@@ -10846,6 +10906,16 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
 		  gfc_add_modify (&fnblock, comp, tse.expr);
 		}
 	    }
+	  else if (c->initializer && !c->attr.pdt_string && !c->attr.pdt_array
+		   && !c->as && !(c->ts.type == BT_DERIVED
+				  && c->ts.u.derived->attr.pdt_type))   /* Take care of arrays.  */
+	    {
+	      gfc_se tse;
+	      gfc_expr *c_expr;
+	      c_expr = c->initializer;
+	      gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
+	      gfc_add_modify (&fnblock, comp, tse.expr);
+	    }
 
 	  if (c->attr.pdt_string)
 	    {
@@ -11690,8 +11760,8 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
 					  gfc_index_zero_node);
 	}
 
-      tmp = gfc_conv_descriptor_offset (desc);
-      gfc_add_modify (&loop_pre_block, tmp, gfc_index_zero_node);
+      gfc_conv_descriptor_offset_set (&loop_pre_block, desc,
+				      gfc_index_zero_node);
 
       tmp = fold_build2_loc (input_location, EQ_EXPR,
 			     logical_type_node, array1,
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 1bb3294..345a975 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -20,9 +20,8 @@ along with GCC; see the file COPYING3.  If not see
 
 /* Generate code to initialize and allocate an array.  Statements are added to
    se, which should contain an expression for the array descriptor.  */
-bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree,
-			 tree, tree *, gfc_expr *, tree, bool,
-			 gfc_omp_namelist *, bool);
+bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree, tree,
+			 gfc_expr *, tree, bool, gfc_omp_namelist *, bool);
 
 /* Allow the bounds of a loop to be set from a callee's array spec.  */
 void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *,
@@ -174,7 +173,6 @@ void gfc_get_descriptor_offsets_for_info (const_tree, tree *, tree *, tree *, tr
 					  tree *, tree *, tree *, tree *);
 
 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_span_get (tree);
 tree gfc_conv_descriptor_dtype (tree);
diff --git a/gcc/fortran/trans-common.cc b/gcc/fortran/trans-common.cc
index 2db50da..135d304 100644
--- a/gcc/fortran/trans-common.cc
+++ b/gcc/fortran/trans-common.cc
@@ -469,9 +469,6 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
 
       gfc_set_decl_location (decl, &com->where);
 
-      if (com->threadprivate)
-	set_decl_tls_model (decl, decl_default_tls_model (decl));
-
       if (com->omp_device_type != OMP_DEVICE_TYPE_UNSET)
 	{
 	  tree c = build_omp_clause (UNKNOWN_LOCATION, OMP_CLAUSE_DEVICE_TYPE);
@@ -536,6 +533,10 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
       DECL_COMMON (decl) = 0;
       DECL_DEFER_OUTPUT (decl) = 0;
     }
+
+  if (com->threadprivate)
+    set_decl_tls_model (decl, decl_default_tls_model (decl));
+
   return decl;
 }
 
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index d5acdca..b077cee 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -197,6 +197,7 @@ tree gfor_fndecl_string_scan;
 tree gfor_fndecl_string_verify;
 tree gfor_fndecl_string_trim;
 tree gfor_fndecl_string_minmax;
+tree gfor_fndecl_string_split;
 tree gfor_fndecl_adjustl;
 tree gfor_fndecl_adjustr;
 tree gfor_fndecl_select_string;
@@ -208,6 +209,7 @@ 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_string_split_char4;
 tree gfor_fndecl_adjustl_char4;
 tree gfor_fndecl_adjustr_char4;
 tree gfor_fndecl_select_string_char4;
@@ -821,11 +823,6 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
         }
     }
 
-  /* Handle threadprivate variables.  */
-  if (sym->attr.threadprivate
-      && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
-    set_decl_tls_model (decl, decl_default_tls_model (decl));
-
   if (sym->attr.omp_allocate && TREE_STATIC (decl))
     {
       struct gfc_omp_namelist *n;
@@ -844,6 +841,11 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
   if (sym->attr.ext_attr & (1 << EXT_ATTR_WEAK))
     declare_weak (decl);
 
+  /* Handle threadprivate variables.  */
+  if (sym->attr.threadprivate
+      && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
+    set_decl_tls_model (decl, decl_default_tls_model (decl));
+
   gfc_finish_decl_attrs (decl, &sym->attr);
 }
 
@@ -2216,13 +2218,13 @@ get_proc_pointer_decl (gfc_symbol *sym)
 						  false, true);
     }
 
+  add_attributes_to_decl (&decl, sym);
+
   /* Handle threadprivate procedure pointers.  */
   if (sym->attr.threadprivate
       && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
     set_decl_tls_model (decl, decl_default_tls_model (decl));
 
-  add_attributes_to_decl (&decl, sym);
-
   return decl;
 }
 
@@ -3569,6 +3571,12 @@ gfc_build_intrinsic_function_decls (void)
 	build_pointer_type (pchar1_type_node), integer_type_node,
 	integer_type_node);
 
+  gfor_fndecl_string_split = gfc_build_library_function_decl_with_spec (
+    get_identifier (PREFIX ("string_split")), ". . R . R . . ",
+    gfc_charlen_type_node, 6, gfc_charlen_type_node, pchar1_type_node,
+    gfc_charlen_type_node, pchar1_type_node, gfc_charlen_type_node,
+    gfc_logical4_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,
@@ -3641,6 +3649,12 @@ gfc_build_intrinsic_function_decls (void)
 	build_pointer_type (pchar4_type_node), integer_type_node,
 	integer_type_node);
 
+  gfor_fndecl_string_split_char4 = gfc_build_library_function_decl_with_spec (
+    get_identifier (PREFIX ("string_split_char4")), ". . R . R . . ",
+    gfc_charlen_type_node, 6, gfc_charlen_type_node, pchar4_type_node,
+    gfc_charlen_type_node, pchar4_type_node, gfc_charlen_type_node,
+    gfc_logical4_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,
@@ -4922,20 +4936,6 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	    }
 	}
 
-      if (sym->attr.pointer && sym->attr.dimension
-	  && sym->attr.save == SAVE_NONE
-	  && !sym->attr.use_assoc
-	  && !sym->attr.host_assoc
-	  && !sym->attr.dummy
-	  && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)))
-	{
-	  gfc_init_block (&tmpblock);
-	  gfc_conv_descriptor_span_set (&tmpblock, 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 || flag_max_stack_var_size == 0)
 	  && CLASS_DATA (sym)->attr.allocatable)
@@ -5134,18 +5134,31 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 		      se.descriptor_only = 1;
 		      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);
+		      se.expr = gfc_conv_descriptor_data_get (se.expr);
 		    }
 		  gfc_free_expr (e);
 
 		  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->ts.type == BT_CLASS
+			  && (CLASS_DATA (sym)->attr.dimension
+			      || CLASS_DATA (sym)->attr.codimension))
+			{
+			  stmtblock_t nullify;
+			  gfc_init_block (&nullify);
+			  gfc_conv_descriptor_data_set (&nullify, descriptor,
+							null_pointer_node);
+			  tmp = gfc_finish_block (&nullify);
+			}
+		      else
+			{
+			  tree typed_null = fold_convert (TREE_TYPE (se.expr),
+							  null_pointer_node);
+			  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+						 TREE_TYPE (se.expr), se.expr,
+						 typed_null);
+			}
 		      if (sym->attr.optional)
 			{
 			  tree present = gfc_conv_expr_present (sym);
@@ -5326,7 +5339,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	continue;
       /* 'omp allocate( {purpose: allocator, value: align},
 			{purpose: init-stmtlist, value: cleanup-stmtlist},
-			{purpose: size-var, value: last-size-expr}}
+			{purpose: size-var, value: last-size-expr} )
 	  where init-stmt/cleanup-stmt is the STATEMENT list to find the
 	  try-final block; last-size-expr is to find the location after
 	  which to add the code and 'size-var' is for the proper size, cf.
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 0db7ba3..97431d9 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -1168,7 +1168,6 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
       else
 	{
 	  parmse->ss = ss;
-	  parmse->use_offset = 1;
 	  gfc_conv_expr_descriptor (parmse, e);
 
 	  /* Array references with vector subscripts and non-variable expressions
@@ -5485,16 +5484,6 @@ gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
   /* Translate the expression.  */
   gfc_conv_expr (&rse, expr);
 
-  /* Reset the offset for the function call since the loop
-     is zero based on the data pointer.  Note that the temp
-     comes first in the loop chain since it is added second.  */
-  if (gfc_is_class_array_function (expr))
-    {
-      tmp = loop.ss->loop_chain->info->data.array.descriptor;
-      gfc_conv_descriptor_offset_set (&loop.pre, tmp,
-				      gfc_index_zero_node);
-    }
-
   gfc_conv_tmp_array_ref (&lse);
 
   if (intent != INTENT_OUT)
@@ -6521,6 +6510,20 @@ conv_cond_temp (gfc_se * parmse, gfc_expr * e, tree cond)
 }
 
 
+/* Returns true if the type specified in TS is a character type whose length
+   is constant.  Otherwise returns false.  */
+
+static bool
+gfc_const_length_character_type_p (gfc_typespec *ts)
+{
+  return (ts->type == BT_CHARACTER
+	  && ts->u.cl
+	  && ts->u.cl->length
+	  && ts->u.cl->length->expr_type == EXPR_CONSTANT
+	  && ts->u.cl->length->ts.type == BT_INTEGER);
+}
+
+
 /* Helper function for the handling of (currently) scalar dummy variables
    with the VALUE attribute.  Argument parmse should already be set up.  */
 static void
@@ -6531,6 +6534,20 @@ conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym,
 
   gcc_assert (fsym && fsym->attr.value && !fsym->attr.dimension);
 
+  if (e && e->ts.type == BT_DERIVED && e->ts.u.derived->attr.pdt_type)
+    {
+      tmp = gfc_create_var (TREE_TYPE (parmse->expr), "PDT");
+      gfc_add_modify (&parmse->pre, tmp, parmse->expr);
+      gfc_add_expr_to_block (&parmse->pre,
+			     gfc_copy_alloc_comp (e->ts.u.derived,
+						  parmse->expr, tmp,
+						  e->rank, 0));
+      parmse->expr = tmp;
+      tmp = gfc_deallocate_pdt_comp (e->ts.u.derived, tmp, e->rank);
+      gfc_add_expr_to_block (&parmse->post, tmp);
+      return;
+    }
+
   /* Absent actual argument for optional scalar dummy.  */
   if ((e == NULL || e->expr_type == EXPR_NULL) && fsym->attr.optional)
     {
@@ -6562,6 +6579,26 @@ conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym,
       return;
     }
 
+  /* Truncate a too long constant character actual argument.  */
+  if (gfc_const_length_character_type_p (&fsym->ts)
+      && e->expr_type == EXPR_CONSTANT
+      && mpz_cmp_ui (fsym->ts.u.cl->length->value.integer,
+		     e->value.character.length) < 0)
+    {
+      gfc_charlen_t flen = mpz_get_ui (fsym->ts.u.cl->length->value.integer);
+
+      /* Truncate actual string argument.  */
+      gfc_conv_expr (parmse, e);
+      parmse->expr = gfc_build_wide_string_const (e->ts.kind, flen,
+						  e->value.character.string);
+      parmse->string_length = build_int_cst (gfc_charlen_type_node, flen);
+
+      /* Indicate value,optional scalar dummy argument as present.  */
+      if (fsym->attr.optional)
+	vec_safe_push (optionalargs, boolean_true_node);
+      return;
+    }
+
   /* gfortran argument passing conventions:
      actual arguments to CHARACTER(len=1),VALUE
      dummy arguments are actually passed by value.
@@ -7552,7 +7589,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 			|| CLASS_DATA (fsym)->attr.codimension))
 	    {
 	      /* Pass a class array.  */
-	      parmse.use_offset = 1;
 	      gfc_conv_expr_descriptor (&parmse, e);
 	      bool defer_to_dealloc_blk = false;
 
@@ -8864,28 +8900,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
 	  && expr->must_finalize)
 	{
-	  int n;
-	  if (se->ss && se->ss->loop)
-	    {
-	      gfc_add_block_to_block (&se->ss->loop->pre, &se->pre);
-	      se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre);
-	      tmp = gfc_class_data_get (se->expr);
-	      info->descriptor = tmp;
-	      info->data = gfc_conv_descriptor_data_get (tmp);
-	      info->offset = gfc_conv_descriptor_offset_get (tmp);
-	      for (n = 0; n < se->ss->loop->dimen; n++)
-		{
-		  tree dim = gfc_rank_cst[n];
-		  se->ss->loop->to[n] = gfc_conv_descriptor_ubound_get (tmp, dim);
-		  se->ss->loop->from[n] = gfc_conv_descriptor_lbound_get (tmp, dim);
-		}
-	    }
-	  else
-	    {
-	      /* TODO Eliminate the doubling of temporaries. This
-		 one is necessary to ensure no memory leakage.  */
-	      se->expr = gfc_evaluate_now (se->expr, &se->pre);
-	    }
+	  /* TODO Eliminate the doubling of temporaries.  This
+	     one is necessary to ensure no memory leakage.  */
+	  se->expr = gfc_evaluate_now (se->expr, &se->pre);
 
 	  /* Finalize the result, if necessary.  */
 	  attr = expr->value.function.esym
@@ -9612,8 +9629,8 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
 
   /* Shift the lbound and ubound of temporaries to being unity,
      rather than zero, based. Always calculate the offset.  */
+  gfc_conv_descriptor_offset_set (&block, dest, gfc_index_zero_node);
   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++)
@@ -11177,11 +11194,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	    {
 	      rse.expr = gfc_class_data_get (rse.expr);
 	      gfc_add_modify (&lse.pre, desc, rse.expr);
-	      /* Set the lhs span.  */
-	      tmp = TREE_TYPE (rse.expr);
-	      tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
-	      tmp = fold_convert (gfc_array_index_type, tmp);
-	      gfc_conv_descriptor_span_set (&lse.pre, desc, tmp);
  	    }
 	  else
 	    {
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index be98427..71556b1 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -3466,6 +3466,74 @@ else
   return gfc_finish_block (&block);
 }
 
+static tree
+conv_intrinsic_split (gfc_code *code)
+{
+  stmtblock_t block, post_block;
+  gfc_se se;
+  gfc_expr *string_expr, *set_expr, *pos_expr, *back_expr;
+  tree string, string_len;
+  tree set, set_len;
+  tree pos, pos_for_call;
+  tree back;
+  tree fndecl, call;
+
+  string_expr = code->ext.actual->expr;
+  set_expr = code->ext.actual->next->expr;
+  pos_expr = code->ext.actual->next->next->expr;
+  back_expr = code->ext.actual->next->next->next->expr;
+
+  gfc_start_block (&block);
+  gfc_init_block (&post_block);
+
+  gfc_init_se (&se, NULL);
+  gfc_conv_expr (&se, string_expr);
+  gfc_conv_string_parameter (&se);
+  gfc_add_block_to_block (&block, &se.pre);
+  gfc_add_block_to_block (&post_block, &se.post);
+  string = se.expr;
+  string_len = se.string_length;
+
+  gfc_init_se (&se, NULL);
+  gfc_conv_expr (&se, set_expr);
+  gfc_conv_string_parameter (&se);
+  gfc_add_block_to_block (&block, &se.pre);
+  gfc_add_block_to_block (&post_block, &se.post);
+  set = se.expr;
+  set_len = se.string_length;
+
+  gfc_init_se (&se, NULL);
+  gfc_conv_expr (&se, pos_expr);
+  gfc_add_block_to_block (&block, &se.pre);
+  gfc_add_block_to_block (&post_block, &se.post);
+  pos = se.expr;
+  pos_for_call = fold_convert (gfc_charlen_type_node, pos);
+
+  if (back_expr)
+    {
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr (&se, back_expr);
+      gfc_add_block_to_block (&block, &se.pre);
+      gfc_add_block_to_block (&post_block, &se.post);
+      back = se.expr;
+    }
+  else
+    back = logical_false_node;
+
+  if (string_expr->ts.kind == 1)
+    fndecl = gfor_fndecl_string_split;
+  else if (string_expr->ts.kind == 4)
+    fndecl = gfor_fndecl_string_split_char4;
+  else
+    gcc_unreachable ();
+
+  call = build_call_expr_loc (input_location, fndecl, 6, string_len, string,
+			      set_len, set, pos_for_call, back);
+  gfc_add_modify (&block, pos, fold_convert (TREE_TYPE (pos), call));
+
+  gfc_add_block_to_block (&block, &post_block);
+  return gfc_finish_block (&block);
+}
 
 /* Return a character string containing the tty name.  */
 
@@ -9850,38 +9918,40 @@ conv_isocbinding_function (gfc_se *se, gfc_expr *expr)
 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;
+  gfc_expr *cptr, *fptr, *shape, *lower;
+  gfc_se se, cptrse, fptrse, shapese, lowerse;
+  gfc_ss *shape_ss, *lower_ss;
+  tree desc, dim, tmp, stride, offset, lbound, ubound;
   stmtblock_t body, block;
   gfc_loopinfo loop;
-  gfc_actual_arglist *arg = code->ext.actual;
+  gfc_actual_arglist *arg;
+
+  arg = code->ext.actual;
+  cptr = arg->expr;
+  fptr = arg->next->expr;
+  shape = arg->next->next ? arg->next->next->expr : NULL;
+  lower = shape && arg->next->next->next ? arg->next->next->next->expr : NULL;
 
   gfc_init_se (&se, NULL);
   gfc_init_se (&cptrse, NULL);
-  gfc_conv_expr (&cptrse, arg->expr);
+  gfc_conv_expr (&cptrse, cptr);
   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)
+  if (fptr->rank == 0)
     {
       fptrse.want_pointer = 1;
-      gfc_conv_expr (&fptrse, arg->next->expr);
+      gfc_conv_expr (&fptrse, fptr);
       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));
+      if (fptr->symtree->n.sym->attr.proc_pointer
+	  && fptr->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);
@@ -9891,7 +9961,7 @@ conv_isocbinding_subroutine (gfc_code *code)
 
   /* Get the descriptor of the Fortran pointer.  */
   fptrse.descriptor_only = 1;
-  gfc_conv_expr_descriptor (&fptrse, arg->next->expr);
+  gfc_conv_expr_descriptor (&fptrse, fptr);
   gfc_add_block_to_block (&block, &fptrse.pre);
   desc = fptrse.expr;
 
@@ -9908,18 +9978,33 @@ conv_isocbinding_subroutine (gfc_code *code)
 
   /* Start scalarization of the bounds, using the shape argument.  */
 
-  shape_ss = gfc_walk_expr (arg->next->next->expr);
+  shape_ss = gfc_walk_expr (shape);
   gcc_assert (shape_ss != gfc_ss_terminator);
   gfc_init_se (&shapese, NULL);
+  if (lower)
+    {
+      lower_ss = gfc_walk_expr (lower);
+      gcc_assert (lower_ss != gfc_ss_terminator);
+      gfc_init_se (&lowerse, NULL);
+    }
 
   gfc_init_loopinfo (&loop);
   gfc_add_ss_to_loop (&loop, shape_ss);
+  if (lower)
+    gfc_add_ss_to_loop (&loop, lower_ss);
   gfc_conv_ss_startstride (&loop);
-  gfc_conv_loop_setup (&loop, &arg->next->expr->where);
+  gfc_conv_loop_setup (&loop, &fptr->where);
   gfc_mark_ss_chain_used (shape_ss, 1);
+  if (lower)
+    gfc_mark_ss_chain_used (lower_ss, 1);
 
   gfc_copy_loopinfo_to_se (&shapese, &loop);
   shapese.ss = shape_ss;
+  if (lower)
+    {
+      gfc_copy_loopinfo_to_se (&lowerse, &loop);
+      lowerse.ss = lower_ss;
+    }
 
   stride = gfc_create_var (gfc_array_index_type, "stride");
   offset = gfc_create_var (gfc_array_index_type, "offset");
@@ -9930,27 +10015,44 @@ conv_isocbinding_subroutine (gfc_code *code)
   gfc_start_scalarized_body (&loop, &body);
 
   dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
-			     loop.loopvar[0], loop.from[0]);
+			 loop.loopvar[0], loop.from[0]);
+
+  if (lower)
+    {
+      gfc_conv_expr (&lowerse, lower);
+      gfc_add_block_to_block (&body, &lowerse.pre);
+      lbound = fold_convert (gfc_array_index_type, lowerse.expr);
+      gfc_add_block_to_block (&body, &lowerse.post);
+    }
+  else
+    lbound = gfc_index_one_node;
 
   /* Set bounds and stride.  */
-  gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node);
+  gfc_conv_descriptor_lbound_set (&body, desc, dim, lbound);
   gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
 
-  gfc_conv_expr (&shapese, arg->next->next->expr);
+  gfc_conv_expr (&shapese, shape);
   gfc_add_block_to_block (&body, &shapese.pre);
-  gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr);
+  ubound = fold_build2_loc (
+    input_location, MINUS_EXPR, gfc_array_index_type,
+    fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, lbound,
+		     fold_convert (gfc_array_index_type, shapese.expr)),
+    gfc_index_one_node);
+  gfc_conv_descriptor_ubound_set (&body, desc, dim, ubound);
   gfc_add_block_to_block (&body, &shapese.post);
 
   /* Calculate offset.  */
+  tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			 stride, lbound);
   gfc_add_modify (&body, offset,
 		  fold_build2_loc (input_location, PLUS_EXPR,
-				   gfc_array_index_type, offset, stride));
+				   gfc_array_index_type, offset, tmp));
+
   /* 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)));
+  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);
@@ -13261,6 +13363,10 @@ gfc_conv_intrinsic_subroutine (gfc_code *code)
       res = conv_intrinsic_system_clock (code);
       break;
 
+    case GFC_ISYM_SPLIT:
+      res = conv_intrinsic_split (code);
+      break;
+
     default:
       res = NULL_TREE;
       break;
diff --git a/gcc/fortran/trans-io.cc b/gcc/fortran/trans-io.cc
index 824f232..df2fef7 100644
--- a/gcc/fortran/trans-io.cc
+++ b/gcc/fortran/trans-io.cc
@@ -2499,7 +2499,8 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
 	      for (c = ts->u.derived->components; c; c = c->next)
 		{
 		  /* Ignore hidden string lengths.  */
-		  if (c->name[0] == '_')
+		  if (c->name[0] == '_'
+		      || c->attr.pdt_kind || c->attr.pdt_len)
 		    continue;
 
 		  field = c->backend_decl;
diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc
index 278e91c..69a70d7 100644
--- a/gcc/fortran/trans-openmp.cc
+++ b/gcc/fortran/trans-openmp.cc
@@ -9735,6 +9735,12 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns, gfc_namespace *parent_ns)
 			 variant_proc_name, &odv->where);
 	      variant_proc_sym = NULL;
 	    }
+	  else if (variant_proc_sym == ns->proc_name)
+	    {
+	      gfc_error ("variant %qs at %L is the same as base function",
+			 variant_proc_name, &odv->where);
+	      variant_proc_sym = NULL;
+	    }
 	  else if (omp_get_context_selector (set_selectors,
 					     OMP_TRAIT_SET_CONSTRUCT,
 					     OMP_TRAIT_CONSTRUCT_SIMD)
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index f105401..f4e6c57 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -1876,9 +1876,6 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
   bool class_target;
   bool unlimited;
   tree desc;
-  tree offset;
-  tree dim;
-  int n;
   tree charlen;
   bool need_len_assign;
   bool whole_array = true;
@@ -2116,7 +2113,6 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
       if (sym->assoc->variable || cst_array_ctor)
 	{
 	  se.direct_byref = 1;
-	  se.use_offset = 1;
 	  se.expr = desc;
 	  GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1;
 	}
@@ -2183,16 +2179,6 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 					      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 && !se.direct_byref)
-	{
-	  gcc_assert (e->expr_type == EXPR_VARIABLE);
-	  tmp = gfc_get_array_span (se.expr, e);
-
-	  gfc_conv_descriptor_span_set (&se.pre, desc, tmp);
-	}
-
       if (e->expr_type == EXPR_FUNCTION
 	  && sym->ts.type == BT_DERIVED
 	  && sym->ts.u.derived
@@ -2303,21 +2289,6 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 
 	  desc = gfc_class_data_get (se.expr);
 
-	  /* Set the offset.  */
-	  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);
-
 	  if (need_len_assign)
 	    {
 	      if (e->symtree
@@ -2494,9 +2465,10 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	{
 	  tmp = sym->backend_decl;
 	  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
-	    tmp = gfc_conv_descriptor_data_get (tmp);
-	  gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
-						    null_pointer_node));
+	    gfc_conv_descriptor_data_set (&se.pre, tmp, null_pointer_node);
+	  else
+	    gfc_add_modify (&se.pre, tmp,
+			    fold_convert (TREE_TYPE (tmp), null_pointer_node));
 	}
 
       lhs = gfc_lval_expr_from_sym (sym);
@@ -6710,7 +6682,6 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate)
   stmtblock_t block;
   stmtblock_t post;
   stmtblock_t final_block;
-  tree nelems;
   bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set, is_coarray;
   bool needs_caf_sync, caf_refs_comp;
   bool e3_has_nodescriptor = false;
@@ -7242,7 +7213,6 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate)
 	 to handle the complete array allocation.  Only the element size
 	 needs to be provided, which is done most of the time by the
 	 pre-evaluation step.  */
-      nelems = NULL_TREE;
       if (expr3_len && (code->expr3->ts.type == BT_CHARACTER
 			|| code->expr3->ts.type == BT_CLASS))
 	{
@@ -7313,9 +7283,8 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate)
 
 	}
 
-      if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen,
-			       label_finish, tmp, &nelems,
-			       e3rhs ? e3rhs : code->expr3,
+      if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish,
+			       tmp, e3rhs ? e3rhs : code->expr3,
 			       e3_is == E3_DESC ? expr3 : NULL_TREE,
 			       e3_has_nodescriptor, omp_alloc_item,
 			       code->ext.alloc.ts.type != BT_UNKNOWN))
diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc
index 13fd5ad..47396c3 100644
--- a/gcc/fortran/trans.cc
+++ b/gcc/fortran/trans.cc
@@ -1740,7 +1740,7 @@ gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived,
 			     gfc_call_free (data_ptr),
 			     build_empty_stmt (input_location));
       gfc_add_expr_to_block (&se->loop->post, tmp);
-      gfc_add_modify (&se->loop->post, data_ptr, data_null);
+      gfc_conv_descriptor_data_set (&se->loop->post, desc, data_null);
     }
   else
     {
@@ -1754,7 +1754,7 @@ gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived,
 				 gfc_call_free (data_ptr),
 				 build_empty_stmt (input_location));
 	  gfc_add_expr_to_block (&se->finalblock, tmp);
-	  gfc_add_modify (&se->finalblock, data_ptr, data_null);
+	  gfc_conv_descriptor_data_set (&se->finalblock, desc, data_null);
 	}
     }
 }
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 461b0cd..5554184 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -105,10 +105,6 @@ typedef struct gfc_se
   /* If set, will pass subref descriptors without a temporary.  */
   unsigned force_no_tmp:1;
 
-  /* Unconditionally calculate offset for array segments and constant
-     arrays in gfc_conv_expr_descriptor.  */
-  unsigned use_offset:1;
-
   unsigned want_coarray:1;
 
   /* Scalarization parameters.  */
@@ -961,6 +957,7 @@ 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_string_split;
 extern GTY(()) tree gfor_fndecl_adjustl;
 extern GTY(()) tree gfor_fndecl_adjustr;
 extern GTY(()) tree gfor_fndecl_select_string;
@@ -972,6 +969,7 @@ 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_string_split_char4;
 extern GTY(()) tree gfor_fndecl_adjustl_char4;
 extern GTY(()) tree gfor_fndecl_adjustr_char4;
 extern GTY(()) tree gfor_fndecl_select_string_char4;