2006-04-03 Paul Thomas <pault@gcc.gnu.org>

	PR fortran/26981
	* trans.h : Prototype for gfc_conv_missing_dummy.
	* trans-expr (gfc_conv_missing_dummy): New function
	(gfc_conv_function_call): Call it and tidy up some of the code.
	* trans-intrinsic (gfc_conv_intrinsic_function_args): The same.

	PR fortran/26976
	* array.c (gfc_array_dimen_size): If available, return shape[dimen].
	* resolve.c (resolve_function): If available, use the argument shape for the
	function expression.
	* iresolve.c (gfc_resolve_transfer): Set shape[0] = size.

2006-04-03  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/26981
	* gfortran.dg/missing_optional_dummy_1.f90: New test.

	PR fortran/26976
	* gfortran.dg/compliant_elemental_intrinsics_1.f90: New test.
	* gfortran.dg/initialization_1.f90: Make assignment compliant.
	* gfortran.dg/transfer_array_intrinsic_1.f90: Simplify.
	* gfortran.dg/transfer_array_intrinsic_2.f90: Make assignments compliant and detect
	bigendian-ness.





git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@112634 138bc75d-0d04-0410-961f-82ee72b054a4

13 files changed, 316 insertions, 143 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 3743cbdbd1b..fe9ad51929c 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,17 @@
+2006-04-03  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/26981
+	* trans.h : Prototype for gfc_conv_missing_dummy.
+	* trans-expr (gfc_conv_missing_dummy): New function
+	(gfc_conv_function_call): Call it and tidy up some of the code.
+	* trans-intrinsic (gfc_conv_intrinsic_function_args): The same.
+
+	PR fortran/26976
+	* array.c (gfc_array_dimen_size): If available, return shape[dimen].
+	* resolve.c (resolve_function): If available, use the argument shape for the
+	function expression.
+	* iresolve.c (gfc_resolve_transfer): Set shape[0] = size.
+
 2006-04-02  Erik Edelmann  <eedelman@gcc.gnu.org>
 
 	* trans-array.c (gfc_trans_dealloc_allocated): Take a
diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index 9491406d97e..2cb34994562 100644
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -1872,6 +1872,12 @@ gfc_array_dimen_size (gfc_expr * array, int dimen, mpz_t * result)
 	    }
 	}
 
+      if (array->shape && array->shape[dimen])
+	{
+	  mpz_init_set (*result, array->shape[dimen]);
+	  return SUCCESS;
+	}
+
       if (spec_dimen_size (array->symtree->n.sym->as, dimen, result) == FAILURE)
 	return FAILURE;
 
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index a51799461e1..d07864ee36e 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -1955,6 +1955,11 @@ gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED,
     {
       f->rank = 1;
       f->value.function.name = transfer1;
+      if (size && gfc_is_constant_expr (size))
+	{
+	  f->shape = gfc_get_shape (1);
+	  mpz_init_set (f->shape[0], size->value.integer);
+	}
     }
 }
 
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 562338fdb64..4831d799d70 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1205,6 +1205,7 @@ resolve_function (gfc_expr * expr)
   const char *name;
   try t;
   int temp;
+  int i;
 
   sym = NULL;
   if (expr->symtree)
@@ -1304,6 +1305,12 @@ resolve_function (gfc_expr * expr)
 	  if (arg->expr != NULL && arg->expr->rank > 0)
 	    {
 	      expr->rank = arg->expr->rank;
+	      if (!expr->shape && arg->expr->shape)
+		{
+		  expr->shape = gfc_get_shape (expr->rank);
+		  for (i = 0; i < expr->rank; i++)
+		    mpz_init_set (expr->shape[i], arg->expr->shape[i]);
+	        }
 	      break;
 	    }
 	}
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 94921bc1138..1e1802ed205 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -142,6 +142,31 @@ gfc_conv_expr_present (gfc_symbol * sym)
 }
 
 
+/* Converts a missing, dummy argument into a null or zero.  */
+
+void
+gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts)
+{
+  tree present;
+  tree tmp;
+
+  present = gfc_conv_expr_present (arg->symtree->n.sym);
+  tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr,
+		convert (TREE_TYPE (se->expr), integer_zero_node));
+  tmp = gfc_evaluate_now (tmp, &se->pre);
+  se->expr = tmp;
+  if (ts.type == BT_CHARACTER)
+    {
+      tmp = convert (gfc_charlen_type_node, integer_zero_node);
+      tmp = build3 (COND_EXPR, gfc_charlen_type_node, present,
+		    se->string_length, tmp);
+      tmp = gfc_evaluate_now (tmp, &se->pre);
+      se->string_length = tmp;
+    }
+  return;
+}
+
+
 /* Get the character length of an expression, looking through gfc_refs
    if necessary.  */
 
@@ -1805,6 +1830,8 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
   bool callee_alloc;
   gfc_typespec ts;
   gfc_charlen cl;
+  gfc_expr *e;
+  gfc_symbol *fsym;
 
   arglist = NULL_TREE;
   retargs = NULL_TREE;
@@ -1844,7 +1871,9 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
   /* Evaluate the arguments.  */
   for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
     {
-      if (arg->expr == NULL)
+      e = arg->expr;
+      fsym = formal ? formal->sym : NULL;
+      if (e == NULL)
 	{
 
 	  if (se->ignore_optional)
@@ -1872,19 +1901,19 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	{
 	  /* An elemental function inside a scalarized loop.  */
           gfc_init_se (&parmse, se);
-          gfc_conv_expr_reference (&parmse, arg->expr);
+          gfc_conv_expr_reference (&parmse, e);
 	}
       else
 	{
 	  /* A scalar or transformational function.  */
 	  gfc_init_se (&parmse, NULL);
-	  argss = gfc_walk_expr (arg->expr);
+	  argss = gfc_walk_expr (e);
 
 	  if (argss == gfc_ss_terminator)
             {
-	      gfc_conv_expr_reference (&parmse, arg->expr);
-              if (formal && formal->sym->attr.pointer
-		  && arg->expr->expr_type != EXPR_NULL)
+	      gfc_conv_expr_reference (&parmse, e);
+              if (fsym && fsym->attr.pointer
+		  && e->expr_type != EXPR_NULL)
                 {
                   /* Scalar pointer dummy args require an extra level of
 		  indirection. The null pointer already contains
@@ -1901,27 +1930,27 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
                  convention, and pass the address of the array descriptor
                  instead. Otherwise we use g77's calling convention.  */
 	      int f;
-	      f = (formal != NULL)
-		  && !(formal->sym->attr.pointer || formal->sym->attr.allocatable)
-		  && formal->sym->as->type != AS_ASSUMED_SHAPE;
+	      f = (fsym != NULL)
+		  && !(fsym->attr.pointer || fsym->attr.allocatable)
+		  && fsym->as->type != AS_ASSUMED_SHAPE;
 	      f = f || !sym->attr.always_explicit;
-	      if (arg->expr->expr_type == EXPR_VARIABLE
-		    && is_aliased_array (arg->expr))
+	      if (e->expr_type == EXPR_VARIABLE
+		    && is_aliased_array (e))
 		/* The actual argument is a component reference to an
 		   array of derived types.  In this case, the argument
 		   is converted to a temporary, which is passed and then
 		   written back after the procedure call.  */
-		gfc_conv_aliased_arg (&parmse, arg->expr, f);
+		gfc_conv_aliased_arg (&parmse, e, f);
 	      else
-	        gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
+	        gfc_conv_array_parameter (&parmse, e, argss, f);
 
               /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is 
                  allocated on entry, it must be deallocated.  */
-              if (formal && formal->sym->attr.allocatable
-                  && formal->sym->attr.intent == INTENT_OUT)
+              if (fsym && fsym->attr.allocatable
+                  && fsym->attr.intent == INTENT_OUT)
                 {
-		  tmp = arg->expr->symtree->n.sym->backend_decl;
-		  if (arg->expr->symtree->n.sym->attr.dummy)
+		  tmp = e->symtree->n.sym->backend_decl;
+		  if (e->symtree->n.sym->attr.dummy)
                     tmp = build_fold_indirect_ref (tmp);
                   tmp = gfc_trans_dealloc_allocated (tmp);
                   gfc_add_expr_to_block (&se->pre, tmp);
@@ -1930,8 +1959,15 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	    } 
 	}
 
-      if (formal && need_interface_mapping)
-	gfc_add_interface_mapping (&mapping, formal->sym, &parmse);
+      /* If an optional argument is itself an optional dummy argument,
+	 check its presence and substitute a null if absent.  */
+      if (e && e->expr_type == EXPR_VARIABLE
+	    && e->symtree->n.sym->attr.optional
+	    && fsym && fsym->attr.optional)
+	gfc_conv_missing_dummy (&parmse, e, fsym->ts);
+
+      if (fsym && need_interface_mapping)
+	gfc_add_interface_mapping (&mapping, fsym, &parmse);
 
       gfc_add_block_to_block (&se->pre, &parmse.pre);
       gfc_add_block_to_block (&se->post, &parmse.post);
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 87d3a742a05..b69ffefc8a0 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -165,28 +165,42 @@ static tree
 gfc_conv_intrinsic_function_args (gfc_se * se, gfc_expr * expr)
 {
   gfc_actual_arglist *actual;
-  tree args;
+  gfc_expr *e;
+  gfc_intrinsic_arg  *formal;
   gfc_se argse;
+  tree args;
 
   args = NULL_TREE;
-  for (actual = expr->value.function.actual; actual; actual = actual->next)
+  formal = expr->value.function.isym->formal;
+
+  for (actual = expr->value.function.actual; actual; actual = actual->next,
+       formal = formal ? formal->next : NULL)
     {
+      e = actual->expr;
       /* Skip omitted optional arguments.  */
-      if (!actual->expr)
+      if (!e)
 	continue;
 
       /* Evaluate the parameter.  This will substitute scalarized
          references automatically.  */
       gfc_init_se (&argse, se);
 
-      if (actual->expr->ts.type == BT_CHARACTER)
+      if (e->ts.type == BT_CHARACTER)
 	{
-	  gfc_conv_expr (&argse, actual->expr);
+	  gfc_conv_expr (&argse, e);
 	  gfc_conv_string_parameter (&argse);
 	  args = gfc_chainon_list (args, argse.string_length);
 	}
       else
-        gfc_conv_expr_val (&argse, actual->expr);
+        gfc_conv_expr_val (&argse, e);
+
+      /* If an optional argument is itself an optional dummy argument,
+	 check its presence and substitute a null if absent.  */
+      if (e->expr_type ==EXPR_VARIABLE
+	    && e->symtree->n.sym->attr.optional
+	    && formal
+	    && formal->optional)
+	gfc_conv_missing_dummy (&argse, e, formal->ts);
 
       gfc_add_block_to_block (&se->pre, &argse.pre);
       gfc_add_block_to_block (&se->post, &argse.post);
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 4955fe48c49..0b1514e94d6 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -317,6 +317,8 @@ void gfc_conv_structure (gfc_se *, gfc_expr *, int);
 
 /* Return an expression which determines if a dummy parameter is present.  */
 tree gfc_conv_expr_present (gfc_symbol *);
+/* Convert a missing, dummy argument into a null or zero.  */
+void gfc_conv_missing_dummy (gfc_se *, gfc_expr *, gfc_typespec);
 
 /* Generate code to allocate a string temporary.  */
 tree gfc_conv_string_tmp (gfc_se *, tree, tree);
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 66badc350ce..6ae43d57e00 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,15 @@
+2006-04-03  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/26981
+	* gfortran.dg/missing_optional_dummy_1.f90: New test.
+
+	PR fortran/26976
+	* gfortran.dg/compliant_elemental_intrinsics_1.f90: New test.
+	* gfortran.dg/initialization_1.f90: Make assignment compliant.
+	* gfortran.dg/transfer_array_intrinsic_1.f90: Simplify.
+	* gfortran.dg/transfer_array_intrinsic_2.f90: Make assignments compliant and detect
+	bigendian-ness.
+
 2006-04-02  Erik Edelmann  <eedelman@gcc.gnu.org>
 
 	* gfortran.dg/allocatable_dummy_1.f90: Also check that allocatable
diff --git a/gcc/testsuite/gfortran.dg/compliant_elemental_intrinsics_1.f90 b/gcc/testsuite/gfortran.dg/compliant_elemental_intrinsics_1.f90
new file mode 100644
index 00000000000..7829d977eb2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/compliant_elemental_intrinsics_1.f90
@@ -0,0 +1,26 @@
+! { dg-do compile }
+! Tests the fix for PR26976, in which non-compliant elemental
+! intrinsic function results were not detected.  At the same
+! time, the means to tests the compliance of TRANSFER with the
+! optional SIZE parameter was added.
+!
+! Contributed by Dominique Dhumieres  <dominiq@lps.ens.fr>
+!
+real(4) :: pi, a(2), b(3)
+character(26) :: ch
+
+pi = acos(-1.0)
+b = pi
+
+a = cos(b) ! { dg-error "different shape for Array assignment" }
+
+a = -pi
+b = cos(a) ! { dg-error "different shape for Array assignment" }
+
+ch = "abcdefghijklmnopqrstuvwxyz"
+a = transfer (ch, pi, 3) ! { dg-error "different shape for Array assignment" }
+
+! This already generated an error
+b = reshape ((/1.0/),(/1/)) ! { dg-error "different shape for Array assignment" }
+
+end
diff --git a/gcc/testsuite/gfortran.dg/initialization_1.f90 b/gcc/testsuite/gfortran.dg/initialization_1.f90
index b9199fe68fa..af7ccb0f782 100644
--- a/gcc/testsuite/gfortran.dg/initialization_1.f90
+++ b/gcc/testsuite/gfortran.dg/initialization_1.f90
@@ -21,6 +21,7 @@ contains
     real(8) :: x (1:2, *)
     real(8) :: y (0:,:)
     integer :: i
+    real :: z(2, 2)
 
 ! However, this gives a warning because it is an initialization expression.
     integer :: l1 = len (ch1)     ! { dg-warning "assumed character length variable" }
diff --git a/gcc/testsuite/gfortran.dg/missing_optional_dummy_1.f90 b/gcc/testsuite/gfortran.dg/missing_optional_dummy_1.f90
new file mode 100644
index 00000000000..29f08f9e0e8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/missing_optional_dummy_1.f90
@@ -0,0 +1,49 @@
+! { dg-do run }
+! Test the fix for PR26891, in which an optional argument, whose actual
+! is a missing dummy argument would cause a segfault.
+!
+! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+!
+  logical :: back =.false.
+
+! This was the case that would fail - PR case was an intrinsic call.
+  if (scan ("A quick brown fox jumps over the lazy dog", "lazy", back) &
+      .ne. myscan ("A quick brown fox jumps over the lazy dog", "lazy")) &
+    call abort ()
+
+! Check that the patch works with non-intrinsic functions.
+  if (myscan ("A quick brown fox jumps over the lazy dog", "fox", back) &
+      .ne. thyscan ("A quick brown fox jumps over the lazy dog", "fox")) &
+    call abort ()
+
+! Check that missing, optional character actual arguments are OK.
+  if (scan ("A quick brown fox jumps over the lazy dog", "over", back) &
+      .ne. thyscan ("A quick brown fox jumps over the lazy dog")) &
+    call abort ()
+
+contains
+  integer function myscan (str, substr, back)
+    character(*), intent(in) :: str, substr
+    logical, optional, intent(in) :: back
+    myscan = scan (str, substr, back)
+  end function myscan
+
+  integer function thyscan (str, substr, back)
+    character(*), intent(in) :: str
+    character(*), optional, intent(in) :: substr
+    logical, optional, intent(in) :: back
+    thyscan = isscan (str, substr, back)
+  end function thyscan
+
+  integer function isscan (str, substr, back)
+    character(*), intent(in) :: str
+    character(*), optional :: substr
+    logical, optional, intent(in) :: back
+    if (.not.present(substr)) then
+      isscan = myscan (str, "over", back)
+    else
+      isscan = myscan (str, substr, back)
+    end if
+  end function isscan
+
+end
diff --git a/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_1.f90 b/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_1.f90
index 05b4717249c..0d828efa66b 100644
--- a/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_1.f90
+++ b/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_1.f90
@@ -1,22 +1,11 @@
-! { dg-do run { target i?86-*-* x86_64-*-* } }
+! { dg-do run }
 ! Tests the patch to implement the array version of the TRANSFER
 ! intrinsic (PR17298).
-! Contributed by Paul Thomas  <pault@gcc.gnu.org>
 
-   character(8) :: ch(2) = (/"lmnoPQRS","LMNOpqrs"/)
-
-! tests numeric transfers(including PR testcase).
+! test the PR is fixed.
 
    call test1 ()
 
-! tests numeric/character transfers.
-
-   call test2 ()
-
-! Test dummies, automatic objects and assumed character length.
-
-   call test3 (ch, ch, ch, 8)
-
 contains
 
    subroutine test1 ()
@@ -29,90 +18,6 @@ contains
      cmp = transfer (z, cmp) * 2.0
      if (any (cmp .ne. (/2.0, 4.0/))) call abort ()
 
-! Check that size smaller than the source word length is OK.
-
-     z = (-1.0, -2.0)
-     cmp = transfer (z, cmp, 1) * 8.0
-     if (any (cmp .ne. (/-8.0, 4.0/))) call abort ()
-
-! Check multi-dimensional sources and that transfer works as an actual
-! argument of reshape.
-
-     a = reshape ((/(rand (), i = 1, 16)/), (/4,4/))
-     jt = transfer (a, it)
-     it = reshape (jt, (/4, 2, 4/))
-     if (any (reshape (transfer (it, a), (/4,4/)) .ne. a)) call abort ()
-
    end subroutine test1
 
-   subroutine test2 ()
-     integer(4) :: y(4), z(2)
-     character(4) :: ch(4)
-     y = (/(i + ishft (i + 1, 8) + ishft (i + 2, 16) &
-              + ishft (i + 3, 24), i = 65, 80 , 4)/)
-
-! Check source array sections in both directions.
-
-     ch = "wxyz"
-     ch = transfer (y(2:4:2), ch)
-     if (any (ch .ne. (/"EFGH","MNOP","wxyz","wxyz"/))) call abort ()
-     ch = "wxyz"
-     ch = transfer (y(4:2:-2), ch)
-     if (any (ch .ne. (/"MNOP","EFGH","wxyz","wxyz"/))) call abort ()
-
-! Check that a complete array transfers with size absent.
-
-     ch = transfer (y, ch)
-     if (any (ch .ne. (/"ABCD","EFGH","IJKL","MNOP"/))) call abort ()
-
-! Check that a character array section is OK
-
-     z = transfer (ch(2:3), y)
-     if (any (z .ne. y(2:3))) call abort ()
-
-! Check dest array sections in both directions.
-
-     ch = "wxyz"
-     ch(3:4) = transfer (y, ch, 2)
-     if (any (ch .ne. (/"wxyz","wxyz","ABCD","EFGH"/))) call abort ()
-     ch = "wxyz"
-     ch(3:2:-1) = transfer (y, ch, 3)
-     if (any (ch .ne. (/"wxyz","EFGH","ABCD","wxyz"/))) call abort ()
-
-! Check that too large a value of size is cut off.
-
-     ch = "wxyz"
-     ch(1:2) = transfer (y, ch, 3)
-     if (any (ch .ne. (/"ABCD","EFGH","wxyz","wxyz"/))) call abort ()
-
-! Make sure that character to numeric is OK.
-
-     z = transfer (ch, y)
-     if (any (y(1:2) .ne. z)) call abort ()
-
-   end subroutine test2
-
-   subroutine test3 (ch1, ch2, ch3, clen)
-     integer clen
-     character(8) :: ch1(:)
-     character(*) :: ch2(2)
-     character(clen) :: ch3(2)
-     character(8) :: cntrl(2) = (/"lmnoPQRS","LMNOpqrs"/)
-     integer(8) :: ic(2)
-     ic = transfer (cntrl, ic)
-
-! Check assumed shape.
-
-     if (any (ic .ne. transfer (ch1, ic))) call abort ()
-
-! Check assumed character length.
-
-     if (any (ic .ne. transfer (ch2, ic))) call abort ()
-
-! Check automatic character length.
-
-     if (any (ic .ne. transfer (ch3, ic))) call abort ()
-
-  end subroutine test3
-
 end
diff --git a/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_2.f90 b/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_2.f90
index a787440b682..aaa10f8a4f5 100644
--- a/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_2.f90
+++ b/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_2.f90
@@ -1,23 +1,119 @@
-! { dg-do run { target i?86-*-* x86_64-*-* } }
-! { dg-options "-fpack-derived" }
-   call test3()
+! { dg-do run }
+! Tests the patch to implement the array version of the TRANSFER
+! intrinsic (PR17298).
+! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+
+! Bigendian test posted by Perseus in comp.lang.fortran on 4 July 2005.
+! Original had parameter but this fails, at present, if is_gimple_var with -Ox, x>0
+
+   LOGICAL :: bigend
+   integer :: icheck = 1
+
+   character(8) :: ch(2) = (/"lmnoPQRS","LMNOpqrs"/)
+
+   bigend = IACHAR(TRANSFER(icheck,"a")) == 0
+
+! tests numeric transfers other than original testscase.
+
+   call test1 ()
+
+! tests numeric/character transfers.
+
+   call test2 ()
+
+! Test dummies, automatic objects and assumed character length.
+
+   call test3 (ch, ch, ch, 8)
+
 contains
-   subroutine test3 ()
-     type mytype
-       sequence
-       real(8) :: x = 3.14159
-       character(4) :: ch = "wxyz"
-       integer(2) :: i = 77
-     end type mytype
-     type(mytype) :: z(2)
-     character(1) :: c(32)
-     character(4) :: chr
-     real(8) :: a
-     integer(2) :: l
-     equivalence (a, c(15)), (chr, c(23)), (l, c(27))
-     c = transfer(z, c)
-     if (a .ne. z(1)%x) call abort ()
-     if (chr .ne. z(1)%ch) call abort ()
-     if (l .ne. z(1)%i) call abort ()
-   end subroutine test3
+
+   subroutine test1 ()
+     real(4) :: a(4, 4)
+     integer(2) :: it(4, 2, 4), jt(32)
+
+! Check multi-dimensional sources and that transfer works as an actual
+! argument of reshape.
+
+     a = reshape ((/(rand (), i = 1, 16)/), (/4,4/))
+     jt = transfer (a, it)
+     it = reshape (jt, (/4, 2, 4/))
+     if (any (reshape (transfer (it, a), (/4,4/)) .ne. a)) call abort ()
+
+   end subroutine test1
+
+   subroutine test2 ()
+     integer(4) :: y(4), z(2)
+     character(4) :: ch(4)
+
+! Allow for endian-ness
+     if (bigend) then
+       y = (/(i + 3 + ishft (i + 2, 8) + ishft (i + 1, 16) &
+                + ishft (i, 24), i = 65, 80 , 4)/)
+     else 
+       y = (/(i + ishft (i + 1, 8) + ishft (i + 2, 16) &
+                + ishft (i + 3, 24), i = 65, 80 , 4)/)
+     end if
+
+! Check source array sections in both directions.
+
+     ch = "wxyz"
+     ch(1:2) = transfer (y(2:4:2), ch)
+     if (any (ch(1:2) .ne. (/"EFGH","MNOP"/))) call abort ()
+     ch = "wxyz"
+     ch(1:2) = transfer (y(4:2:-2), ch)
+     if (any (ch(1:2) .ne. (/"MNOP","EFGH"/))) call abort ()
+
+! Check that a complete array transfers with size absent.
+
+     ch = transfer (y, ch)
+     if (any (ch .ne. (/"ABCD","EFGH","IJKL","MNOP"/))) call abort ()
+
+! Check that a character array section is OK
+
+     z = transfer (ch(2:3), y)
+     if (any (z .ne. y(2:3))) call abort ()
+
+! Check dest array sections in both directions.
+
+     ch = "wxyz"
+     ch(3:4) = transfer (y, ch, 2)
+     if (any (ch(3:4) .ne. (/"ABCD","EFGH"/))) call abort ()
+     ch = "wxyz"
+     ch(3:2:-1) = transfer (y, ch, 2)
+     if (any (ch(2:3) .ne. (/"EFGH","ABCD"/))) call abort ()
+
+! Make sure that character to numeric is OK.
+
+     ch = "wxyz"
+     ch(1:2) = transfer (y, ch, 2)
+     if (any (ch(1:2) .ne. (/"ABCD","EFGH"/))) call abort ()
+
+     z = transfer (ch, y)
+     if (any (y(1:2) .ne. z)) call abort ()
+
+   end subroutine test2
+
+   subroutine test3 (ch1, ch2, ch3, clen)
+     integer clen
+     character(8) :: ch1(:)
+     character(*) :: ch2(2)
+     character(clen) :: ch3(2)
+     character(8) :: cntrl(2) = (/"lmnoPQRS","LMNOpqrs"/)
+     integer(8) :: ic(2)
+     ic = transfer (cntrl, ic)
+
+! Check assumed shape.
+
+     if (any (ic .ne. transfer (ch1, ic))) call abort ()
+
+! Check assumed character length.
+
+     if (any (ic .ne. transfer (ch2, ic))) call abort ()
+
+! Check automatic character length.
+
+     if (any (ic .ne. transfer (ch3, ic))) call abort ()
+
+  end subroutine test3
+
 end