X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Ffortran%2Ftrans-intrinsic.c;h=75b5a4cffc5a9e9fc1a8031a65160240303ef4fb;hb=9915365eaddf007c2fff0945552fbd69c4597968;hp=b81b543a2710cc68581cb5e1569b4ac248157283;hpb=1038783304983d4f79b0df3e70088cc7edbb3371;p=pf3gnuchains%2Fgcc-fork.git

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index b81b543a271..75b5a4cffc5 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -1,5 +1,6 @@
 /* Intrinsic translation
-   Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
+   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
+   Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
    and Steven Bosscher <s.bosscher@student.tudelft.nl>
 
@@ -129,7 +130,9 @@ static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
   /* Functions in libgfortran.  */
   LIBF_FUNCTION (FRACTION, "fraction", false),
   LIBF_FUNCTION (NEAREST, "nearest", false),
+  LIBF_FUNCTION (RRSPACING, "rrspacing", false),
   LIBF_FUNCTION (SET_EXPONENT, "set_exponent", false),
+  LIBF_FUNCTION (SPACING, "spacing", false),
 
   /* End the list.  */
   LIBF_FUNCTION (NONE, NULL, false)
@@ -158,35 +161,52 @@ typedef struct
 }
 real_compnt_info;
 
+enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
 
 /* Evaluate the arguments to an intrinsic function.  */
+/* FIXME: This function and its callers should be rewritten so that it's
+   not necessary to cons up a list to hold the arguments.  */
 
 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);
@@ -291,23 +311,24 @@ build_round_expr (stmtblock_t * pblock, tree arg, tree type)
 
 static tree
 build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
-               enum tree_code op)
+               enum rounding_mode op)
 {
   switch (op)
     {
-    case FIX_FLOOR_EXPR:
+    case RND_FLOOR:
       return build_fixbound_expr (pblock, arg, type, 0);
       break;
 
-    case FIX_CEIL_EXPR:
+    case RND_CEIL:
       return build_fixbound_expr (pblock, arg, type, 1);
       break;
 
-    case FIX_ROUND_EXPR:
+    case RND_ROUND:
       return build_round_expr (pblock, arg, type);
 
     default:
-      return build1 (op, type, arg);
+      gcc_assert (op == RND_TRUNC);
+      return build1 (FIX_TRUNC_EXPR, type, arg);
     }
 }
 
@@ -315,14 +336,14 @@ build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
 /* Round a real value using the specified rounding mode.
    We use a temporary integer of that same kind size as the result.
    Values larger than those that can be represented by this kind are
-   unchanged, as thay will not be accurate enough to represent the
+   unchanged, as they will not be accurate enough to represent the
    rounding.
     huge = HUGE (KIND (a))
     aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
    */
 
 static void
-gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum tree_code op)
+gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
 {
   tree type;
   tree itype;
@@ -339,7 +360,7 @@ gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum tree_code op)
   /* We have builtin functions for some cases.  */
   switch (op)
     {
-    case FIX_ROUND_EXPR:
+    case RND_ROUND:
       switch (kind)
 	{
 	case 4:
@@ -357,7 +378,7 @@ gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum tree_code op)
 	}
       break;
 
-    case FIX_TRUNC_EXPR:
+    case RND_TRUNC:
       switch (kind)
 	{
 	case 4:
@@ -387,7 +408,7 @@ gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum tree_code op)
   if (n != END_BUILTINS)
     {
       tmp = built_in_decls[n];
-      se->expr = gfc_build_function_call (tmp, arg);
+      se->expr = build_function_call_expr (tmp, arg);
       return;
     }
 
@@ -421,7 +442,7 @@ gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum tree_code op)
 /* Convert to an integer using the specified rounding mode.  */
 
 static void
-gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, int op)
+gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
 {
   tree type;
   tree arg;
@@ -576,12 +597,18 @@ gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
 
   if (m->libm_name)
     {
-      gcc_assert (ts->kind == 4 || ts->kind == 8 || ts->kind == 10
-                 || ts->kind == 16);
-      snprintf (name, sizeof (name), "%s%s%s",
-		ts->type == BT_COMPLEX ? "c" : "",
-		m->name,
-		ts->kind == 4 ? "f" : "");
+      if (ts->kind == 4)
+	snprintf (name, sizeof (name), "%s%s%s",
+		ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
+      else if (ts->kind == 8)
+	snprintf (name, sizeof (name), "%s%s",
+		ts->type == BT_COMPLEX ? "c" : "", m->name);
+      else
+	{
+	  gcc_assert (ts->kind == 10 || ts->kind == 16);
+	  snprintf (name, sizeof (name), "%s%s%s",
+		ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
+	}
     }
   else
     {
@@ -641,7 +668,7 @@ gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
   /* Get the decl and generate the call.  */
   args = gfc_conv_intrinsic_function_args (se, expr);
   fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
-  se->expr = gfc_build_function_call (fndecl, args);
+  se->expr = build_function_call_expr (fndecl, args);
 }
 
 /* Generate code for EXPONENT(X) intrinsic function.  */
@@ -673,7 +700,7 @@ gfc_conv_intrinsic_exponent (gfc_se * se, gfc_expr * expr)
       gcc_unreachable ();
     }
 
-  se->expr = gfc_build_function_call (fndecl, args);
+  se->expr = build_function_call_expr (fndecl, args);
 }
 
 /* Evaluate a single upper or lower bound.  */
@@ -688,10 +715,13 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
   tree type;
   tree bound;
   tree tmp;
-  tree cond;
+  tree cond, cond1, cond2, cond3, cond4, size;
+  tree ubound;
+  tree lbound;
   gfc_se argse;
   gfc_ss *ss;
-  int i;
+  gfc_array_spec * as;
+  gfc_ref *ref;
 
   arg = expr->value.function.actual;
   arg2 = arg->next;
@@ -733,9 +763,14 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
 
   if (INTEGER_CST_P (bound))
     {
-      gcc_assert (TREE_INT_CST_HIGH (bound) == 0);
-      i = TREE_INT_CST_LOW (bound);
-      gcc_assert (i >= 0 && i < GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)));
+      int hi, low;
+
+      hi = TREE_INT_CST_HIGH (bound);
+      low = TREE_INT_CST_LOW (bound);
+      if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
+	gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
+		   "dimension index", upper ? "UBOUND" : "LBOUND",
+		   &expr->where);
     }
   else
     {
@@ -747,14 +782,119 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
           tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
           tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp);
           cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp);
-          gfc_trans_runtime_check (cond, gfc_strconst_fault, &se->pre);
+          gfc_trans_runtime_check (cond, gfc_msg_fault, &se->pre, &expr->where);
         }
     }
 
-  if (upper)
-    se->expr = gfc_conv_descriptor_ubound(desc, bound);
+  ubound = gfc_conv_descriptor_ubound (desc, bound);
+  lbound = gfc_conv_descriptor_lbound (desc, bound);
+  
+  /* Follow any component references.  */
+  if (arg->expr->expr_type == EXPR_VARIABLE
+      || arg->expr->expr_type == EXPR_CONSTANT)
+    {
+      as = arg->expr->symtree->n.sym->as;
+      for (ref = arg->expr->ref; ref; ref = ref->next)
+	{
+	  switch (ref->type)
+	    {
+	    case REF_COMPONENT:
+	      as = ref->u.c.component->as;
+	      continue;
+
+	    case REF_SUBSTRING:
+	      continue;
+
+	    case REF_ARRAY:
+	      {
+		switch (ref->u.ar.type)
+		  {
+		  case AR_ELEMENT:
+		  case AR_SECTION:
+		  case AR_UNKNOWN:
+		    as = NULL;
+		    continue;
+
+		  case AR_FULL:
+		    break;
+		  }
+	      }
+	    }
+	}
+    }
+  else
+    as = NULL;
+
+  /* 13.14.53: Result value for LBOUND
+
+     Case (i): For an array section or for an array expression other than a
+               whole array or array structure component, LBOUND(ARRAY, DIM)
+               has the value 1.  For a whole array or array structure
+               component, LBOUND(ARRAY, DIM) has the value:
+                 (a) equal to the lower bound for subscript DIM of ARRAY if
+                     dimension DIM of ARRAY does not have extent zero
+                     or if ARRAY is an assumed-size array of rank DIM,
+              or (b) 1 otherwise.
+
+     13.14.113: Result value for UBOUND
+
+     Case (i): For an array section or for an array expression other than a
+               whole array or array structure component, UBOUND(ARRAY, DIM)
+               has the value equal to the number of elements in the given
+               dimension; otherwise, it has a value equal to the upper bound
+               for subscript DIM of ARRAY if dimension DIM of ARRAY does
+               not have size zero and has value zero if dimension DIM has
+               size zero.  */
+
+  if (as)
+    {
+      tree stride = gfc_conv_descriptor_stride (desc, bound);
+
+      cond1 = fold_build2 (GE_EXPR, boolean_type_node, ubound, lbound);
+      cond2 = fold_build2 (LE_EXPR, boolean_type_node, ubound, lbound);
+
+      cond3 = fold_build2 (GE_EXPR, boolean_type_node, stride,
+			   gfc_index_zero_node);
+      cond3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1);
+
+      cond4 = fold_build2 (LT_EXPR, boolean_type_node, stride,
+			   gfc_index_zero_node);
+      cond4 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond4, cond2);
+
+      if (upper)
+	{
+	  cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
+
+	  se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
+				  ubound, gfc_index_zero_node);
+	}
+      else
+	{
+	  if (as->type == AS_ASSUMED_SIZE)
+	    cond = fold_build2 (EQ_EXPR, boolean_type_node, bound,
+				build_int_cst (TREE_TYPE (bound),
+					       arg->expr->rank - 1));
+	  else
+	    cond = boolean_false_node;
+
+	  cond1 = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
+	  cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond1);
+
+	  se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
+				  lbound, gfc_index_one_node);
+	}
+    }
   else
-    se->expr = gfc_conv_descriptor_lbound(desc, bound);
+    {
+      if (upper)
+        {
+	  size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
+	  se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
+				  gfc_index_one_node);
+	}
+      else
+	se->expr = gfc_index_one_node;
+    }
 
   type = gfc_typenode_for_spec (&expr->ts);
   se->expr = convert (type, se->expr);
@@ -795,7 +935,7 @@ gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
 	default:
 	  gcc_unreachable ();
 	}
-      se->expr = fold (gfc_build_function_call (built_in_decls[n], args));
+      se->expr = build_function_call_expr (built_in_decls[n], args);
       break;
 
     default:
@@ -846,17 +986,18 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
   tree test;
   tree test2;
   mpfr_t huge;
-  int n;
+  int n, ikind;
 
   arg = gfc_conv_intrinsic_function_args (se, expr);
-  arg2 = TREE_VALUE (TREE_CHAIN (arg));
-  arg = TREE_VALUE (arg);
-  type = TREE_TYPE (arg);
 
   switch (expr->ts.type)
     {
     case BT_INTEGER:
       /* Integer case is easy, we've got a builtin op.  */
+      arg2 = TREE_VALUE (TREE_CHAIN (arg));
+      arg = TREE_VALUE (arg);
+      type = TREE_TYPE (arg);
+
       if (modulo)
        se->expr = build2 (FLOOR_MOD_EXPR, type, arg, arg2);
       else
@@ -864,15 +1005,79 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
       break;
 
     case BT_REAL:
-      /* Real values we have to do the hard way.  */
+      n = END_BUILTINS;
+      /* Check if we have a builtin fmod.  */
+      switch (expr->ts.kind)
+	{
+	case 4:
+	  n = BUILT_IN_FMODF;
+	  break;
+
+	case 8:
+	  n = BUILT_IN_FMOD;
+	  break;
+
+	case 10:
+	case 16:
+	  n = BUILT_IN_FMODL;
+	  break;
+
+	default:
+	  break;
+	}
+
+      /* Use it if it exists.  */
+      if (n != END_BUILTINS)
+	{
+	  tmp = built_in_decls[n];
+	  se->expr = build_function_call_expr (tmp, arg);
+	  if (modulo == 0)
+	    return;
+	}
+
+      arg2 = TREE_VALUE (TREE_CHAIN (arg));
+      arg = TREE_VALUE (arg);
+      type = TREE_TYPE (arg);
+
       arg = gfc_evaluate_now (arg, &se->pre);
       arg2 = gfc_evaluate_now (arg2, &se->pre);
 
+      /* Definition:
+	 modulo = arg - floor (arg/arg2) * arg2, so
+		= test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2, 
+	 where
+	  test  = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
+	 thereby avoiding another division and retaining the accuracy
+	 of the builtin function.  */
+      if (n != END_BUILTINS && modulo)
+	{
+	  tree zero = gfc_build_const (type, integer_zero_node);
+	  tmp = gfc_evaluate_now (se->expr, &se->pre);
+	  test = build2 (LT_EXPR, boolean_type_node, arg, zero);
+	  test2 = build2 (LT_EXPR, boolean_type_node, arg2, zero);
+	  test2 = build2 (TRUTH_XOR_EXPR, boolean_type_node, test, test2);
+	  test = build2 (NE_EXPR, boolean_type_node, tmp, zero);
+	  test = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
+	  test = gfc_evaluate_now (test, &se->pre);
+	  se->expr = build3 (COND_EXPR, type, test,
+			     build2 (PLUS_EXPR, type, tmp, arg2), tmp);
+	  return;
+	}
+
+      /* If we do not have a built_in fmod, the calculation is going to
+	 have to be done longhand.  */
       tmp = build2 (RDIV_EXPR, type, arg, arg2);
+
       /* Test if the value is too large to handle sensibly.  */
       gfc_set_model_kind (expr->ts.kind);
       mpfr_init (huge);
-      n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
+      n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, true);
+      ikind = expr->ts.kind;
+      if (n < 0)
+	{
+	  n = gfc_validate_kind (BT_INTEGER, gfc_max_integer_kind, false);
+	  ikind = gfc_max_integer_kind;
+	}
       mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
       test2 = build2 (LT_EXPR, boolean_type_node, tmp, test);
@@ -882,11 +1087,11 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
       test = build2 (GT_EXPR, boolean_type_node, tmp, test);
       test2 = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
 
-      itype = gfc_get_int_type (expr->ts.kind);
+      itype = gfc_get_int_type (ikind);
       if (modulo)
-       tmp = build_fix_expr (&se->pre, tmp, itype, FIX_FLOOR_EXPR);
+       tmp = build_fix_expr (&se->pre, tmp, itype, RND_FLOOR);
       else
-       tmp = build_fix_expr (&se->pre, tmp, itype, FIX_TRUNC_EXPR);
+       tmp = build_fix_expr (&se->pre, tmp, itype, RND_TRUNC);
       tmp = convert (type, tmp);
       tmp = build3 (COND_EXPR, type, test2, tmp, arg);
       tmp = build2 (MULT_EXPR, type, tmp, arg2);
@@ -928,7 +1133,7 @@ gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
 /* SIGN(A, B) is absolute value of A times sign of B.
    The real value versions use library functions to ensure the correct
    handling of negative zero.  Integer case implemented as:
-   SIGN(A, B) = ((a >= 0) .xor. (b >= 0)) ? a : -a
+   SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
   */
 
 static void
@@ -938,10 +1143,6 @@ gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
   tree arg;
   tree arg2;
   tree type;
-  tree zero;
-  tree testa;
-  tree testb;
-
 
   arg = gfc_conv_intrinsic_function_args (se, expr);
   if (expr->ts.type == BT_REAL)
@@ -961,20 +1162,31 @@ gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
 	default:
 	  gcc_unreachable ();
 	}
-      se->expr = fold (gfc_build_function_call (tmp, arg));
+      se->expr = build_function_call_expr (tmp, arg);
       return;
     }
 
+  /* Having excluded floating point types, we know we are now dealing
+     with signed integer types.  */
   arg2 = TREE_VALUE (TREE_CHAIN (arg));
   arg = TREE_VALUE (arg);
   type = TREE_TYPE (arg);
-  zero = gfc_build_const (type, integer_zero_node);
 
-  testa = fold_build2 (GE_EXPR, boolean_type_node, arg, zero);
-  testb = fold_build2 (GE_EXPR, boolean_type_node, arg2, zero);
-  tmp = fold_build2 (TRUTH_XOR_EXPR, boolean_type_node, testa, testb);
-  se->expr = fold_build3 (COND_EXPR, type, tmp,
-			  build1 (NEGATE_EXPR, type, arg), arg);
+  /* Arg is used multiple times below.  */
+  arg = gfc_evaluate_now (arg, &se->pre);
+
+  /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
+     the signs of A and B are the same, and of all ones if they differ.  */
+  tmp = fold_build2 (BIT_XOR_EXPR, type, arg, arg2);
+  tmp = fold_build2 (RSHIFT_EXPR, type, tmp,
+		     build_int_cst (type, TYPE_PRECISION (type) - 1));
+  tmp = gfc_evaluate_now (tmp, &se->pre);
+
+  /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
+     is all ones (i.e. -1).  */
+  se->expr = fold_build2 (BIT_XOR_EXPR, type,
+			  fold_build2 (PLUS_EXPR, type, arg, tmp),
+			  tmp);
 }
 
 
@@ -1037,6 +1249,113 @@ gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
 }
 
 
+static void
+gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
+{
+  tree var;
+  tree len;
+  tree tmp;
+  tree arglist;
+  tree type;
+  tree cond;
+  tree gfc_int8_type_node = gfc_get_int_type (8);
+
+  type = build_pointer_type (gfc_character1_type_node);
+  var = gfc_create_var (type, "pstr");
+  len = gfc_create_var (gfc_int8_type_node, "len");
+
+  tmp = gfc_conv_intrinsic_function_args (se, expr);
+  arglist = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (var));
+  arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
+  arglist = chainon (arglist, tmp);
+
+  tmp = build_function_call_expr (gfor_fndecl_ctime, arglist);
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  /* Free the temporary afterwards, if necessary.  */
+  cond = build2 (GT_EXPR, boolean_type_node, len,
+		 build_int_cst (TREE_TYPE (len), 0));
+  tmp = gfc_call_free (var);
+  tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
+  gfc_add_expr_to_block (&se->post, tmp);
+
+  se->expr = var;
+  se->string_length = len;
+}
+
+
+static void
+gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
+{
+  tree var;
+  tree len;
+  tree tmp;
+  tree arglist;
+  tree type;
+  tree cond;
+  tree gfc_int4_type_node = gfc_get_int_type (4);
+
+  type = build_pointer_type (gfc_character1_type_node);
+  var = gfc_create_var (type, "pstr");
+  len = gfc_create_var (gfc_int4_type_node, "len");
+
+  tmp = gfc_conv_intrinsic_function_args (se, expr);
+  arglist = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (var));
+  arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
+  arglist = chainon (arglist, tmp);
+
+  tmp = build_function_call_expr (gfor_fndecl_fdate, arglist);
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  /* Free the temporary afterwards, if necessary.  */
+  cond = build2 (GT_EXPR, boolean_type_node, len,
+		 build_int_cst (TREE_TYPE (len), 0));
+  tmp = gfc_call_free (var);
+  tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
+  gfc_add_expr_to_block (&se->post, tmp);
+
+  se->expr = var;
+  se->string_length = len;
+}
+
+
+/* Return a character string containing the tty name.  */
+
+static void
+gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
+{
+  tree var;
+  tree len;
+  tree tmp;
+  tree arglist;
+  tree type;
+  tree cond;
+  tree gfc_int4_type_node = gfc_get_int_type (4);
+
+  type = build_pointer_type (gfc_character1_type_node);
+  var = gfc_create_var (type, "pstr");
+  len = gfc_create_var (gfc_int4_type_node, "len");
+
+  tmp = gfc_conv_intrinsic_function_args (se, expr);
+  arglist = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (var));
+  arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
+  arglist = chainon (arglist, tmp);
+
+  tmp = build_function_call_expr (gfor_fndecl_ttynam, arglist);
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  /* Free the temporary afterwards, if necessary.  */
+  cond = build2 (GT_EXPR, boolean_type_node, len,
+		 build_int_cst (TREE_TYPE (len), 0));
+  tmp = gfc_call_free (var);
+  tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
+  gfc_add_expr_to_block (&se->post, tmp);
+
+  se->expr = var;
+  se->string_length = len;
+}
+
+
 /* Get the minimum/maximum value of all the parameters.
     minmax (a1, a2, a3, ...)
     {
@@ -1073,7 +1392,7 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
     limit = convert (type, limit);
   /* Only evaluate the argument once.  */
   if (TREE_CODE (limit) != VAR_DECL && !TREE_CONSTANT (limit))
-    limit = gfc_evaluate_now(limit, &se->pre);
+    limit = gfc_evaluate_now (limit, &se->pre);
 
   mvar = gfc_create_var (type, "M");
   elsecase = build2_v (MODIFY_EXPR, mvar, limit);
@@ -1085,7 +1404,7 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
 
       /* Only evaluate the argument once.  */
       if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
-        val = gfc_evaluate_now(val, &se->pre);
+        val = gfc_evaluate_now (val, &se->pre);
 
       thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
 
@@ -1135,6 +1454,7 @@ static void
 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
 {
   gfc_symbol *sym;
+  tree append_args;
 
   gcc_assert (!se->ss || se->ss->expr == expr);
 
@@ -1144,7 +1464,54 @@ gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
     gcc_assert (expr->rank == 0);
 
   sym = gfc_get_symbol_for_expr (expr);
-  gfc_conv_function_call (se, sym, expr->value.function.actual);
+
+  /* Calls to libgfortran_matmul need to be appended special arguments,
+     to be able to call the BLAS ?gemm functions if required and possible.  */
+  append_args = NULL_TREE;
+  if (expr->value.function.isym->generic_id == GFC_ISYM_MATMUL
+      && sym->ts.type != BT_LOGICAL)
+    {
+      tree cint = gfc_get_int_type (gfc_c_int_kind);
+
+      if (gfc_option.flag_external_blas
+	  && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
+	  && (sym->ts.kind == gfc_default_real_kind
+	      || sym->ts.kind == gfc_default_double_kind))
+	{
+	  tree gemm_fndecl;
+
+	  if (sym->ts.type == BT_REAL)
+	    {
+	      if (sym->ts.kind == gfc_default_real_kind)
+		gemm_fndecl = gfor_fndecl_sgemm;
+	      else
+		gemm_fndecl = gfor_fndecl_dgemm;
+	    }
+	  else
+	    {
+	      if (sym->ts.kind == gfc_default_real_kind)
+		gemm_fndecl = gfor_fndecl_cgemm;
+	      else
+		gemm_fndecl = gfor_fndecl_zgemm;
+	    }
+
+	  append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 1));
+	  append_args = gfc_chainon_list
+			  (append_args, build_int_cst
+					  (cint, gfc_option.blas_matmul_limit));
+	  append_args = gfc_chainon_list (append_args,
+					  gfc_build_addr_expr (NULL_TREE,
+							       gemm_fndecl));
+	}
+      else
+	{
+	  append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 0));
+	  append_args = gfc_chainon_list (append_args, build_int_cst (cint, 0));
+	  append_args = gfc_chainon_list (append_args, null_pointer_node);
+	}
+    }
+
+  gfc_conv_function_call (se, sym, expr->value.function.actual, append_args);
   gfc_free (sym);
 }
 
@@ -1237,8 +1604,8 @@ gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op)
   gfc_conv_expr_val (&arrayse, actual->expr);
 
   gfc_add_block_to_block (&body, &arrayse.pre);
-  tmp = build2 (op, boolean_type_node, arrayse.expr,
-		build_int_cst (TREE_TYPE (arrayse.expr), 0));
+  tmp = fold_build2 (op, boolean_type_node, arrayse.expr,
+		     build_int_cst (TREE_TYPE (arrayse.expr), 0));
   tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt ());
   gfc_add_expr_to_block (&body, tmp);
   gfc_add_block_to_block (&body, &arrayse.post);
@@ -1364,7 +1731,7 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op)
   actual = actual->next->next;
   gcc_assert (actual);
   maskexpr = actual->expr;
-  if (maskexpr)
+  if (maskexpr && maskexpr->rank != 0)
     {
       maskss = gfc_walk_expr (maskexpr);
       gcc_assert (maskss != gfc_ss_terminator);
@@ -1425,6 +1792,122 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op)
   gfc_add_expr_to_block (&body, tmp);
 
   gfc_trans_scalarizing_loops (&loop, &body);
+
+  /* For a scalar mask, enclose the loop in an if statement.  */
+  if (maskexpr && maskss == NULL)
+    {
+      gfc_init_se (&maskse, NULL);
+      gfc_conv_expr_val (&maskse, maskexpr);
+      gfc_init_block (&block);
+      gfc_add_block_to_block (&block, &loop.pre);
+      gfc_add_block_to_block (&block, &loop.post);
+      tmp = gfc_finish_block (&block);
+
+      tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
+      gfc_add_expr_to_block (&block, tmp);
+      gfc_add_block_to_block (&se->pre, &block);
+    }
+  else
+    {
+      gfc_add_block_to_block (&se->pre, &loop.pre);
+      gfc_add_block_to_block (&se->pre, &loop.post);
+    }
+
+  gfc_cleanup_loop (&loop);
+
+  se->expr = resvar;
+}
+
+
+/* Inline implementation of the dot_product intrinsic. This function
+   is based on gfc_conv_intrinsic_arith (the previous function).  */
+static void
+gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
+{
+  tree resvar;
+  tree type;
+  stmtblock_t body;
+  stmtblock_t block;
+  tree tmp;
+  gfc_loopinfo loop;
+  gfc_actual_arglist *actual;
+  gfc_ss *arrayss1, *arrayss2;
+  gfc_se arrayse1, arrayse2;
+  gfc_expr *arrayexpr1, *arrayexpr2;
+
+  type = gfc_typenode_for_spec (&expr->ts);
+
+  /* Initialize the result.  */
+  resvar = gfc_create_var (type, "val");
+  if (expr->ts.type == BT_LOGICAL)
+    tmp = build_int_cst (type, 0);
+  else
+    tmp = gfc_build_const (type, integer_zero_node);
+
+  gfc_add_modify_expr (&se->pre, resvar, tmp);
+
+  /* Walk argument #1.  */
+  actual = expr->value.function.actual;
+  arrayexpr1 = actual->expr;
+  arrayss1 = gfc_walk_expr (arrayexpr1);
+  gcc_assert (arrayss1 != gfc_ss_terminator);
+
+  /* Walk argument #2.  */
+  actual = actual->next;
+  arrayexpr2 = actual->expr;
+  arrayss2 = gfc_walk_expr (arrayexpr2);
+  gcc_assert (arrayss2 != gfc_ss_terminator);
+
+  /* Initialize the scalarizer.  */
+  gfc_init_loopinfo (&loop);
+  gfc_add_ss_to_loop (&loop, arrayss1);
+  gfc_add_ss_to_loop (&loop, arrayss2);
+
+  /* Initialize the loop.  */
+  gfc_conv_ss_startstride (&loop);
+  gfc_conv_loop_setup (&loop);
+
+  gfc_mark_ss_chain_used (arrayss1, 1);
+  gfc_mark_ss_chain_used (arrayss2, 1);
+
+  /* Generate the loop body.  */
+  gfc_start_scalarized_body (&loop, &body);
+  gfc_init_block (&block);
+
+  /* Make the tree expression for [conjg(]array1[)].  */
+  gfc_init_se (&arrayse1, NULL);
+  gfc_copy_loopinfo_to_se (&arrayse1, &loop);
+  arrayse1.ss = arrayss1;
+  gfc_conv_expr_val (&arrayse1, arrayexpr1);
+  if (expr->ts.type == BT_COMPLEX)
+    arrayse1.expr = build1 (CONJ_EXPR, type, arrayse1.expr);
+  gfc_add_block_to_block (&block, &arrayse1.pre);
+
+  /* Make the tree expression for array2.  */
+  gfc_init_se (&arrayse2, NULL);
+  gfc_copy_loopinfo_to_se (&arrayse2, &loop);
+  arrayse2.ss = arrayss2;
+  gfc_conv_expr_val (&arrayse2, arrayexpr2);
+  gfc_add_block_to_block (&block, &arrayse2.pre);
+
+  /* Do the actual product and sum.  */
+  if (expr->ts.type == BT_LOGICAL)
+    {
+      tmp = build2 (TRUTH_AND_EXPR, type, arrayse1.expr, arrayse2.expr);
+      tmp = build2 (TRUTH_OR_EXPR, type, resvar, tmp);
+    }
+  else
+    {
+      tmp = build2 (MULT_EXPR, type, arrayse1.expr, arrayse2.expr);
+      tmp = build2 (PLUS_EXPR, type, resvar, tmp);
+    }
+  gfc_add_modify_expr (&block, resvar, tmp);
+
+  /* Finish up the loop block and the loop.  */
+  tmp = gfc_finish_block (&block);
+  gfc_add_expr_to_block (&body, tmp);
+
+  gfc_trans_scalarizing_loops (&loop, &body);
   gfc_add_block_to_block (&se->pre, &loop.pre);
   gfc_add_block_to_block (&se->pre, &loop.post);
   gfc_cleanup_loop (&loop);
@@ -1432,17 +1915,19 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op)
   se->expr = resvar;
 }
 
+
 static void
 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
 {
   stmtblock_t body;
   stmtblock_t block;
   stmtblock_t ifblock;
+  stmtblock_t elseblock;
   tree limit;
   tree type;
   tree tmp;
+  tree elsetmp;
   tree ifbody;
-  tree cond;
   gfc_loopinfo loop;
   gfc_actual_arglist *actual;
   gfc_ss *arrayss;
@@ -1473,7 +1958,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
   actual = actual->next->next;
   gcc_assert (actual);
   maskexpr = actual->expr;
-  if (maskexpr)
+  if (maskexpr && maskexpr->rank != 0)
     {
       maskss = gfc_walk_expr (maskexpr);
       gcc_assert (maskss != gfc_ss_terminator);
@@ -1498,11 +1983,18 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
       gcc_unreachable ();
     }
 
-  /* Most negative(+HUGE) for maxval, most negative (-HUGE) for minval.  */
+  /* We start with the most negative possible value for MAXLOC, and the most
+     positive possible value for MINLOC. The most negative possible value is
+     -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
+     possible value is HUGE in both cases. */
   if (op == GT_EXPR)
     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
   gfc_add_modify_expr (&se->pre, limit, tmp);
 
+  if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
+    tmp = build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
+		  build_int_cst (type, 1));
+
   /* Initialize the scalarizer.  */
   gfc_init_loopinfo (&loop);
   gfc_add_ss_to_loop (&loop, arrayss);
@@ -1515,17 +2007,10 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
 
   gcc_assert (loop.dimen == 1);
 
-  /* Initialize the position to the first element.  If the array has zero
-     size we need to return zero.  Otherwise use the first element of the
-     array, in case all elements are equal to the limit.
-     i.e. pos = (ubound >= lbound) ? lbound, lbound - 1;  */
-  tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
-		     loop.from[0], gfc_index_one_node);
-  cond = fold_build2 (GE_EXPR, boolean_type_node,
-		      loop.to[0], loop.from[0]);
-  tmp = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
-		     loop.from[0], tmp);
-  gfc_add_modify_expr (&loop.pre, pos, tmp);
+  /* Initialize the position to zero, following Fortran 2003.  We are free
+     to do this because Fortran 95 allows the result of an entirely false
+     mask to be processor dependent.  */
+  gfc_add_modify_expr (&loop.pre, pos, gfc_index_zero_node);
 
   gfc_mark_ss_chain_used (arrayss, 1);
   if (maskss)
@@ -1565,8 +2050,10 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
 
   ifbody = gfc_finish_block (&ifblock);
 
-  /* If it is a more extreme value.  */
-  tmp = build2 (op, boolean_type_node, arrayse.expr, limit);
+  /* If it is a more extreme value or pos is still zero.  */
+  tmp = build2 (TRUTH_OR_EXPR, boolean_type_node,
+		  build2 (op, boolean_type_node, arrayse.expr, limit),
+		  build2 (EQ_EXPR, boolean_type_node, pos, gfc_index_zero_node));
   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
   gfc_add_expr_to_block (&block, tmp);
 
@@ -1583,15 +2070,39 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
 
   gfc_trans_scalarizing_loops (&loop, &body);
 
-  gfc_add_block_to_block (&se->pre, &loop.pre);
-  gfc_add_block_to_block (&se->pre, &loop.post);
-  gfc_cleanup_loop (&loop);
+  /* For a scalar mask, enclose the loop in an if statement.  */
+  if (maskexpr && maskss == NULL)
+    {
+      gfc_init_se (&maskse, NULL);
+      gfc_conv_expr_val (&maskse, maskexpr);
+      gfc_init_block (&block);
+      gfc_add_block_to_block (&block, &loop.pre);
+      gfc_add_block_to_block (&block, &loop.post);
+      tmp = gfc_finish_block (&block);
 
-  /* Return a value in the range 1..SIZE(array).  */
-  tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, loop.from[0],
-		     gfc_index_one_node);
-  tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, pos, tmp);
-  /* And convert to the required type.  */
+      /* For the else part of the scalar mask, just initialize
+	 the pos variable the same way as above.  */
+
+      gfc_init_block (&elseblock);
+      gfc_add_modify_expr (&elseblock, pos, gfc_index_zero_node);
+      elsetmp = gfc_finish_block (&elseblock);
+
+      tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
+      gfc_add_expr_to_block (&block, tmp);
+      gfc_add_block_to_block (&se->pre, &block);
+    }
+  else
+    {
+      gfc_add_block_to_block (&se->pre, &loop.pre);
+      gfc_add_block_to_block (&se->pre, &loop.post);
+    }
+  gfc_cleanup_loop (&loop);
+
+  /* Return a value in the range 1..SIZE(array).  */
+  tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, loop.from[0],
+		     gfc_index_one_node);
+  tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, pos, tmp);
+  /* And convert to the required type.  */
   se->expr = convert (type, tmp);
 }
 
@@ -1638,9 +2149,17 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op)
       gcc_unreachable ();
     }
 
-  /* Most negative(-HUGE) for maxval, most positive (-HUGE) for minval.  */
+  /* We start with the most negative possible value for MAXVAL, and the most
+     positive possible value for MINVAL. The most negative possible value is
+     -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
+     possible value is HUGE in both cases. */
   if (op == GT_EXPR)
     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
+
+  if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
+    tmp = build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
+		  build_int_cst (type, 1));
+
   gfc_add_modify_expr (&se->pre, limit, tmp);
 
   /* Walk the arguments.  */
@@ -1652,7 +2171,7 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op)
   actual = actual->next->next;
   gcc_assert (actual);
   maskexpr = actual->expr;
-  if (maskexpr)
+  if (maskexpr && maskexpr->rank != 0)
     {
       maskss = gfc_walk_expr (maskexpr);
       gcc_assert (maskss != gfc_ss_terminator);
@@ -1714,8 +2233,26 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op)
 
   gfc_trans_scalarizing_loops (&loop, &body);
 
-  gfc_add_block_to_block (&se->pre, &loop.pre);
-  gfc_add_block_to_block (&se->pre, &loop.post);
+  /* For a scalar mask, enclose the loop in an if statement.  */
+  if (maskexpr && maskss == NULL)
+    {
+      gfc_init_se (&maskse, NULL);
+      gfc_conv_expr_val (&maskse, maskexpr);
+      gfc_init_block (&block);
+      gfc_add_block_to_block (&block, &loop.pre);
+      gfc_add_block_to_block (&block, &loop.post);
+      tmp = gfc_finish_block (&block);
+
+      tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
+      gfc_add_expr_to_block (&block, tmp);
+      gfc_add_block_to_block (&se->pre, &block);
+    }
+  else
+    {
+      gfc_add_block_to_block (&se->pre, &loop.pre);
+      gfc_add_block_to_block (&se->pre, &loop.post);
+    }
+
   gfc_cleanup_loop (&loop);
 
   se->expr = limit;
@@ -1816,7 +2353,7 @@ gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
   arg2 = TREE_VALUE (arg2);
   type = TREE_TYPE (arg);
 
-  mask = build_int_cst (NULL_TREE, -1);
+  mask = build_int_cst (type, -1);
   mask = build2 (LSHIFT_EXPR, type, mask, arg3);
   mask = build1 (BIT_NOT_EXPR, type, mask);
 
@@ -1825,6 +2362,22 @@ gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
   se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
 }
 
+/* RSHIFT (I, SHIFT) = I >> SHIFT
+   LSHIFT (I, SHIFT) = I << SHIFT  */
+static void
+gfc_conv_intrinsic_rlshift (gfc_se * se, gfc_expr * expr, int right_shift)
+{
+  tree arg;
+  tree arg2;
+
+  arg = gfc_conv_intrinsic_function_args (se, expr);
+  arg2 = TREE_VALUE (TREE_CHAIN (arg));
+  arg = TREE_VALUE (arg);
+
+  se->expr = fold_build2 (right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
+			  TREE_TYPE (arg), arg, arg2);
+}
+
 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
                         ? 0
 	 	        : ((shift >= 0) ? i << shift : i >> -shift)
@@ -1847,7 +2400,7 @@ gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
   arg2 = TREE_VALUE (TREE_CHAIN (arg));
   arg = TREE_VALUE (arg);
   type = TREE_TYPE (arg);
-  utype = gfc_unsigned_type (type);
+  utype = unsigned_type_for (type);
 
   width = fold_build1 (ABS_EXPR, TREE_TYPE (arg2), arg2);
 
@@ -1929,7 +2482,7 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
 	default:
 	  gcc_unreachable ();
 	}
-      se->expr = gfc_build_function_call (tmp, arg);
+      se->expr = build_function_call_expr (tmp, arg);
       /* Convert the result back to the original type, if we extended
 	 the first argument's width above.  */
       if (expr->ts.kind < 4)
@@ -1967,6 +2520,7 @@ gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
   gfc_symbol *sym;
   gfc_se argse;
   gfc_expr *arg;
+  gfc_ss *ss;
 
   gcc_assert (!se->ss);
 
@@ -1979,32 +2533,44 @@ gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
       len = build_int_cst (NULL_TREE, arg->value.character.length);
       break;
 
-    default:
-	if (arg->expr_type == EXPR_VARIABLE
-	    && (arg->ref == NULL || (arg->ref->next == NULL
-				     && arg->ref->type == REF_ARRAY)))
-	  {
-	    /* This doesn't catch all cases.
-	       See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
-	       and the surrounding thread.  */
-	    sym = arg->symtree->n.sym;
-	    decl = gfc_get_symbol_decl (sym);
-	    if (decl == current_function_decl && sym->attr.function
+    case EXPR_ARRAY:
+      /* Obtain the string length from the function used by
+         trans-array.c(gfc_trans_array_constructor).  */
+      len = NULL_TREE;
+      get_array_ctor_strlen (arg->value.constructor, &len);
+      break;
+
+    case EXPR_VARIABLE:
+      if (arg->ref == NULL
+	    || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
+	{
+	  /* This doesn't catch all cases.
+	     See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
+	     and the surrounding thread.  */
+	  sym = arg->symtree->n.sym;
+	  decl = gfc_get_symbol_decl (sym);
+	  if (decl == current_function_decl && sym->attr.function
 		&& (sym->result == sym))
-	      decl = gfc_get_fake_result_decl (sym);
-
-	    len = sym->ts.cl->backend_decl;
-	    gcc_assert (len);
-	  }
-	else
-	  {
-	    /* Anybody stupid enough to do this deserves inefficient code.  */
-	    gfc_init_se (&argse, se);
-	    gfc_conv_expr (&argse, arg);
-	    gfc_add_block_to_block (&se->pre, &argse.pre);
-	    gfc_add_block_to_block (&se->post, &argse.post);
-	    len = argse.string_length;
+	    decl = gfc_get_fake_result_decl (sym, 0);
+
+	  len = sym->ts.cl->backend_decl;
+	  gcc_assert (len);
+	  break;
 	}
+
+      /* Otherwise fall through.  */
+
+    default:
+      /* Anybody stupid enough to do this deserves inefficient code.  */
+      ss = gfc_walk_expr (arg);
+      gfc_init_se (&argse, se);
+      if (ss == gfc_ss_terminator)
+	gfc_conv_expr (&argse, arg);
+      else
+	gfc_conv_expr_descriptor (&argse, arg, ss);
+      gfc_add_block_to_block (&se->pre, &argse.pre);
+      gfc_add_block_to_block (&se->post, &argse.post);
+      len = argse.string_length;
       break;
     }
   se->expr = convert (type, len);
@@ -2019,7 +2585,7 @@ gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
 
   args = gfc_conv_intrinsic_function_args (se, expr);
   type = gfc_typenode_for_spec (&expr->ts);
-  se->expr = gfc_build_function_call (gfor_fndecl_string_len_trim, args);
+  se->expr = build_function_call_expr (gfor_fndecl_string_len_trim, args);
   se->expr = convert (type, se->expr);
 }
 
@@ -2050,7 +2616,7 @@ gfc_conv_intrinsic_index (gfc_se * se, gfc_expr * expr)
       TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
     }
 
-  se->expr = gfc_build_function_call (gfor_fndecl_string_index, args);
+  se->expr = build_function_call_expr (gfor_fndecl_string_index, args);
   se->expr = convert (type, se->expr);
 }
 
@@ -2067,7 +2633,7 @@ gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
   arg = build1 (NOP_EXPR, pchar_type_node, arg);
   type = gfc_typenode_for_spec (&expr->ts);
 
-  se->expr = gfc_build_indirect_ref (arg);
+  se->expr = build_fold_indirect_ref (arg);
   se->expr = convert (type, se->expr);
 }
 
@@ -2115,9 +2681,10 @@ static void
 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
 {
   gfc_actual_arglist *actual;
-  tree args;
+  tree arg1;
   tree type;
-  tree fndecl;
+  tree fncall0;
+  tree fncall1;
   gfc_se argse;
   gfc_ss *ss;
 
@@ -2127,24 +2694,52 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
   ss = gfc_walk_expr (actual->expr);
   gcc_assert (ss != gfc_ss_terminator);
   argse.want_pointer = 1;
+  argse.data_not_needed = 1;
   gfc_conv_expr_descriptor (&argse, actual->expr, ss);
   gfc_add_block_to_block (&se->pre, &argse.pre);
   gfc_add_block_to_block (&se->post, &argse.post);
-  args = gfc_chainon_list (NULL_TREE, argse.expr);
+  arg1 = gfc_evaluate_now (argse.expr, &se->pre);
+
+  /* Build the call to size0.  */
+  fncall0 = build_call_expr (gfor_fndecl_size0, 1, arg1);
 
   actual = actual->next;
+
   if (actual->expr)
     {
       gfc_init_se (&argse, NULL);
-      gfc_conv_expr_type (&argse, actual->expr, gfc_array_index_type);
+      gfc_conv_expr_type (&argse, actual->expr,
+			  gfc_array_index_type);
       gfc_add_block_to_block (&se->pre, &argse.pre);
-      args = gfc_chainon_list (args, argse.expr);
-      fndecl = gfor_fndecl_size1;
+
+      /* Build the call to size1.  */
+      fncall1 = build_call_expr (gfor_fndecl_size1, 2,
+				 arg1, argse.expr);
+
+      /* Unusually, for an intrinsic, size does not exclude
+	 an optional arg2, so we must test for it.  */  
+      if (actual->expr->expr_type == EXPR_VARIABLE
+	    && actual->expr->symtree->n.sym->attr.dummy
+	    && actual->expr->symtree->n.sym->attr.optional)
+	{
+	  tree tmp;
+	  gfc_init_se (&argse, NULL);
+	  argse.want_pointer = 1;
+	  argse.data_not_needed = 1;
+	  gfc_conv_expr (&argse, actual->expr);
+	  gfc_add_block_to_block (&se->pre, &argse.pre);
+	  tmp = build2 (NE_EXPR, boolean_type_node, argse.expr,
+			null_pointer_node);
+	  tmp = gfc_evaluate_now (tmp, &se->pre);
+	  se->expr = build3 (COND_EXPR, pvoid_type_node,
+			     tmp, fncall1, fncall0);
+	}
+      else
+	se->expr = fncall1;
     }
   else
-    fndecl = gfor_fndecl_size0;
+    se->expr = fncall0;
 
-  se->expr = gfc_build_function_call (fndecl, args);
   type = gfc_typenode_for_spec (&expr->ts);
   se->expr = convert (type, se->expr);
 }
@@ -2157,13 +2752,17 @@ gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
 {
   tree type;
   tree args;
+  tree arg2;
 
   args = gfc_conv_intrinsic_function_args (se, expr);
-  /* Build a call for the comparison.  */
-  se->expr = gfc_build_function_call (gfor_fndecl_compare_string, args);
+  arg2 = TREE_CHAIN (TREE_CHAIN (args));
+
+  se->expr = gfc_build_compare_string (TREE_VALUE (args),
+		TREE_VALUE (TREE_CHAIN (args)), TREE_VALUE (arg2),
+		TREE_VALUE (TREE_CHAIN (arg2)));
 
   type = gfc_typenode_for_spec (&expr->ts);
-  se->expr = build2 (op, type, se->expr,
+  se->expr = fold_build2 (op, type, se->expr,
 		     build_int_cst (TREE_TYPE (se->expr), 0));
 }
 
@@ -2184,15 +2783,257 @@ gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
   var = gfc_conv_string_tmp (se, type, len);
   args = tree_cons (NULL_TREE, var, args);
 
-  tmp = gfc_build_function_call (fndecl, args);
+  tmp = build_function_call_expr (fndecl, args);
   gfc_add_expr_to_block (&se->pre, tmp);
   se->expr = var;
   se->string_length = len;
 }
 
 
+/* Array transfer statement.
+     DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
+   where:
+     typeof<DEST> = typeof<MOLD>
+   and:
+     N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
+	      sizeof (DEST(0) * SIZE).  */
+
+static void
+gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
+{
+  tree tmp;
+  tree extent;
+  tree source;
+  tree source_type;
+  tree source_bytes;
+  tree mold_type;
+  tree dest_word_len;
+  tree size_words;
+  tree size_bytes;
+  tree upper;
+  tree lower;
+  tree stride;
+  tree stmt;
+  gfc_actual_arglist *arg;
+  gfc_se argse;
+  gfc_ss *ss;
+  gfc_ss_info *info;
+  stmtblock_t block;
+  int n;
+
+  gcc_assert (se->loop);
+  info = &se->ss->data.info;
+
+  /* Convert SOURCE.  The output from this stage is:-
+	source_bytes = length of the source in bytes
+	source = pointer to the source data.  */
+  arg = expr->value.function.actual;
+  gfc_init_se (&argse, NULL);
+  ss = gfc_walk_expr (arg->expr);
+
+  source_bytes = gfc_create_var (gfc_array_index_type, NULL);
+
+  /* Obtain the pointer to source and the length of source in bytes.  */
+  if (ss == gfc_ss_terminator)
+    {
+      gfc_conv_expr_reference (&argse, arg->expr);
+      source = argse.expr;
+
+      source_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
+
+      /* Obtain the source word length.  */
+      if (arg->expr->ts.type == BT_CHARACTER)
+	tmp = fold_convert (gfc_array_index_type, argse.string_length);
+      else
+	tmp = fold_convert (gfc_array_index_type,
+			    size_in_bytes (source_type)); 
+    }
+  else
+    {
+      gfc_init_se (&argse, NULL);
+      argse.want_pointer = 0;
+      gfc_conv_expr_descriptor (&argse, arg->expr, ss);
+      source = gfc_conv_descriptor_data_get (argse.expr);
+      source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
+
+      /* Repack the source if not a full variable array.  */
+      if (!(arg->expr->expr_type == EXPR_VARIABLE
+	      && arg->expr->ref->u.ar.type == AR_FULL))
+	{
+	  tmp = build_fold_addr_expr (argse.expr);
+	  source = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
+	  source = gfc_evaluate_now (source, &argse.pre);
+
+	  /* Free the temporary.  */
+	  gfc_start_block (&block);
+	  tmp = gfc_call_free (convert (pvoid_type_node, source));
+	  gfc_add_expr_to_block (&block, tmp);
+	  stmt = gfc_finish_block (&block);
+
+	  /* Clean up if it was repacked.  */
+	  gfc_init_block (&block);
+	  tmp = gfc_conv_array_data (argse.expr);
+	  tmp = build2 (NE_EXPR, boolean_type_node, source, tmp);
+	  tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
+	  gfc_add_expr_to_block (&block, tmp);
+	  gfc_add_block_to_block (&block, &se->post);
+	  gfc_init_block (&se->post);
+	  gfc_add_block_to_block (&se->post, &block);
+	}
+
+      /* Obtain the source word length.  */
+      if (arg->expr->ts.type == BT_CHARACTER)
+	tmp = fold_convert (gfc_array_index_type, argse.string_length);
+      else
+	tmp = fold_convert (gfc_array_index_type,
+			    size_in_bytes (source_type)); 
+
+      /* Obtain the size of the array in bytes.  */
+      extent = gfc_create_var (gfc_array_index_type, NULL);
+      for (n = 0; n < arg->expr->rank; n++)
+	{
+	  tree idx;
+	  idx = gfc_rank_cst[n];
+	  gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
+	  stride = gfc_conv_descriptor_stride (argse.expr, idx);
+	  lower = gfc_conv_descriptor_lbound (argse.expr, idx);
+	  upper = gfc_conv_descriptor_ubound (argse.expr, idx);
+	  tmp = build2 (MINUS_EXPR, gfc_array_index_type,
+			upper, lower);
+	  gfc_add_modify_expr (&argse.pre, extent, tmp);
+	  tmp = build2 (PLUS_EXPR, gfc_array_index_type,
+			extent, gfc_index_one_node);
+	  tmp = build2 (MULT_EXPR, gfc_array_index_type,
+			tmp, source_bytes);
+	}
+    }
+
+  gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
+  gfc_add_block_to_block (&se->pre, &argse.pre);
+  gfc_add_block_to_block (&se->post, &argse.post);
+
+  /* Now convert MOLD.  The outputs are:
+	mold_type = the TREE type of MOLD
+	dest_word_len = destination word length in bytes.  */
+  arg = arg->next;
+
+  gfc_init_se (&argse, NULL);
+  ss = gfc_walk_expr (arg->expr);
+
+  if (ss == gfc_ss_terminator)
+    {
+      gfc_conv_expr_reference (&argse, arg->expr);
+      mold_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
+    }
+  else
+    {
+      gfc_init_se (&argse, NULL);
+      argse.want_pointer = 0;
+      gfc_conv_expr_descriptor (&argse, arg->expr, ss);
+      mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
+    }
+
+  if (arg->expr->ts.type == BT_CHARACTER)
+    {
+      tmp = fold_convert (gfc_array_index_type, argse.string_length);
+      mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
+    }
+  else
+    tmp = fold_convert (gfc_array_index_type,
+			size_in_bytes (mold_type)); 
+ 
+  dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
+  gfc_add_modify_expr (&se->pre, dest_word_len, tmp);
+
+  /* Finally convert SIZE, if it is present.  */
+  arg = arg->next;
+  size_words = gfc_create_var (gfc_array_index_type, NULL);
+
+  if (arg->expr)
+    {
+      gfc_init_se (&argse, NULL);
+      gfc_conv_expr_reference (&argse, arg->expr);
+      tmp = convert (gfc_array_index_type,
+			 build_fold_indirect_ref (argse.expr));
+      gfc_add_block_to_block (&se->pre, &argse.pre);
+      gfc_add_block_to_block (&se->post, &argse.post);
+    }
+  else
+    tmp = NULL_TREE;
+
+  size_bytes = gfc_create_var (gfc_array_index_type, NULL);
+  if (tmp != NULL_TREE)
+    {
+      tmp = build2 (MULT_EXPR, gfc_array_index_type,
+		    tmp, dest_word_len);
+      tmp = build2 (MIN_EXPR, gfc_array_index_type, tmp, source_bytes);
+    }
+  else
+    tmp = source_bytes;
+
+  gfc_add_modify_expr (&se->pre, size_bytes, tmp);
+  gfc_add_modify_expr (&se->pre, size_words,
+		       build2 (CEIL_DIV_EXPR, gfc_array_index_type,
+			       size_bytes, dest_word_len));
+
+  /* Evaluate the bounds of the result.  If the loop range exists, we have
+     to check if it is too large.  If so, we modify loop->to be consistent
+     with min(size, size(source)).  Otherwise, size is made consistent with
+     the loop range, so that the right number of bytes is transferred.*/
+  n = se->loop->order[0];
+  if (se->loop->to[n] != NULL_TREE)
+    {
+      tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+			 se->loop->to[n], se->loop->from[n]);
+      tmp = build2 (PLUS_EXPR, gfc_array_index_type,
+		    tmp, gfc_index_one_node);
+      tmp = build2 (MIN_EXPR, gfc_array_index_type,
+		    tmp, size_words);
+      gfc_add_modify_expr (&se->pre, size_words, tmp);
+      gfc_add_modify_expr (&se->pre, size_bytes,
+			   build2 (MULT_EXPR, gfc_array_index_type,
+			   size_words, dest_word_len));
+      upper = build2 (PLUS_EXPR, gfc_array_index_type,
+		      size_words, se->loop->from[n]);
+      upper = build2 (MINUS_EXPR, gfc_array_index_type,
+		      upper, gfc_index_one_node);
+    }
+  else
+    {
+      upper = build2 (MINUS_EXPR, gfc_array_index_type,
+		      size_words, gfc_index_one_node);
+      se->loop->from[n] = gfc_index_zero_node;
+    }
+
+  se->loop->to[n] = upper;
+
+  /* Build a destination descriptor, using the pointer, source, as the
+     data field.  This is already allocated so set callee_alloc.
+     FIXME callee_alloc is not set!  */
+
+  gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
+			       info, mold_type, false, true, false);
+
+  /* Cast the pointer to the result.  */
+  tmp = gfc_conv_descriptor_data_get (info->descriptor);
+  tmp = fold_convert (pvoid_type_node, tmp);
+
+  /* Use memcpy to do the transfer.  */
+  tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY],
+			 3,
+			 tmp,
+			 fold_convert (pvoid_type_node, source),
+			 size_bytes);
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  se->expr = info->descriptor;
+  if (expr->ts.type == BT_CHARACTER)
+    se->string_length = dest_word_len;
+}
+
+
 /* Scalar transfer statement.
-   TRANSFER (source, mold) = *(typeof<mould> *)&source  */
+   TRANSFER (source, mold) = memcpy(&tmpdecl, &source, size), tmpdecl.  */
 
 static void
 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
@@ -2202,8 +3043,7 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
   tree type;
   tree ptr;
   gfc_ss *ss;
-
-  gcc_assert (!se->ss);
+  tree tmpdecl, tmp;
 
   /* Get a pointer to the source.  */
   arg = expr->value.function.actual;
@@ -2219,9 +3059,10 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
 
   arg = arg->next;
   type = gfc_typenode_for_spec (&expr->ts);
-  ptr = convert (build_pointer_type (type), ptr);
+
   if (expr->ts.type == BT_CHARACTER)
     {
+      ptr = convert (build_pointer_type (type), ptr);
       gfc_init_se (&argse, NULL);
       gfc_conv_expr (&argse, arg->expr);
       gfc_add_block_to_block (&se->pre, &argse.pre);
@@ -2231,7 +3072,19 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
     }
   else
     {
-      se->expr = gfc_build_indirect_ref (ptr);
+      tree moldsize;
+      tmpdecl = gfc_create_var (type, "transfer");
+      moldsize = size_in_bytes (type);
+
+      /* Use memcpy to do the transfer.  */
+      tmp = build1 (ADDR_EXPR, build_pointer_type (type), tmpdecl);
+      tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
+			     fold_convert (pvoid_type_node, tmp),
+			     fold_convert (pvoid_type_node, ptr),
+			     moldsize);
+      gfc_add_expr_to_block (&se->pre, tmp);
+
+      se->expr = tmpdecl;
     }
 }
 
@@ -2275,7 +3128,9 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
   gfc_se arg2se;
   tree tmp2;
   tree tmp;
-  tree args, fndecl;
+  tree fndecl;
+  tree nonzero_charlen;
+  tree nonzero_arraylen;
   gfc_ss *ss1, *ss2;
 
   gfc_init_se (&arg1se, NULL);
@@ -2297,10 +3152,11 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
       else
         {
           /* A pointer to an array.  */
-          arg1se.descriptor_only = 1;
-          gfc_conv_expr_lhs (&arg1se, arg1->expr);
+          gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
           tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
         }
+      gfc_add_block_to_block (&se->pre, &arg1se.pre);
+      gfc_add_block_to_block (&se->post, &arg1se.post);
       tmp = build2 (NE_EXPR, boolean_type_node, tmp2,
 		    fold_convert (TREE_TYPE (tmp2), null_pointer_node));
       se->expr = tmp;
@@ -2309,6 +3165,13 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
     {
       /* An optional target.  */
       ss2 = gfc_walk_expr (arg2->expr);
+
+      nonzero_charlen = NULL_TREE;
+      if (arg1->expr->ts.type == BT_CHARACTER)
+	nonzero_charlen = build2 (NE_EXPR, boolean_type_node,
+				  arg1->expr->ts.cl->backend_decl,
+				  integer_zero_node);
+
       if (ss1 == gfc_ss_terminator)
         {
           /* A pointer to a scalar.  */
@@ -2317,26 +3180,48 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
           gfc_conv_expr (&arg1se, arg1->expr);
           arg2se.want_pointer = 1;
           gfc_conv_expr (&arg2se, arg2->expr);
+	  gfc_add_block_to_block (&se->pre, &arg1se.pre);
+	  gfc_add_block_to_block (&se->post, &arg1se.post);
           tmp = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr);
-          se->expr = tmp;
+          tmp2 = build2 (NE_EXPR, boolean_type_node, arg1se.expr,
+                         null_pointer_node);
+          se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node, tmp, tmp2);
         }
       else
         {
+
+	  /* An array pointer of zero length is not associated if target is
+	     present.  */
+	  arg1se.descriptor_only = 1;
+	  gfc_conv_expr_lhs (&arg1se, arg1->expr);
+	  tmp = gfc_conv_descriptor_stride (arg1se.expr,
+					    gfc_rank_cst[arg1->expr->rank - 1]);
+	  nonzero_arraylen = build2 (NE_EXPR, boolean_type_node,
+				 tmp, integer_zero_node);
+
           /* A pointer to an array, call library function _gfor_associated.  */
           gcc_assert (ss2 != gfc_ss_terminator);
-          args = NULL_TREE;
           arg1se.want_pointer = 1;
           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
-          args = gfc_chainon_list (args, arg1se.expr);
+
           arg2se.want_pointer = 1;
           gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
           gfc_add_block_to_block (&se->pre, &arg2se.pre);
           gfc_add_block_to_block (&se->post, &arg2se.post);
-          args = gfc_chainon_list (args, arg2se.expr);
           fndecl = gfor_fndecl_associated;
-          se->expr = gfc_build_function_call (fndecl, args);
+          se->expr = build_call_expr (fndecl, 2, arg1se.expr, arg2se.expr);
+	  se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
+			     se->expr, nonzero_arraylen);
+
         }
-     }
+
+      /* If target is present zero character length pointers cannot
+	 be associated.  */
+      if (nonzero_charlen != NULL_TREE)
+	se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
+			   se->expr, nonzero_charlen);
+    }
+
   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
 }
 
@@ -2367,7 +3252,7 @@ gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr)
       TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
     }
 
-  se->expr = gfc_build_function_call (gfor_fndecl_string_scan, args);
+  se->expr = build_function_call_expr (gfor_fndecl_string_scan, args);
   se->expr = convert (type, se->expr);
 }
 
@@ -2400,207 +3285,10 @@ gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr)
       TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
     }
 
-  se->expr = gfc_build_function_call (gfor_fndecl_string_verify, args);
+  se->expr = build_function_call_expr (gfor_fndecl_string_verify, args);
   se->expr = convert (type, se->expr);
 }
 
-/* Prepare components and related information of a real number which is
-   the first argument of a elemental functions to manipulate reals.  */
-
-static void
-prepare_arg_info (gfc_se * se, gfc_expr * expr,
-		  real_compnt_info * rcs, int all)
-{
-   tree arg;
-   tree masktype;
-   tree tmp;
-   tree wbits;
-   tree one;
-   tree exponent, fraction;
-   int n;
-   gfc_expr *a1;
-
-   if (TARGET_FLOAT_FORMAT != IEEE_FLOAT_FORMAT)
-     gfc_todo_error ("Non-IEEE floating format");
-
-   gcc_assert (expr->expr_type == EXPR_FUNCTION);
-
-   arg = gfc_conv_intrinsic_function_args (se, expr);
-   arg = TREE_VALUE (arg);
-   rcs->type = TREE_TYPE (arg);
-
-   /* Force arg'type to integer by unaffected convert  */
-   a1 = expr->value.function.actual->expr;
-   masktype = gfc_get_int_type (a1->ts.kind);
-   rcs->mtype = masktype;
-   tmp = build1 (VIEW_CONVERT_EXPR, masktype, arg);
-   arg = gfc_create_var (masktype, "arg");
-   gfc_add_modify_expr(&se->pre, arg, tmp);
-   rcs->arg = arg;
-
-   /* Calculate the numbers of bits of exponent, fraction and word  */
-   n = gfc_validate_kind (a1->ts.type, a1->ts.kind, false);
-   tmp = build_int_cst (NULL_TREE, gfc_real_kinds[n].digits - 1);
-   rcs->fdigits = convert (masktype, tmp);
-   wbits = build_int_cst (NULL_TREE, TYPE_PRECISION (rcs->type) - 1);
-   wbits = convert (masktype, wbits);
-   rcs->edigits = fold_build2 (MINUS_EXPR, masktype, wbits, tmp);
-
-   /* Form masks for exponent/fraction/sign  */
-   one = gfc_build_const (masktype, integer_one_node);
-   rcs->smask = fold_build2 (LSHIFT_EXPR, masktype, one, wbits);
-   rcs->f1 = fold_build2 (LSHIFT_EXPR, masktype, one, rcs->fdigits);
-   rcs->emask = fold_build2 (MINUS_EXPR, masktype, rcs->smask, rcs->f1);
-   rcs->fmask = fold_build2 (MINUS_EXPR, masktype, rcs->f1, one);
-   /* Form bias.  */
-   tmp = fold_build2 (MINUS_EXPR, masktype, rcs->edigits, one);
-   tmp = fold_build2 (LSHIFT_EXPR, masktype, one, tmp);
-   rcs->bias = fold_build2 (MINUS_EXPR, masktype, tmp ,one);
-
-   if (all)
-     {
-       /* exponent, and fraction  */
-       tmp = build2 (BIT_AND_EXPR, masktype, arg, rcs->emask);
-       tmp = build2 (RSHIFT_EXPR, masktype, tmp, rcs->fdigits);
-       exponent = gfc_create_var (masktype, "exponent");
-       gfc_add_modify_expr(&se->pre, exponent, tmp);
-       rcs->expn = exponent;
-
-       tmp = build2 (BIT_AND_EXPR, masktype, arg, rcs->fmask);
-       fraction = gfc_create_var (masktype, "fraction");
-       gfc_add_modify_expr(&se->pre, fraction, tmp);
-       rcs->frac = fraction;
-     }
-}
-
-/* Build a call to __builtin_clz.  */
-
-static tree
-call_builtin_clz (tree result_type, tree op0)
-{
-  tree fn, parms, call;
-  enum machine_mode op0_mode = TYPE_MODE (TREE_TYPE (op0));
-
-  if (op0_mode == TYPE_MODE (integer_type_node))
-    fn = built_in_decls[BUILT_IN_CLZ];
-  else if (op0_mode == TYPE_MODE (long_integer_type_node))
-    fn = built_in_decls[BUILT_IN_CLZL];
-  else if (op0_mode == TYPE_MODE (long_long_integer_type_node))
-    fn = built_in_decls[BUILT_IN_CLZLL];
-  else
-    gcc_unreachable ();
-
-  parms = tree_cons (NULL, op0, NULL);
-  call = gfc_build_function_call (fn, parms);
-
-  return convert (result_type, call);
-}
-
-
-/* Generate code for SPACING (X) intrinsic function.
-   SPACING (X) = POW (2, e-p)
-
-   We generate:
-
-    t = expn - fdigits // e - p.
-    res = t << fdigits // Form the exponent. Fraction is zero.
-    if (t < 0) // The result is out of range. Denormalized case.
-      res = tiny(X)
- */
-
-static void
-gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
-{
-   tree arg;
-   tree masktype;
-   tree tmp, t1, cond;
-   tree tiny, zero;
-   tree fdigits;
-   real_compnt_info rcs;
-
-   prepare_arg_info (se, expr, &rcs, 0);
-   arg = rcs.arg;
-   masktype = rcs.mtype;
-   fdigits = rcs.fdigits;
-   tiny = rcs.f1;
-   zero = gfc_build_const (masktype, integer_zero_node);
-   tmp = build2 (BIT_AND_EXPR, masktype, rcs.emask, arg);
-   tmp = build2 (RSHIFT_EXPR, masktype, tmp, fdigits);
-   tmp = build2 (MINUS_EXPR, masktype, tmp, fdigits);
-   cond = build2 (LE_EXPR, boolean_type_node, tmp, zero);
-   t1 = build2 (LSHIFT_EXPR, masktype, tmp, fdigits);
-   tmp = build3 (COND_EXPR, masktype, cond, tiny, t1);
-   tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
-
-   se->expr = tmp;
-}
-
-/* Generate code for RRSPACING (X) intrinsic function.
-   RRSPACING (X) = |X * POW (2, -e)| * POW (2, p) = |FRACTION (X)| * POW (2, p)
-
-   So the result's exponent is p. And if X is normalized, X's fraction part
-   is the result's fraction. If X is denormalized, to get the X's fraction we
-   shift X's fraction part to left until the first '1' is removed.
-
-   We generate:
-
-    if (expn == 0 && frac == 0)
-       res = 0;
-    else
-    {
-       // edigits is the number of exponent bits. Add the sign bit.
-       sedigits = edigits + 1;
-
-       if (expn == 0) // Denormalized case.
-       {
-         t1 = leadzero (frac);
-         frac = frac << (t1 + 1); //Remove the first '1'.
-         frac = frac >> (sedigits); //Form the fraction.
-       }
-
-       //fdigits is the number of fraction bits. Form the exponent.
-       t = bias + fdigits;
-
-       res = (t << fdigits) | frac;
-    }
-*/
-
-static void
-gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
-{
-   tree masktype;
-   tree tmp, t1, t2, cond, cond2;
-   tree one, zero;
-   tree fdigits, fraction;
-   real_compnt_info rcs;
-
-   prepare_arg_info (se, expr, &rcs, 1);
-   masktype = rcs.mtype;
-   fdigits = rcs.fdigits;
-   fraction = rcs.frac;
-   one = gfc_build_const (masktype, integer_one_node);
-   zero = gfc_build_const (masktype, integer_zero_node);
-   t2 = fold_build2 (PLUS_EXPR, masktype, rcs.edigits, one);
-
-   t1 = call_builtin_clz (masktype, fraction);
-   tmp = build2 (PLUS_EXPR, masktype, t1, one);
-   tmp = build2 (LSHIFT_EXPR, masktype, fraction, tmp);
-   tmp = build2 (RSHIFT_EXPR, masktype, tmp, t2);
-   cond = build2 (EQ_EXPR, boolean_type_node, rcs.expn, zero);
-   fraction = build3 (COND_EXPR, masktype, cond, tmp, fraction);
-
-   tmp = fold_build2 (PLUS_EXPR, masktype, rcs.bias, fdigits);
-   tmp = fold_build2 (LSHIFT_EXPR, masktype, tmp, fdigits);
-   tmp = build2 (BIT_IOR_EXPR, masktype, tmp, fraction);
-
-   cond2 = build2 (EQ_EXPR, boolean_type_node, rcs.frac, zero);
-   cond = build2 (TRUTH_ANDIF_EXPR, boolean_type_node, cond, cond2);
-   tmp = build3 (COND_EXPR, masktype, cond,
-		 build_int_cst (masktype, 0), tmp);
-
-   tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
-   se->expr = tmp;
-}
 
 /* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */
 
@@ -2611,9 +3299,8 @@ gfc_conv_intrinsic_si_kind (gfc_se * se, gfc_expr * expr)
 
   args = gfc_conv_intrinsic_function_args (se, expr);
   args = TREE_VALUE (args);
-  args = gfc_build_addr_expr (NULL, args);
-  args = tree_cons (NULL_TREE, args, NULL_TREE);
-  se->expr = gfc_build_function_call (gfor_fndecl_si_kind, args);
+  args = build_fold_addr_expr (args);
+  se->expr = build_call_expr (gfor_fndecl_si_kind, 1, args);
 }
 
 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function.  */
@@ -2640,7 +3327,7 @@ gfc_conv_intrinsic_sr_kind (gfc_se * se, gfc_expr * expr)
       gfc_add_block_to_block (&se->post, &argse.post);
       args = gfc_chainon_list (args, argse.expr);
     }
-  se->expr = gfc_build_function_call (gfor_fndecl_sr_kind, args);
+  se->expr = build_function_call_expr (gfor_fndecl_sr_kind, args);
 }
 
 
@@ -2666,18 +3353,17 @@ gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
   len = gfc_create_var (gfc_int4_type_node, "len");
 
   tmp = gfc_conv_intrinsic_function_args (se, expr);
-  arglist = gfc_chainon_list (arglist, gfc_build_addr_expr (NULL, len));
+  arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
   arglist = gfc_chainon_list (arglist, addr);
   arglist = chainon (arglist, tmp);
 
-  tmp = gfc_build_function_call (gfor_fndecl_string_trim, arglist);
+  tmp = build_function_call_expr (gfor_fndecl_string_trim, arglist);
   gfc_add_expr_to_block (&se->pre, tmp);
 
   /* Free the temporary afterwards, if necessary.  */
   cond = build2 (GT_EXPR, boolean_type_node, len,
 		 build_int_cst (TREE_TYPE (len), 0));
-  arglist = gfc_chainon_list (NULL_TREE, var);
-  tmp = gfc_build_function_call (gfor_fndecl_internal_free, arglist);
+  tmp = gfc_call_free (var);
   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
   gfc_add_expr_to_block (&se->post, tmp);
 
@@ -2691,31 +3377,111 @@ gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
 static void
 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
 {
-  tree gfc_int4_type_node = gfc_get_int_type (4);
-  tree tmp;
-  tree len;
-  tree args;
-  tree arglist;
-  tree ncopies;
-  tree var;
-  tree type;
+  tree args, ncopies, dest, dlen, src, slen, ncopies_type;
+  tree type, cond, tmp, count, exit_label, n, max, largest;
+  stmtblock_t block, body;
+  int i;
 
+  /* Get the arguments.  */
   args = gfc_conv_intrinsic_function_args (se, expr);
-  len = TREE_VALUE (args);
-  tmp = gfc_advance_chain (args, 2);
-  ncopies = TREE_VALUE (tmp);
-  len = fold_build2 (MULT_EXPR, gfc_int4_type_node, len, ncopies);
+  slen = fold_convert (size_type_node, gfc_evaluate_now (TREE_VALUE (args),
+							 &se->pre));
+  src = TREE_VALUE (TREE_CHAIN (args));
+  ncopies = TREE_VALUE (TREE_CHAIN (TREE_CHAIN (args)));
+  ncopies = gfc_evaluate_now (ncopies, &se->pre);
+  ncopies_type = TREE_TYPE (ncopies);
+
+  /* Check that NCOPIES is not negative.  */
+  cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies,
+		      build_int_cst (ncopies_type, 0));
+  gfc_trans_runtime_check (cond,
+			   "Argument NCOPIES of REPEAT intrinsic is negative",
+			   &se->pre, &expr->where);
+
+  /* If the source length is zero, any non negative value of NCOPIES
+     is valid, and nothing happens.  */
+  n = gfc_create_var (ncopies_type, "ncopies");
+  cond = fold_build2 (EQ_EXPR, boolean_type_node, slen,
+		      build_int_cst (size_type_node, 0));
+  tmp = fold_build3 (COND_EXPR, ncopies_type, cond,
+		     build_int_cst (ncopies_type, 0), ncopies);
+  gfc_add_modify_expr (&se->pre, n, tmp);
+  ncopies = n;
+
+  /* Check that ncopies is not too large: ncopies should be less than
+     (or equal to) MAX / slen, where MAX is the maximal integer of
+     the gfc_charlen_type_node type.  If slen == 0, we need a special
+     case to avoid the division by zero.  */
+  i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
+  max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
+  max = fold_build2 (TRUNC_DIV_EXPR, size_type_node,
+		     fold_convert (size_type_node, max), slen);
+  largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
+	      ? size_type_node : ncopies_type;
+  cond = fold_build2 (GT_EXPR, boolean_type_node,
+		      fold_convert (largest, ncopies),
+		      fold_convert (largest, max));
+  tmp = fold_build2 (EQ_EXPR, boolean_type_node, slen,
+		     build_int_cst (size_type_node, 0));
+  cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node,
+		      cond);
+  gfc_trans_runtime_check (cond,
+			   "Argument NCOPIES of REPEAT intrinsic is too large",
+			   &se->pre, &expr->where);
+
+  /* Compute the destination length.  */
+  dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node, slen, ncopies);
   type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
-  var = gfc_conv_string_tmp (se, build_pointer_type (type), len);
+  dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
 
-  arglist = NULL_TREE;
-  arglist = gfc_chainon_list (arglist, var);
-  arglist = chainon (arglist, args);
-  tmp = gfc_build_function_call (gfor_fndecl_string_repeat, arglist);
+  /* Generate the code to do the repeat operation:
+       for (i = 0; i < ncopies; i++)
+         memmove (dest + (i * slen), src, slen);  */
+  gfc_start_block (&block);
+  count = gfc_create_var (ncopies_type, "count");
+  gfc_add_modify_expr (&block, count, build_int_cst (ncopies_type, 0));
+  exit_label = gfc_build_label_decl (NULL_TREE);
+
+  /* Start the loop body.  */
+  gfc_start_block (&body);
+
+  /* Exit the loop if count >= ncopies.  */
+  cond = fold_build2 (GE_EXPR, boolean_type_node, count, ncopies);
+  tmp = build1_v (GOTO_EXPR, exit_label);
+  TREE_USED (exit_label) = 1;
+  tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
+		     build_empty_stmt ());
+  gfc_add_expr_to_block (&body, tmp);
+
+  /* Call memmove (dest + (i*slen), src, slen).  */
+  tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node, slen,
+		     fold_convert (gfc_charlen_type_node, count));
+  tmp = fold_build2 (PLUS_EXPR, pchar_type_node, dest,
+		     fold_convert (pchar_type_node, tmp));
+  tmp = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], 3,
+			 tmp, src, slen);
+  gfc_add_expr_to_block (&body, tmp);
+
+  /* Increment count.  */
+  tmp = build2 (PLUS_EXPR, ncopies_type, count,
+		build_int_cst (TREE_TYPE (count), 1));
+  gfc_add_modify_expr (&body, count, tmp);
+
+  /* Build the loop.  */
+  tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
+  gfc_add_expr_to_block (&block, tmp);
+
+  /* Add the exit label.  */
+  tmp = build1_v (LABEL_EXPR, exit_label);
+  gfc_add_expr_to_block (&block, tmp);
+
+  /* Finish the block.  */
+  tmp = gfc_finish_block (&block);
   gfc_add_expr_to_block (&se->pre, tmp);
 
-  se->expr = var;
-  se->string_length = len;
+  /* Set the result value.  */
+  se->expr = dest;
+  se->string_length = dlen;
 }
 
 
@@ -2730,7 +3496,7 @@ gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
 
   /* Call the library function.  This always returns an INTEGER(4).  */
   fndecl = gfor_fndecl_iargc;
-  tmp = gfc_build_function_call (fndecl, NULL_TREE);
+  tmp = build_call_expr (fndecl, 0);
 
   /* Convert it to the required type.  */
   type = gfc_typenode_for_spec (&expr->ts);
@@ -2744,7 +3510,7 @@ gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
    gfc_index_integer_kind integer.  */
 
 static void
-gfc_conv_intrinsic_loc(gfc_se * se, gfc_expr * expr)
+gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
 {
   tree temp_var;
   gfc_expr *arg_expr;
@@ -2758,13 +3524,11 @@ gfc_conv_intrinsic_loc(gfc_se * se, gfc_expr * expr)
     gfc_conv_expr_reference (se, arg_expr);
   else
     gfc_conv_array_parameter (se, arg_expr, ss, 1); 
-  se->expr= convert (gfc_unsigned_type (long_integer_type_node), 
-		     se->expr);
+  se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
    
   /* Create a temporary variable for loc return value.  Without this, 
      we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1).  */
-  temp_var = gfc_create_var (gfc_unsigned_type (long_integer_type_node), 
-			     NULL);
+  temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
   gfc_add_modify_expr (&se->pre, temp_var, se->expr);
   se->expr = temp_var;
 }
@@ -2784,7 +3548,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
 
   name = &expr->value.function.name[2];
 
-  if (expr->rank > 0)
+  if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
     {
       lib = gfc_is_intrinsic_libcall (expr);
       if (lib != 0)
@@ -2821,14 +3585,6 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_exponent (se, expr);
       break;
 
-    case GFC_ISYM_SPACING:
-      gfc_conv_intrinsic_spacing (se, expr);
-      break;
-
-    case GFC_ISYM_RRSPACING:
-      gfc_conv_intrinsic_rrspacing (se, expr);
-      break;
-
     case GFC_ISYM_SCAN:
       gfc_conv_intrinsic_scan (se, expr);
       break;
@@ -2862,7 +3618,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       break;
 
     case GFC_ISYM_AINT:
-      gfc_conv_intrinsic_aint (se, expr, FIX_TRUNC_EXPR);
+      gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
       break;
 
     case GFC_ISYM_ALL:
@@ -2870,7 +3626,11 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       break;
 
     case GFC_ISYM_ANINT:
-      gfc_conv_intrinsic_aint (se, expr, FIX_ROUND_EXPR);
+      gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
+      break;
+
+    case GFC_ISYM_AND:
+      gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
       break;
 
     case GFC_ISYM_ANY:
@@ -2896,19 +3656,22 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       /* Integer conversions are handled separately to make sure we get the
          correct rounding mode.  */
     case GFC_ISYM_INT:
-      gfc_conv_intrinsic_int (se, expr, FIX_TRUNC_EXPR);
+    case GFC_ISYM_INT2:
+    case GFC_ISYM_INT8:
+    case GFC_ISYM_LONG:
+      gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
       break;
 
     case GFC_ISYM_NINT:
-      gfc_conv_intrinsic_int (se, expr, FIX_ROUND_EXPR);
+      gfc_conv_intrinsic_int (se, expr, RND_ROUND);
       break;
 
     case GFC_ISYM_CEILING:
-      gfc_conv_intrinsic_int (se, expr, FIX_CEIL_EXPR);
+      gfc_conv_intrinsic_int (se, expr, RND_CEIL);
       break;
 
     case GFC_ISYM_FLOOR:
-      gfc_conv_intrinsic_int (se, expr, FIX_FLOOR_EXPR);
+      gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
       break;
 
     case GFC_ISYM_MOD:
@@ -2927,6 +3690,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_iargc (se, expr);
       break;
 
+    case GFC_ISYM_COMPLEX:
+      gfc_conv_intrinsic_cmplx (se, expr, 1);
+      break;
+
     case GFC_ISYM_CONJG:
       gfc_conv_intrinsic_conjg (se, expr);
       break;
@@ -2935,14 +3702,26 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_count (se, expr);
       break;
 
+    case GFC_ISYM_CTIME:
+      gfc_conv_intrinsic_ctime (se, expr);
+      break;
+
     case GFC_ISYM_DIM:
       gfc_conv_intrinsic_dim (se, expr);
       break;
 
+    case GFC_ISYM_DOT_PRODUCT:
+      gfc_conv_intrinsic_dot_product (se, expr);
+      break;
+
     case GFC_ISYM_DPROD:
       gfc_conv_intrinsic_dprod (se, expr);
       break;
 
+    case GFC_ISYM_FDATE:
+      gfc_conv_intrinsic_fdate (se, expr);
+      break;
+
     case GFC_ISYM_IAND:
       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
       break;
@@ -2981,6 +3760,14 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
       break;
 
+    case GFC_ISYM_LSHIFT:
+      gfc_conv_intrinsic_rlshift (se, expr, 0);
+      break;
+
+    case GFC_ISYM_RSHIFT:
+      gfc_conv_intrinsic_rlshift (se, expr, 1);
+      break;
+
     case GFC_ISYM_ISHFT:
       gfc_conv_intrinsic_ishft (se, expr);
       break;
@@ -2993,6 +3780,16 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_bound (se, expr, 0);
       break;
 
+    case GFC_ISYM_TRANSPOSE:
+      if (se->ss && se->ss->useflags)
+	{
+	  gfc_conv_tmp_array_ref (se);
+	  gfc_advance_se_ss_chain (se);
+	}
+      else
+	gfc_conv_array_transpose (se, expr->value.function.actual->expr);
+      break;
+
     case GFC_ISYM_LEN:
       gfc_conv_intrinsic_len (se, expr);
       break;
@@ -3049,6 +3846,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_not (se, expr);
       break;
 
+    case GFC_ISYM_OR:
+      gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
+      break;
+
     case GFC_ISYM_PRESENT:
       gfc_conv_intrinsic_present (se, expr);
       break;
@@ -3070,22 +3871,49 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       break;
 
     case GFC_ISYM_TRANSFER:
-      gfc_conv_intrinsic_transfer (se, expr);
+      if (se->ss)
+	{
+	  if (se->ss->useflags)
+	    {
+	      /* Access the previously obtained result.  */
+	      gfc_conv_tmp_array_ref (se);
+	      gfc_advance_se_ss_chain (se);
+	      break;
+	    }
+	  else
+	    gfc_conv_intrinsic_array_transfer (se, expr);
+	}
+      else
+	gfc_conv_intrinsic_transfer (se, expr);
+      break;
+
+    case GFC_ISYM_TTYNAM:
+      gfc_conv_intrinsic_ttynam (se, expr);
       break;
 
     case GFC_ISYM_UBOUND:
       gfc_conv_intrinsic_bound (se, expr, 1);
       break;
 
+    case GFC_ISYM_XOR:
+      gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
+      break;
+
     case GFC_ISYM_LOC:
       gfc_conv_intrinsic_loc (se, expr);
       break;
 
+    case GFC_ISYM_ACCESS:
     case GFC_ISYM_CHDIR:
-    case GFC_ISYM_DOT_PRODUCT:
+    case GFC_ISYM_CHMOD:
     case GFC_ISYM_ETIME:
+    case GFC_ISYM_FGET:
+    case GFC_ISYM_FGETC:
     case GFC_ISYM_FNUM:
+    case GFC_ISYM_FPUT:
+    case GFC_ISYM_FPUTC:
     case GFC_ISYM_FSTAT:
+    case GFC_ISYM_FTELL:
     case GFC_ISYM_GETCWD:
     case GFC_ISYM_GETGID:
     case GFC_ISYM_GETPID:
@@ -3096,8 +3924,11 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
     case GFC_ISYM_IRAND:
     case GFC_ISYM_ISATTY:
     case GFC_ISYM_LINK:
+    case GFC_ISYM_LSTAT:
     case GFC_ISYM_MALLOC:
     case GFC_ISYM_MATMUL:
+    case GFC_ISYM_MCLOCK:
+    case GFC_ISYM_MCLOCK8:
     case GFC_ISYM_RAND:
     case GFC_ISYM_RENAME:
     case GFC_ISYM_SECOND:
@@ -3154,6 +3985,7 @@ gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
   newss->type = GFC_SS_INTRINSIC;
   newss->expr = expr;
   newss->next = ss;
+  newss->data.info.dimen = 1;
 
   return newss;
 }
@@ -3227,7 +4059,7 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
   gcc_assert (isym);
 
   if (isym->elemental)
-    return gfc_walk_elemental_function_args (ss, expr, GFC_SS_SCALAR);
+    return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
 
   if (expr->rank == 0)
     return ss;
@@ -3242,6 +4074,9 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
     case GFC_ISYM_UBOUND:
       return gfc_walk_intrinsic_bound (ss, expr);
 
+    case GFC_ISYM_TRANSFER:
+      return gfc_walk_intrinsic_libfunc (ss, expr);
+
     default:
       /* This probably meant someone forgot to add an intrinsic to the above
          list(s) when they implemented it, or something's gone horribly wrong.